diff --git a/.gitignore b/.gitignore index a93e28036..3eeca5a49 100755 --- a/.gitignore +++ b/.gitignore @@ -6,6 +6,7 @@ # summa executable and bin directory bin summa.exe +summa_sundials.exe # temporary files *~ *.swp @@ -27,6 +28,7 @@ summa.exe *.layout gmon.out summa.exe.dSYM* +summa_sundials.exe.dSYM* summaversion.inc # makefile make.out @@ -35,3 +37,19 @@ Makefile-* *.backup # site directory from mkdocs site/ +# cmake_build containing cmake build objects +build/cmake_build +runinfo.txt +# OpenWQ source code +build/source/openwq/openwq +# pre-processing files +utils/pre-processing/*.nc +# vscode related files +.vscode +# test files +test_ngen/gauge_01073000/simulations/run_1/SUMMA/*.nc +test_ngen/domain_provo/forcing/*.nc +test_ngen/domain_provo/forcing/SUMMA_input/*.nc +test_ngen/domain_provo/simulations/run_1/SUMMA/*.nc +test_ngen/domain_provo/simulations/*.nc +test_ngen/domain_provo/simulations/*.csv diff --git a/.readthedocs.yaml b/.readthedocs.yaml new file mode 100644 index 000000000..85e6ee858 --- /dev/null +++ b/.readthedocs.yaml @@ -0,0 +1,19 @@ +# Read the Docs configuration file for MkDocs projects +# See https://docs.readthedocs.io/en/stable/config-file/v2.html for details + +# Required +version: 2 + +# Set the version of Python and other tools you might need +build: + os: ubuntu-22.04 + tools: + python: "3.12" + +mkdocs: + configuration: mkdocs.yml + +# Specify the python packages we need to build properly +python: + install: + - requirements: docs/requirements.txt \ No newline at end of file diff --git a/Dockerfile b/Dockerfile deleted file mode 100644 index b736ce13f..000000000 --- a/Dockerfile +++ /dev/null @@ -1,36 +0,0 @@ -FROM ubuntu:xenial - -# install only the packages that are needed -RUN apt-get update && \ - apt-get install -y --no-install-recommends \ - software-properties-common python-software-properties \ - ca-certificates \ - git \ - make \ - libnetcdff-dev \ - liblapack-dev \ - vim - -# install gfortran-6 -RUN add-apt-repository ppa:ubuntu-toolchain-r/test -y \ - && apt-get update \ - && apt-get install -y --no-install-recommends gfortran-6 \ - && apt-get clean - -# set environment variables for docker build -ENV F_MASTER /code -ENV FC gfortran -ENV FC_EXE gfortran -ENV INCLUDES -I/usr/include -ENV LIBRARIES '-L/usr/lib -lnetcdff -llapack -lblas' - -# add code directory -WORKDIR /code -ADD . /code - -# fetch tags and build summa -RUN git fetch --tags && make -C build/ -f Makefile - -# run summa when running the docker image -WORKDIR bin -ENTRYPOINT ["./summa.exe"] diff --git a/build/CMakeLists.txt b/build/CMakeLists.txt new file mode 100644 index 000000000..36f6940bc --- /dev/null +++ b/build/CMakeLists.txt @@ -0,0 +1,252 @@ +cmake_minimum_required(VERSION 3.21 FATAL_ERROR) +project(summa VERSION 4.0.0 LANGUAGES Fortran C CXX) + +if(DEFINED ENV{FC}) + set (CMAKE_Fortran_COMPILER $ENV{FC}) #for NextGen need, works for others +else() + set (CMAKE_Fortran_COMPILER gfortran) +endif() + +#========================================================================================= +# SUMMA can be compiled with debug flags by specifiying -DCMAKE_BUILD_TYPE=Debug +# +# There are multiple options for building SUMMA, including using the +# Sundials suite of solvers and the NextGen framework. +# The options are set by specifying -DOPTION=ON when running cmake. +# For example to compile SUMMA with Sundials, use +# cmake -B ../cmake_build -S ../. -DUSE_SUNDIALS=ON +# cmake --build ../cmake_build --target all -j +# +# To compile SUMMA with Actors, see the Summa-Actors repo: +# https://github.com/uofs-simlab/Summa-Actors +#========================================================================================= + +# Add options for build type +set(CMAKE_CONFIGURATION_TYPES Release Debug) + +# Options: Enable each with cmake -DOPTION=ON +option(USE_SUNDIALS "Use IDA solver from SUNDIALS suite" OFF) +option(USE_NEXTGEN "Use NextGen Framework" OFF) +option(USE_OPENWQ "Use OpenWQ Framework" OFF) +set(EXT_TARGETS) # list of external targets to link to + +# Set Default Executable Name +set(EXEC_NAME summa.exe) +# Set top-level directory +if (USE_NEXTGEN) + set(F_MASTER "${CMAKE_CURRENT_SOURCE_DIR}/summa") +else() + set(F_MASTER "${CMAKE_CURRENT_SOURCE_DIR}/..") +endif() + +set(PARENT_DIR "${F_MASTER}") +set(EXEC_DIR "${F_MASTER}/bin") + +# Handle optional external libraries +if (USE_SUNDIALS) + message("ENABLING SUNDIALS") + find_package(SUNDIALS REQUIRED) + list(APPEND EXT_TARGETS SUNDIALS::fida_mod_shared + SUNDIALS::fkinsol_mod_shared) + add_compile_definitions(SUNDIALS_ACTIVE) + set(EXEC_NAME summa_sundials.exe) +endif() + +if (USE_NEXTGEN) + message("ENABLING NEXTGEN") + add_compile_definitions(NGEN_ACTIVE BMI_ACTIVE NGEN_FORCING_ACTIVE + NGEN_OUTPUT_ACTIVE) + add_subdirectory(../iso_c_fortran_bmi ${CMAKE_BINARY_DIR}/iso_c_bmi) + list(INSERT CMAKE_MODULE_PATH 0 "${CMAKE_CURRENT_LIST_DIR}/summa/build/cmake/") + list(INSERT CMAKE_PREFIX_PATH 0 "${CMAKE_CURRENT_LIST_DIR}/summa/build/cmake/") + set(CMAKE_Fortran_MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/fortran) + set(SUMMA_LIB_NAME_CMAKE summabmi) + set(SUMMA_LIB_DESC_CMAKE "Summa-Sundials BMI Module Shared Library") +else() + LIST(INSERT CMAKE_MODULE_PATH 0 "${CMAKE_SOURCE_DIR}/cmake/") + LIST(INSERT CMAKE_PREFIX_PATH 0 "${CMAKE_SOURCE_DIR}/cmake/") +endif() + +# OpenWQ Framework +if (USE_OPENWQ) + message("ENABLING OPENWQ") + add_compile_definitions(OPENWQ_ACTIVE) + if (USE_SUNDIALS) + set(EXEC_NAME summa_sundials_openwq.exe) + else() + set(EXEC_NAME summa_openwq.exe) + endif() +endif() + + +get_filename_component(F_MASTER "${F_MASTER}" REALPATH) +get_filename_component(PARENT_DIR "${PARENT_DIR}" REALPATH) +get_filename_component(EXEC_DIR "${EXEC_DIR}" REALPATH) +set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${EXEC_DIR}) + +#========================================================================================= +# SET THE PATHS TO THE LIBRARIES AND INCLUDE FILES +#========================================================================================= + +# NetCDF is found with a custom FindNetCDF.cmake file +find_package(NetCDF REQUIRED) +list(APPEND EXT_TARGETS NetCDF::NetCDF) + +# Find LAPACK with user-specified links or automatic detection +option(SPECIFY_LAPACK_LINKS "Use specified LAPACK links" OFF) +if(SPECIFY_LAPACK_LINKS) + message("Using LAPACK links from LIBRARY_LINKS environment variable") + if(DEFINED ENV{LIBRARY_LINKS}) + set(LIBRARY_LINKS $ENV{LIBRARY_LINKS}) + else() + message(FATAL_ERROR "LIBRARY_LINKS environment variable not found. Set this variable or try -DSPECIFY_LAPACK_LINKS=OFF in build file.") + endif() +else() + message("Automatically detect LAPACK links") + set(LIBRARY_LINKS "") + + # OpenBLAS + set(BLA_VENDOR OpenBLAS) + find_package(OpenBLAS REQUIRED COMPONENTS serial) + list(APPEND EXT_TARGETS OpenBLAS::OpenBLAS) +endif() + +# Set compiler flags +set(FLAGS_OPT $ENV{FLAGS_OPT}) # get optional user-specified flags from environment variables +if(CMAKE_BUILD_TYPE MATCHES Debug) + message("\nSetting SUMMA Debug Options") + add_compile_definitions(DEBUG) + # Notes: - optimization -Og is selected here to maximize information displayed in debugging software (e.g., gdb) + # - however, it may be useful to vary the optimization level to test for optimization related issues + set(FLAGS_NOAH -g -Og -fbacktrace -Wall -fcheck=all,no-array-temps -Wfatal-errors -ffree-line-length-none -fPIC -ffree-form ${FLAGS_OPT}) + set(FLAGS_ALL -g -Og -fbacktrace -Wall -fcheck=all,no-array-temps -Wfatal-errors -ffree-line-length-none -fPIC -cpp -frecursive ${FLAGS_OPT}) + set(FLAGS_CXX -g -Og -fbacktrace -Wall -fcheck=all,no-array-temps -Wfatal-errors -std=c++17 ${FLAGS_OPT}) +else() + message("\nSetting SUMMA Release Options") + if (CMAKE_Fortran_COMPILER MATCHES gfortran) + set(FLAGS_NOAH -O3 -Wfatal-errors -ffree-line-length-none -fPIC -ffree-form ${FLAGS_OPT}) + set(FLAGS_ALL -O3 -Wfatal-errors -ffree-line-length-none -fPIC -cpp -frecursive ${FLAGS_OPT}) + set(FLAGS_CXX -O3 -Wfatal-errors -std=c++17 ${FLAGS_OPT}) + else(CMAKE_Fortran_COMPILER MATCHES ifx) # ifx does not currently compile SUMMA -- derived type modifications needed in source code + set(FLAGS_NOAH -O3 -heap-arrays -fPIC -free ${FLAGS_OPT}) + set(FLAGS_ALL -O3 -heap-arrays -fPIC -cxxlib ${FLAGS_OPT}) + set(FLAGS_CXX -O3 -std=c++17 ${FLAGS_OPT}) + endif() +endif() + +#========================================================================================= +# COMPILE PART 1: Define directory paths +#========================================================================================= + +# Define directories that contains source code +set(DRIVER_DIR ${F_MASTER}/build/source/driver) +set(DSHARE_DIR ${F_MASTER}/build/source/dshare) +set(ENGINE_DIR ${F_MASTER}/build/source/engine) +set(HOOKUP_DIR ${F_MASTER}/build/source/hookup) +set(NETCDF_DIR ${F_MASTER}/build/source/netcdf) +set(NOAHMP_DIR ${F_MASTER}/build/source/noah-mp) + +#========================================================================================= +# COMPILE PART 2: Assemble all of the SUMMA sub-routines +#========================================================================================= + +# SUMMA Source Files are defined in the CMakeLists.txt file in the subdirectory +add_subdirectory(${F_MASTER}/build/source/) + + +#========================================================================================= +# COMPILE PART 3: Collect the subroutines into build groups depending on build type +#========================================================================================= + +set(COMM_ALL ${NRPROC} ${HOOKUP} ${DATAMS} ${UTILMS}) +set(SUMMA_ALL ${NETCDF} ${PRELIM} ${MODRUN} ${SOLVER} ${DRIVER}) +set(MAIN_SUMMA ${DRIVER_DIR}/summa_driver.f90) + +if (USE_NEXTGEN) + set(SUMMA_ALL ${SUMMA_ALL} ${DRIVER_NEXTGEN}) +endif() + +if (USE_SUNDIALS) + set(COMM_ALL ${COMM_ALL} ${DATAMS_SUNDIALS} ${UTILMS_SUNDIALS}) + set(SUMMA_ALL ${SUMMA_ALL} ${MODRUN_SUNDIALS} ${SOLVER_SUNDIALS}) +endif() + +if (USE_OPENWQ) + add_subdirectory(${F_MASTER}/build/source/openwq) + if (DEFINED OPENWQ_ERROR) + message(FATAL_ERROR "OpenWQ build failed") + endif() + set(SUMMA_ALL ${SUMMA_ALL} ${OPENWQ_COUPLER}) + list(APPEND EXT_TARGETS openWQ) +endif () + + +# Define version number +set(VERSIONFILE ${DRIVER_DIR}/summaversion.inc) +execute_process( + COMMAND bash -c "git tag | tail -n 1" + OUTPUT_VARIABLE VERSION + OUTPUT_STRIP_TRAILING_WHITESPACE +) +execute_process( + COMMAND date + OUTPUT_VARIABLE BUILDTIM + OUTPUT_STRIP_TRAILING_WHITESPACE +) +execute_process( + COMMAND bash -c "git describe --long --all --always | sed 's#heads/##'" + OUTPUT_VARIABLE GITBRCH + OUTPUT_STRIP_TRAILING_WHITESPACE +) +execute_process( + COMMAND git rev-parse HEAD + OUTPUT_VARIABLE GITHASH + OUTPUT_STRIP_TRAILING_WHITESPACE +) + +#========================================================================================= +# COMPILE PART 4: Do the compilation +#========================================================================================= + +# update version information +file(WRITE ${VERSIONFILE} "character(len=64), parameter :: summaVersion = '${VERSION}'\n") +file(APPEND ${VERSIONFILE} "character(len=64), parameter :: buildTime = '${BUILDTIM}'\n") +file(APPEND ${VERSIONFILE} "character(len=64), parameter :: gitBranch = '${GITBRCH}'\n") +file(APPEND ${VERSIONFILE} "character(len=64), parameter :: gitHash = '${GITHASH}'") + +# Build SUMMA_NOAHMP Object +add_library(SUMMA_NOAHMP OBJECT ${NOAHMP} ${NRUTIL}) +target_compile_options(SUMMA_NOAHMP PRIVATE ${FLAGS_NOAH}) + +# Build SUMMA_COMM Object +add_library(SUMMA_COMM OBJECT ${COMM_ALL}) +target_compile_options(SUMMA_COMM PRIVATE ${FLAGS_ALL}) +target_link_libraries(SUMMA_COMM PUBLIC SUMMA_NOAHMP ${EXT_TARGETS} ${LIBRARY_LINKS}) + +# For NextGen, build SUMMA Shared Library and add the outside BMI libraries +if(USE_NEXTGEN) + if(WIN32) + add_library(summabmi ${SUMMA_ALL}) + else() + add_library(summabmi SHARED ${SUMMA_ALL}) + endif() + target_compile_options(summabmi PRIVATE ${FLAGS_ALL}) + target_link_libraries(summabmi PUBLIC ${EXT_TARGETS} iso_c_bmi SUMMA_NOAHMP SUMMA_COMM) + + set_target_properties(summabmi PROPERTIES VERSION ${PROJECT_VERSION}) + include(GNUInstallDirs) + + install(TARGETS summabmi + LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR} + PUBLIC_HEADER DESTINATION ${CMAKE_INSTALL_INCLUDEDIR}) + configure_file(summabmi.pc.in summabmi.pc @ONLY) + install(FILES ${CMAKE_BINARY_DIR}/summabmi.pc DESTINATION ${CMAKE_INSTALL_DATAROOTDIR}/pkgconfig) +else() + add_library(summa SHARED ${SUMMA_ALL}) + target_compile_options(summa PRIVATE ${FLAGS_ALL}) + target_link_libraries(summa PUBLIC ${EXT_TARGETS} SUMMA_NOAHMP SUMMA_COMM ${LIBRARY_LINKS}) + add_executable(${EXEC_NAME} ${MAIN_SUMMA}) + target_compile_options(${EXEC_NAME} PRIVATE ${FLAGS_ALL}) + set_property(TARGET ${EXEC_NAME} PROPERTY LINKER_LANGUAGE Fortran) + target_link_libraries(${EXEC_NAME} summa ${EXT_TARGETS} ${LIBRARY_LINKS}) +endif() diff --git a/build/Makefile b/build/Makefile deleted file mode 100644 index 207e1e9bd..000000000 --- a/build/Makefile +++ /dev/null @@ -1,385 +0,0 @@ -#======================================================================== -# Makefile to compile SUMMA -#======================================================================== -# -# Recommended use: Copy this file to Makefile.local, edit it to your -# heart's content, and then run `make -f build/Makefile.local` from -# your top level SUMMA directory. Don't include the Makefile.local in -# any pull requests you make. -# -# Note that Makefile configurations that we commonly use can be found on -# the SUMMA wiki at: -# https://github.com/NCAR/summa/wiki/SUMMA-Makefile-Part-0-configuration -# feel free to add yours to that page. -# -# To troubleshoot your paths and setup, type 'make check' -# -# At a minimum you will need to set the following: -# * F_MASTER - top level summa directory -# * FC - compiler suite -# * FC_EXE - compiler executable -# * INCLUDES - path to include files -# * LIBRARIES - path to and libraries to include -# -# Some further options can be specified for OpenMP, etc. See in Part 0 of -# the Makefile. You don't need to make any changes in PART 1 and -# following unless you are doing SUMMA development and changed what -# needs to be compiled - -#======================================================================== -# PART 0: User-configurable part -#======================================================================== - -# The variables can be specified in one of two ways: -# * delete the '##' in front of the variable, fill out the entry, -# save the file and run make -# * make no changes to this file, but specify the variables in your -# environment before you run make - -# Define core directory below which everything resides. This is the -# parent directory of the 'build' directory -##F_MASTER = - -# Define the Fortran Compiler. If you are using gfortran, then this needs -# to be version 6 or higher. This variable is simply used to select the right -# compiler flags in the ifeq statements in this Makefile. The compiler -# executable is set separately as FC_EXE -# Currently this is either gfortran or ifort -##FC = - -# Define the path for the compiler executable. This is the actual executable -# that is invoked. For example, FC=gfortran and FC_EXE=/usr/bin-gfortran-mp-6 -# FC and FC_EXE have to be consistent -##FC_EXE = - -# Define the NetCDF and LAPACK libraries and path to include files. -# INCLUDES needs to be of the form (no quotes around the string): -# INCLUDES = -I -I -I<...> -I -# LIBRARIES needs to be of the form ( no quotes around the string): -# LIBRARIES = '-L -lnetcdff -L -lblas -L -l' -# If none of this makes sense, please talk to your system -# administrator. -##INCLUDES = -##LIBRARIES = - -# Eventually we plan move to a real configure script, but for now we like -# to keep track of successful compilations of SUMMA on different platforms -# and with different compilers. If you are successful compiling SUMMA, -# please add your configuration (operating system and compiler plus -# part 0 of the Makefile) to the SUMMA wiki on github. - -# Define compiler flags. If you use a different compiler, -# you will need to figure out what the equivalent flags are -# and may need to update this section - -# ------------ define compiler flags ---------------------------------------- - -# define open MP flags -isOpenMP = -FLAGS_OMP = -LIBOPENMP = - -# Define compiler flags. If you use a different compiler, -# you will need to figure out what the equivalent flags are -# and may need to update this section - -# gfortran compiler flags -ifeq "$(FC)" "gfortran" - - ifeq "$(isOpenMP)" "yes" - FLAGS_OMP = -fopenmp - endif - -# Production runs -FLAGS_NOAH = -O3 -ffree-form -ffree-line-length-none -fmax-errors=0 $(FLAGS_OMP) -FLAGS_COMM = -O3 -ffree-line-length-none -fmax-errors=0 $(FLAGS_OMP) -FLAGS_SUMMA = -O3 -ffree-line-length-none -fmax-errors=0 $(FLAGS_OMP) - -# Debug runs -#FLAGS_NOAH = -p -g -ffree-form -ffree-line-length-none -fmax-errors=0 -fbacktrace -Wno-unused -Wno-unused-dummy-argument -#FLAGS_COMM = -p -g -Wall -ffree-line-length-none -fmax-errors=0 -fbacktrace -fcheck=bounds -#FLAGS_SUMMA = -p -g -Wall -ffree-line-length-none -fmax-errors=0 -fbacktrace -fcheck=bounds - -endif - -# ifort compiler flags -ifeq "$(FC)" "ifort" - - ifeq "$(isOpenMP)" "yes" - FLAGS_OMP = -qopenmp - endif - -# Production runs -FLAGS_NOAH = -O3 -noerror_limit -FR -auto -fltconsistency $(FLAGS_OMP) -FLAGS_COMM = -O3 -FR -auto -fltconsistency -fpe0 $(FLAGS_OMP) -FLAGS_SUMMA = -O3 -FR -auto -fltconsistency -fpe0 $(FLAGS_OMP) - -# Debug runs -#FLAGS_NOAH = -O0 -p -g -warn nounused -noerror_limit -FR -auto -WB -traceback -fltconsistency -#FLAGS_COMM = -O0 -p -g -debug -warn all -check all -FR -auto -WB -traceback -fltconsistency -fpe0 -#FLAGS_SUMMA = -O0 -p -g -debug -warn all -check all -FR -auto -WB -traceback -fltconsistency -fpe0 -endif - -#======================================================================== -# PART 1: Define directory paths -#======================================================================== - -# Core directory that contains source code -F_KORE_DIR = $(F_MASTER)/build/source - -# Location of the compiled modules -MOD_PATH = $(F_MASTER)/build - -# Define the directory for the executables -EXE_PATH = $(F_MASTER)/bin - -#======================================================================== -# PART 2: Assemble all of the SUMMA sub-routines -#======================================================================== - -# Define directories -DRIVER_DIR = $(F_KORE_DIR)/driver -HOOKUP_DIR = $(F_KORE_DIR)/hookup -NETCDF_DIR = $(F_KORE_DIR)/netcdf -DSHARE_DIR = $(F_KORE_DIR)/dshare -NUMREC_DIR = $(F_KORE_DIR)/numrec -NOAHMP_DIR = $(F_KORE_DIR)/noah-mp -ENGINE_DIR = $(F_KORE_DIR)/engine - -# utilities -SUMMA_NRUTIL= \ - nrtype.f90 \ - f2008funcs.f90 \ - nr_utility.f90 -NRUTIL = $(patsubst %, $(ENGINE_DIR)/%, $(SUMMA_NRUTIL)) - -# -# Numerical recipes procedures -# NOTE: all numerical recipes procedures are now replaced with free versions -SUMMA_NRPROC= \ - expIntegral.f90 \ - spline_int.f90 -NRPROC = $(patsubst %, $(ENGINE_DIR)/%, $(SUMMA_NRPROC)) - -# Hook-up modules (set files and directory paths) -SUMMA_HOOKUP= \ - ascii_util.f90 \ - summaFileManager.f90 -HOOKUP = $(patsubst %, $(HOOKUP_DIR)/%, $(SUMMA_HOOKUP)) - -# Data modules -SUMMA_DATAMS= \ - multiconst.f90 \ - var_lookup.f90 \ - data_types.f90 \ - globalData.f90 \ - flxMapping.f90 \ - get_ixname.f90 \ - popMetadat.f90 \ - outpt_stat.f90 -DATAMS = $(patsubst %, $(DSHARE_DIR)/%, $(SUMMA_DATAMS)) - -# utility modules -SUMMA_UTILMS= \ - time_utils.f90 \ - mDecisions.f90 \ - snow_utils.f90 \ - soil_utils.f90 \ - updatState.f90 \ - matrixOper.f90 -UTILMS = $(patsubst %, $(ENGINE_DIR)/%, $(SUMMA_UTILMS)) - -# Model guts -SUMMA_MODGUT= \ - MODGUT = $(patsubst %, $(ENGINE_DIR)/%, $(SUMMA_MODGUT)) - -# Solver -SUMMA_SOLVER= \ - vegPhenlgy.f90 \ - diagn_evar.f90 \ - stomResist.f90 \ - groundwatr.f90 \ - vegSWavRad.f90 \ - vegNrgFlux.f90 \ - ssdNrgFlux.f90 \ - vegLiqFlux.f90 \ - snowLiqFlx.f90 \ - soilLiqFlx.f90 \ - bigAquifer.f90 \ - computFlux.f90 \ - computResid.f90 \ - computJacob.f90 \ - eval8summa.f90 \ - summaSolve.f90 \ - systemSolv.f90 \ - varSubstep.f90 \ - opSplittin.f90 \ - coupled_em.f90 \ - run_oneHRU.f90 \ - run_oneGRU.f90 -SOLVER = $(patsubst %, $(ENGINE_DIR)/%, $(SUMMA_SOLVER)) - -# Define routines for SUMMA preliminaries -SUMMA_PRELIM= \ - conv_funcs.f90 \ - sunGeomtry.f90 \ - convE2Temp.f90 \ - allocspace.f90 \ - checkStruc.f90 \ - childStruc.f90 \ - ffile_info.f90 \ - read_attrb.f90 \ - read_pinit.f90 \ - pOverwrite.f90 \ - read_param.f90 \ - paramCheck.f90 \ - check_icond.f90 -PRELIM = $(patsubst %, $(ENGINE_DIR)/%, $(SUMMA_PRELIM)) - -SUMMA_NOAHMP= \ - module_model_constants.F \ - module_sf_noahutl.F \ - module_sf_noahlsm.F \ - module_sf_noahmplsm.F - -NOAHMP = $(patsubst %, $(NOAHMP_DIR)/%, $(SUMMA_NOAHMP)) - -# Define routines for the SUMMA model runs -SUMMA_MODRUN = \ - indexState.f90 \ - getVectorz.f90 \ - updateVars.f90 \ - var_derive.f90 \ - read_force.f90 \ - derivforce.f90 \ - snowAlbedo.f90 \ - canopySnow.f90 \ - tempAdjust.f90 \ - snwCompact.f90 \ - layerMerge.f90 \ - layerDivide.f90 \ - volicePack.f90 \ - qTimeDelay.f90 -MODRUN = $(patsubst %, $(ENGINE_DIR)/%, $(SUMMA_MODRUN)) - -# Define routines for the solver -SUMMA_MSOLVE = \ - -# Define NetCDF routines -SUMMA_NETCDF = \ - netcdf_util.f90 \ - def_output.f90 \ - modelwrite.f90 \ - read_icond.f90 -NETCDF = $(patsubst %, $(NETCDF_DIR)/%, $(SUMMA_NETCDF)) - -# ... stitch together common programs -COMM_ALL = $(NRUTIL) $(NRPROC) $(HOOKUP) $(DATAMS) $(UTILMS) - -# ... stitch together SUMMA programs -SUMMA_ALL = $(NETCDF) $(PRELIM) $(MODRUN) $(SOLVER) - -# Define the driver routine -SUMMA_DRIVER= \ - summa_type.f90 \ - summa_util.f90 \ - summa_alarms.f90 \ - summa_globalData.f90 \ - summa_defineOutput.f90 \ - summa_init.f90 \ - summa_setup.f90 \ - summa_restart.f90 \ - summa_forcing.f90 \ - summa_modelRun.f90 \ - summa_writeOutput.f90 \ - summa_driver.f90 -DRIVER = $(patsubst %, $(DRIVER_DIR)/%, $(SUMMA_DRIVER)) - -# Define the executable -DRIVER__EX = summa.exe - -# Define version number -VERSIONFILE = $(DRIVER_DIR)/summaversion.inc -BULTTIM = $(shell date) -GITBRCH = $(shell git describe --long --all --always | sed -e's/heads\///') -GITHASH = $(shell git rev-parse HEAD) -VERSION = $(shell git show-ref --tags | grep $GITHASH | sed 's/.*tags\///' | grep . || echo "undefined") - -#======================================================================== -# PART 3: Checks -#====================================================================== -# make sure that the paths are defined. These are just some high level checks -ifndef F_MASTER - $(error F_MASTER is undefined) -endif -ifndef FC - $(error FC is undefined: Specify your compiler) -endif -ifndef FC_EXE - $(error FC_EXE is undefined: Specify your compiler executable) -endif -ifndef FLAGS_SUMMA - $(error Specify flags for your compiler: $(FC)) -endif -ifndef INCLUDES - $(error INCLUDES is undefined) -endif -ifndef LIBRARIES - $(error LIBRARIES is undefined) -endif - -#======================================================================== -# PART 4: compilation -#====================================================================== - -# Compile -all: compile_noah compile_comm compile_summa link clean install - -check: - $(info) - $(info Displaying make variables:) - $(info F_MASTER : $(F_MASTER)) - $(info EXE_PATH : $(EXE_PATH)) - $(info FC : $(FC)) - $(info INCLUDES : $(INCLUDES)) - $(info LIBRARIES : $(LIBRARIES)) - $(info FLAGS_NOAH : $(FLAGS_NOAH)) - $(info FLAGS_COMM : $(FLAGS_COMM)) - $(info FLAGS_SUMMA: $(FLAGS_SUMMA)) - $(info) - -# update version information -update_version: - echo "character(len=64), parameter :: summaVersion = '${VERSION}'" > $(VERSIONFILE) - echo "character(len=64), parameter :: buildTime = '${BULTTIM}'" >> $(VERSIONFILE) - echo "character(len=64), parameter :: gitBranch = '${GITBRCH}'" >> $(VERSIONFILE) - echo "character(len=64), parameter :: gitHash = '${GITHASH}'" >> $(VERSIONFILE) - -# compile Noah-MP routines -compile_noah: - $(FC_EXE) $(FLAGS_NOAH) -c $(NRUTIL) $(NOAHMP) - -# compile common routines -compile_comm: - $(FC_EXE) $(FLAGS_COMM) -c $(COMM_ALL) $(INCLUDES) - -# compile SUMMA routines -compile_summa: update_version - $(FC_EXE) $(FLAGS_SUMMA) -c $(SUMMA_ALL) $(DRIVER) \ - $(INCLUDES) - -# link routines -link: - $(FC_EXE) -g *.o $(LIBRARIES) -o $(DRIVER__EX) - -# Remove object files -clean: - rm -f *.o - rm -f *.mod - rm -f soil_veg_gen_parm__genmod.f90 - -# Copy the executable to the bin directory -install: - @mkdir -p $(EXE_PATH) - @mv $(DRIVER__EX) $(EXE_PATH) - $(info $(DRIVER__EX) successfully installed in $(EXE_PATH)) diff --git a/build/cmake/FindNetCDF.cmake b/build/cmake/FindNetCDF.cmake new file mode 100644 index 000000000..1f49cb485 --- /dev/null +++ b/build/cmake/FindNetCDF.cmake @@ -0,0 +1,28 @@ +include(FindPackageHandleStandardArgs) + +# Find the NetCDF C library and include directory +find_library(NetCDF_C_LIBRARY NAMES netcdf) +find_path(NetCDF_C_INCLUDE_DIR NAMES netcdf.h) + +# Find the NetCDF Fortran library +find_library(NetCDF_F90_LIBRARY NAMES netcdff) +find_path(NetCDF_F90_INCLUDE_DIR NAMES netcdf.mod) + +set (NetCDF_LIBRARIES ${NetCDF_C_LIBRARY} ${NetCDF_F90_LIBRARY}) +set (NetCDF_INCLUDE_DIRS ${NetCDF_C_INCLUDE_DIR} ${NetCDF_F90_INCLUDE_DIR}) + +find_package_handle_standard_args(NetCDF DEFAULT_MSG + NetCDF_LIBRARIES NetCDF_INCLUDE_DIRS) + +if(NetCDF_FOUND) + mark_as_advanced (NetCDF_C_LIBRARY NetCDF_C_INCLUDE_DIR NetCDF_F90_LIBRARY NetCDF_DIR) + + add_library(NetCDF::NetCDF INTERFACE IMPORTED) + + set_target_properties(NetCDF::NetCDF PROPERTIES + INTERFACE_INCLUDE_DIRECTORIES "${NetCDF_INCLUDE_DIRS}" + INTERFACE_LINK_LIBRARIES "${NetCDF_LIBRARIES}") + + message(STATUS "NetCDF incl for all components -- ${NetCDF_INCLUDE_DIRS}") + message(STATUS "NetCDF lib for all components -- ${NetCDF_LIBRARIES}") +endif() \ No newline at end of file diff --git a/build/cmake/FindOpenBLAS.cmake b/build/cmake/FindOpenBLAS.cmake new file mode 100644 index 000000000..38ad49332 --- /dev/null +++ b/build/cmake/FindOpenBLAS.cmake @@ -0,0 +1,14 @@ +# Find the OpenBLAS library +find_library(OpenBLAS_LIBRARY NAMES openblas) + +# Find the OpenBLAS include directory +find_path(OpenBLAS_INCLUDE_DIR NAMES cblas.h) + +if(OpenBLAS_LIBRARY AND OpenBLAS_INCLUDE_DIR) + add_library(OpenBLAS::OpenBLAS INTERFACE IMPORTED) + set_target_properties(OpenBLAS::OpenBLAS PROPERTIES + INTERFACE_INCLUDE_DIRECTORIES "${OpenBLAS_INCLUDE_DIR}" + INTERFACE_LINK_LIBRARIES "${OpenBLAS_LIBRARY}") +else() + message(FATAL_ERROR "OpenBLAS not found") +endif() \ No newline at end of file diff --git a/build/cmake/build.cluster.bash b/build/cmake/build.cluster.bash new file mode 100755 index 000000000..3ac88b2e5 --- /dev/null +++ b/build/cmake/build.cluster.bash @@ -0,0 +1,29 @@ +#!/bin/bash + +# build on HPC, from cmake directory run this as ./build.cluster.bash + +# load these modules in run environment as well as build environment +# Digital Resource Alliance of Canada settings +module load StdEnv/2023 +module load gcc/12.3 +module load openblas/0.3.24 +module load openmpi/4.1.5 +module load netcdf-fortran/4.6.1 +# +# Purdue Anvil settings +#module load gcc/14.2.0 +#module load openmpi/4.1.6 +#module load openblas/0.3.17 +#module load netcdf-fortran/4.5.3 + +# Actors install of sundials +#export SUNDIALS_DIR="$CMAKE_PREFIX_PATH:$HOME/Summa-Actors/utils/dependencies/sundials/" +# +# Regular install of sundials +export SUNDIALS_DIR=$HOME/SummaSundials/sundials/instdir/ + +# May want to use this flag +#export FLAGS_OPT="-flto=1;-fuse-linker-plugin" + +cmake -B ../cmake_build -S ../. -DUSE_SUNDIALS=ON -DCMAKE_BUILD_TYPE=Release -DSPECIFY_LAPACK_LINKS=OFF +cmake --build ../cmake_build --target all -j diff --git a/build/cmake/build.mac.bash b/build/cmake/build.mac.bash new file mode 100755 index 000000000..78cbb39de --- /dev/null +++ b/build/cmake/build.mac.bash @@ -0,0 +1,14 @@ +#!/bin/bash + +# build SUMMA on a Mac using Bash, from cmake directory run this as ./build.mac.bash +# Environment variables may be set within this script (see examples below) or in the terminal environment before executing this script +# Actual settings may vary + +# Mac Example using MacPorts: +export FC=/opt/local/bin/gfortran # Fortran compiler family +#export FLAGS_OPT="-flto=1" # -flto=1 is slow to compile, but might want to use +export LIBRARY_LINKS='-llapack' # list of library links +export SUNDIALS_DIR=../../../sundials/instdir/ + +cmake -B ../cmake_build -S ../. -DUSE_SUNDIALS=ON -DSPECIFY_LAPACK_LINKS=ON -DCMAKE_BUILD_TYPE=Release +cmake --build ../cmake_build --target all -j diff --git a/build/cmake/build.pc.bash b/build/cmake/build.pc.bash new file mode 100755 index 000000000..73d85f24d --- /dev/null +++ b/build/cmake/build.pc.bash @@ -0,0 +1,17 @@ +#!/bin/bash + +# Build SUMMA on a PC using Bash, from cmake directory run this as ./build.pc.bash +# Environment variables may be set within this script (see examples below) or in the terminal environment before executing this script +# Actual settings may vary + +# PC Example using Ubuntu: LAPACK Builds +#export FLAGS_OPT="-flto=1;-fuse-linker-plugin" # optional compiler flags -- LAPACK builds + +# PC Example using Ubuntu: Intel oneMKL builds (see https://www.intel.com/content/www/us/en/developer/tools/oneapi/onemkl-link-line-advisor.html) +#oneAPI_dir=/opt/intel/oneapi # Intel oneAPI main directory +#source $oneAPI_dir/setvars.sh # initialize environment variables for Intel oneAPI +#export LIBRARY_LINKS="-m64;-Wl,--start-group ${MKLROOT}/lib/libmkl_gf_lp64.a ${MKLROOT}/lib/libmkl_sequential.a ${MKLROOT}/lib/libmkl_core.a -Wl,--end-group;-lpthread;-lm;-ldl" # static sequential library (i.e., no multithreading) +#export FLAGS_OPT="-m64;-I"${MKLROOT}/include";-flto=1;-fuse-linker-plugin" # optional compiler flags -- Intel oneMKL builds + +cmake -B ../cmake_build -S ../. -DUSE_SUNDIALS=ON -DUSE_OPENWQ=OFF -DSPECIFY_LAPACK_LINKS=ON #-DCMAKE_BUILD_TYPE=Debug +cmake --build ../cmake_build --target all -j diff --git a/build/cmake/build_ngen.cluster.bash b/build/cmake/build_ngen.cluster.bash new file mode 100755 index 000000000..d1a9bcfed --- /dev/null +++ b/build/cmake/build_ngen.cluster.bash @@ -0,0 +1,80 @@ +#!/bin/bash + +# Build nextgen on HPC, from ngen directory put this one directory up and run this as ../build_ngen.cluster.bash +# Load modules, example on Anvil +module load r/4.4.1 +module load gcc/14.2.0 +module load openmpi/4.1.6 +module load gdal/3.10.0 +module load conda/2024.09 +module load openblas/0.3.17 +module load netcdf-fortran/4.5.3 +module load udunits/2.2.28 +module load boost/1.86.0 +module load sqlite/3.46.0-ayg27dg + +# Environment variables may be set within this script (see examples below) or in the terminal environment before executing this script +# activate correct python environment, here is an example with conda environment named venv installed from SYMFLUENCE +: "${PYNGEN_CONDA_ENV:=venv}" +source ${HOME}/Symfluence/SYMFLUENCE/${PYNGEN_CONDA_ENV}/bin/activate +# fallback: allow overriding python executable explicitly +: "${DPython3_EXECUTABLE:=$(which python 2>/dev/null || echo /usr/bin/python3)}" +export DPython3_EXECUTABLE +export PYTHONNOUSERSITE=1 +python -m pip install --upgrade "pip<24.1" >/dev/null 2>&1 || true +python - <<'PY' || (python -m pip install "numpy<2" "setuptools<70" && true) +from packaging.version import Version +import numpy as np +assert Version(np.__version__) < Version("2.0") +PY +python - <<'PY' +import numpy as np +print("Using NumPy:", np.__version__) +PY +: "${DPython_NumPy_INCLUDE_DIR:=$(python -c 'import numpy; print(numpy.get_include())')}" +export DPython_NumPy_INCLUDE_DIR + +#export FLAGS_OPT="-flto=1" # -flto=1 is slow to compile, but might want to use + +export SUNDIALS_DIR="$CMAKE_PREFIX_PATH:$HOME/Summa-Actors/utils/dependencies/sundials/" + +# Build SUMMA NGEN below +cmake -B extern/iso_c_fortran_bmi/cmake_build -S extern/iso_c_fortran_bmi +cmake --build extern/iso_c_fortran_bmi/cmake_build --target all + +cmake -B extern/summa/cmake_build -S extern/summa -DUSE_NEXTGEN=ON -DUSE_SUNDIALS=OFF -DSPECIFY_LAPACK_LINKS=OFF -DCMAKE_BUILD_TYPE=Release +cmake --build extern/summa/cmake_build --target all -j + +cmake -S . -B cmake_build -DPython_NumPy_INCLUDE_DIR=${DPython_NumPy_INCLUDE_DIR} -DPython_EXECUTABLE=${DPython3_EXECUTABLE} \ + -DCMAKE_BUILD_TYPE=RelWithDebInfo \ + -DNGEN_IS_MAIN_PROJECT=ON \ + -DNGEN_WITH_MPI:BOOL=ON \ + -DNGEN_WITH_NETCDF:BOOL=ON \ + -DNGEN_WITH_SQLITE:BOOL=ON \ + -DNGEN_WITH_UDUNITS:BOOL=ON \ + -DNGEN_WITH_BMI_FORTRAN:BOOL=ON \ + -DNGEN_WITH_BMI_C:BOOL=ON \ + -DNGEN_WITH_PYTHON:BOOL=ON \ + -DNGEN_WITH_ROUTING:BOOL=ON \ + -DNGEN_WITH_TESTS:BOOL=ON \ + -DNGEN_QUIET:BOOL=ON \ + -DNGEN_WITH_EXTERN_ALL:BOOL=ON + +# Comments on above choices, and defaults +# -DCMAKE_BUILD_TYPE=RelWithDebInfo: to be able to run in gdb change to -DCMAKE_BUILD_TYPE=Debug +# -DNGEN_IS_MAIN_PROJECT=ON : must be BOOL=ON for DNGEN_WITH_EXTERN_ALL:BOOL=ON +# -DNGEN_WITH_MPI:BOOL=OFF : may want to turn this ON as well as uncommenting "make -j 8 -C cmake_build" +# -DNGEN_WITH_NETCDF:BOOL=ON : must be BOOL=ON to build SUMMA NGEN +# -DNGEN_WITH_SQLITE:BOOL=ON : must be BOOL=ON if planning to use GeoPackages (and not just geojsons) +# -DNGEN_WITH_UDUNITS:BOOL=ON : must be BOOL=ON to build SUMMA NGEN +# -DNGEN_WITH_BMI_FORTRAN:BOOL=ON : must be BOOL=ON to build SUMMA NGEN +# -DNGEN_WITH_BMI_C:BOOL=ON : must be BOOL=ON for DNGEN_WITH_EXTERN_ALL:BOOL=ON +# -DNGEN_WITH_PYTHON:BOOL=ON : must be BOOL=ON for DNGEN_WITH_EXTERN_ALL:BOOL=ON +# -DNGEN_WITH_ROUTING:BOOL=ON : must have DNGEN_WITH_PYTHON:BOOL=ON for this to be ON +# -DNGEN_WITH_TESTS:BOOL=ON : must have DNGEN_WITH_EXTERN_ALL:BOOL=ON for this to be ON +# -DNGEN_QUIET:BOOL=ON : may want turn to this OFF, especially if debugging +# -DNGEN_WITH_EXTERN_ALL:BOOL=ON : these submodules are not used with SUMMA, you may turn this off you don't want to use them + +# make -j 8 -C cmake_build # build w/ 8 parallel jobs, if uncomment then comment the next line and use DNGEN_WITH_MPI:BOOL=ON +make -C cmake_build + diff --git a/build/cmake/build_ngen.mac.bash b/build/cmake/build_ngen.mac.bash new file mode 100755 index 000000000..c1e486a4c --- /dev/null +++ b/build/cmake/build_ngen.mac.bash @@ -0,0 +1,72 @@ +#!/bin/bash + +# Build nextgen on Mac, from ngen directory put this one directory up and run this as ../build_ngen.mac.bash +# Environment variables may be set within this script (see examples below) or in the terminal environment before executing this script +# activate correct python environment, here is an example with conda environment named pyngen +: "${PYNGEN_CONDA_ENV:=pyngen}" +# try common conda install locations; adjust if your conda is elsewhere +if [ -f "${HOME}/opt/anaconda3/etc/profile.d/conda.sh" ]; then + . "${HOME}/opt/anaconda3/etc/profile.d/conda.sh" +elif [ -f "/Users/amedin/opt/anaconda3/etc/profile.d/conda.sh" ]; then + . "/Users/amedin/opt/anaconda3/etc/profile.d/conda.sh" +elif command -v conda >/dev/null 2>&1; then + eval "$(conda shell.bash hook)" || true +fi +# activate env if possible (non-fatal) +if command -v conda >/dev/null 2>&1; then + conda activate "${PYNGEN_CONDA_ENV}" || true +fi +# fallback: allow overriding python executable explicitly +: "${DPython3_EXECUTABLE:=$(which python 2>/dev/null || echo /usr/bin/python3)}" +export DPython3_EXECUTABLE + +# Mac Example using MacPorts: +export CC=/opt/local/bin/gcc +export CXX=/opt/local/bin/g++ +export FC=/opt/local/bin/gfortran + +#export FLAGS_OPT="-flto=1" # -flto=1 is slow to compile, but might want to use +export C_INCLUDE_PATH=/opt/local/include +export CPLUS_INCLUDE_PATH=/opt/local/include +export LIBRARY_LINKS='-llapack' # list of library links +export SUNDIALS_DIR=../../../sundials/instdir/ # will not be used if -DUSE_SUNDIALS=OFF + +# Build SUMMA NGEN below, may wish to turn -DUSE_SUNDIALS=ON (must install Sundials first) +cmake -B extern/iso_c_fortran_bmi/cmake_build -S extern/iso_c_fortran_bmi +cmake --build extern/iso_c_fortran_bmi/cmake_build --target all + +cmake -B extern/summa/cmake_build -S extern/summa -DUSE_NEXTGEN=ON -DUSE_SUNDIALS=OFF -DSPECIFY_LAPACK_LINKS=ON -DCMAKE_BUILD_TYPE=Release +cmake --build extern/summa/cmake_build --target all -j + +cmake -S . -B cmake_build -DBoost_INCLUDE_DIR=/opt/local/libexec/boost/1.81/include -DPython_NumPy_INCLUDE_DIR=/opt/local/bin/python \ + -DCMAKE_BUILD_TYPE=RelWithDebInfo \ + -DNGEN_IS_MAIN_PROJECT=ON \ + -DNGEN_WITH_MPI:BOOL=OFF \ + -DNGEN_WITH_NETCDF:BOOL=ON \ + -DNGEN_WITH_SQLITE:BOOL=ON \ + -DNGEN_WITH_UDUNITS:BOOL=ON \ + -DNGEN_WITH_BMI_FORTRAN:BOOL=ON \ + -DNGEN_WITH_BMI_C:BOOL=ON \ + -DNGEN_WITH_PYTHON:BOOL=ON \ + -DNGEN_WITH_ROUTING:BOOL=ON \ + -DNGEN_WITH_TESTS:BOOL=ON \ + -DNGEN_QUIET:BOOL=ON \ + -DNGEN_WITH_EXTERN_ALL:BOOL=ON + +# Comments on above choices, and defaults +# -DCMAKE_BUILD_TYPE=RelWithDebInfo: to be able to run in gdb change to -DCMAKE_BUILD_TYPE=Debug +# -DNGEN_IS_MAIN_PROJECT=ON : must be BOOL=ON for DNGEN_WITH_EXTERN_ALL:BOOL=ON +# -DNGEN_WITH_MPI:BOOL=OFF : may want to turn this ON as well as uncommenting "make -j 8 -C cmake_build" +# -DNGEN_WITH_NETCDF:BOOL=ON : must be BOOL=ON to build SUMMA NGEN +# -DNGEN_WITH_SQLITE:BOOL=ON : must be BOOL=ON if planning to use GeoPackages (and not just geojsons) +# -DNGEN_WITH_UDUNITS:BOOL=ON : must be BOOL=ON to build SUMMA NGEN +# -DNGEN_WITH_BMI_FORTRAN:BOOL=ON : must be BOOL=ON to build SUMMA NGEN +# -DNGEN_WITH_BMI_C:BOOL=ON : must be BOOL=ON for DNGEN_WITH_EXTERN_ALL:BOOL=ON +# -DNGEN_WITH_PYTHON:BOOL=ON : must be BOOL=ON for DNGEN_WITH_EXTERN_ALL:BOOL=ON +# -DNGEN_WITH_ROUTING:BOOL=ON : must have DNGEN_WITH_PYTHON:BOOL=ON for this to be ON +# -DNGEN_WITH_TESTS:BOOL=ON : must have DNGEN_WITH_EXTERN_ALL:BOOL=ON for this to be ON +# -DNGEN_QUIET:BOOL=ON : may want turn to this OFF, especially if debugging +# -DNGEN_WITH_EXTERN_ALL:BOOL=ON : these submodules are not used with SUMMA, you may turn this off you don't want to use them + +# make -j 8 -C cmake_build # build w/ 8 parallel jobs, if uncomment then comment the next line and use DNGEN_WITH_MPI:BOOL=ON +make -C cmake_build diff --git a/build/cmake/summabmi.pc.in b/build/cmake/summabmi.pc.in new file mode 100644 index 000000000..cbbadcf8a --- /dev/null +++ b/build/cmake/summabmi.pc.in @@ -0,0 +1,10 @@ +prefix=@CMAKE_INSTALL_PREFIX@ +exec_prefix=@CMAKE_INSTALL_PREFIX@ +libdir=${exec_prefix}/@CMAKE_INSTALL_LIBDIR@ +includedir=${prefix}/@CMAKE_INSTALL_INCLUDEDIR@ +Name: @SUMMA_LIB_NAME_CMAKE@ +Description: @SUMMA_DESC_CMAKE@ +Version: @PROJECT_VERSION@ +Requires: +Libs: -L${libdir} -lmylib +Cflags: -I${includedir} diff --git a/build/cmake_external/build_cmakeActors.bash b/build/cmake_external/build_cmakeActors.bash new file mode 100755 index 000000000..4c27c3561 --- /dev/null +++ b/build/cmake_external/build_cmakeActors.bash @@ -0,0 +1,9 @@ +#!/bin/bash + +# from {$maindir}/actor-framework, run +# cp ../../summa/build/summa/build/cmake_external/build_cmakeActors.bash build_cmake +# run script from the actor-framework directory with ./build_cmake +# run `cd build`, `make`, then `make install` + +export CXX="g++" +./configure --prefix=../install diff --git a/build/cmake_external/build_cmakeBMI.bash b/build/cmake_external/build_cmakeBMI.bash new file mode 100755 index 000000000..d03062fa3 --- /dev/null +++ b/build/cmake_external/build_cmakeBMI.bash @@ -0,0 +1,8 @@ +#!/bin/bash + +# from {$maindir}/bmi/builddir, run +# cp ../../summa/build/cmake_external/build_cmakeBMI.bash build_cmake +# run script from the builddir directory with ./build_cmake +# run `make`, then `make install` + +cmake ../../bmi-fortran/ -DCMAKE_Fortran_COMPILER=gfortran -DCMAKE_INSTALL_PREFIX=../../bmi/instdir diff --git a/build/cmake_external/build_cmakeSundials.bash b/build/cmake_external/build_cmakeSundials.bash new file mode 100755 index 000000000..d56903efe --- /dev/null +++ b/build/cmake_external/build_cmakeSundials.bash @@ -0,0 +1,9 @@ +#!/bin/bash + +# from {$maindir}/sundials/builddir, run +# cp ../../summa/build/cmake_external/build_cmakeSundials.bash build_cmake +# run script from the builddir directory with ./build_cmake +# run `make`, then `make install` +# Note, using -DEXAMPLES_ENABLE_C=OFF -DEXAMPLES_ENABLE_F2003=OFF, if want to run examples should change + +cmake ../../sundials-software/ -DEXAMPLES_ENABLE_C=OFF -DEXAMPLES_ENABLE_F2003=OFF -DBUILD_FORTRAN_MODULE_INTERFACE=ON -DCMAKE_Fortran_COMPILER=gfortran -DCMAKE_INSTALL_PREFIX=../../sundials/instdir -DEXAMPLES_INSTALL_PATH=../../sundials/instdir/examples diff --git a/build/source/CMakeLists.txt b/build/source/CMakeLists.txt new file mode 100644 index 000000000..a9f885857 --- /dev/null +++ b/build/source/CMakeLists.txt @@ -0,0 +1,163 @@ +#=============================================================================== +# List of Source Files for SUMMA +# All Variables are reachable from the parent scope +#=============================================================================== + +# NOAHMP modules +set(NOAHMP + ${NOAHMP_DIR}/module_model_constants.F + ${NOAHMP_DIR}/module_sf_noahutl.F + ${NOAHMP_DIR}/module_sf_noahlsm.F + ${NOAHMP_DIR}/module_sf_noahmplsm.F + CACHE INTERNAL "NOAHMP") + +# Free versions of numerical recipes utilities for NOAH-MP modules +set(NRUTIL + ${ENGINE_DIR}/f2008funcs.f90 + ${ENGINE_DIR}/nr_utility.f90 + ${ENGINE_DIR}/nrtype.f90 + CACHE INTERNAL "NRUTIL") + +# Free versions of numerical recipes procedures for SUMMA modules +set(NRPROC + ${ENGINE_DIR}/expIntegral.f90 + ${ENGINE_DIR}/spline_int.f90 + ${ENGINE_DIR}/hyp_2F1.f90 + CACHE INTERNAL "NRPROC") + +# Hook-up modules +set(HOOKUP + ${HOOKUP_DIR}/ascii_util.f90 + ${HOOKUP_DIR}/summaFileManager.f90 + CACHE INTERNAL "HOOKUP") + +# Data modules +set(DATAMS + ${DSHARE_DIR}/data_types.f90 + ${DSHARE_DIR}/flxMapping.f90 + ${DSHARE_DIR}/get_ixname.f90 + ${DSHARE_DIR}/globalData.f90 + ${DSHARE_DIR}/multiconst.f90 + ${DSHARE_DIR}/outpt_stat.f90 + ${DSHARE_DIR}/popMetadat.f90 + ${DSHARE_DIR}/var_lookup.f90 + CACHE INTERNAL "DATAMS") +set(DATAMS_SUNDIALS + ${DSHARE_DIR}/type4ida.f90 + ${DSHARE_DIR}/type4kinsol.f90 + CACHE INTERNAL "DATAMS_SUNDIALS") + +# Utility modules +set(UTILMS + ${ENGINE_DIR}/matrixOper.f90 + ${ENGINE_DIR}/mDecisions.f90 + ${ENGINE_DIR}/snow_utils.f90 + ${ENGINE_DIR}/soil_utils.f90 + ${ENGINE_DIR}/time_utils.f90 + ${ENGINE_DIR}/updatState.f90 + CACHE INTERNAL "UTILMS") +set(UTILMS_SUNDIALS + ${ENGINE_DIR}/soil_utilsAddPrime.f90 + ${ENGINE_DIR}/updatStateWithPrime.f90 + CACHE INTERNAL "UTILMS_SUNDIALS") + +# NetCDF routines +set(NETCDF + ${NETCDF_DIR}/def_output.f90 + ${NETCDF_DIR}/modelwrite.f90 + ${NETCDF_DIR}/netcdf_util.f90 + ${NETCDF_DIR}/read_icond.f90 + CACHE INTERNAL "NETCDF") + +# Preliminary modules +set(PRELIM + ${ENGINE_DIR}/allocspace.f90 + ${ENGINE_DIR}/check_icond.f90 + ${ENGINE_DIR}/checkStruc.f90 + ${ENGINE_DIR}/childStruc.f90 + ${ENGINE_DIR}/conv_funcs.f90 + ${ENGINE_DIR}/ffile_info.f90 + ${ENGINE_DIR}/read_pinit.f90 + ${ENGINE_DIR}/read_attrb.f90 + ${ENGINE_DIR}/paramCheck.f90 + ${ENGINE_DIR}/pOverwrite.f90 + ${ENGINE_DIR}/sunGeomtry.f90 + ${ENGINE_DIR}/read_param.f90 + CACHE INTERNAL "PRELIM") + +# Model run support modules +set(MODRUN + ${ENGINE_DIR}/canopySnow.f90 + ${ENGINE_DIR}/derivforce.f90 + ${ENGINE_DIR}/enthalpyTemp.f90 + ${ENGINE_DIR}/getVectorz.f90 + ${ENGINE_DIR}/indexState.f90 + ${ENGINE_DIR}/layerMerge.f90 + ${ENGINE_DIR}/layerDivide.f90 + ${ENGINE_DIR}/qTimeDelay.f90 + ${ENGINE_DIR}/read_force.f90 + ${ENGINE_DIR}/snowAlbedo.f90 + ${ENGINE_DIR}/snwCompact.f90 + ${ENGINE_DIR}/tempAdjust.f90 + ${ENGINE_DIR}/updateVars.f90 + ${ENGINE_DIR}/var_derive.f90 + ${ENGINE_DIR}/volicePack.f90 + CACHE INTERNAL "MODRUN") +set(MODRUN_SUNDIALS + ${ENGINE_DIR}/tol4ida.f90 + ${ENGINE_DIR}/updateVarsWithPrime.f90 + CACHE INTERNAL "MODRUN_SUNDIALS") + +# Solver main modules +set(SOLVER + ${ENGINE_DIR}/bigAquifer.f90 + ${ENGINE_DIR}/computFlux.f90 + ${ENGINE_DIR}/computHeatCap.f90 + ${ENGINE_DIR}/computJacob.f90 + ${ENGINE_DIR}/computResid.f90 + ${ENGINE_DIR}/computSnowDepth.f90 + ${ENGINE_DIR}/computThermConduct.f90 + ${ENGINE_DIR}/coupled_em.f90 + ${ENGINE_DIR}/diagn_evar.f90 + ${ENGINE_DIR}/eval8summa.f90 + ${ENGINE_DIR}/groundwatr.f90 + ${ENGINE_DIR}/opSplittin.f90 + ${ENGINE_DIR}/run_oneGRU.f90 + ${ENGINE_DIR}/run_oneHRU.f90 + ${ENGINE_DIR}/snowLiqFlx.f90 + ${ENGINE_DIR}/soilLiqFlx.f90 + ${ENGINE_DIR}/ssdNrgFlux.f90 + ${ENGINE_DIR}/stomResist.f90 + ${ENGINE_DIR}/summaSolve4homegrown.f90 + ${ENGINE_DIR}/systemSolv.f90 + ${ENGINE_DIR}/varSubstep.f90 + ${ENGINE_DIR}/vegLiqFlux.f90 + ${ENGINE_DIR}/vegNrgFlux.f90 + ${ENGINE_DIR}/vegPhenlgy.f90 + ${ENGINE_DIR}/vegSWavRad.f90 + CACHE INTERNAL "SOLVER") +set(SOLVER_SUNDIALS + ${ENGINE_DIR}/computJacobWithPrime.f90 + ${ENGINE_DIR}/computResidWithPrime.f90 + ${ENGINE_DIR}/eval8summaWithPrime.f90 + ${ENGINE_DIR}/summaSolve4ida.f90 + ${ENGINE_DIR}/summaSolve4kinsol.f90 + CACHE INTERNAL "SOLVER_SUNDIALS") + +# Driver support modules +set(DRIVER + ${DRIVER_DIR}/summa_type.f90 + ${DRIVER_DIR}/summa_setup.f90 + ${DRIVER_DIR}/summa_restart.f90 + ${DRIVER_DIR}/summa_alarms.f90 + ${DRIVER_DIR}/summa_globalData.f90 + ${DRIVER_DIR}/summa_util.f90 + ${DRIVER_DIR}/summa_defineOutput.f90 + ${DRIVER_DIR}/summa_init.f90 + ${DRIVER_DIR}/summa_forcing.f90 + ${DRIVER_DIR}/summa_modelRun.f90 + ${DRIVER_DIR}/summa_writeOutput.f90 + CACHE INTERNAL "DRIVER") +set(DRIVER_NEXTGEN + ${DRIVER_DIR}/summa_bmi.f90 + CACHE INTERNAL "DRIVER_NEXTGEN") diff --git a/build/source/driver/summa_alarms.f90 b/build/source/driver/summa_alarms.f90 old mode 100755 new mode 100644 index 0d9c27864..1ee5d1564 --- a/build/source/driver/summa_alarms.f90 +++ b/build/source/driver/summa_alarms.f90 @@ -41,7 +41,7 @@ module summa_alarms ! named variable for time structures USE var_lookup,only:iLookTIME ! named variables for time data structure -USE var_lookup,only:iLookFreq ! named variables for the frequency structure +USE var_lookup,only:iLookFREQ ! named variables for the frequency structure ! structure dimensions USE var_lookup,only:maxvarFreq ! maximum number of output files @@ -52,116 +52,116 @@ module summa_alarms public::summa_setWriteAlarms contains - ! used to set alarms to write model output - subroutine summa_setWriteAlarms(oldTime, newTime, endTime, & ! time vectors - newOutputFile, defNewOutputFile, & ! flag to define new output file - ixRestart, printRestart, & ! flag to print the restart file - ixProgress, printProgress, & ! flag to print simulation progress - resetStats, finalizeStats, & ! flags to reset and finalize stats - statCounter, & ! statistics counter - err,message) ! error control - ! --------------------------------------------------------------------------------------- - ! data types - USE nrtype ! variable types, etc. - ! --------------------------------------------------------------------------------------- - implicit none - ! dummy variables: time vectors - integer(i4b),intent(in) :: oldTime(:) ! time vector from the previous time step - integer(i4b),intent(in) :: newTime(:) ! time vector from the current time step - integer(i4b),intent(in) :: endTime(:) ! time vector at the end of the simulation - ! dummy variables: model decisions - integer(i4b),intent(in) :: newOutputFile ! option for the new output file - integer(i4b),intent(in) :: ixRestart ! option to write the restart file - integer(i4b),intent(in) :: ixProgress ! option to print simulation progress - logical(lgt),intent(in) :: resetStats(:) ! flags to reset statistics - ! dummy variables: alarms - logical(lgt),intent(out) :: defNewOutputFile ! flag to define new output file - logical(lgt),intent(out) :: printRestart ! flag to write the restart file - logical(lgt),intent(out) :: printProgress ! flag to print simulation progress - ! dummy variables: controls on statistics output - logical(lgt),intent(out) :: finalizeStats(:) ! flags to finalize statistics - integer(i4b),intent(out) :: statCounter(:) ! index in model output for different output frequencies - ! dummy variables: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! --------------------------------------------------------------------------------------- - ! local variables - integer(i4b) :: iFreq ! loop through frequencies - ! --------------------------------------------------------------------------------------- - ! initialize error control - err=0; message='summa_setWriteAlarms/' - - ! ***************************************************************************** - ! *** define the need to create the model output file - ! ***************************************************************************** - - ! define the need to create a new output file - select case(newOutputFile) - - ! (don't create a new output files) - case(noNewFiles); defNewOutputFile=.false. - - ! (check for the start of the USA water year) - case(newFileEveryOct1) - defNewOutputFile = (newTime(iLookTIME%im) == 10 .and. & ! month = October - newTime(iLookTIME%im) /= oldTime(iLookTIME%im)) ! first timestep in October - - ! (check that we found the option) - case default; err=20; message=trim(message)//'unable to identify the option to define new output files'; return - - end select - - ! ***************************************************************************** - ! *** define the need to create a restart file - ! ***************************************************************************** - select case(ixRestart) - case(ixRestart_iy); printRestart = (newTime(iLookTIME%im) == 1 .and. newTime(iLookTIME%id) == 1 .and. & - newTime(iLookTIME%ih) == 0 .and. newTime(iLookTIME%imin) == 0) - case(ixRestart_im); printRestart = (newTime(iLookTIME%id) == 1 .and. newTime(iLookTIME%ih) == 0 .and. & - newTime(iLookTIME%imin) == 0) - case(ixRestart_id); printRestart = (newTime(iLookTIME%ih) == 0 .and. newTime(iLookTIME%imin) == 0) - case(ixRestart_end); printRestart = (newTime(iLookTIME%im) == endTime(iLookTIME%im) .and. & - newTime(iLookTIME%id) == endTime(iLookTIME%id) .and. & - newTime(iLookTIME%ih) == endTime(iLookTIME%ih) .and. & - newTime(iLookTIME%imin) == endTime(iLookTIME%imin)) ! newTime does not have a '24h', won't write ending state if end_h=24 - case(ixRestart_never); printRestart = .false. - case default; err=20; message=trim(message)//'unable to identify option for the restart file'; return - end select - - ! ***************************************************************************** - ! *** define the need to print progress - ! ***************************************************************************** - select case(ixProgress) - case(ixProgress_im); printProgress = (newTime(iLookTIME%im) /= oldTime(iLookTIME%im)) ! start month missed - case(ixProgress_id); printProgress = (newTime(iLookTIME%id) /= oldTime(iLookTIME%id)) ! start day missed - case(ixProgress_ih); printProgress = (newTime(iLookTIME%imin) == 0) - case(ixProgress_it); printProgress = .true. - case(ixProgress_never); printProgress = .false. - case default; err=20; message=trim(message)//'unable to identify option to print progress'; return - end select - - ! ***************************************************************************** - ! *** reset counters/flags for model statistics - ! ***************************************************************************** - - ! reset output counters/flags - do iFreq=1,maxVarFreq ! loop through output frequencies - - ! define the need to finalize statistics - ! NOTE: time vector is configured so that ih=0 at the start of the day, hence day in oldTime and timeStruct%var differ - select case(iFreq) - case(iLookFreq%day ); finalizeStats(iFreq)=(oldTime(iLookTIME%id )/=newTime(iLookTIME%id )) ! daily aggregation - case(iLookFreq%month ); finalizeStats(iFreq)=(oldTime(iLookTIME%im )/=newTime(iLookTIME%im )) ! monthly aggregation - case(iLookFreq%annual ); finalizeStats(iFreq)=(oldTime(iLookTIME%iyyy)/=newTime(iLookTIME%iyyy)) ! yearly (annual) aggregation - case(iLookFreq%timestep); finalizeStats(iFreq)=.true. ! timestep-level output (no temporal aggregation) - case default; err=20; message=trim(message)//'unable to identify output frequency'; return - end select - - ! reset ouput timestep - if(resetStats(iFreq)) statCounter(iFreq)=1 - - end do ! looping through output frequencies - - end subroutine summa_setWriteAlarms - -end module summa_alarms +! used to set alarms to write model output +subroutine summa_setWriteAlarms(oldTime, newTime, endTime, & ! time vectors + newOutputFile, defNewOutputFile, & ! flag to define new output file + ixRestart, printRestart, & ! flag to print the restart file + ixProgress, printProgress, & ! flag to print simulation progress + resetStats, finalizeStats, & ! flags to reset and finalize stats + statCounter, & ! statistics counter + err,message) ! error control + ! --------------------------------------------------------------------------------------- + ! data types + USE nrtype ! variable types, etc. + ! --------------------------------------------------------------------------------------- + implicit none + ! dummy variables: time vectors + integer(i4b),intent(in) :: oldTime(:) ! time vector from the previous time step + integer(i4b),intent(in) :: newTime(:) ! time vector from the current time step + integer(i4b),intent(in) :: endTime(:) ! time vector at the end of the simulation + ! dummy variables: model decisions + integer(i4b),intent(in) :: newOutputFile ! option for the new output file + integer(i4b),intent(in) :: ixRestart ! option to write the restart file + integer(i4b),intent(in) :: ixProgress ! option to print simulation progress + logical(lgt),intent(in) :: resetStats(:) ! flags to reset statistics + ! dummy variables: alarms + logical(lgt),intent(out) :: defNewOutputFile ! flag to define new output file + logical(lgt),intent(out) :: printRestart ! flag to write the restart file + logical(lgt),intent(out) :: printProgress ! flag to print simulation progress + ! dummy variables: controls on statistics output + logical(lgt),intent(out) :: finalizeStats(:) ! flags to finalize statistics + integer(i4b),intent(out) :: statCounter(:) ! index in model output for different output frequencies + ! dummy variables: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! --------------------------------------------------------------------------------------- + ! local variables + integer(i4b) :: iFreq ! loop through frequencies + ! --------------------------------------------------------------------------------------- + ! initialize error control + err=0; message='summa_setWriteAlarms/' + + ! ***************************************************************************** + ! *** define the need to create the model output file + ! ***************************************************************************** + + ! define the need to create a new output file + select case(newOutputFile) + + ! (don't create a new output files) + case(noNewFiles); defNewOutputFile=.false. + + ! (check for the start of the USA water year) + case(newFileEveryOct1) + defNewOutputFile = (newTime(iLookTIME%im) == 10 .and. & ! month = October + newTime(iLookTIME%im) /= oldTime(iLookTIME%im)) ! first timestep in October + + ! (check that we found the option) + case default; err=20; message=trim(message)//'unable to identify the option to define new output files'; return + + end select + + ! ***************************************************************************** + ! *** define the need to create a restart file + ! ***************************************************************************** + select case(ixRestart) + case(ixRestart_iy); printRestart = (newTime(iLookTIME%im) == 1 .and. newTime(iLookTIME%id) == 1 .and. & + newTime(iLookTIME%ih) == 0 .and. newTime(iLookTIME%imin) == 0) + case(ixRestart_im); printRestart = (newTime(iLookTIME%id) == 1 .and. newTime(iLookTIME%ih) == 0 .and. & + newTime(iLookTIME%imin) == 0) + case(ixRestart_id); printRestart = (newTime(iLookTIME%ih) == 0 .and. newTime(iLookTIME%imin) == 0) + case(ixRestart_end); printRestart = (newTime(iLookTIME%im) == endTime(iLookTIME%im) .and. & + newTime(iLookTIME%id) == endTime(iLookTIME%id) .and. & + newTime(iLookTIME%ih) == endTime(iLookTIME%ih) .and. & + newTime(iLookTIME%imin) == endTime(iLookTIME%imin)) ! newTime does not have a '24h', won't write ending state if end_h=24 + case(ixRestart_never); printRestart = .false. + case default; err=20; message=trim(message)//'unable to identify option for the restart file'; return + end select + + ! ***************************************************************************** + ! *** define the need to print progress + ! ***************************************************************************** + select case(ixProgress) + case(ixProgress_im); printProgress = (newTime(iLookTIME%im) /= oldTime(iLookTIME%im)) ! start month missed + case(ixProgress_id); printProgress = (newTime(iLookTIME%id) /= oldTime(iLookTIME%id)) ! start day missed + case(ixProgress_ih); printProgress = (newTime(iLookTIME%imin) == 0) + case(ixProgress_it); printProgress = .true. + case(ixProgress_never); printProgress = .false. + case default; err=20; message=trim(message)//'unable to identify option to print progress'; return + end select + + ! ***************************************************************************** + ! *** reset counters/flags for model statistics + ! ***************************************************************************** + + ! reset output counters/flags + do iFreq=1,maxVarFreq ! loop through output frequencies + + ! define the need to finalize statistics + ! NOTE: time vector is configured so that ih=0 at the start of the day, hence day in oldTime and timeStruct%var differ + select case(iFreq) + case(iLookFREQ%day ); finalizeStats(iFreq)=(oldTime(iLookTIME%id )/=newTime(iLookTIME%id )) ! daily aggregation + case(iLookFREQ%month ); finalizeStats(iFreq)=(oldTime(iLookTIME%im )/=newTime(iLookTIME%im )) ! monthly aggregation + case(iLookFREQ%annual ); finalizeStats(iFreq)=(oldTime(iLookTIME%iyyy)/=newTime(iLookTIME%iyyy)) ! yearly (annual) aggregation + case(iLookFREQ%timestep); finalizeStats(iFreq)=.true. ! timestep-level output (no temporal aggregation) + case default; err=20; message=trim(message)//'unable to identify output frequency'; return + end select + + ! reset ouput timestep + if(resetStats(iFreq)) statCounter(iFreq)=1 + + end do ! looping through output frequencies + +end subroutine summa_setWriteAlarms + +end module summa_alarms \ No newline at end of file diff --git a/build/source/driver/summa_bmi.f90 b/build/source/driver/summa_bmi.f90 new file mode 100644 index 000000000..7ff2cb7b9 --- /dev/null +++ b/build/source/driver/summa_bmi.f90 @@ -0,0 +1,1441 @@ +! SUMMA - Structure for Unifying Multiple Modeling Alternatives +! Copyright (C) 2014-2020 NCAR/RAL; University of Saskatchewan; University of Washington +! +! This file is part of SUMMA +! +! For more information see: http://www.ral.ucar.edu/projects/summa +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see . + +module summabmi + ! provides functions needed for summa driver routines adding BMI functions + ! ***************************************************************************** + ! * use desired modules + ! ***************************************************************************** + ! data types + USE,intrinsic :: iso_c_binding, only: c_ptr, c_loc, c_f_pointer + USE nrtype ! variable types, etc. +! NGEN_ACTIVE is to be set when running in the Nextgen framework +! https://github.com/NOAA-OWP/ngen +#ifdef NGEN_ACTIVE + use bmif_2_0_iso ! BMI libraries NextGen +#else + use bmif_2_0 ! BMI libraries standard +#endif + USE summa_type, only: summa1_type_dec ! master summa data type + USE data_types, only: gru2hru_map ! mapping between the GRUs and HRUs + USE data_types, only: hru2gru_map ! mapping between the GRUs and HRUs + USE data_types, only: model_options ! the model decision structure + USE data_types, only: var_info ! metadata for variables in each model structure + USE data_types, only: extended_info ! extended metadata for variables in each model structure + USE data_types, only: file_info ! metadata for model forcing datafile + USE data_types, only: var_i ! vector of integers + ! subroutines and functions: model setup + USE summa_init, only: summa_initialize ! used to allocate/initialize summa data structures + USE summa_setup, only: summa_paramSetup ! used to initialize parameter data structures (e.g. vegetation and soil parameters) + USE summa_restart, only: summa_readRestart ! used to read restart data and reset the model state + ! subroutines and functions: model simulation + USE summa_forcing, only: summa_readForcing ! used to read forcing data + USE summa_modelRun, only: summa_runPhysics ! used to run the summa physics for one time step + USE summa_writeOutput, only: summa_writeOutputFiles ! used to write the summa output files + ! utility functions + USE summa_util, only: stop_program ! used to stop the summa program (with errors) + USE summa_util, only: handle_err ! used to process errors + ! global data + USE globalData, only: numtim ! number of model time steps + USE globalData, only: print_step_freq + USE globalData, only: dJulianStart ! julian day of start time of simulation + USE globalData, only: dJulianFinsh ! julian day of end time of simulation + USE globalData, only: data_step ! length of time steps for the outermost timeloop + USE globalData, only: startGRU ! index of the starting GRU for run + USE globalData, only: ixRestart_iy,ixRestart_im,ixRestart_id,ixRestart_end,ixRestart_never ! restart file frequency options + USE globalData, only: gru_struc ! HRU information for given GRU + USE globalData, only: index_map ! GRU information for given HRU + USE globalData, only: model_decisions ! model decision structure + USE globalData, only: fileout, output_fileSuffix ! output filename and suffix + USE globalData, only: outFreq ! output frequency flags + USE globalData, only: ncid ! netcdf output file id + USE globalData, only: maxLayers, maxSnowLayers ! maximum number of layers and snow layers + USE globalData, only: ixProgress ! define frequency to write progress + USE globalData, only: ixRestart ! define frequency to write restart files + USE globalData, only: newOutputFile ! define option for new output files + USE globalData, only: nHRUrun ! number of HRUs in the run domain + USE globalData, only: urbanVegCategory ! vegetation category for urban areas +#ifndef NGEN_FORCING_ACTIVE + USE globalData, only: ixHRUfile_min, ixHRUfile_max ! indices of the first and last HRUs in the forcing file + USE globalData, only: nHRUfile ! number of HRUs in the forcing file + USE globalData, only: forcFileInfo ! file info for model forcing data + USE globalData, only: iFile ! index of current forcing file from forcing file list + USE globalData, only: forcingStep, forcNcid ! index of current time step in current forcing file and netcdf id +#endif + USE globalData, only: statCounter, outputTimeStep ! timestep in output files and time counter for stats + USE globalData, only: resetStats, finalizeStats ! flags to reset and finalize statistics + USE globalData, only: oldTime ! time for the previous model time step + USE globalData, only: elapsedInit ! elapsed time for the initialization + USE globalData, only: elapsedSetup ! elapsed time for the parameter setup + USE globalData, only: elapsedRestart ! elapsed time to read restart data + USE globalData, only: elapsedRead ! elapsed time for the forcing data read + USE globalData, only: elapsedWrite ! elapsed time for the stats/write + USE globalData, only: elapsedPhysics ! elapsed time for the physics + USE multiconst, only: secprday ! number of seconds in a day + ! provide access to the named variables that describe elements of parent model structures + USE var_lookup, only: iLookTIME ! named variables for time data structure + USE var_lookup, only: iLookATTR ! named variables for real valued attribute data structure + USE var_lookup, only: iLookFORCE ! named variables for forcing data structure + USE var_lookup, only: iLookFLUX ! named variables for local flux variables + USE var_lookup, only: iLookDIAG ! named variables for local diagnostic variables + USE var_lookup, only: iLookPROG ! named variables for local prognostic variables + USE var_lookup, only: iLookBVAR ! named variables for basin (GRU) variables + USE var_lookup, only: maxvarDecisions ! maximum number of decisions + USE var_lookup, only: maxvarFreq ! maximum number of output files + + implicit none + + ! Define the attributes of the model. + type :: summa_model + integer(i4b) :: timeStep ! index of model time step + type(summa1_type_dec), allocatable :: summa1_struc(:) ! master summa data structure + type(gru2hru_map), allocatable :: gru_struc(:) ! HRU information for given GRU + type(hru2gru_map), allocatable :: index_map(:) ! GRU information for given HRU + type(model_options) :: model_decisions(maxvarDecisions) ! the model decisions, could change if different decisions for different GRUs + character(len=256) :: fileout, output_fileSuffix ! output filename and suffix + logical(lgt),dimension(maxvarFreq) :: outFreq ! true if the output frequency is desired + integer(i4b),dimension(maxvarFreq) :: ncid ! netcdf output file id + integer(i4b) :: maxLayers, maxSnowLayers ! maximum number of layers and snow layers, could be different for different GRUs + integer(i4b) :: ixProgress ! define frequency to write progress + integer(i4b) :: ixRestart ! define frequency to write restart files + integer(i4b) :: newOutputFile ! define option for new output files + integer(i4b) :: nHRUrun ! number of HRUs in the run domain + integer(i4b) :: urbanVegCategory ! vegetation category for urban areas +#ifndef NGEN_FORCING_ACTIVE + integer(i4b) :: ixHRUfile_min, ixHRUfile_max ! indices of the first and last HRUs in the forcing file + integer(i4b) :: nHRUfile ! number of HRUs in the forcing file + type(file_info), allocatable :: forcFileInfo(:) ! file info for model forcing data + integer(i4b) :: iFile ! index of current forcing file from forcing file list + integer(i4b) :: forcingStep, forcNcid ! index of current time step in current forcing file and netcdf id +#endif + integer(i4b),dimension(maxvarFreq) :: statCounter, outputTimeStep ! time counter for stats and time step in output files + logical(lgt),dimension(maxvarFreq) :: resetStats, finalizeStats ! flags to reset and finalize statistics + type(var_i) :: oldTime ! time for the previous model time step + real(rkind) :: elapsedInit ! elapsed time for the initialization + real(rkind) :: elapsedSetup ! elapsed time for the parameter setup + real(rkind) :: elapsedRestart ! elapsed time to read restart data + real(rkind) :: elapsedRead ! elapsed time for the forcing data read + real(rkind) :: elapsedWrite ! elapsed time for the stats/write + real(rkind) :: elapsedPhysics ! elapsed time for the physics + end type summa_model + + type, extends (bmi) :: summa_bmi + private + type (summa_model) :: model + contains + procedure :: get_component_name => summa_component_name + procedure :: get_input_item_count => summa_input_item_count + procedure :: get_output_item_count => summa_output_item_count + procedure :: get_input_var_names => summa_input_var_names + procedure :: get_output_var_names => summa_output_var_names + procedure :: initialize => summa_bmi_initialize + procedure :: finalize => summa_finalize + procedure :: get_start_time => summa_start_time + procedure :: get_end_time => summa_end_time + procedure :: get_current_time => summa_current_time + procedure :: get_time_step => summa_time_step + procedure :: get_time_units => summa_time_units + procedure :: update => summa_update + procedure :: update_until => summa_update_until + procedure :: get_var_grid => summa_var_grid + procedure :: get_grid_type => summa_grid_type + procedure :: get_grid_rank => summa_grid_rank + procedure :: get_grid_shape => summa_grid_shape + procedure :: get_grid_size => summa_grid_size + procedure :: get_grid_spacing => summa_grid_spacing + procedure :: get_grid_origin => summa_grid_origin + procedure :: get_grid_x => summa_grid_x + procedure :: get_grid_y => summa_grid_y + procedure :: get_grid_z => summa_grid_z + procedure :: get_grid_node_count => summa_grid_node_count + procedure :: get_grid_edge_count => summa_grid_edge_count + procedure :: get_grid_face_count => summa_grid_face_count + procedure :: get_grid_edge_nodes => summa_grid_edge_nodes + procedure :: get_grid_face_edges => summa_grid_face_edges + procedure :: get_grid_face_nodes => summa_grid_face_nodes + procedure :: get_grid_nodes_per_face => summa_grid_nodes_per_face + procedure :: get_var_type => summa_var_type + procedure :: get_var_units => summa_var_units + procedure :: get_var_itemsize => summa_var_itemsize + procedure :: get_var_nbytes => summa_var_nbytes + procedure :: get_var_location => summa_var_location + procedure :: get_value_int => summa_get_int + procedure :: get_value_float => summa_get_float + procedure :: get_value_double => summa_get_double + generic :: get_value => & + get_value_int, & + get_value_float, & + get_value_double + procedure :: get_value_ptr_int => summa_get_ptr_int + procedure :: get_value_ptr_float => summa_get_ptr_float + procedure :: get_value_ptr_double => summa_get_ptr_double + generic :: get_value_ptr => & + get_value_ptr_int, & + get_value_ptr_float, & + get_value_ptr_double + procedure :: get_value_at_indices_int => summa_get_at_indices_int + procedure :: get_value_at_indices_float => summa_get_at_indices_float + procedure :: get_value_at_indices_double => summa_get_at_indices_double + generic :: get_value_at_indices => & + get_value_at_indices_int, & + get_value_at_indices_float, & + get_value_at_indices_double + procedure :: set_value_int => summa_set_int + procedure :: set_value_float => summa_set_float + procedure :: set_value_double => summa_set_double + generic :: set_value => & + set_value_int, & + set_value_float, & + set_value_double + procedure :: set_value_at_indices_int => summa_set_at_indices_int + procedure :: set_value_at_indices_float => summa_set_at_indices_float + procedure :: set_value_at_indices_double => summa_set_at_indices_double + generic :: set_value_at_indices => & + set_value_at_indices_int, & + set_value_at_indices_float, & + set_value_at_indices_double + end type summa_bmi + + private + public :: summa_bmi + + ! ***************************************************************************** + ! * variable definitions + ! ***************************************************************************** + character (len=BMI_MAX_COMPONENT_NAME), target :: & + component_name = "Structure for Unifying Multiple Modeling Alternatives: SUMMA" + ! define parameters for the model simulation + integer(i4b), parameter :: n=1 ! number of instantiations + ! Exchange items +#ifdef NGEN_ACTIVE + integer, parameter :: input_item_count = 8 +#else + integer, parameter :: input_item_count = 7 +#endif + integer, parameter :: output_item_count = 16 + character (len=BMI_MAX_VAR_NAME), target,dimension(input_item_count) :: input_items + character (len=BMI_MAX_VAR_NAME), target,dimension(output_item_count) :: output_items + ! --------------------------------------------------------------------------------------- + + contains + + ! ***************************************************************************** + ! * model setup/initialization + ! ***************************************************************************** + function summa_bmi_initialize(this, config_file) result (bmi_status) + class (summa_bmi), intent(out) :: this + character (len=*), intent(in) :: config_file + ! error control + integer(i4b) :: err=0 ! error code + character(len=1024) :: message='' ! error message + character(len=1024) :: file_manager + character(len=16) :: restart_print_freq + integer(i4b) :: attrib_file_HRU_order + character(len=16) :: ixRestart_str + integer :: bmi_status,i,fu,rc + ! namelist definition + namelist /parameters/ file_manager, attrib_file_HRU_order, restart_print_freq + + ! initialize global variables + this%model%timeStep = 0 + fileout = '' + output_fileSuffix = '' +#ifndef NGEN_FORCING_ACTIVE + iFile = 1 + forcingStep = integerMissing + forcNcid = integerMissing +#endif + statCounter = 0 + outputTimeStep = 0 + resetStats = .true. + finalizeStats = .false. + + ! allocate space for the master summa structure + allocate(this%model%summa1_struc(n), stat=err) + if(err/=0) call stop_program(1, 'problem allocating master summa structure') + + ! if using the BMI interface, there is an argument pointing to the file manager file + ! then make sure summaFileManagerFile is set before executing initialization + if (len(config_file) > 0)then +#ifdef NGEN_ACTIVE + ! with NGEN the argument gives the file manager file as an input parameter in a namelist + open (action='read', file=config_file, iostat=rc, newunit=fu) + read (nml=parameters, iostat=rc, unit=fu) + this%model%summa1_struc(n)%summaFileManagerFile=trim(file_manager) + startGRU = attrib_file_HRU_order + ixRestart_str = trim(restart_print_freq) + select case (ixRestart_str) + case ('y' , 'year'); ixRestart = ixRestart_iy + case ('m' , 'month'); ixRestart = ixRestart_im + case ('d' , 'day'); ixRestart = ixRestart_id + case ('e' , 'end'); ixRestart = ixRestart_end + case ('n' , 'never'); ixRestart = ixRestart_never + case default; print*, 'unknown frequency to write restart files in NGEN parameters namelist'; err=1; return + end select + print * + print *, "INFO: NGEN detected, using file manager file ", trim(file_manager), " and GRU index in files ", startGRU +#else + ! without NGEN the argument gives the file manager file directly + ! Note, if this is more than 80 characters the pre-built BMI libraries will fail + this%model%summa1_struc(n)%summaFileManagerFile=trim(config_file) +#endif + endif + + ! declare and allocate summa data structures and initialize model state to known values + call summa_initialize(this%model%summa1_struc(n), err, message) + call handle_err(err, message) + + ! initialize parameter data structures (e.g. vegetation and soil parameters) + call summa_paramSetup(this%model%summa1_struc(n), err, message) + call handle_err(err, message) + + ! read restart data and reset the model state + call summa_readRestart(this%model%summa1_struc(n), err, message) + call handle_err(err, message) + + ! get global variables that are constants throughout the model simulation + this%model%gru_struc = gru_struc + this%model%index_map = index_map + this%model%model_decisions = model_decisions + this%model%output_fileSuffix = output_fileSuffix + this%model%maxLayers = maxLayers + this%model%maxSnowLayers = maxSnowLayers + this%model%urbanVegCategory = urbanVegCategory + this%model%ixProgress = ixProgress + this%model%ixRestart = ixRestart + this%model%newOutputFile = newOutputFile +#ifndef NGEN_FORCING_ACTIVE + this%model%ixHRUfile_min = ixHRUfile_min + this%model%ixHRUfile_max = ixHRUfile_max + this%model%forcFileInfo = forcFileInfo +#endif + ! update global variables in the model structure that change during the model simulation + this%model%timeStep = 1 + this%model%oldTime = oldTime + this%model%outFreq = outFreq + this%model%ncid = ncid + this%model%elapsedInit = elapsedInit + this%model%elapsedSetup = elapsedSetup + this%model%elapsedRestart = elapsedRestart + this%model%elapsedRead = elapsedRead + this%model%elapsedWrite = elapsedWrite + this%model%elapsedPhysics = elapsedPhysics + bmi_status = BMI_SUCCESS + end function summa_bmi_initialize + + ! ***************************************************************************** + ! * advance model by one time step. + ! ***************************************************************************** + function summa_update(this) result (bmi_status) + class (summa_bmi), intent(inout) :: this + ! error control + integer(i4b) :: err=0 ! error code + character(len=1024) :: message='' ! error message + integer :: bmi_status + + ! get global variables that are constants throughout the model simulation + gru_struc = this%model%gru_struc + index_map = this%model%index_map + model_decisions = this%model%model_decisions + output_fileSuffix = this%model%output_fileSuffix + newOutputFile = this%model%newOutputFile + outFreq = this%model%outFreq + maxLayers = this%model%maxLayers + maxSnowLayers = this%model%maxSnowLayers + urbanVegCategory = this%model%urbanVegCategory + ixProgress = this%model%ixProgress + ixRestart = this%model%ixRestart +#ifndef NGEN_FORCING_ACTIVE + ixHRUfile_min = this%model%ixHRUfile_min + ixHRUfile_max = this%model%ixHRUfile_max + forcFileInfo = this%model%forcFileInfo + iFile = this%model%iFile + forcingStep = this%model%forcingStep + forcNcid = this%model%forcNcid +#endif + ! initialize global variables that change during the model simulation + fileout = this%model%fileout + ncid = this%model%ncid + statCounter = this%model%statCounter + outputTimeStep = this%model%outputTimeStep + resetStats = this%model%resetStats + finalizeStats = this%model%finalizeStats + oldTime = this%model%oldTime + elapsedRead = this%model%elapsedRead + elapsedWrite = this%model%elapsedWrite + elapsedPhysics = this%model%elapsedPhysics + ! initialize global variables that change during the model simulation and are not initialized before the first time step + if(this%model%timeStep >1)then + this%model%nHRUrun = nHRUrun +#ifndef NGEN_FORCING_ACTIVE + this%model%nHRUrun = nHRUfile +#endif + end if + + ! read model forcing data + call summa_readForcing(this%model%timeStep, this%model%summa1_struc(n), err, message) + call handle_err(err, message) + +#ifndef NGEN_ACTIVE + if (mod(this%model%timeStep, print_step_freq) == 0)then + print *, 'step ---> ', this%model%timeStep + endif +#endif + ! run the summa physics for one time step + call summa_runPhysics(this%model%timeStep, this%model%summa1_struc(n), err, message) + call handle_err(err, message) + + ! write the model output +!#ifndef NGEN_OUTPUT_ACTIVE + call summa_writeOutputFiles(this%model%timeStep, this%model%summa1_struc(n), err, message) + call handle_err(err, message) +!#endif + + ! update global variables that change during the model simulation + this%model%timeStep = this%model%timeStep + 1 + this%model%fileout = fileout + this%model%ncid = ncid + this%model%nHRUrun = nHRUrun +#ifndef NGEN_FORCING_ACTIVE + this%model%nHRUrun = nHRUfile + this%model%iFile = iFile + this%model%forcingStep = forcingStep + this%model%forcNcid = forcNcid +#endif + this%model%statCounter = statCounter + this%model%outputTimeStep = outputTimeStep + this%model%resetStats = resetStats + this%model%finalizeStats = finalizeStats + this%model%oldTime = oldTime + this%model%elapsedRead = elapsedRead + this%model%elapsedWrite = elapsedWrite + this%model%elapsedPhysics = elapsedPhysics + bmi_status = BMI_SUCCESS + end function summa_update + + ! **************************************************************************** + ! * advance the model until the given time + ! **************************************************************************** + function summa_update_until(this, time) result (bmi_status) + class (summa_bmi), intent(inout) :: this + double precision, intent(in) :: time + integer :: bmi_status, istat, n_steps, i + double precision :: current + + istat = this%get_current_time(current) ! unit seconds + if (time < current) then + bmi_status = BMI_FAILURE + return + end if + + n_steps = nint( (time - current)/data_step ) + 1 ! model can only do a full data_step + ! SUMMA runs the ending step (so start=end would still run a step) + do i = 1, n_steps + istat = this%update() + end do + bmi_status = BMI_SUCCESS + end function summa_update_until + + ! ***************************************************************************** + ! * successful end (NOTE, NGEN does not call finalize) + ! ***************************************************************************** + function summa_finalize(this) result (bmi_status) + class (summa_bmi), intent(inout) :: this + integer :: bmi_status + + ! get global variables that change during the model simulation + ncid = this%model%ncid + elapsedInit = this%model%elapsedInit + elapsedSetup = this%model%elapsedSetup + elapsedRestart = this%model%elapsedRestart + elapsedRead = this%model%elapsedRead + elapsedWrite = this%model%elapsedWrite + elapsedPhysics = this%model%elapsedPhysics + + call stop_program(0, 'finished simulation successfully.') + ! to prevent exiting before HDF5 has closed + call sleep(2) + bmi_status = BMI_SUCCESS + end function summa_finalize + + ! ***************************************************************************** + ! * extra BMI functions + ! ***************************************************************************** + + ! Get the name of the model + function summa_component_name(this, name) result (bmi_status) + class (summa_bmi), intent(in) :: this + character (len=*), pointer, intent(out) :: name + integer :: bmi_status + + name => component_name + bmi_status = BMI_SUCCESS + end function summa_component_name + + ! Count the input variables + function summa_input_item_count(this, count) result (bmi_status) + class (summa_bmi), intent(in) :: this + integer, intent(out) :: count + integer :: bmi_status + + count = input_item_count + bmi_status = BMI_SUCCESS + end function summa_input_item_count + + ! Count the output variables + function summa_output_item_count(this, count) result (bmi_status) + class (summa_bmi), intent(in) :: this + integer, intent(out) :: count + integer :: bmi_status + + count = output_item_count + bmi_status = BMI_SUCCESS + end function summa_output_item_count + + ! List output variables standardized as "https://csdms.colorado.edu/wiki/CSDMS_Standard_Names" + ! These are the inputs we will need if we do not want to call read_force inside summa_forcing.f90 + ! NGEN uses two component wind and a time vector that is not currently separable + ! (compute wind speed from the two components and time from start time and hourly step assumption) + function summa_input_var_names(this, names) result (bmi_status) + class (summa_bmi), intent(in) :: this + character (*), pointer, intent(out) :: names(:) + integer :: bmi_status + + input_items(1) = 'atmosphere_water__precipitation_mass_flux' + input_items(2) = 'land_surface_air__temperature' + input_items(3) = 'atmosphere_air_water~vapor__relative_saturation' +#ifdef NGEN_ACTIVE + input_items(4) = 'land_surface_wind__x_component_of_velocity' + input_items(8) = 'land_surface_wind__y_component_of_velocity' +#else + input_items(4) = 'land_surface_wind__speed' +#endif + input_items(5) = 'land_surface_radiation~incoming~shortwave__energy_flux' + input_items(6) = 'land_surface_radiation~incoming~longwave__energy_flux' + input_items(7) = 'land_surface_air__pressure' + + names => input_items + bmi_status = BMI_SUCCESS + end function summa_input_var_names + + ! List output variables standardized as "https://csdms.colorado.edu/wiki/CSDMS_Standard_Names" + function summa_output_var_names(this, names) result (bmi_status) + class (summa_bmi), intent(in) :: this + character (*), pointer, intent(out) :: names(:) + integer :: bmi_status, i + + output_items(1) = 'land_surface_water__runoff_volume_flux' + output_items(2) = 'land_surface_water__evaporation_mass_flux' + output_items(3) = 'land_vegetation_water__evaporation_mass_flux' + output_items(4) = 'land_vegetation_water__transpiration_mass_flux' + output_items(5) = 'snowpack__sublimation_mass_flux' + output_items(6) = 'land_vegetation_water__sublimation_mass_flux' + output_items(7) = 'snowpack_mass' + output_items(8) = 'soil_water__mass' + output_items(9) = 'land_vegetation_water__mass' + output_items(10)= 'land_surface_radiation~net~total__energy_flux' + output_items(11)= 'land_atmosphere_heat~net~latent__energy_flux' !(incoming to the *atmosphere*, since atmosphere is last) + output_items(12)= 'land_atmosphere_heat~net~sensible__energy_flux' !(incoming to the *atmosphere*, since atmosphere is last) + output_items(13)= 'atmosphere_energy~net~total__energy_flux' + output_items(14)= 'land_vegetation_energy~net~total__energy_flux' + output_items(15)= 'land_surface_energy~net~total__energy_flux' + output_items(16)= 'land_surface_water__baseflow_volume_flux' + names => output_items + bmi_status = BMI_SUCCESS + end function summa_output_var_names + + ! Model start time + function summa_start_time(this, time) result (bmi_status) + class (summa_bmi), intent(in) :: this + double precision, intent(out) :: time + integer :: bmi_status + + time = 0.0 ! unit seconds + bmi_status = BMI_SUCCESS + end function summa_start_time + + ! Model end time + function summa_end_time(this, time) result (bmi_status) + class (summa_bmi), intent(in) :: this + double precision, intent(out) :: time + integer :: bmi_status + + time = (dJulianFinsh - dJulianStart)*secprday ! unit seconds + bmi_status = BMI_SUCCESS + end function summa_end_time + + ! Model current time + function summa_current_time(this, time) result (bmi_status) + class (summa_bmi), intent(in) :: this + double precision, intent(out) :: time + integer :: bmi_status + + if(this%model%timeStep==0)then + time = 0.0 ! unit seconds + else + time = (data_step*real(this%model%timeStep-1,dp)) ! unit seconds + end if + bmi_status = BMI_SUCCESS + end function summa_current_time + + ! Model time step + function summa_time_step(this, time_step) result (bmi_status) + class (summa_bmi), intent(in) :: this + double precision, intent(out) :: time_step + integer :: bmi_status + + time_step = data_step ! unit seconds + bmi_status = BMI_SUCCESS + end function summa_time_step + + ! Model time units + function summa_time_units(this, units) result (bmi_status) + class (summa_bmi), intent(in) :: this + character (len=*), intent(out) :: units + integer :: bmi_status + + units = "s" + bmi_status = BMI_SUCCESS + end function summa_time_units + + ! Get the grid id for a particular variable + function summa_var_grid(this, name, grid) result (bmi_status) + class (summa_bmi), intent(in) :: this + character (len=*), intent(in) :: name + integer, intent(out) :: grid + integer :: bmi_status + + select case(name) + case default + grid = 0 + bmi_status = BMI_SUCCESS + end select + end function summa_var_grid + + ! The type of a variable's grid + function summa_grid_type(this, grid, type) result (bmi_status) + class (summa_bmi), intent(in) :: this + integer, intent(in) :: grid + character (len=*), intent(out) :: type + integer :: bmi_status + + select case(grid) + case(0) + type = 'points' + bmi_status = BMI_SUCCESS + case default + type = "-" + bmi_status = BMI_FAILURE + end select + end function summa_grid_type + + ! The number of dimensions of a grid, latitude and longitude and elevation + function summa_grid_rank(this, grid, rank) result (bmi_status) + class (summa_bmi), intent(in) :: this + integer, intent(in) :: grid + integer, intent(out) :: rank + integer :: bmi_status + + select case(grid) + case(0) + rank = 3 + bmi_status = BMI_SUCCESS + case default + rank = -1 + bmi_status = BMI_FAILURE + end select + end function summa_grid_rank + + ! The dimensions of a grid, not applicable to unstructured + function summa_grid_shape(this, grid, shape) result (bmi_status) + class (summa_bmi), intent(in) :: this + integer, intent(in) :: grid + integer, dimension(:), intent(out) :: shape + integer :: bmi_status + + select case(grid) + case default + shape(:) = -1 + bmi_status = BMI_FAILURE + end select + end function summa_grid_shape + + ! The total number of elements in a grid + function summa_grid_size(this, grid, size) result (bmi_status) + class (summa_bmi), intent(in) :: this + integer, intent(in) :: grid + integer, intent(out) :: size + integer :: bmi_status + + select case(grid) + case(0) + size = sum(gru_struc(:)%hruCount) + bmi_status = BMI_SUCCESS + case default + size = -1 + bmi_status = BMI_FAILURE + end select + end function summa_grid_size + + ! The distance between nodes of a grid, not applicable to unstructured + function summa_grid_spacing(this, grid, spacing) result (bmi_status) + class (summa_bmi), intent(in) :: this + integer, intent(in) :: grid + double precision, dimension(:), intent(out) :: spacing + integer :: bmi_status + + select case(grid) + case default + spacing(:) = -1.d0 + bmi_status = BMI_FAILURE + end select + end function summa_grid_spacing + + ! Coordinates of grid origin, not applicable to unstructured + function summa_grid_origin(this, grid, origin) result (bmi_status) + class (summa_bmi), intent(in) :: this + integer, intent(in) :: grid + double precision, dimension(:), intent(out) :: origin + integer :: bmi_status + + select case(grid) + case default + origin(:) = -1.d0 + bmi_status = BMI_FAILURE + end select + end function summa_grid_origin + + ! X-coordinates of grid nodes, longitude (degrees east) + function summa_grid_x(this, grid, x) result (bmi_status) + class (summa_bmi), intent(in) :: this + integer, intent(in) :: grid + double precision, dimension(:), intent(out) :: x + integer :: bmi_status, iGRU, jHRU + + summaVars: associate(attrStruct => this%model%summa1_struc(n)%attrStruct & ! x%gru(:)%hru(:)%var(:) -- local attributes for each HRU + ) + select case(grid) + case default + do iGRU = 1, this%model%summa1_struc(n)%nGRU + do jHRU = 1, gru_struc(iGRU)%hruCount + x((iGRU-1) * gru_struc(iGRU)%hruCount + jHRU) = attrStruct%gru(iGRU)%hru(jHRU)%var(iLookATTR%longitude) + end do + end do + bmi_status = BMI_SUCCESS + end select + end associate summaVars + end function summa_grid_x + + ! Y-coordinates of grid nodes, latitude (degrees north) + function summa_grid_y(this, grid, y) result (bmi_status) + class (summa_bmi), intent(in) :: this + integer, intent(in) :: grid + double precision, dimension(:), intent(out) :: y + integer :: bmi_status, iGRU, jHRU + + summaVars: associate(attrStruct => this%model%summa1_struc(n)%attrStruct & ! x%gru(:)%hru(:)%var(:) -- local attributes for each HRU + ) + select case(grid) + case default + do iGRU = 1, this%model%summa1_struc(n)%nGRU + do jHRU = 1, gru_struc(iGRU)%hruCount + y((iGRU-1) * gru_struc(iGRU)%hruCount + jHRU) = attrStruct%gru(iGRU)%hru(jHRU)%var(iLookATTR%latitude) + end do + end do + bmi_status = BMI_SUCCESS + end select + end associate summaVars + end function summa_grid_y + + ! Z-coordinates of grid nodes, elevation (m) + function summa_grid_z(this, grid, z) result (bmi_status) + class (summa_bmi), intent(in) :: this + integer, intent(in) :: grid + double precision, dimension(:), intent(out) :: z + integer :: bmi_status, iGRU, jHRU + + summaVars: associate(attrStruct => this%model%summa1_struc(n)%attrStruct & ! x%gru(:)%hru(:)%var(:) -- local attributes for each HRU + ) + select case(grid) + case default + do iGRU = 1, this%model%summa1_struc(n)%nGRU + do jHRU = 1, gru_struc(iGRU)%hruCount + z((iGRU-1) * gru_struc(iGRU)%hruCount + jHRU) = attrStruct%gru(iGRU)%hru(jHRU)%var(iLookATTR%elevation) + end do + end do + bmi_status = BMI_SUCCESS + end select + end associate summaVars + end function summa_grid_z + + ! Get the number of nodes in an unstructured grid + function summa_grid_node_count(this, grid, count) result(bmi_status) + class(summa_bmi), intent(in) :: this + integer, intent(in) :: grid + integer, intent(out) :: count + integer :: bmi_status + + select case(grid) + case default + count = sum(gru_struc(:)%hruCount) + bmi_status = BMI_SUCCESS + end select + end function summa_grid_node_count + + ! Get the number of edges in an unstructured grid, points is 0 BUT USED FOR ROUTING FLOW BETWEEN GRUs + function summa_grid_edge_count(this, grid, count) result(bmi_status) + class(summa_bmi), intent(in) :: this + integer, intent(in) :: grid + integer, intent(out) :: count + integer :: bmi_status + + select case(grid) + case default + count = 0 + bmi_status = BMI_SUCCESS + end select + end function summa_grid_edge_count + + ! Get the number of faces in an unstructured grid, points is 0 BUT COULD BE USED FOR GRUs + function summa_grid_face_count(this, grid, count) result(bmi_status) + class(summa_bmi), intent(in) :: this + integer, intent(in) :: grid + integer, intent(out) :: count + integer :: bmi_status + + select case(grid) + case default + count = 0 ! could be this%model%summa1_struc(n)%nGRU + bmi_status = BMI_SUCCESS + end select + end function summa_grid_face_count + + ! Get the edge-node connectivity, points is 0 BUT COULD BE USED FOR LATERAL FLOW BETWEEN HRUs + function summa_grid_edge_nodes(this, grid, edge_nodes) result(bmi_status) + class(summa_bmi), intent(in) :: this + integer, intent(in) :: grid + integer, dimension(:), intent(out) :: edge_nodes + integer :: bmi_status + + select case(grid) + case default + edge_nodes(:) = -1 + bmi_status = BMI_FAILURE + end select + end function summa_grid_edge_nodes + + ! Get the face-edge connectivity, points is 0 BUT COULD BE USED FOR LATERAL FLOW TO GRU + function summa_grid_face_edges(this, grid, face_edges) result(bmi_status) + class(summa_bmi), intent(in) :: this + integer, intent(in) :: grid + integer, dimension(:), intent(out) :: face_edges + integer :: bmi_status + + select case(grid) + case default + face_edges(:) = -1 + bmi_status = BMI_FAILURE + end select + end function summa_grid_face_edges + + ! Get the face-node connectivity, points is 0 BUT COULD BE USED FOR HRU FLOW TO GRU + function summa_grid_face_nodes(this, grid, face_nodes) result(bmi_status) + class(summa_bmi), intent(in) :: this + integer, intent(in) :: grid + integer, dimension(:), intent(out) :: face_nodes + integer :: bmi_status + + select case(grid) + case default + face_nodes(:) = -1 !gru_struc(iGRU)%hruInfo(iHRU)%hru_id for iHRU=1,hruCount + bmi_status = BMI_FAILURE + end select + end function summa_grid_face_nodes + + ! Get the number of nodes for each face, points is 0 BUT COULD BE USED FOR GRUs + function summa_grid_nodes_per_face(this, grid, nodes_per_face) result(bmi_status) + class(summa_bmi), intent(in) :: this + integer, intent(in) :: grid + integer, dimension(:), intent(out) :: nodes_per_face + integer :: bmi_status + + select case(grid) + case default + nodes_per_face(:) = -1 ! could be gru_struc(iGRU)%hruCount + bmi_status = BMI_SUCCESS + end select + end function summa_grid_nodes_per_face + + ! The data type of the variable, as a string + function summa_var_type(this, name, type) result (bmi_status) + class (summa_bmi), intent(in) :: this + character (len=*), intent(in) :: name + character (len=*), intent(out) :: type + integer :: bmi_status + + if(name(1:5)=='model')then ! not currently used, left in for future integer type needs + type = "integer" + else + type = "real" + endif + bmi_status = BMI_SUCCESS + end function summa_var_type + + ! The units of the given variable + function summa_var_units(this, name, units) result (bmi_status) + class (summa_bmi), intent(in) :: this + character (len=*), intent(in) :: name + character (len=*), intent(out) :: units + integer :: bmi_status + + select case (name) + ! input, note using the NGEN preferred unit definitions, equivalent to standard SUMMA definitions as noted + case('atmosphere_water__precipitation_mass_flux') ; units = 'mm s-1'; ; bmi_status = BMI_SUCCESS !equivalent kg m-2 s-1 + case('land_surface_air__temperature') ; units = 'K' ; bmi_status = BMI_SUCCESS + case('atmosphere_air_water~vapor__relative_saturation') ; units = 'kg kg-1' ; bmi_status = BMI_SUCCESS +#ifdef NGEN_ACTIVE + case('land_surface_wind__x_component_of_velocity') ; units = 'm s-1' ; bmi_status = BMI_SUCCESS + case('land_surface_wind__y_component_of_velocity') ; units = 'm s-1' ; bmi_status = BMI_SUCCESS +#else + case('land_surface_wind__speed') ; units = 'm s-1' ; bmi_status = BMI_SUCCESS +#endif + case('land_surface_radiation~incoming~shortwave__energy_flux') ; units = 'W m-2' ; bmi_status = BMI_SUCCESS + case('land_surface_radiation~incoming~longwave__energy_flux') ; units = 'W m-2' ; bmi_status = BMI_SUCCESS + case('land_surface_air__pressure') ; units = 'kg m-1 s-2'; bmi_status = BMI_SUCCESS + + ! output + case('land_surface_water__runoff_volume_flux') ; units = 'm s-1' ; bmi_status = BMI_SUCCESS + case('land_surface_water__evaporation_mass_flux') ; units = 'mm s-1' ; bmi_status = BMI_SUCCESS !equivalent kg m-2 s-1 + case('land_vegetation_water__evaporation_mass_flux') ; units = 'mm s-1' ; bmi_status = BMI_SUCCESS !equivalent kg m-2 s-1 + case('land_vegetation_water__transpiration_mass_flux'); units = 'mm s-1' ; bmi_status = BMI_SUCCESS !equivalent kg m-2 s-1 + case('snowpack__sublimation_mass_flux') ; units = 'mm s-1' ; bmi_status = BMI_SUCCESS !equivalent kg m-2 s-1 + case('land_vegetation_water__sublimation_mass_flux') ; units = 'mm s-1' ; bmi_status = BMI_SUCCESS !equivalent kg m-2 s-1 + case('snowpack_mass') ; units = 'kg m-2' ; bmi_status = BMI_SUCCESS + case('soil_water__mass') ; units = 'kg m-2' ; bmi_status = BMI_SUCCESS + case('land_vegetation_water__mass') ; units = 'kg m-2' ; bmi_status = BMI_SUCCESS + case('land_surface_radiation~net~total__energy_flux') ; units = 'W m-2' ; bmi_status = BMI_SUCCESS + case('land_atmosphere_heat~net~latent__energy_flux') ; units = 'W m-2' ; bmi_status = BMI_SUCCESS + case('land_atmosphere_heat~net~sensible__energy_flux'); units = 'W m-2' ; bmi_status = BMI_SUCCESS + case('atmosphere_energy~net~total__energy_flux') ; units = 'W m-2' ; bmi_status = BMI_SUCCESS + case('land_vegetation_energy~net~total__energy_flux') ; units = 'W m-2' ; bmi_status = BMI_SUCCESS + case('land_surface_energy~net~total__energy_flux') ; units = 'W m-2' ; bmi_status = BMI_SUCCESS + case('land_surface_water__baseflow_volume_flux') ; units = 'm s-1' ; bmi_status = BMI_SUCCESS + case default; units = "-"; bmi_status = BMI_FAILURE + end select + end function summa_var_units + + ! Memory use per array element + function summa_var_itemsize(this, name, size) result (bmi_status) + class (summa_bmi), intent(in) :: this + character (len=*), intent(in) :: name + integer, intent(out) :: size + real, target :: target_arr(sum(gru_struc(:)%hruCount)) + integer ,target :: itarget_arr + integer :: bmi_status + + call get_basin_field(this, name, 1, target_arr, itarget_arr) ! See near bottom of file + ! use the real or integer target + if(name(1:5)=='model')then ! not currently used, left in for future integer type needs + size = sizeof(itarget_arr) ! 'sizeof' in gcc & ifort + else + size = sizeof(target_arr(1)) ! 'sizeof' in gcc & ifort + endif + bmi_status = BMI_SUCCESS + end function summa_var_itemsize + + ! The size of the given variable + function summa_var_nbytes(this, name, nbytes) result (bmi_status) + class (summa_bmi), intent(in) :: this + character (len=*), intent(in) :: name + integer, intent(out) :: nbytes + integer :: bmi_status + integer :: s1, s2, s3, grid, grid_size, item_size + + s1 = this%get_var_grid(name, grid) + s2 = this%get_grid_size(grid, grid_size) + s3 = this%get_var_itemsize(name, item_size) + if ((s1 == BMI_SUCCESS).and.(s2 == BMI_SUCCESS).and.(s3 == BMI_SUCCESS)) then + nbytes = item_size * grid_size + bmi_status = BMI_SUCCESS + else + nbytes = -1 + bmi_status = BMI_FAILURE + end if + end function summa_var_nbytes + + ! The location (node, face, edge) of the given variable + function summa_var_location(this, name, location) result (bmi_status) + class (summa_bmi), intent(in) :: this + character (len=*), intent(in) :: name + character (len=*), intent(out) :: location + integer :: bmi_status + + select case(name) + case default + location = "node" + bmi_status = BMI_SUCCESS + end select + end function summa_var_location + + ! Get a copy of a integer variable's values, flattened + function summa_get_int(this, name, dest) result (bmi_status) + class (summa_bmi), intent(in) :: this + character (len=*), intent(in) :: name + integer, intent(inout) :: dest(:) + real, target :: target_arr(sum(gru_struc(:)%hruCount)) + integer ,target :: itarget_arr + integer :: bmi_status + + select case(name) + case default + call get_basin_field(this, name, 1, target_arr, itarget_arr) ! See near bottom of file + ! use the integer target + dest = itarget_arr + bmi_status = BMI_SUCCESS + end select + end function summa_get_int + + ! Get a copy of a real variable's values, flattened + function summa_get_float(this, name, dest) result (bmi_status) + class (summa_bmi), intent(in) :: this + character (len=*), intent(in) :: name + real, intent(inout) :: dest(:) + real, target :: target_arr(sum(gru_struc(:)%hruCount)) + integer ,target :: itarget_arr + integer :: bmi_status + + select case(name) + case default + call get_basin_field(this, name, 1, target_arr, itarget_arr) ! See near bottom of file + ! use the real target + dest = target_arr + bmi_status = BMI_SUCCESS + end select + end function summa_get_float + + ! Get a copy of a double variable's values, flattened + function summa_get_double(this, name, dest) result (bmi_status) + class (summa_bmi), intent(in) :: this + character (len=*), intent(in) :: name + double precision, intent(inout) :: dest(:) + integer :: bmi_status + + select case(name) + case default + dest(:) = -1.d0 + bmi_status = BMI_FAILURE + end select + end function summa_get_double + + ! Get a reference to an integer-valued variable, flattened + function summa_get_ptr_int(this, name, dest_ptr) result (bmi_status) + class (summa_bmi), intent(in) :: this + character (len=*), intent(in) :: name + integer, pointer, intent(inout) :: dest_ptr(:) + integer :: bmi_status, n_elements + real, target :: target_arr(sum(gru_struc(:)%hruCount)) + integer ,target :: itarget_arr + type (c_ptr) :: src + + select case(name) + case default + call get_basin_field(this, name, 1, target_arr, itarget_arr) ! See near bottom of file + ! use the integer target + src = c_loc(itarget_arr) + n_elements = sum(gru_struc(:)%hruCount) + call c_f_pointer(src, dest_ptr, [n_elements]) + bmi_status = BMI_SUCCESS + end select + end function summa_get_ptr_int + + ! Get a reference to a real-valued variable, flattened + function summa_get_ptr_float(this, name, dest_ptr) result (bmi_status) + class (summa_bmi), intent(in) :: this + character (len=*), intent(in) :: name + real, pointer, intent(inout) :: dest_ptr(:) + integer :: bmi_status, n_elements + real, target :: target_arr(sum(gru_struc(:)%hruCount)) + integer ,target :: itarget_arr + type (c_ptr) :: src + + select case(name) + case default + call get_basin_field(this, name, 1, target_arr, itarget_arr) ! See near bottom of file + ! use the real target + src = c_loc(target_arr(1)) + n_elements = sum(gru_struc(:)%hruCount) + call c_f_pointer(src, dest_ptr, [n_elements]) + bmi_status = BMI_SUCCESS + end select + end function summa_get_ptr_float + + ! Get a reference to an double-valued variable, flattened + function summa_get_ptr_double(this, name, dest_ptr) result (bmi_status) + class (summa_bmi), intent(in) :: this + character (len=*), intent(in) :: name + double precision, pointer, intent(inout) :: dest_ptr(:) + integer :: bmi_status, n_elements + type (c_ptr) :: src + + select case(name) + case default + bmi_status = BMI_FAILURE + end select + end function summa_get_ptr_double + + ! Get values of an integer variable at the given locations + function summa_get_at_indices_int(this, name, dest, inds) result (bmi_status) + class (summa_bmi), intent(in) :: this + character (len=*), intent(in) :: name + integer, intent(inout) :: dest(:) + integer, intent(in) :: inds(:) + integer :: bmi_status, i, n_elements + real, target :: target_arr(sum(gru_struc(:)%hruCount)) + integer ,target :: itarget_arr + type (c_ptr) src + integer, pointer :: src_flattened(:) + + select case(name) + case default + call get_basin_field(this, name, 1, target_arr, itarget_arr) ! See near bottom of file + ! use the integer target + src = c_loc(itarget_arr) + call c_f_pointer(src, src_flattened, [n_elements]) + n_elements = size(inds) + do i = 1, n_elements + dest(i) = src_flattened(inds(i)) + end do + bmi_status = BMI_SUCCESS + end select + end function summa_get_at_indices_int + + ! Get values of a real variable at the given locations + function summa_get_at_indices_float(this, name, dest, inds) result (bmi_status) + class (summa_bmi), intent(in) :: this + character (len=*), intent(in) :: name + real, intent(inout) :: dest(:) + integer, intent(in) :: inds(:) + integer :: bmi_status, i, n_elements + real, target :: target_arr(sum(gru_struc(:)%hruCount)) + integer ,target :: itarget_arr + type (c_ptr) src + real, pointer :: src_flattened(:) + + select case(name) + case default + call get_basin_field(this, name, 1, target_arr, itarget_arr) ! See near bottom of file + ! use the real target + src = c_loc(target_arr(1)) + call c_f_pointer(src, src_flattened, [n_elements]) + n_elements = size(inds) + do i = 1, n_elements + dest(i) = src_flattened(inds(i)) + end do + bmi_status = BMI_SUCCESS + end select + end function summa_get_at_indices_float + + ! Get values of a double variable at the given locations + function summa_get_at_indices_double(this, name, dest, inds) result (bmi_status) + class (summa_bmi), intent(in) :: this + character (len=*), intent(in) :: name + double precision, intent(inout) :: dest(:) + integer, intent(in) :: inds(:) + integer :: bmi_status, i, n_elements + type (c_ptr) src + double precision, pointer :: src_flattened(:) + + select case(name) + case default + bmi_status = BMI_FAILURE + end select + end function summa_get_at_indices_double + + ! Set new integer values, ONLY FOR INPUT VARIABLES + function summa_set_int(this, name, src) result (bmi_status) + class (summa_bmi), intent(inout) :: this + character (len=*), intent(in) :: name + integer, intent(in) :: src(:) + real :: rsrc(sum(gru_struc(:)%hruCount)) + integer :: bmi_status + + select case(name) + case default + rsrc = -999.0 + call assign_basin_field(this, name, rsrc, src(1)) ! See near bottom of file + bmi_status = BMI_SUCCESS + end select + end function summa_set_int + + ! Set new real values, ONLY FOR INPUT VARIABLES + function summa_set_float(this, name, src) result (bmi_status) + class (summa_bmi), intent(inout) :: this + character (len=*), intent(in) :: name + real, intent(in) :: src(:) + integer :: bmi_status, isrc + + select case(name) + case default + isrc = -999 + call assign_basin_field(this, name, src, isrc) ! See near bottom of file + bmi_status = BMI_SUCCESS + end select + end function summa_set_float + + ! Set new double values + function summa_set_double(this, name, src) result (bmi_status) + class (summa_bmi), intent(inout) :: this + character (len=*), intent(in) :: name + double precision, intent(in) :: src(:) + integer :: bmi_status + + select case(name) + case default + bmi_status = BMI_FAILURE + end select + end function summa_set_double + + ! Set integer values at particular locations + function summa_set_at_indices_int(this, name, inds, src) result (bmi_status) + class (summa_bmi), intent(inout) :: this + character (len=*), intent(in) :: name + integer, intent(in) :: inds(:) + integer, intent(in) :: src(:) + integer :: bmi_status + type (c_ptr) dest + integer, pointer :: dest_flattened(:) + integer :: i + + select case(name) + case default + bmi_status = BMI_FAILURE + end select + end function summa_set_at_indices_int + + ! Set real values at particular locations, ONLY FOR INPUT VARIABLES + function summa_set_at_indices_float(this, name, inds, src) result (bmi_status) + class (summa_bmi), intent(inout) :: this + character (len=*), intent(in) :: name + integer, intent(in) :: inds(:) + real, intent(in) :: src(:) + integer :: bmi_status + type (c_ptr) dest + real, pointer :: dest_flattened(:) + integer :: i + + select case(name) + case default + bmi_status = BMI_FAILURE + end select + end function summa_set_at_indices_float + + ! Set double values at particular locations + function summa_set_at_indices_double(this, name, inds, src) result (bmi_status) + class (summa_bmi), intent(inout) :: this + character (len=*), intent(in) :: name + integer, intent(in) :: inds(:) + double precision, intent(in) :: src(:) + integer :: bmi_status + type (c_ptr) dest + double precision, pointer :: dest_flattened(:) + integer :: i + + select case(name) + case default + bmi_status = BMI_FAILURE + end select + end function summa_set_at_indices_double + +#ifdef NGEN_ACTIVE + function register_bmi(this) result(bmi_status) bind(C, name="register_bmi") + use, intrinsic:: iso_c_binding, only: c_ptr, c_loc, c_int + use iso_c_bmif_2_0 + implicit none + type(c_ptr) :: this ! If not value, then from the C perspective `this` is a void** + integer(kind=c_int) :: bmi_status + !Create the model instance to use + type(summa_bmi), pointer :: bmi_model + !Create a simple pointer wrapper + type(box), pointer :: bmi_box + + !allocate model + allocate(summa_bmi::bmi_model) + !allocate the pointer box + allocate(bmi_box) + + !associate the wrapper pointer the created model instance + bmi_box%ptr => bmi_model + + if( .not. associated( bmi_box ) .or. .not. associated( bmi_box%ptr ) ) then + bmi_status = BMI_FAILURE + else + ! Return the pointer to box + this = c_loc(bmi_box) + bmi_status = BMI_SUCCESS + endif + end function register_bmi +#endif + + ! non-BMI helper function to assign input fields + subroutine assign_basin_field(this, name, src_arr, isrc_arr) + implicit none + class (summa_bmi), intent(inout) :: this + character (len=*), intent(in) :: name + real, intent(in) :: src_arr(sum(gru_struc(:)%hruCount)) + integer, intent(in) :: isrc_arr + integer :: iGRU, jHRU, i + + summaVars: associate(& + timeStruct => this%model%summa1_struc(n)%timeStruct , & ! x%var(:) -- model time data + forcStruct => this%model%summa1_struc(n)%forcStruct , & ! x%gru(:)%hru(:)%var(:) -- model forcing data + diagStruct => this%model%summa1_struc(n)%diagStruct & ! x%gru(:)%hru(:)%var(:)%dat -- model diagnostic variables + ) + + if(name(1:5)=='model')then ! not currently used, left in for future integer type needs + select case (name) + ! input + case('model__time_year') + timeStruct%var(iLookTIME%iyyy) = isrc_arr + end select + else + do iGRU = 1, this%model%summa1_struc(n)%nGRU + do jHRU = 1, gru_struc(iGRU)%hruCount + i = (iGRU-1) * gru_struc(iGRU)%hruCount + jHRU + select case (name) + ! input + case('atmosphere_water__precipitation_mass_flux') + forcStruct%gru(iGRU)%hru(jHRU)%var(iLookFORCE%pptrate) = src_arr(i) + case('land_surface_air__temperature') + forcStruct%gru(iGRU)%hru(jHRU)%var(iLookFORCE%airtemp) = src_arr(i) + case('atmosphere_air_water~vapor__relative_saturation') + forcStruct%gru(iGRU)%hru(jHRU)%var(iLookFORCE%spechum) = src_arr(i) + case('land_surface_wind__x_component_of_velocity') + diagStruct%gru(iGRU)%hru(jHRU)%var(iLookDIAG%windspd_x)%dat(1) = src_arr(i) + case('land_surface_wind__y_component_of_velocity') + diagStruct%gru(iGRU)%hru(jHRU)%var(iLookDIAG%windspd_y)%dat(1) = src_arr(i) + case('land_surface_wind__speed') + forcStruct%gru(iGRU)%hru(jHRU)%var(iLookFORCE%windspd) = src_arr(i) + case('land_surface_radiation~incoming~shortwave__energy_flux') + forcStruct%gru(iGRU)%hru(jHRU)%var(iLookFORCE%SWRadAtm) = src_arr(i) + case('land_surface_radiation~incoming~longwave__energy_flux') + forcStruct%gru(iGRU)%hru(jHRU)%var(iLookFORCE%LWRadAtm) = src_arr(i) + case('land_surface_air__pressure') + forcStruct%gru(iGRU)%hru(jHRU)%var(iLookFORCE%airpres) = src_arr(i) + end select + end do + end do + endif + end associate summaVars + end subroutine assign_basin_field + + ! non-BMI helper function to get fields, only get first do_nHRU of them + subroutine get_basin_field(this, name, do_nHRU, target_arr, itarget_arr) + implicit none + class (summa_bmi), intent(in) :: this + integer, intent(in) :: do_nHRU + character (len=*), intent(in) :: name + real, target, intent(out) :: target_arr(sum(gru_struc(:)%hruCount)) + integer, target, intent(out) :: itarget_arr + integer :: iGRU, jHRU, i + + summaVars: associate(& + timeStruct => this%model%summa1_struc(n)%timeStruct , & ! x%var(:) -- model time data + forcStruct => this%model%summa1_struc(n)%forcStruct , & ! x%gru(:)%hru(:)%var(:) -- model forcing data + progStruct => this%model%summa1_struc(n)%progStruct , & ! x%gru(:)%hru(:)%var(:)%dat -- model prognostic (state) variables + diagStruct => this%model%summa1_struc(n)%diagStruct , & ! x%gru(:)%hru(:)%var(:)%dat -- model diagnostic variables + fluxStruct => this%model%summa1_struc(n)%fluxStruct , & ! x%gru(:)%hru(:)%var(:)%dat -- model fluxes + bvarStruct => this%model%summa1_struc(n)%bvarStruct & ! x%gru(:)%var(:)%dat -- model basin (GRU) variables + ) + target_arr = -999.0 + itarget_arr = -999 + if(name(1:5)=='model')then ! not currently used, left in for future integer type needs + select case (name) + ! input + case('model__time_year') + itarget_arr = timeStruct%var(iLookTIME%iyyy) + end select + else + do iGRU = 1, this%model%summa1_struc(n)%nGRU + do jHRU = 1, gru_struc(iGRU)%hruCount + i = (iGRU-1) * gru_struc(iGRU)%hruCount + jHRU + if (i > do_nHRU) return + select case (name) + ! input + case('atmosphere_water__precipitation_mass_flux') + target_arr(i) = forcStruct%gru(iGRU)%hru(jHRU)%var(iLookFORCE%pptrate) + case('land_surface_air__temperature') + target_arr(i) = forcStruct%gru(iGRU)%hru(jHRU)%var(iLookFORCE%airtemp) + case('atmosphere_air_water~vapor__relative_saturation') + target_arr(i) = forcStruct%gru(iGRU)%hru(jHRU)%var(iLookFORCE%spechum) + case('land_surface_wind__x_component_of_velocity') + target_arr(i) = diagStruct%gru(iGRU)%hru(jHRU)%var(iLookDIAG%windspd_x)%dat(1) + case('land_surface_wind__y_component_of_velocity') + target_arr(i) = diagStruct%gru(iGRU)%hru(jHRU)%var(iLookDIAG%windspd_y)%dat(1) + case('land_surface_wind__speed') + target_arr(i) = forcStruct%gru(iGRU)%hru(jHRU)%var(iLookFORCE%windspd) + case('land_surface_radiation~incoming~shortwave__energy_flux') + target_arr(i) = forcStruct%gru(iGRU)%hru(jHRU)%var(iLookFORCE%SWRadAtm) + case('land_surface_radiation~incoming~longwave__energy_flux') + target_arr(i) = forcStruct%gru(iGRU)%hru(jHRU)%var(iLookFORCE%LWRadAtm) + case('land_surface_air__pressure') + target_arr(i) = forcStruct%gru(iGRU)%hru(jHRU)%var(iLookFORCE%airpres) + + ! output + case('land_surface_water__runoff_volume_flux') + target_arr(i) = bvarStruct%gru(iGRU)%var(iLookBVAR%averageRoutedRunoff)%dat(1) + !target_arr(i) = fluxStruct%gru(iGRU)%hru(jHRU)%var(iLookFLUX%scalarSurfaceRunoff)%dat(1) + case('land_surface_water__evaporation_mass_flux') + target_arr(i) = fluxStruct%gru(iGRU)%hru(jHRU)%var(iLookFLUX%scalarGroundEvaporation)%dat(1) + case('land_vegetation_water__evaporation_mass_flux') + target_arr(i) = fluxStruct%gru(iGRU)%hru(jHRU)%var(iLookFLUX%scalarCanopyEvaporation)%dat(1) + case('land_vegetation_water__transpiration_mass_flux') + target_arr(i) = fluxStruct%gru(iGRU)%hru(jHRU)%var(iLookFLUX%scalarCanopyTranspiration)%dat(1) + case('snowpack__sublimation_mass_flux') + target_arr(i) = fluxStruct%gru(iGRU)%hru(jHRU)%var(iLookFLUX%scalarSnowSublimation)%dat(1) + case('land_vegetation_water__sublimation_mass_flux') + target_arr(i) = fluxStruct%gru(iGRU)%hru(jHRU)%var(iLookFLUX%scalarCanopySublimation)%dat(1) + case('snowpack_mass') + target_arr(i) = progStruct%gru(iGRU)%hru(jHRU)%var(iLookPROG%scalarSWE)%dat(1) + case('soil_water__mass') + target_arr(i) = diagStruct%gru(iGRU)%hru(jHRU)%var(iLookDIAG%scalarTotalSoilWat)%dat(1) + case('land_vegetation_water__mass') + target_arr(i) = progStruct%gru(iGRU)%hru(jHRU)%var(iLookPROG%scalarCanopyWat)%dat(1) + case('land_surface_radiation~net~total__energy_flux') + target_arr(i) = fluxStruct%gru(iGRU)%hru(jHRU)%var(iLookFLUX%scalarNetRadiation)%dat(1) + case('land_atmosphere_heat~net~latent__energy_flux') + target_arr(i) = fluxStruct%gru(iGRU)%hru(jHRU)%var(iLookFLUX%scalarLatHeatTotal)%dat(1) + case('land_atmosphere_heat~net~sensible__energy_flux') + target_arr(i) = fluxStruct%gru(iGRU)%hru(jHRU)%var(iLookFLUX%scalarSenHeatTotal)%dat(1) + case('atmosphere_energy~net~total__energy_flux') + target_arr(i) = fluxStruct%gru(iGRU)%hru(jHRU)%var(iLookFLUX%scalarCanairNetNrgFlux)%dat(1) + case('land_vegetation_energy~net~total__energy_flux') + target_arr(i) = fluxStruct%gru(iGRU)%hru(jHRU)%var(iLookFLUX%scalarCanopyNetNrgFlux)%dat(1) + case('land_surface_energy~net~total__energy_flux') + target_arr(i) = fluxStruct%gru(iGRU)%hru(jHRU)%var(iLookFLUX%scalarGroundNetNrgFlux)%dat(1) + case('land_surface_water__baseflow_volume_flux') + target_arr(i) = fluxStruct%gru(iGRU)%hru(jHRU)%var(iLookFLUX%scalarAquiferBaseflow)%dat(1) + end select + end do + end do + endif + end associate summaVars + end subroutine get_basin_field + +end module summabmi diff --git a/build/source/driver/summa_defineOutput.f90 b/build/source/driver/summa_defineOutput.f90 old mode 100755 new mode 100644 index 27092834c..531f6545f --- a/build/source/driver/summa_defineOutput.f90 +++ b/build/source/driver/summa_defineOutput.f90 @@ -22,7 +22,7 @@ module summa_defineOutput ! used to define model output file ! access missing values USE globalData,only:integerMissing ! missing integer -USE globalData,only:realMissing ! missing double precision number +USE globalData,only:realMissing ! missing real number ! named variables to define new output files USE globalData, only: noNewFiles ! no new output files @@ -38,7 +38,7 @@ module summa_defineOutput ! used to define model output file ! named variables USE var_lookup,only:maxvarFreq ! maximum number of output files USE var_lookup,only:iLookTIME ! named variables for time data structure -USE var_lookup,only:iLookFreq ! named variables for the frequency structure +USE var_lookup,only:iLookFREQ ! named variables for the frequency structure ! safety: set private unless specified otherwise implicit none diff --git a/build/source/driver/summa_driver.f90 b/build/source/driver/summa_driver.f90 old mode 100755 new mode 100644 index cffec57ee..b9ea54eaa --- a/build/source/driver/summa_driver.f90 +++ b/build/source/driver/summa_driver.f90 @@ -19,86 +19,128 @@ ! along with this program. If not, see . program summa_driver -! driver program for summa simulations -! ***************************************************************************** -! * use desired modules -! ***************************************************************************** -! data types -USE nrtype ! variable types, etc. -USE summa_type, only: summa1_type_dec ! master summa data type -! subroutines and functions: model setup -USE summa_init, only: summa_initialize ! used to allocate/initialize summa data structures -USE summa_setup, only: summa_paramSetup ! used to initialize parameter data structures (e.g. vegetation and soil parameters) -USE summa_restart, only: summa_readRestart ! used to read restart data and reset the model state -! subroutines and functions: model simulation -USE summa_forcing, only: summa_readForcing ! used to read forcing data -USE summa_modelRun, only: summa_runPhysics ! used to run the summa physics for one time step -USE summa_writeOutput, only: summa_writeOutputFiles ! used to write the summa output files -! utility functions -USE summa_util, only: stop_program ! used to stop the summa program (with errors) -USE summa_util, only: handle_err ! used to process errors -! global data -USE globalData, only: numtim ! number of model time steps -implicit none - -! ***************************************************************************** -! * variable definitions -! ***************************************************************************** -! define the master summa data structure -type(summa1_type_dec), allocatable :: summa1_struc(:) -! define parameters for the model simulation -integer(i4b), parameter :: n=1 ! number of instantiations -! define timing information -integer(i4b) :: modelTimeStep ! index of model time step -! error control -integer(i4b) :: err=0 ! error code -character(len=1024) :: message='' ! error message - -! ***************************************************************************** -! * preliminaries -! ***************************************************************************** - -! allocate space for the master summa structure -allocate(summa1_struc(n), stat=err) -if(err/=0) call stop_program(1, 'problem allocating master summa structure') - -! ***************************************************************************** -! * model setup/initialization -! ***************************************************************************** - -! declare and allocate summa data structures and initialize model state to known values -call summa_initialize(summa1_struc(n), err, message) -call handle_err(err, message) - -! initialize parameter data structures (e.g. vegetation and soil parameters) -call summa_paramSetup(summa1_struc(n), err, message) -call handle_err(err, message) - -! read restart data and reset the model state -call summa_readRestart(summa1_struc(n), err, message) -call handle_err(err, message) - -! ***************************************************************************** -! * model simulation -! ***************************************************************************** - -! loop through time -do modelTimeStep=1,numtim - - ! read model forcing data - call summa_readForcing(modelTimeStep, summa1_struc(n), err, message) - call handle_err(err, message) - - ! run the summa physics for one time step - call summa_runPhysics(modelTimeStep, summa1_struc(n), err, message) - call handle_err(err, message) - - ! write the model output - call summa_writeOutputFiles(modelTimeStep, summa1_struc(n), err, message) - call handle_err(err, message) - -end do ! looping through time - -! successful end -call stop_program(0, 'finished simulation successfully.') + ! **** Driver program for SUMMA simulations **** + + ! * module access * + ! data types + USE nrtype ! variable types, etc. + USE summa_type, only: summa1_type_dec ! master summa data type + ! subroutines and functions: model setup + USE summa_init, only: summa_initialize ! used to allocate/initialize summa data structures + USE summa_setup, only: summa_paramSetup ! used to initialize parameter data structures (e.g. vegetation and soil parameters) + USE summa_restart, only: summa_readRestart ! used to read restart data and reset the model state + ! subroutines and functions: model simulation + USE summa_forcing, only: summa_readForcing ! used to read forcing data + USE summa_modelRun, only: summa_runPhysics ! used to run the summa physics for one time step + USE summa_writeOutput, only: summa_writeOutputFiles ! used to write the summa output files + ! utility functions + USE summa_util, only: stop_program ! used to stop the summa program (with errors) + USE summa_util, only: handle_err ! used to process errors + ! global data + USE globalData, only: numtim ! number of model time steps + USE globalData, only: print_step_freq + + ! OpenWQ coupling +#ifdef OPENWQ_ACTIVE + USE summa_openwq,only:openwq_init + USE summa_openwq,only:openwq_run_time_start + USE summa_openwq,only:openwq_run_space_step + USE summa_openwq,only:openwq_run_time_end +#endif + + implicit none + + ! * driver variables * + ! define the master summa data structure + type(summa1_type_dec), allocatable :: summa1_struc(:) + ! define parameters for the model simulation + integer(i4b), parameter :: n=1 ! number of instantiations + ! define timing information + integer(i4b) :: modelTimeStep ! index of model time step + ! error control + integer(i4b) :: err=0 ! error code + character(len=1024) :: message='' ! error message + + ! Initialize + call initialize_summa_driver + + ! Update + call update_summa_driver + + ! Finalize + call finalize_summa_driver + +contains + + subroutine initialize_summa_driver + ! *** Initial operations for SUMMA driver program *** + + ! allocate space for the master summa structure + allocate(summa1_struc(n), stat=err) + if (err/=0) call stop_program(1, 'problem allocating master summa structure') + + ! declare and allocate summa data structures and initialize model state to known values + call summa_initialize(summa1_struc(n), err, message) + call handle_err(err, message) + + ! initialize parameter data structures (e.g. vegetation and soil parameters) + call summa_paramSetup(summa1_struc(n), err, message) + call handle_err(err, message) + + ! read restart data and reset the model state + call summa_readRestart(summa1_struc(n), err, message) + call handle_err(err, message) + +#ifdef OPENWQ_ACTIVE + call openwq_init(err) + if (err /= 0) call stop_program(1, 'Problem Initializing OpenWQ') +#endif + end subroutine initialize_summa_driver + + subroutine update_summa_driver + ! *** Update operations for SUMMA driver program *** + + ! loop through time + do modelTimeStep=1,numtim + + ! read model forcing data + call summa_readForcing(modelTimeStep, summa1_struc(n), err, message) + call handle_err(err, message) + +#ifdef OPENWQ_ACTIVE + call openwq_run_time_start(summa1_struc(n)) ! Passing state volumes to openWQ +#endif + + if (mod(modelTimeStep, print_step_freq) == 0) then + print *, 'step ---> ', modelTimeStep + end if + + ! run the summa physics for one time step + call summa_runPhysics(modelTimeStep, summa1_struc(n), err, message) + call handle_err(err, message) + +#ifdef OPENWQ_ACTIVE + call openwq_run_space_step(summa1_struc(n)) ! Passing fluxes to openWQ +#endif + + ! write the model output + call summa_writeOutputFiles(modelTimeStep, summa1_struc(n), err, message) + call handle_err(err, message) + +#ifdef OPENWQ_ACTIVE + call openwq_run_time_end(summa1_struc(n)) +#endif + + end do ! end looping through time + end subroutine update_summa_driver + + subroutine finalize_summa_driver + ! *** Final operations for SUMMA driver program *** + ! successful end + call stop_program(0, 'finished simulation successfully.') + + ! to prevent exiting before HDF5 has closed + call sleep(2) + end subroutine finalize_summa_driver + end program summa_driver diff --git a/build/source/driver/summa_driver4bmi.f90 b/build/source/driver/summa_driver4bmi.f90 new file mode 100644 index 000000000..9154f2154 --- /dev/null +++ b/build/source/driver/summa_driver4bmi.f90 @@ -0,0 +1,56 @@ +! SUMMA - Structure for Unifying Multiple Modeling Alternatives +! Copyright (C) 2014-2020 NCAR/RAL; University of Saskatchewan; University of Washington +! +! This file is part of SUMMA +! +! For more information see: http://www.ral.ucar.edu/projects/summa +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see . + +program summa_driver4bmi + ! driver program for summa simulations + ! ***************************************************************************** + ! * use desired modules + ! ***************************************************************************** + USE nrtype ! variable types, etc. + ! subroutines and functions: model simulation + USE summa_bmi + ! global data + USE globalData,only:numtim ! number of time steps + + implicit none + + ! ***************************************************************************** + ! * variable definitions + ! ***************************************************************************** + type (summa_bmi) :: model + integer(i4b) :: istat + ! define timing information + integer(i4b) :: modelTimeStep ! index of model time step + + ! ***************************************************************************** + ! * model simulation + ! ***************************************************************************** + ! give this a 0 length argument to use fileManager from summa standard command arguments + istat = model%initialize('') + + ! loop through time where numtim has been already computed as + ! numtim = nint( (dJulianFinsh - dJulianStart)*secprday/data_step ) + 1 + ! SUMMA runs the ending step (so start=end would still run a step) + do modelTimeStep=1,numtim + istat = model%update() + end do ! (looping through time) + istat = model%finalize() + +end program summa_driver4bmi diff --git a/build/source/driver/summa_forcing.f90 b/build/source/driver/summa_forcing.f90 old mode 100755 new mode 100644 diff --git a/build/source/driver/summa_globalData.f90 b/build/source/driver/summa_globalData.f90 old mode 100755 new mode 100644 index b3f5cfd9a..51857d4d9 --- a/build/source/driver/summa_globalData.f90 +++ b/build/source/driver/summa_globalData.f90 @@ -23,7 +23,7 @@ module summa_globalData ! access missing values USE globalData,only:integerMissing ! missing integer -USE globalData,only:realMissing ! missing double precision number +USE globalData,only:realMissing ! missing real number ! size of data structures USE var_lookup,only:maxvarForc ! forcing data: maximum number variables @@ -62,103 +62,99 @@ module summa_globalData public::summa_defineGlobalData contains - subroutine summa_defineGlobalData(err, message) - ! --------------------------------------------------------------------------------------- - ! * desired modules - ! --------------------------------------------------------------------------------------- - ! data types - USE nrtype ! variable types, etc. - ! subroutines and functions: initial priming - USE,intrinsic :: ieee_arithmetic ! IEEE arithmetic (obviously) - ! subroutines and functions: define metadata structures - USE popMetadat_module,only:popMetadat ! module to populate metadata structures - USE flxMapping_module,only:flxMapping ! module to map fluxes to states - USE checkStruc_module,only:checkStruc ! module to check metadata structures - USE childStruc_module,only:childStruc ! module to create a child data structure - ! miscellaneous global data - USE globalData,only:dNaN ! double precision NaN - USE globalData,only:doJacobian ! flag to compute the Jacobian - USE globalData,only:structInfo ! information on the data structures - ! named variables that describe elements of child model structures - USE var_lookup,only:iLookVarType ! look-up values for variable type structure - USE var_lookup,only:childFLUX_MEAN ! look-up values for timestep-average model fluxes - ! --------------------------------------------------------------------------------------- - ! * variables - ! --------------------------------------------------------------------------------------- - implicit none - ! dummy variables - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! local variables - character(LEN=256) :: cmessage ! error message of downwind routine - logical(lgt), dimension(maxvarFlux) :: flux_mask ! mask defining desired flux variables - logical(lgt), dimension(maxvarForc) :: statForc_mask ! mask defining forc stats - logical(lgt), dimension(maxvarProg) :: statProg_mask ! mask defining prog stats - logical(lgt), dimension(maxvarDiag) :: statDiag_mask ! mask defining diag stats - logical(lgt), dimension(maxvarFlux) :: statFlux_mask ! mask defining flux stats - logical(lgt), dimension(maxvarIndx) :: statIndx_mask ! mask defining indx stats - logical(lgt), dimension(maxvarBvar) :: statBvar_mask ! mask defining bvar stats - integer(i4b) :: iStruct ! index of data structure - ! --------------------------------------------------------------------------------------- - ! initialize error control - err=0; message='summa_defineGlobalData/' - - ! initialize the Jacobian flag - doJacobian=.false. ! initialize the Jacobian flag - - ! define double precision NaNs (shared in globalData) - dNaN = ieee_value(1._rkind, ieee_quiet_nan) - - ! populate metadata for all model variables - call popMetadat(err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - - ! define mapping between fluxes and states - call flxMapping(err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - - ! check data structures - call checkStruc(err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - - ! define the mask to identify the subset of variables in the "child" data structure (just scalar variables) - flux_mask = (flux_meta(:)%vartype==iLookVarType%scalarv) - - ! create the averageFlux metadata structure - call childStruc(flux_meta, flux_mask, averageFlux_meta, childFLUX_MEAN, err, cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - - ! child metadata structures - so that we do not carry full stats structures around everywhere - ! only carry stats for variables with output frequency > model time step - statForc_mask = (forc_meta(:)%vartype==iLookVarType%scalarv.and.forc_meta(:)%varDesire) - statProg_mask = (prog_meta(:)%vartype==iLookVarType%scalarv.and.prog_meta(:)%varDesire) - statDiag_mask = (diag_meta(:)%vartype==iLookVarType%scalarv.and.diag_meta(:)%varDesire) - statFlux_mask = (flux_meta(:)%vartype==iLookVarType%scalarv.and.flux_meta(:)%varDesire) - statIndx_mask = (indx_meta(:)%vartype==iLookVarType%scalarv.and.indx_meta(:)%varDesire) - statBvar_mask = (bvar_meta(:)%vartype==iLookVarType%scalarv.and.bvar_meta(:)%varDesire) - - ! create the stats metadata structures - do iStruct=1,size(structInfo) - select case (trim(structInfo(iStruct)%structName)) - case('forc'); call childStruc(forc_meta,statForc_mask,statForc_meta,forcChild_map,err,cmessage) - case('prog'); call childStruc(prog_meta,statProg_mask,statProg_meta,progChild_map,err,cmessage) - case('diag'); call childStruc(diag_meta,statDiag_mask,statDiag_meta,diagChild_map,err,cmessage) - case('flux'); call childStruc(flux_meta,statFlux_mask,statFlux_meta,fluxChild_map,err,cmessage) - case('indx'); call childStruc(indx_meta,statIndx_mask,statIndx_meta,indxChild_map,err,cmessage) - case('bvar'); call childStruc(bvar_meta,statBvar_mask,statBvar_meta,bvarChild_map,err,cmessage) - end select - ! check errors - if(err/=0)then; message=trim(message)//trim(cmessage)//'[statistics for = '//trim(structInfo(iStruct)%structName)//']'; return; endif - end do ! iStruct - - ! set all stats metadata to correct var types - statForc_meta(:)%vartype = iLookVarType%outstat - statProg_meta(:)%vartype = iLookVarType%outstat - statDiag_meta(:)%vartype = iLookVarType%outstat - statFlux_meta(:)%vartype = iLookVarType%outstat - statIndx_meta(:)%vartype = iLookVarType%outstat - statBvar_meta(:)%vartype = iLookVarType%outstat - - end subroutine summa_defineGlobalData +subroutine summa_defineGlobalData(err, message) + ! --------------------------------------------------------------------------------------- + ! * desired modules + ! --------------------------------------------------------------------------------------- + ! data types + USE nrtype ! variable types, etc. + ! subroutines and functions: initial priming + USE,intrinsic :: ieee_arithmetic ! IEEE arithmetic (obviously) + ! subroutines and functions: define metadata structures + USE popMetadat_module,only:popMetadat ! module to populate metadata structures + USE flxMapping_module,only:flxMapping ! module to map fluxes to states + USE checkStruc_module,only:checkStruc ! module to check metadata structures + USE childStruc_module,only:childStruc ! module to create a child data structure + ! miscellaneous global data + USE globalData,only:dNaN ! double precision NaN + USE globalData,only:structInfo ! information on the data structures + ! named variables that describe elements of child model structures + USE var_lookup,only:iLookVarType ! look-up values for variable type structure + USE var_lookup,only:childFLUX_MEAN ! look-up values for timestep-average model fluxes + ! --------------------------------------------------------------------------------------- + ! * variables + ! --------------------------------------------------------------------------------------- + implicit none + ! dummy variables + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! local variables + character(LEN=256) :: cmessage ! error message of downwind routine + logical(lgt), dimension(maxvarFlux) :: flux_mask ! mask defining desired flux variables + logical(lgt), dimension(maxvarForc) :: statForc_mask ! mask defining forc stats + logical(lgt), dimension(maxvarProg) :: statProg_mask ! mask defining prog stats + logical(lgt), dimension(maxvarDiag) :: statDiag_mask ! mask defining diag stats + logical(lgt), dimension(maxvarFlux) :: statFlux_mask ! mask defining flux stats + logical(lgt), dimension(maxvarIndx) :: statIndx_mask ! mask defining indx stats + logical(lgt), dimension(maxvarBvar) :: statBvar_mask ! mask defining bvar stats + integer(i4b) :: iStruct ! index of data structure + ! --------------------------------------------------------------------------------------- + ! initialize error control + err=0; message='summa_defineGlobalData/' + + ! define double precision NaNs (shared in globalData) + dNaN = ieee_value(1._rkind, ieee_quiet_nan) + + ! populate metadata for all model variables + call popMetadat(err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! define mapping between fluxes and states + call flxMapping(err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! check data structures + call checkStruc(err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! define the mask to identify the subset of variables in the "child" data structure (just scalar variables) + flux_mask = (flux_meta(:)%vartype==iLookVarType%scalarv) + + ! create the averageFlux metadata structure + call childStruc(flux_meta, flux_mask, averageFlux_meta, childFLUX_MEAN, err, cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! child metadata structures - so that we do not carry full stats structures around everywhere + ! only carry stats for variables with output frequency > model time step + statForc_mask = (forc_meta(:)%vartype==iLookVarType%scalarv.and.forc_meta(:)%varDesire) + statProg_mask = (prog_meta(:)%vartype==iLookVarType%scalarv.and.prog_meta(:)%varDesire) + statDiag_mask = (diag_meta(:)%vartype==iLookVarType%scalarv.and.diag_meta(:)%varDesire) + statFlux_mask = (flux_meta(:)%vartype==iLookVarType%scalarv.and.flux_meta(:)%varDesire) + statIndx_mask = (indx_meta(:)%vartype==iLookVarType%scalarv.and.indx_meta(:)%varDesire) + statBvar_mask = (bvar_meta(:)%vartype==iLookVarType%scalarv.and.bvar_meta(:)%varDesire) + + ! create the stats metadata structures + do iStruct=1,size(structInfo) + select case (trim(structInfo(iStruct)%structName)) + case('forc'); call childStruc(forc_meta,statForc_mask,statForc_meta,forcChild_map,err,cmessage) + case('prog'); call childStruc(prog_meta,statProg_mask,statProg_meta,progChild_map,err,cmessage) + case('diag'); call childStruc(diag_meta,statDiag_mask,statDiag_meta,diagChild_map,err,cmessage) + case('flux'); call childStruc(flux_meta,statFlux_mask,statFlux_meta,fluxChild_map,err,cmessage) + case('indx'); call childStruc(indx_meta,statIndx_mask,statIndx_meta,indxChild_map,err,cmessage) + case('bvar'); call childStruc(bvar_meta,statBvar_mask,statBvar_meta,bvarChild_map,err,cmessage) + end select + ! check errors + if(err/=0)then; message=trim(message)//trim(cmessage)//'[statistics for = '//trim(structInfo(iStruct)%structName)//']'; return; endif + end do ! iStruct + + ! set all stats metadata to correct var types + statForc_meta(:)%vartype = iLookVarType%outstat + statProg_meta(:)%vartype = iLookVarType%outstat + statDiag_meta(:)%vartype = iLookVarType%outstat + statFlux_meta(:)%vartype = iLookVarType%outstat + statIndx_meta(:)%vartype = iLookVarType%outstat + statBvar_meta(:)%vartype = iLookVarType%outstat + +end subroutine summa_defineGlobalData end module summa_globalData diff --git a/build/source/driver/summa_init.f90 b/build/source/driver/summa_init.f90 old mode 100755 new mode 100644 index 63c68763e..4706b582e --- a/build/source/driver/summa_init.f90 +++ b/build/source/driver/summa_init.f90 @@ -23,7 +23,7 @@ module summa_init ! access missing values USE globalData,only:integerMissing ! missing integer -USE globalData,only:realMissing ! missing double precision number +USE globalData,only:realMissing ! missing real number ! named variables for run time options USE globalData,only:iRunModeFull,iRunModeGRU,iRunModeHRU @@ -33,7 +33,7 @@ module summa_init USE globalData,only:prog_meta,diag_meta,flux_meta,id_meta ! metadata structures USE globalData,only:mpar_meta,indx_meta ! metadata structures USE globalData,only:bpar_meta,bvar_meta ! metadata structures -USE globalData,only:averageFlux_meta ! metadata for time-step average fluxes +USE globalData,only:lookup_meta ! statistics metadata structures USE globalData,only:statForc_meta ! child metadata for stats @@ -56,284 +56,281 @@ module summa_init public::summa_initialize contains - ! used to declare and allocate summa data structures and initialize model state to known values - subroutine summa_initialize(summa1_struc, err, message) - ! --------------------------------------------------------------------------------------- - ! * desired modules - ! --------------------------------------------------------------------------------------- - ! data types - USE nrtype ! variable types, etc. - USE summa_type, only:summa1_type_dec ! master summa data type - ! subroutines and functions: initial priming - USE summa_util, only:getCommandArguments ! process command line arguments - USE summaFileManager,only:summa_SetTimesDirsAndFiles ! sets directories and filenames - USE summa_globalData,only:summa_defineGlobalData ! used to define global summa data structures - USE time_utils_module,only:elapsedSec ! calculate the elapsed time - ! subroutines and functions: read dimensions (NOTE: NetCDF) - USE read_attrb_module,only:read_dimension ! module to read dimensions of GRU and HRU - USE read_icond_module,only:read_icond_nlayers ! module to read initial condition dimensions - ! subroutines and functions: allocate space - USE allocspace_module,only:allocGlobal ! module to allocate space for global data structures - USE allocspace_module,only:allocLocal ! module to allocate space for local data structures - ! timing variables - USE globalData,only:startInit,endInit ! date/time for the start and end of the initialization - USE globalData,only:elapsedInit ! elapsed time for the initialization - USE globalData,only:elapsedRead ! elapsed time for the data read - USE globalData,only:elapsedWrite ! elapsed time for the stats/write - USE globalData,only:elapsedPhysics ! elapsed time for the physics - ! model time structures - USE globalData,only:startTime ! start time - USE globalData,only:finshTime ! end time - USE globalData,only:refTime ! reference time - USE globalData,only:oldTime ! time from previous step - ! run time options - USE globalData,only:startGRU ! index of the starting GRU for parallelization run - USE globalData,only:checkHRU ! index of the HRU for a single HRU run - USE globalData,only:iRunMode ! define the current running mode - ! miscellaneous global data - USE globalData,only:ncid ! file id of netcdf output file - USE globalData,only:gru_struc ! gru-hru mapping structures - USE globalData,only:structInfo ! information on the data structures - USE globalData,only:output_fileSuffix ! suffix for the output file - ! --------------------------------------------------------------------------------------- - ! * variables - ! --------------------------------------------------------------------------------------- - implicit none - ! dummy variables - type(summa1_type_dec),intent(inout) :: summa1_struc ! master summa data structure - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! local variables - character(LEN=256) :: cmessage ! error message of downwind routine - character(len=256) :: restartFile ! restart file name - character(len=256) :: attrFile ! attributes file name - character(len=128) :: fmtGruOutput ! a format string used to write start and end GRU in output file names - integer(i4b) :: iStruct,iGRU ! looping variables - integer(i4b) :: fileGRU ! [used for filenames] number of GRUs in the input file - integer(i4b) :: fileHRU ! [used for filenames] number of HRUs in the input file - ! --------------------------------------------------------------------------------------- - ! associate to elements in the data structure - summaVars: associate(& - - ! statistics structures - forcStat => summa1_struc%forcStat , & ! x%gru(:)%hru(:)%var(:)%dat -- model forcing data - progStat => summa1_struc%progStat , & ! x%gru(:)%hru(:)%var(:)%dat -- model prognostic (state) variables - diagStat => summa1_struc%diagStat , & ! x%gru(:)%hru(:)%var(:)%dat -- model diagnostic variables - fluxStat => summa1_struc%fluxStat , & ! x%gru(:)%hru(:)%var(:)%dat -- model fluxes - indxStat => summa1_struc%indxStat , & ! x%gru(:)%hru(:)%var(:)%dat -- model indices - bvarStat => summa1_struc%bvarStat , & ! x%gru(:)%var(:)%dat -- basin-average variables - - ! primary data structures (scalars) - timeStruct => summa1_struc%timeStruct , & ! x%var(:) -- model time data - forcStruct => summa1_struc%forcStruct , & ! x%gru(:)%hru(:)%var(:) -- model forcing data - attrStruct => summa1_struc%attrStruct , & ! x%gru(:)%hru(:)%var(:) -- local attributes for each HRU - typeStruct => summa1_struc%typeStruct , & ! x%gru(:)%hru(:)%var(:) -- local classification of soil veg etc. for each HRU - idStruct => summa1_struc%idStruct , & ! x%gru(:)%hru(:)%var(:) -- - - ! primary data structures (variable length vectors) - indxStruct => summa1_struc%indxStruct , & ! x%gru(:)%hru(:)%var(:)%dat -- model indices - mparStruct => summa1_struc%mparStruct , & ! x%gru(:)%hru(:)%var(:)%dat -- model parameters - progStruct => summa1_struc%progStruct , & ! x%gru(:)%hru(:)%var(:)%dat -- model prognostic (state) variables - diagStruct => summa1_struc%diagStruct , & ! x%gru(:)%hru(:)%var(:)%dat -- model diagnostic variables - fluxStruct => summa1_struc%fluxStruct , & ! x%gru(:)%hru(:)%var(:)%dat -- model fluxes - - ! basin-average structures - bparStruct => summa1_struc%bparStruct , & ! x%gru(:)%var(:) -- basin-average parameters - bvarStruct => summa1_struc%bvarStruct , & ! x%gru(:)%var(:)%dat -- basin-average variables - - ! ancillary data structures - dparStruct => summa1_struc%dparStruct , & ! x%gru(:)%hru(:)%var(:) -- default model parameters - - ! run time variables - computeVegFlux => summa1_struc%computeVegFlux , & ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) - dt_init => summa1_struc%dt_init , & ! used to initialize the length of the sub-step for each HRU - upArea => summa1_struc%upArea , & ! area upslope of each HRU - - ! miscellaneous variables - summa1open => summa1_struc%summa1open , & ! flag to define if the summa file is open?? - numout => summa1_struc%numout , & ! number of output variables?? - ts => summa1_struc%ts , & ! model time step ?? - nGRU => summa1_struc%nGRU , & ! number of grouped response units - nHRU => summa1_struc%nHRU , & ! number of global hydrologic response units - hruCount => summa1_struc%hruCount , & ! number of local hydrologic response units - greenVegFrac_monthly => summa1_struc%greenVegFrac_monthly, & ! fraction of green vegetation in each month (0-1) - summaFileManagerFile => summa1_struc%summaFileManagerFile & ! path/name of file defining directories and files - - ) ! assignment to variables in the data structures - ! --------------------------------------------------------------------------------------- - ! initialize error control - err=0; message='summa_initialize/' - - ! initialize the start of the initialization - call date_and_time(values=startInit) - - ! ***************************************************************************** - ! *** inital priming -- get command line arguments, identify files, etc. - ! ***************************************************************************** - - ! initialize the netcdf file id - ncid(:) = integerMissing - - ! initialize the elapsed time for cumulative quantities - elapsedRead=0._rkind - elapsedWrite=0._rkind - elapsedPhysics=0._rkind - - ! get the command line arguments - call getCommandArguments(summa1_struc,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - - ! set directories and files -- summaFileManager used as command-line argument - call summa_SetTimesDirsAndFiles(summaFileManagerFile,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - - ! define global data (parameters, metadata) - call summa_defineGlobalData(err, cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - - ! ***************************************************************************** - ! *** read the number of GRUs and HRUs - ! ***************************************************************************** - ! obtain the HRU and GRU dimensions in the LocalAttribute file - attrFile = trim(SETTINGS_PATH)//trim(LOCAL_ATTRIBUTES) - select case (iRunMode) - case(iRunModeFull); call read_dimension(trim(attrFile),fileGRU,fileHRU,nGRU,nHRU,err,cmessage) - case(iRunModeGRU ); call read_dimension(trim(attrFile),fileGRU,fileHRU,nGRU,nHRU,err,cmessage,startGRU=startGRU) - case(iRunModeHRU ); call read_dimension(trim(attrFile),fileGRU,fileHRU,nGRU,nHRU,err,cmessage,checkHRU=checkHRU) - end select - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - - ! ***************************************************************************** - ! *** read the number of snow and soil layers - ! ***************************************************************************** - ! set restart filename and read the number of snow and soil layers from the initial conditions (restart) file - if(STATE_PATH == '') then - restartFile = trim(SETTINGS_PATH)//trim(MODEL_INITCOND) - else - restartFile = trim(STATE_PATH)//trim(MODEL_INITCOND) - endif - call read_icond_nlayers(trim(restartFile),nGRU,indx_meta,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - - ! ***************************************************************************** - ! *** allocate space for data structures - ! ***************************************************************************** - - ! allocate time structures - do iStruct=1,4 - select case(iStruct) - case(1); call allocLocal(time_meta, startTime, err=err, message=cmessage) ! start time for the model simulation - case(2); call allocLocal(time_meta, finshTime, err=err, message=cmessage) ! end time for the model simulation - case(3); call allocLocal(time_meta, refTime, err=err, message=cmessage) ! reference time for the model simulation - case(4); call allocLocal(time_meta, oldTime, err=err, message=cmessage) ! time from the previous step - end select - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - end do ! looping through time structures - - ! allocate other data structures - do iStruct=1,size(structInfo) - ! allocate space - select case(trim(structInfo(iStruct)%structName)) - case('time'); call allocGlobal(time_meta, timeStruct, err, cmessage) ! model forcing data - case('forc'); call allocGlobal(forc_meta, forcStruct, err, cmessage) ! model forcing data - case('attr'); call allocGlobal(attr_meta, attrStruct, err, cmessage) ! local attributes for each HRU - case('type'); call allocGlobal(type_meta, typeStruct, err, cmessage) ! local classification of soil veg etc. for each HRU - case('id' ); call allocGlobal(id_meta, idStruct, err, message) ! local values of hru and gru IDs - case('mpar'); call allocGlobal(mpar_meta, mparStruct, err, cmessage) ! model parameters - case('indx'); call allocGlobal(indx_meta, indxStruct, err, cmessage) ! model variables - case('prog'); call allocGlobal(prog_meta, progStruct, err, cmessage) ! model prognostic (state) variables - case('diag'); call allocGlobal(diag_meta, diagStruct, err, cmessage) ! model diagnostic variables - case('flux'); call allocGlobal(flux_meta, fluxStruct, err, cmessage) ! model fluxes - case('bpar'); call allocGlobal(bpar_meta, bparStruct, err, cmessage) ! basin-average parameters - case('bvar'); call allocGlobal(bvar_meta, bvarStruct, err, cmessage) ! basin-average variables - case('deriv'); cycle - case default; err=20; message='unable to find structure name: '//trim(structInfo(iStruct)%structName) - end select - ! check errors - if(err/=0)then - message=trim(message)//trim(cmessage)//'[structure = '//trim(structInfo(iStruct)%structName)//']' - return - endif - end do ! looping through data structures - - ! allocate space for default model parameters - ! NOTE: This is done here, rather than in the loop above, because dpar is not one of the "standard" data structures - call allocGlobal(mpar_meta,dparStruct,err,cmessage) ! default model parameters - if(err/=0)then - message=trim(message)//trim(cmessage)//' [problem allocating dparStruct]' - return - endif - - ! allocate space for the time step and computeVegFlux flags (recycled for each GRU for subsequent model calls) - allocate(dt_init%gru(nGRU),upArea%gru(nGRU),computeVegFlux%gru(nGRU),stat=err) - if(err/=0)then - message=trim(message)//'problem allocating space for dt_init, upArea, or computeVegFlux [GRU]' - return - endif - - ! allocate space for the HRUs - do iGRU=1,nGRU - hruCount = gru_struc(iGRU)%hruCount ! gru_struc populated in "read_dimension" - allocate(dt_init%gru(iGRU)%hru(hruCount),upArea%gru(iGRU)%hru(hruCount),computeVegFlux%gru(iGRU)%hru(hruCount),stat=err) - if(err/=0)then - message='problem allocating space for dt_init, upArea, or computeVegFlux [HRU]' - return - endif - end do - - ! ***************************************************************************** - ! *** allocate space for output statistics data structures - ! ***************************************************************************** - - ! loop through data structures - do iStruct=1,size(structInfo) - - ! allocate space - select case(trim(structInfo(iStruct)%structName)) - case('forc'); call allocGlobal(statForc_meta(:)%var_info,forcStat,err,cmessage) ! model forcing data - case('prog'); call allocGlobal(statProg_meta(:)%var_info,progStat,err,cmessage) ! model prognostic (state) variables - case('diag'); call allocGlobal(statDiag_meta(:)%var_info,diagStat,err,cmessage) ! model diagnostic variables - case('flux'); call allocGlobal(statFlux_meta(:)%var_info,fluxStat,err,cmessage) ! model fluxes - case('indx'); call allocGlobal(statIndx_meta(:)%var_info,indxStat,err,cmessage) ! index vars - case('bvar'); call allocGlobal(statBvar_meta(:)%var_info,bvarStat,err,cmessage) ! basin-average variables - case default; cycle - end select - - ! check errors - if(err/=0)then - message=trim(message)//trim(cmessage)//'[statistics for = '//trim(structInfo(iStruct)%structName)//']' - return - endif - - end do ! iStruct - - ! ***************************************************************************** - ! *** define the suffix for the model output file - ! ***************************************************************************** - - ! set up the output file names as: OUTPUT_PREFIX'_'output_fileSuffix'_'startGRU-endGRU_outfreq.nc or OUTPUT_PREFIX'_'output_fileSuffix'_'HRU_outfreq.nc; - if (output_fileSuffix(1:1) /= '_') output_fileSuffix='_'//trim(output_fileSuffix) ! separate output_fileSuffix from others by underscores - if (output_fileSuffix(len_trim(output_fileSuffix):len_trim(output_fileSuffix)) == '_') output_fileSuffix(len_trim(output_fileSuffix):len_trim(output_fileSuffix)) = ' ' - select case (iRunMode) - case(iRunModeGRU) - ! left zero padding for startGRU and endGRU - write(fmtGruOutput,"(i0)") ceiling(log10(real(fileGRU)+0.1)) ! maximum width of startGRU and endGRU - fmtGruOutput = "i"//trim(fmtGruOutput)//"."//trim(fmtGruOutput) ! construct the format string for startGRU and endGRU - fmtGruOutput = "('_G',"//trim(fmtGruOutput)//",'-',"//trim(fmtGruOutput)//")" - write(output_fileSuffix((len_trim(output_fileSuffix)+1):len(output_fileSuffix)),fmtGruOutput) startGRU,startGRU+nGRU-1 - case(iRunModeHRU) - write(output_fileSuffix((len_trim(output_fileSuffix)+1):len(output_fileSuffix)),"('_H',i0)") checkHRU - end select - - ! identify the end of the initialization - call date_and_time(values=endInit) - - ! aggregate the elapsed time for the initialization - elapsedInit = elapsedSec(startInit, endInit) - - ! end associate statements - end associate summaVars - - end subroutine summa_initialize +! used to declare and allocate summa data structures and initialize model state to known values +subroutine summa_initialize(summa1_struc, err, message) + ! --------------------------------------------------------------------------------------- + ! * desired modules + ! --------------------------------------------------------------------------------------- + ! data types + USE nrtype ! variable types, etc. + USE summa_type, only:summa1_type_dec ! master summa data type + ! subroutines and functions: initial priming + USE summa_util, only:getCommandArguments ! process command line arguments + USE summaFileManager,only:summa_SetTimesDirsAndFiles ! sets directories and filenames + USE summa_globalData,only:summa_defineGlobalData ! used to define global summa data structures + USE time_utils_module,only:elapsedSec ! calculate the elapsed time + ! subroutines and functions: read dimensions (NOTE: NetCDF) + USE read_attrb_module,only:read_dimension ! module to read dimensions of GRU and HRU + USE read_icond_module,only:read_icond_nlayers ! module to read initial condition dimensions + ! subroutines and functions: allocate space + USE allocspace_module,only:allocGlobal ! module to allocate space for global data structures + USE allocspace_module,only:allocLocal ! module to allocate space for local data structures + ! timing variables + USE globalData,only:startInit,endInit ! date/time for the start and end of the initialization + USE globalData,only:elapsedInit ! elapsed time for the initialization + USE globalData,only:elapsedRead ! elapsed time for the data read + USE globalData,only:elapsedWrite ! elapsed time for the stats/write + USE globalData,only:elapsedPhysics ! elapsed time for the physics + ! model time structures + USE globalData,only:startTime ! start time + USE globalData,only:finshTime ! end time + USE globalData,only:refTime ! reference time + USE globalData,only:oldTime ! time from previous step + ! run time options + USE globalData,only:startGRU ! index of the starting GRU for parallelization run + USE globalData,only:checkHRU ! index of the HRU for a single HRU run + USE globalData,only:iRunMode ! define the current running mode + ! miscellaneous global data + USE globalData,only:ncid ! file id of netcdf output file + USE globalData,only:gru_struc ! gru-hru mapping structures + USE globalData,only:structInfo ! information on the data structures + USE globalData,only:output_fileSuffix ! suffix for the output file + ! --------------------------------------------------------------------------------------- + ! * variables + ! --------------------------------------------------------------------------------------- + implicit none + ! dummy variables + type(summa1_type_dec),intent(inout) :: summa1_struc ! master summa data structure + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! local variables + character(LEN=256) :: cmessage ! error message of downwind routine + character(len=256) :: restartFile ! restart file name + character(len=256) :: attrFile ! attributes file name + character(len=128) :: fmtGruOutput ! a format string used to write start and end GRU in output file names + integer(i4b) :: iStruct,iGRU ! looping variables + integer(i4b) :: fileGRU ! [used for filenames] number of GRUs in the input file + integer(i4b) :: fileHRU ! [used for filenames] number of HRUs in the input file + integer(i4b) :: hruCount ! number of local hydrologic response units + ! --------------------------------------------------------------------------------------- + ! associate to elements in the data structure + summaVars: associate(& + ! lookup table data structure + lookupStruct => summa1_struc%lookupStruct , & ! x%gru(:)%hru(:)%z(:)%var(:)%lookup(:) -- lookup tables + ! statistics structures + forcStat => summa1_struc%forcStat , & ! x%gru(:)%hru(:)%var(:)%dat -- model forcing data + progStat => summa1_struc%progStat , & ! x%gru(:)%hru(:)%var(:)%dat -- model prognostic (state) variables + diagStat => summa1_struc%diagStat , & ! x%gru(:)%hru(:)%var(:)%dat -- model diagnostic variables + fluxStat => summa1_struc%fluxStat , & ! x%gru(:)%hru(:)%var(:)%dat -- model fluxes + indxStat => summa1_struc%indxStat , & ! x%gru(:)%hru(:)%var(:)%dat -- model indices + bvarStat => summa1_struc%bvarStat , & ! x%gru(:)%var(:)%dat -- basin-average variables + + ! primary data structures (scalars) + timeStruct => summa1_struc%timeStruct , & ! x%var(:) -- model time data + forcStruct => summa1_struc%forcStruct , & ! x%gru(:)%hru(:)%var(:) -- model forcing data + attrStruct => summa1_struc%attrStruct , & ! x%gru(:)%hru(:)%var(:) -- local attributes for each HRU + typeStruct => summa1_struc%typeStruct , & ! x%gru(:)%hru(:)%var(:) -- local classification of soil veg etc. for each HRU + idStruct => summa1_struc%idStruct , & ! x%gru(:)%hru(:)%var(:) -- + + ! primary data structures (variable length vectors) + indxStruct => summa1_struc%indxStruct , & ! x%gru(:)%hru(:)%var(:)%dat -- model indices + mparStruct => summa1_struc%mparStruct , & ! x%gru(:)%hru(:)%var(:)%dat -- model parameters + progStruct => summa1_struc%progStruct , & ! x%gru(:)%hru(:)%var(:)%dat -- model prognostic (state) variables + diagStruct => summa1_struc%diagStruct , & ! x%gru(:)%hru(:)%var(:)%dat -- model diagnostic variables + fluxStruct => summa1_struc%fluxStruct , & ! x%gru(:)%hru(:)%var(:)%dat -- model fluxes + + ! basin-average structures + bparStruct => summa1_struc%bparStruct , & ! x%gru(:)%var(:) -- basin-average parameters + bvarStruct => summa1_struc%bvarStruct , & ! x%gru(:)%var(:)%dat -- basin-average variables + + ! ancillary data structures + dparStruct => summa1_struc%dparStruct , & ! x%gru(:)%hru(:)%var(:) -- default model parameters + + ! run time variables + computeVegFlux => summa1_struc%computeVegFlux , & ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) + dt_init => summa1_struc%dt_init , & ! used to initialize the length of the sub-step for each HRU + upArea => summa1_struc%upArea , & ! area upslope of each HRU + + ! miscellaneous variables + nGRU => summa1_struc%nGRU , & ! number of grouped response units + nHRU => summa1_struc%nHRU , & ! number of global hydrologic response units + summaFileManagerFile => summa1_struc%summaFileManagerFile & ! path/name of file defining directories and files + + ) ! assignment to variables in the data structures + ! --------------------------------------------------------------------------------------- + ! initialize error control + err=0; message='summa_initialize/' + + ! initialize the start of the initialization + call date_and_time(values=startInit) + + ! ***************************************************************************** + ! *** inital priming -- get command line arguments, identify files, etc. + ! ***************************************************************************** + + ! initialize the netcdf file id + ncid(:) = integerMissing + + ! initialize the elapsed time for cumulative quantities + elapsedRead=0._rkind + elapsedWrite=0._rkind + elapsedPhysics=0._rkind + + ! get the command line arguments + call getCommandArguments(summa1_struc,err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! set directories and files -- summaFileManager used as command-line argument + call summa_SetTimesDirsAndFiles(summaFileManagerFile,err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! define global data (parameters, metadata) + call summa_defineGlobalData(err, cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! ***************************************************************************** + ! *** read the number of GRUs and HRUs + ! ***************************************************************************** + ! obtain the HRU and GRU dimensions in the LocalAttribute file + attrFile = trim(SETTINGS_PATH)//trim(LOCAL_ATTRIBUTES) + select case (iRunMode) + case(iRunModeFull); call read_dimension(trim(attrFile),fileGRU,fileHRU,nGRU,nHRU,err,cmessage) + case(iRunModeGRU ); call read_dimension(trim(attrFile),fileGRU,fileHRU,nGRU,nHRU,err,cmessage,startGRU=startGRU) + case(iRunModeHRU ); call read_dimension(trim(attrFile),fileGRU,fileHRU,nGRU,nHRU,err,cmessage,checkHRU=checkHRU) + end select + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! ***************************************************************************** + ! *** read the number of snow and soil layers + ! ***************************************************************************** + ! set restart filename and read the number of snow and soil layers from the initial conditions (restart) file + if(STATE_PATH == '') then + restartFile = trim(SETTINGS_PATH)//trim(MODEL_INITCOND) + else + restartFile = trim(STATE_PATH)//trim(MODEL_INITCOND) + endif + call read_icond_nlayers(trim(restartFile),nGRU,indx_meta,err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! ***************************************************************************** + ! *** allocate space for data structures + ! ***************************************************************************** + + ! allocate time structures + do iStruct=1,4 + select case(iStruct) + case(1); call allocLocal(time_meta, startTime, err=err, message=cmessage) ! start time for the model simulation + case(2); call allocLocal(time_meta, finshTime, err=err, message=cmessage) ! end time for the model simulation + case(3); call allocLocal(time_meta, refTime, err=err, message=cmessage) ! reference time for the model simulation + case(4); call allocLocal(time_meta, oldTime, err=err, message=cmessage) ! time from the previous step + end select + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + end do ! looping through time structures + + ! allocate other data structures + do iStruct=1,size(structInfo) + ! allocate space + select case(trim(structInfo(iStruct)%structName)) + case('time' ); call allocGlobal(time_meta, timeStruct, err, cmessage) ! model forcing data + case('forc' ); call allocGlobal(forc_meta, forcStruct, err, cmessage) ! model forcing data + case('attr' ); call allocGlobal(attr_meta, attrStruct, err, cmessage) ! local attributes for each HRU + case('type' ); call allocGlobal(type_meta, typeStruct, err, cmessage) ! local classification of soil veg etc. for each HRU + case('id' ); call allocGlobal(id_meta, idStruct, err, message) ! local values of hru and gru IDs + case('mpar' ); call allocGlobal(mpar_meta, mparStruct, err, cmessage) ! model parameters + case('indx' ); call allocGlobal(indx_meta, indxStruct, err, cmessage) ! model variables + case('prog' ); call allocGlobal(prog_meta, progStruct, err, cmessage) ! model prognostic (state) variables + case('diag' ); call allocGlobal(diag_meta, diagStruct, err, cmessage) ! model diagnostic variables + case('flux' ); call allocGlobal(flux_meta, fluxStruct, err, cmessage) ! model fluxes + case('bpar' ); call allocGlobal(bpar_meta, bparStruct, err, cmessage) ! basin-average parameters + case('bvar' ); call allocGlobal(bvar_meta, bvarStruct, err, cmessage) ! basin-average variables + case('lookup'); call allocGlobal(lookup_meta, lookupStruct, err, cmessage) ! basin-average variables + case('deriv' ); cycle + case default; err=20; message='unable to find structure name: '//trim(structInfo(iStruct)%structName) + end select + ! check errors + if(err/=0)then + message=trim(message)//trim(cmessage)//'[structure = '//trim(structInfo(iStruct)%structName)//']' + return + endif + end do ! looping through data structures + + ! allocate space for default model parameters + ! NOTE: This is done here, rather than in the loop above, because dpar is not one of the "standard" data structures + call allocGlobal(mpar_meta,dparStruct,err,cmessage) ! default model parameters + if(err/=0)then + message=trim(message)//trim(cmessage)//' [problem allocating dparStruct]' + return + endif + + ! allocate space for the time step and computeVegFlux flags (recycled for each GRU for subsequent model calls) + allocate(dt_init%gru(nGRU),upArea%gru(nGRU),computeVegFlux%gru(nGRU),stat=err) + if(err/=0)then + message=trim(message)//'problem allocating space for dt_init, upArea, or computeVegFlux [GRU]' + return + endif + + ! allocate space for the HRUs + do iGRU=1,nGRU + hruCount = gru_struc(iGRU)%hruCount ! gru_struc populated in "read_dimension" + allocate(dt_init%gru(iGRU)%hru(hruCount),upArea%gru(iGRU)%hru(hruCount),computeVegFlux%gru(iGRU)%hru(hruCount),stat=err) + if(err/=0)then + message='problem allocating space for dt_init, upArea, or computeVegFlux [HRU]' + return + endif + end do + + ! ***************************************************************************** + ! *** allocate space for output statistics data structures + ! ***************************************************************************** + + ! loop through data structures + do iStruct=1,size(structInfo) + + ! allocate space + select case(trim(structInfo(iStruct)%structName)) + case('forc'); call allocGlobal(statForc_meta(:)%var_info,forcStat,err,cmessage) ! model forcing data + case('prog'); call allocGlobal(statProg_meta(:)%var_info,progStat,err,cmessage) ! model prognostic (state) variables + case('diag'); call allocGlobal(statDiag_meta(:)%var_info,diagStat,err,cmessage) ! model diagnostic variables + case('flux'); call allocGlobal(statFlux_meta(:)%var_info,fluxStat,err,cmessage) ! model fluxes + case('indx'); call allocGlobal(statIndx_meta(:)%var_info,indxStat,err,cmessage) ! index vars + case('bvar'); call allocGlobal(statBvar_meta(:)%var_info,bvarStat,err,cmessage) ! basin-average variables + case default; cycle + end select + + ! check errors + if(err/=0)then + message=trim(message)//trim(cmessage)//'[statistics for = '//trim(structInfo(iStruct)%structName)//']' + return + endif + + end do ! iStruct + + ! ***************************************************************************** + ! *** define the suffix for the model output file + ! ***************************************************************************** + ! set up the output file names as: OUTPUT_PREFIX'_'output_fileSuffix'_'startGRU-endGRU_outfreq.nc or OUTPUT_PREFIX'_'output_fileSuffix'_'HRU_outfreq.nc; + if (output_fileSuffix(1:1) /= '_') output_fileSuffix='_'//trim(output_fileSuffix) ! separate output_fileSuffix from others by underscores + if (output_fileSuffix(len_trim(output_fileSuffix):len_trim(output_fileSuffix)) == '_') output_fileSuffix(len_trim(output_fileSuffix):len_trim(output_fileSuffix)) = ' ' + select case (iRunMode) + case(iRunModeGRU) + ! left zero padding for startGRU and endGRU + write(fmtGruOutput,"(i0)") ceiling(log10(real(fileGRU)+0.1)) ! maximum width of startGRU and endGRU + fmtGruOutput = "i"//trim(fmtGruOutput)//"."//trim(fmtGruOutput) ! construct the format string for startGRU and endGRU + fmtGruOutput = "('_G',"//trim(fmtGruOutput)//",'-',"//trim(fmtGruOutput)//")" + write(output_fileSuffix((len_trim(output_fileSuffix)+1):len(output_fileSuffix)),fmtGruOutput) startGRU,startGRU+nGRU-1 + case(iRunModeHRU) + write(output_fileSuffix((len_trim(output_fileSuffix)+1):len(output_fileSuffix)),"('_H',i0)") checkHRU + end select + + ! identify the end of the initialization + call date_and_time(values=endInit) + + ! aggregate the elapsed time for the initialization + elapsedInit = elapsedSec(startInit, endInit) + + ! end associate statements + end associate summaVars + +end subroutine summa_initialize end module summa_init diff --git a/build/source/driver/summa_modelRun.f90 b/build/source/driver/summa_modelRun.f90 old mode 100755 new mode 100644 index ea9eb8df6..cee0e8ff7 --- a/build/source/driver/summa_modelRun.f90 +++ b/build/source/driver/summa_modelRun.f90 @@ -23,7 +23,7 @@ module summa_modelRun ! access missing values USE globalData,only:integerMissing ! missing integer -USE globalData,only:realMissing ! missing double precision number +USE globalData,only:realMissing ! missing real number ! named variables USE globalData,only:yes,no ! .true. and .false. @@ -32,6 +32,10 @@ module summa_modelRun USE var_lookup,only:iLookINDEX ! look-up values for local column index variables USE summa_util,only:handle_err +! these are needed because we cannot access them in modules locally if we might use those modules with Actors +USE globalData,only:fracJulDay ! fractional julian days since the start of year +USE globalData,only:yearLength ! number of days in the current year + ! safety: set private unless specified otherwise implicit none private @@ -67,21 +71,21 @@ subroutine summa_runPhysics(modelTimeStep, summa1_struc, err, message) character(*),intent(out) :: message ! error message ! --------------------------------------------------------------------------------------- ! local variables: general - character(LEN=256) :: cmessage ! error message of downwind routine + character(LEN=512) :: cmessage ! error message of downwind routine integer(i4b) :: iHRU ! HRU index integer(i4b) :: iGRU,jGRU,kGRU ! GRU indices ! local variables: veg phenology logical(lgt) :: computeVegFluxFlag ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) - real(rkind) :: notUsed_canopyDepth ! NOT USED: canopy depth (m) - real(rkind) :: notUsed_exposedVAI ! NOT USED: exposed vegetation area index (m2 m-2) + real(rkind) :: notUsed_canopyDepth ! NOT USED: canopy depth (m) + real(rkind) :: notUsed_exposedVAI ! NOT USED: exposed vegetation area index (m2 m-2) ! local variables: parallelize the model run integer(i4b), allocatable :: ixExpense(:) ! ranked index GRU w.r.t. computational expense integer(i4b), allocatable :: totalFluxCalls(:) ! total number of flux calls for each GRU ! local variables: timing information integer*8 :: openMPstart,openMPend ! time for the start of the parallelization section integer*8, allocatable :: timeGRUstart(:) ! time GRUs start - real(rkind), allocatable :: timeGRUcompleted(:) ! time required to complete each GRU - real(rkind), allocatable :: timeGRU(:) ! time spent on each GRU + real(rkind), allocatable :: timeGRUcompleted(:) ! time required to complete each GRU + real(rkind), allocatable :: timeGRU(:) ! time spent on each GRU ! --------------------------------------------------------------------------------------- ! associate to elements in the data structure summaVars: associate(& @@ -105,7 +109,6 @@ subroutine summa_runPhysics(modelTimeStep, summa1_struc, err, message) bvarStruct => summa1_struc%bvarStruct , & ! x%gru(:)%var(:)%dat -- basin-average variables ! run time variables - greenVegFrac_monthly => summa1_struc%greenVegFrac_monthly, & ! fraction of green vegetation in each month (0-1) computeVegFlux => summa1_struc%computeVegFlux , & ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) dt_init => summa1_struc%dt_init , & ! used to initialize the length of the sub-step for each HRU nGRU => summa1_struc%nGRU & ! number of grouped response units @@ -118,8 +121,7 @@ subroutine summa_runPhysics(modelTimeStep, summa1_struc, err, message) ! ******************************************************************************************* ! *** initialize computeVegFlux (flag to indicate if we are computing fluxes over vegetation) ! ******************************************************************************************* - - ! if computeVegFlux changes, then the number of state variables changes, and we need to reoranize the data structures + ! if computeVegFlux changes, then the number of state variables changes, and we need to reorganize the data structures if(modelTimeStep==1)then do iGRU=1,nGRU do iHRU=1,gru_struc(iGRU)%hruCount @@ -127,27 +129,28 @@ subroutine summa_runPhysics(modelTimeStep, summa1_struc, err, message) ! get vegetation phenology ! (compute the exposed LAI and SAI and whether veg is buried by snow) call vegPhenlgy(& - ! input/output: data structures - model_decisions, & ! intent(in): model decisions - typeStruct%gru(iGRU)%hru(iHRU), & ! intent(in): type of vegetation and soil - attrStruct%gru(iGRU)%hru(iHRU), & ! intent(in): spatial attributes - mparStruct%gru(iGRU)%hru(iHRU), & ! intent(in): model parameters - progStruct%gru(iGRU)%hru(iHRU), & ! intent(in): model prognostic variables for a local HRU - diagStruct%gru(iGRU)%hru(iHRU), & ! intent(inout): model diagnostic variables for a local HRU + ! model control + gru_struc(iGRU)%hruInfo(iHRU)%nSnow, & ! intent(in): number of snow layers in the HRU + model_decisions, & ! intent(in): model decisions + fracJulDay, & ! intent(in): fractional julian days since the start of year + yearLength, & ! intent(in): number of days in the current year + ! input/output: data structures + typeStruct%gru(iGRU)%hru(iHRU), & ! intent(in): type of vegetation and soil + attrStruct%gru(iGRU)%hru(iHRU), & ! intent(in): spatial attributes + mparStruct%gru(iGRU)%hru(iHRU), & ! intent(in): model parameters + progStruct%gru(iGRU)%hru(iHRU), & ! intent(inout): model prognostic variables for a local HRU + diagStruct%gru(iGRU)%hru(iHRU), & ! intent(inout): model diagnostic variables for a local HRU ! output - computeVegFluxFlag, & ! intent(out): flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) - notUsed_canopyDepth, & ! intent(out): NOT USED: canopy depth (m) - notUsed_exposedVAI, & ! intent(out): NOT USED: exposed vegetation area index (m2 m-2) - err,cmessage) ! intent(out): error control + computeVegFluxFlag, & ! intent(out): flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) + notUsed_canopyDepth, & ! intent(out): NOT USED: canopy depth (m) + notUsed_exposedVAI, & ! intent(out): NOT USED: exposed vegetation area index (m2 m-2) + err,cmessage) ! intent(out): error control if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! save the flag for computing the vegetation fluxes if(computeVegFluxFlag) computeVegFlux%gru(iGRU)%hru(iHRU) = yes if(.not.computeVegFluxFlag) computeVegFlux%gru(iGRU)%hru(iHRU) = no - ! define the green vegetation fraction of the grid box (used to compute LAI) - diagStruct%gru(iGRU)%hru(iHRU)%var(iLookDIAG%scalarGreenVegFraction)%dat(1) = greenVegFrac_monthly(timeStruct%var(iLookTIME%im)) - end do ! looping through HRUs end do ! looping through GRUs end if ! if the first time step @@ -219,8 +222,10 @@ subroutine summa_runPhysics(modelTimeStep, summa1_struc, err, message) bparStruct => summa1_struc%bparStruct , & ! x%gru(:)%var(:) -- basin-average parameters bvarStruct => summa1_struc%bvarStruct , & ! x%gru(:)%var(:)%dat -- basin-average variables + ! lookup table structure + lookupStruct => summa1_struc%lookupStruct , & ! x%gru(:)%hru(:)%z(:)%var(:)%lookup -- lookup-tables + ! run time variables - greenVegFrac_monthly => summa1_struc%greenVegFrac_monthly, & ! fraction of green vegetation in each month (0-1) computeVegFlux => summa1_struc%computeVegFlux , & ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) dt_init => summa1_struc%dt_init , & ! used to initialize the length of the sub-step for each HRU nGRU => summa1_struc%nGRU & ! number of grouped response units @@ -250,6 +255,7 @@ subroutine summa_runPhysics(modelTimeStep, summa1_struc, err, message) typeStruct%gru(iGRU), & ! intent(in): local classification of soil veg etc. for each HRU idStruct%gru(iGRU), & ! intent(in): local classification of soil veg etc. for each HRU attrStruct%gru(iGRU), & ! intent(in): local attributes for each HRU + lookupStruct%gru(iGRU), & ! intent(in): local lookup tables for each HRU ! data structures (input-output) mparStruct%gru(iGRU), & ! intent(inout): local model parameters indxStruct%gru(iGRU), & ! intent(inout): model indices diff --git a/build/source/driver/summa_restart.f90 b/build/source/driver/summa_restart.f90 old mode 100755 new mode 100644 index 1bef46d47..b5fdd5db9 --- a/build/source/driver/summa_restart.f90 +++ b/build/source/driver/summa_restart.f90 @@ -23,7 +23,7 @@ module summa_restart ! access missing values USE globalData,only:integerMissing ! missing integer -USE globalData,only:realMissing ! missing double precision number +USE globalData,only:realMissing ! missing real number ! named variables USE var_lookup,only:iLookPROG ! look-up values for local column model prognostic (state) variables @@ -66,8 +66,17 @@ subroutine summa_readRestart(summa1_struc, err, message) USE globalData,only:elapsedRestart ! elapsed time to read model restart files ! model decisions USE mDecisions_module,only:& ! look-up values for the choice of method for the spatial representation of groundwater - localColumn, & ! separate groundwater representation in each local soil column - singleBasin ! single groundwater store over the entire basin + localColumn, & ! separate groundwater representation in each local soil column + singleBasin ! single groundwater store over the entire basin + ! look-up values for the choice of variable in energy equations (BE residual or IDA state variable) + USE mDecisions_module,only:& + closedForm, & ! use temperature with closed form heat capacity + enthalpyFormLU, & ! use enthalpy with soil temperature-enthalpy lookup tables + enthalpyForm ! use enthalpy with soil temperature-enthalpy analytical solution +! look-up values for the choice of full or empty aquifer at start + USE mDecisions_module,only:& + fullStart, & ! start with full aquifer + emptyStart ! start with empty aquifer ! --------------------------------------------------------------------------------------- ! * variables ! --------------------------------------------------------------------------------------- @@ -80,26 +89,32 @@ subroutine summa_readRestart(summa1_struc, err, message) character(LEN=256) :: cmessage ! error message of downwind routine character(LEN=256) :: restartFile ! restart file name integer(i4b) :: iGRU,iHRU ! looping variables + logical(lgt) :: checkEnthalpy ! flag if checking enthalpy for consistency + logical(lgt) :: no_icond_enth ! flag that enthalpy not in initial conditions + logical(lgt) :: use_lookup ! flag to use the lookup table for soil enthalpy, otherwise use analytical solution + real(rkind) :: aquifer_start ! initial aquifer storage ! --------------------------------------------------------------------------------------- ! associate to elements in the data structure - summaVars: associate(& - + summaVars: associate(& + ! model decisions + ixNrgConserv => model_decisions(iLookDECISIONS%nrgConserv)%iDecision ,& !choice of variable in either energy backward Euler residual or IDA state variable + spatial_gw => model_decisions(iLookDECISIONS%spatial_gw)%iDecision ,& !choice of method for the spatial representation of groundwater + aquiferIni => model_decisions(iLookDECISIONS%aquiferIni)%iDecision ,& !choice of full or empty aquifer at start + ! lookup table data structure + lookupStruct => summa1_struc%lookupStruct , & ! x%gru(:)%hru(:)%z(:)%var(:)%lookup(:) -- lookup tables ! primary data structures (variable length vectors) indxStruct => summa1_struc%indxStruct , & ! x%gru(:)%hru(:)%var(:)%dat -- model indices mparStruct => summa1_struc%mparStruct , & ! x%gru(:)%hru(:)%var(:)%dat -- model parameters progStruct => summa1_struc%progStruct , & ! x%gru(:)%hru(:)%var(:)%dat -- model prognostic (state) variables diagStruct => summa1_struc%diagStruct , & ! x%gru(:)%hru(:)%var(:)%dat -- model diagnostic variables fluxStruct => summa1_struc%fluxStruct , & ! x%gru(:)%hru(:)%var(:)%dat -- model fluxes - ! basin-average structures bparStruct => summa1_struc%bparStruct , & ! x%gru(:)%var(:) -- basin-average parameters bvarStruct => summa1_struc%bvarStruct , & ! x%gru(:)%var(:)%dat -- basin-average variables - ! miscellaneous variables dt_init => summa1_struc%dt_init , & ! used to initialize the length of the sub-step for each HRU nGRU => summa1_struc%nGRU , & ! number of grouped response units nHRU => summa1_struc%nHRU & ! number of global hydrologic response units - ) ! assignment to variables in the data structures ! --------------------------------------------------------------------------------------- @@ -127,14 +142,24 @@ subroutine summa_readRestart(summa1_struc, err, message) progStruct, & ! intent(inout): model prognostic variables bvarStruct, & ! intent(inout): model basin (GRU) variables indxStruct, & ! intent(inout): model indices + no_icond_enth, & ! intent(out): flag that enthalpy not in initial conditions err,cmessage) ! intent(out): error control if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - ! check initial conditions +! check initial conditions + checkEnthalpy = .false. + use_lookup = .false. + if(ixNrgConserv .ne. closedForm) checkEnthalpy = .true. ! check enthalpy either for mixed form energy equation or enthalpy state variable + if(ixNrgConserv==enthalpyFormLU) use_lookup = .true. ! use lookup tables for soil temperature-enthalpy instead of analytical solution call check_icond(nGRU, & ! intent(in): number of response units - progStruct, & ! intent(in): model prognostic (state) variables + progStruct, & ! intent(inout): model prognostic variables + diagStruct, & ! intent(inout): model diagnostic variables mparStruct, & ! intent(in): model parameters indxStruct, & ! intent(in): layer indexes + lookupStruct, & ! intent(in): lookup tables + checkEnthalpy, & ! intent(in): flag if need to start with consistent enthalpy + no_icond_enth, & ! intent(in): flag that enthalpy not in initial conditions + use_lookup, & ! intent(in): flag to use the lookup table for soil enthalpy err,cmessage) ! intent(out): error control if(err/=0)then; message=trim(message)//trim(cmessage); return; endif @@ -192,21 +217,34 @@ subroutine summa_readRestart(summa1_struc, err, message) ! There are two options for groundwater: ! (1) where groundwater is included in the local column (i.e., the HRUs); and ! (2) where groundwater is included for the single basin (i.e., the GRUS, where multiple HRUS drain into a GRU). - ! For water balance calculations it is important to ensure that the local aquifer storage is zero if groundwater is treated as a basin-average state variable (singleBasin); ! and ensure that basin-average aquifer storage is zero when groundwater is included in the local columns (localColumn). + ! select aquifer option + select case(aquiferIni) + case(fullStart) + aquifer_start = 1._rkind ! Start with full aquifer, since easier to spin up by draining than filling (filling we need to wait for precipitation) + case(emptyStart) + aquifer_start = 0._rkind ! Start with empty aquifer ! If want to compare model method outputs, empty start leads to quicker equilibrium + case default + message=trim(message)//'unable to identify decision for initial aquifer storage' + return + end select ! aquifer option + ! select groundwater option - select case(model_decisions(iLookDECISIONS%spatial_gw)%iDecision) + select case(spatial_gw) ! the basin-average aquifer storage is not used if the groundwater is included in the local column case(localColumn) bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferStorage)%dat(1) = 0._rkind ! set to zero to be clear that there is no basin-average aquifer storage in this configuration + do iHRU=1,gru_struc(iGRU)%hruCount + if(aquiferIni==emptyStart) progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarAquiferStorage)%dat(1) = aquifer_start ! leave at initialized values if fullStart + end do ! the local column aquifer storage is not used if the groundwater is basin-average ! (i.e., where multiple HRUs drain to a basin-average aquifer) case(singleBasin) - bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferStorage)%dat(1) = 1._rkind + bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferStorage)%dat(1) = aquifer_start do iHRU=1,gru_struc(iGRU)%hruCount progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarAquiferStorage)%dat(1) = 0._rkind ! set to zero to be clear that there is no local aquifer storage in this configuration end do diff --git a/build/source/driver/summa_setup.f90 b/build/source/driver/summa_setup.f90 old mode 100755 new mode 100644 index e406dfd4b..a4d6593cf --- a/build/source/driver/summa_setup.f90 +++ b/build/source/driver/summa_setup.f90 @@ -22,30 +22,41 @@ module summa_setup ! initializes parameter data structures (e.g. vegetation and soil parameters). ! access missing values -USE globalData,only:integerMissing ! missing integer -USE globalData,only:realMissing ! missing double precision number +USE globalData,only:integerMissing ! missing integer +USE globalData,only:realMissing ! missing real number + +! global data on the forcing file +USE globalData,only:data_step ! length of the data step (s) ! named variables -USE var_lookup,only:iLookATTR ! look-up values for local attributes -USE var_lookup,only:iLookTYPE ! look-up values for classification of veg, soils etc. -USE var_lookup,only:iLookPARAM ! look-up values for local column model parameters -USE var_lookup,only:iLookID ! look-up values for local column model parameters -USE var_lookup,only:iLookBVAR ! look-up values for basin-average model variables -USE var_lookup,only:iLookDECISIONS ! look-up values for model decisions -USE globalData,only:urbanVegCategory ! vegetation category for urban areas +USE var_lookup,only:iLookATTR ! look-up values for local attributes +USE var_lookup,only:iLookTYPE ! look-up values for classification of veg, soils etc. +USE var_lookup,only:iLookPARAM ! look-up values for local column model parameters +USE var_lookup,only:iLookINDEX ! look-up values for local column model indices +USE var_lookup,only:iLookLOOKUP ! look-up values for local column lookup tables +USE var_lookup,only:iLookID ! look-up values for local column model ids +USE var_lookup,only:iLookBVAR ! look-up values for basin-average model variables +USE var_lookup,only:iLookDECISIONS ! look-up values for model decisions +USE globalData,only:urbanVegCategory ! vegetation category for urban areas ! metadata structures -USE globalData,only:mpar_meta,bpar_meta ! parameter metadata structures +USE globalData,only:mpar_meta,bpar_meta ! parameter metadata structures + +! look-up values for the choice of variable in energy equations (BE residual or IDA state variable) +USE mDecisions_module,only:& + closedForm, & ! use temperature with closed form heat capacity + enthalpyFormLU,& ! use enthalpy with soil temperature-enthalpy lookup tables + enthalpyForm ! use enthalpy with soil temperature-enthalpy analytical solution ! named variables to define the decisions for snow layers USE mDecisions_module,only:& - sameRulesAllLayers, & ! SNTHERM option: same combination/sub-dividion rules applied to all layers - rulesDependLayerIndex ! CLM option: combination/sub-dividion rules depend on layer index + sameRulesAllLayers,& ! SNTHERM option: same combination/sub-dividion rules applied to all layers + rulesDependLayerIndex ! CLM option: combination/sub-dividion rules depend on layer index ! named variables to define LAI decisions USE mDecisions_module,only:& - monthlyTable,& ! LAI/SAI taken directly from a monthly table for different vegetation classes - specified ! LAI/SAI computed from green vegetation fraction and winterSAI and summerLAI parameters + monthlyTable,& ! LAI/SAI taken directly from a monthly table for different vegetation classes + specified ! LAI/SAI computed from green vegetation fraction and winterSAI and summerLAI parameters ! safety: set private unless specified otherwise implicit none @@ -69,7 +80,8 @@ subroutine summa_paramSetup(summa1_struc, err, message) USE paramCheck_module,only:paramCheck ! module to check consistency of model parameters USE pOverwrite_module,only:pOverwrite ! module to overwrite default parameter values with info from the Noah tables USE read_param_module,only:read_param ! module to read model parameter sets - USE ConvE2Temp_module,only:E2T_lookup ! module to calculate a look-up table for the temperature-enthalpy conversion + USE enthalpyTemp_module,only:T2H_lookup_snWat ! module to calculate a look-up table for the snow temperature-enthalpy conversion + USE enthalpyTemp_module,only:T2L_lookup_soil ! module to calculate a look-up table for the soil temperature-enthalpy conversion USE var_derive_module,only:fracFuture ! module to calculate the fraction of runoff in future time steps (time delay histogram) USE module_sf_noahmplsm,only:read_mp_veg_parameters ! module to read NOAH vegetation tables ! global data structures @@ -110,6 +122,8 @@ subroutine summa_paramSetup(summa1_struc, err, message) integer(i4b) :: jHRU,kHRU ! HRU indices integer(i4b) :: iGRU,iHRU ! looping variables integer(i4b) :: iVar ! looping variables + real(rkind) :: absEnergyFac ! multiplier for absolute value of energy state variable (for enthalpy or temperature) + logical :: needLookup_soil ! logical to decide if computing soil enthalpy lookup tables ! --------------------------------------------------------------------------------------- ! associate to elements in the data structure summaVars: associate(& @@ -127,6 +141,9 @@ subroutine summa_paramSetup(summa1_struc, err, message) bparStruct => summa1_struc%bparStruct , & ! x%gru(:)%var(:) -- basin-average parameters bvarStruct => summa1_struc%bvarStruct , & ! x%gru(:)%var(:)%dat -- basin-average variables + ! lookup table structure + lookupStruct => summa1_struc%lookupStruct , & ! x%gru(:)%hru(:)%z(:)%var(:)%lookup -- lookup-tables + ! miscellaneous variables upArea => summa1_struc%upArea , & ! area upslope of each HRU nGRU => summa1_struc%nGRU , & ! number of grouped response units @@ -136,15 +153,22 @@ subroutine summa_paramSetup(summa1_struc, err, message) ! --------------------------------------------------------------------------------------- ! initialize error control err=0; message='summa_paramSetup/' - + ! initialize the start of the initialization call date_and_time(values=startSetup) +#ifdef NGEN_FORCING_ACTIVE + ! ***************************************************************************** + ! if using NGEN forcing only need to set the hourly data_step (fixed) + ! ***************************************************************************** + data_step = 3600._rkind +#else ! ***************************************************************************** ! *** read description of model forcing datafile used in each HRU ! ***************************************************************************** call ffile_info(nGRU,err,cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return; endif +#endif ! ***************************************************************************** ! *** read model decisions @@ -153,6 +177,12 @@ subroutine summa_paramSetup(summa1_struc, err, message) call mDecisions(err,cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + ! decide if computing soil enthalpy lookup tables and vegetation enthalpy lookup tables + needLookup_soil = .false. + ! if need enthalpy for either energy backward Euler residual or IDA state variable and not using soil enthalpy hypergeometric function + if(model_decisions(iLookDECISIONS%nrgConserv)%iDecision == enthalpyFormLU) needLookup_soil = .true. + ! if using IDA and enthalpy as a state variable, need temperature-enthalpy lookup tables for soil and vegetation + ! get the maximum number of snow layers select case(model_decisions(iLookDECISIONS%snowLayers)%iDecision) case(sameRulesAllLayers); maxSnowLayers = 100 @@ -179,11 +209,19 @@ subroutine summa_paramSetup(summa1_struc, err, message) ! ***************************************************************************** ! read default values and constraints for model parameters (local column) - call read_pinit(LOCALPARAM_INFO,.TRUE., mpar_meta,localParFallback,err,cmessage) + select case(model_decisions(iLookDECISIONS%nrgConserv)%iDecision) + case(closedForm) ! ida temperature state variable + absEnergyFac = 1.e2_rkind ! energy state variable is 2 orders of magnitude larger than mass state variable + case(enthalpyFormLU,enthalpyForm) ! ida enthalpy state variable + absEnergyFac = 1.e7_rkind ! energy state variable is 7 orders of magnitude larger than mass state variable + case default; err=20; message=trim(message)//'unable to identify option for energy conservation'; return + end select ! (option for energy conservation) + + call read_pinit(LOCALPARAM_INFO,.TRUE., absEnergyFac,mpar_meta,localParFallback,err,cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! read default values and constraints for model parameters (basin-average) - call read_pinit(BASINPARAM_INFO,.FALSE.,bpar_meta,basinParFallback,err,cmessage) + call read_pinit(BASINPARAM_INFO,.FALSE.,absEnergyFac, bpar_meta,basinParFallback,err,cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! ***************************************************************************** @@ -220,12 +258,13 @@ subroutine summa_paramSetup(summa1_struc, err, message) do iGRU=1,nGRU do iHRU=1,gru_struc(iGRU)%hruCount - ! set parmameters to their default value + ! set parameters to their default value dparStruct%gru(iGRU)%hru(iHRU)%var(:) = localParFallback(:)%default_val ! x%hru(:)%var(:) ! overwrite default model parameters with information from the Noah-MP tables call pOverwrite(typeStruct%gru(iGRU)%hru(iHRU)%var(iLookTYPE%vegTypeIndex), & ! vegetation category typeStruct%gru(iGRU)%hru(iHRU)%var(iLookTYPE%soilTypeIndex), & ! soil category + trim(model_decisions(iLookDECISIONS%soilCatTbl)%cDecision), & ! classification system used for soils dparStruct%gru(iGRU)%hru(iHRU)%var, & ! default model parameters err,cmessage) ! error control if(err/=0)then; message=trim(message)//trim(cmessage); return; endif @@ -280,10 +319,23 @@ subroutine summa_paramSetup(summa1_struc, err, message) call paramCheck(mparStruct%gru(iGRU)%hru(iHRU),err,cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - ! calculate a look-up table for the temperature-enthalpy conversion - call E2T_lookup(mparStruct%gru(iGRU)%hru(iHRU),err,cmessage) + ! calculate a look-up table for the temperature-enthalpy conversion of snow for future snow layer merging + ! NOTE1: might be able to make this more efficient by only doing this for the HRUs that have snow + ! NOTE2: H is the mixture enthalpy of snow liquid and ice + call T2H_lookup_snWat(mparStruct%gru(iGRU)%hru(iHRU),err,cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + ! calculate a lookup table for the temperature-enthalpy conversion of soil + ! NOTE: L is the integral of soil Clapeyron equation liquid water matric potential from temperature + ! multiply by Cp_liq*iden_water to get temperature component of enthalpy + if(needLookup_soil)then + call T2L_lookup_soil(gru_struc(iGRU)%hruInfo(iHRU)%nSoil, & ! intent(in): number of soil layers + mparStruct%gru(iGRU)%hru(iHRU), & ! intent(in): parameter data structure + lookupStruct%gru(iGRU)%hru(iHRU), & ! intent(inout): lookup table data structure + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + endif + ! overwrite the vegetation height HVT(typeStruct%gru(iGRU)%hru(iHRU)%var(iLookTYPE%vegTypeIndex)) = mparStruct%gru(iGRU)%hru(iHRU)%var(iLookPARAM%heightCanopyTop)%dat(1) HVB(typeStruct%gru(iGRU)%hru(iHRU)%var(iLookTYPE%vegTypeIndex)) = mparStruct%gru(iGRU)%hru(iHRU)%var(iLookPARAM%heightCanopyBottom)%dat(1) @@ -329,14 +381,6 @@ subroutine summa_paramSetup(summa1_struc, err, message) end subroutine summa_paramSetup - - ! ================================================================================================= - ! ================================================================================================= - ! ================================================================================================= - ! ================================================================================================= - ! ================================================================================================= - ! ================================================================================================= - ! ************************************************************************************************** ! private subroutine SOIL_VEG_GEN_PARM: Read soil, vegetation and other model parameters (from NOAH) ! ************************************************************************************************** @@ -435,7 +479,7 @@ SUBROUTINE SOIL_VEG_GEN_PARM(FILENAME_VEGTABLE, FILENAME_SOILTABLE, FILENAME_GEN SIZE(ALBEDOMAXTBL) < LUCATS .OR. & SIZE(EMISSMINTBL ) < LUCATS .OR. & SIZE(EMISSMAXTBL ) < LUCATS ) THEN - CALL wrf_error_fatal('Table sizes too small for value of LUCATS in module_sf_noahdrv.F') + CALL wrf_error_fatal('Table sizes too small for value of LUCATS in module_sf_noahdrv.F, expand NLUS and MVT parameters to size of vegetation table and recompile') ENDIF IF(LUTYPE.EQ.MMINLU)THEN @@ -526,7 +570,7 @@ SUBROUTINE SOIL_VEG_GEN_PARM(FILENAME_VEGTABLE, FILENAME_SOILTABLE, FILENAME_GEN case('ROSETTA') ! new soil table DO LC=1,SLCATS READ (19,*) IINDEX,& - ! new soil parameters (from Rosetta) + ! new soil parameters (from Rosetta only) theta_res(LC), theta_sat(LC), & vGn_alpha(LC), vGn_n(LC), k_soil(LC), & ! original soil parameters diff --git a/build/source/driver/summa_type.f90 b/build/source/driver/summa_type.f90 old mode 100755 new mode 100644 index 3cc715e7f..e1473642b --- a/build/source/driver/summa_type.f90 +++ b/build/source/driver/summa_type.f90 @@ -42,18 +42,22 @@ MODULE summa_type gru_doubleVec, & ! x%gru(:)%var(:)%dat (dp) ! gru+hru dimension gru_hru_int, & ! x%gru(:)%hru(:)%var(:) (i4b) - gru_hru_int8, & ! x%gru(:)%hru(:)%var(:) (i8b) + gru_hru_int8, & ! x%gru(:)%hru(:)%var(:) (i8b) gru_hru_double, & ! x%gru(:)%hru(:)%var(:) (dp) gru_hru_intVec, & ! x%gru(:)%hru(:)%var(:)%dat (i4b) - gru_hru_doubleVec ! x%gru(:)%hru(:)%var(:)%dat (dp) + gru_hru_doubleVec, & ! x%gru(:)%hru(:)%var(:)%dat (dp) + ! gru+hru+z dimension + gru_hru_z_vLookup ! x%gru(:)%hru(:)%z(:)%var(:)%lookup(:) (dp) implicit none private ! ************************************************************************ ! * master summa data type ! ***************************************************************************** -type, public :: summa1_type_dec - +type, public :: summa1_type_dec + ! define the lookup tables + type(gru_hru_z_vLookup) :: lookupStruct ! x%gru(:)%hru(:)%z(:)%var(:)%lookup(:) -- lookup tables + ! define the statistics structures type(gru_hru_doubleVec) :: forcStat ! x%gru(:)%hru(:)%var(:)%dat -- model forcing data type(gru_hru_doubleVec) :: progStat ! x%gru(:)%hru(:)%var(:)%dat -- model prognostic (state) variables @@ -89,13 +93,8 @@ MODULE summa_type type(gru_d) :: upArea ! area upslope of each HRU ! define miscellaneous variables - integer(i4b) :: summa1open ! flag to define if the summa file is open?? - integer(i4b) :: numout ! number of output variables?? - real(rkind) :: ts ! model time step ?? integer(i4b) :: nGRU ! number of grouped response units integer(i4b) :: nHRU ! number of global hydrologic response units - integer(i4b) :: hruCount ! number of local hydrologic response units - real(rkind),dimension(12) :: greenVegFrac_monthly ! fraction of green vegetation in each month (0-1) character(len=256) :: summaFileManagerFile ! path/name of file defining directories and files end type summa1_type_dec diff --git a/build/source/driver/summa_util.f90 b/build/source/driver/summa_util.f90 old mode 100755 new mode 100644 index f310e3997..c8dd55fd7 --- a/build/source/driver/summa_util.f90 +++ b/build/source/driver/summa_util.f90 @@ -84,6 +84,15 @@ subroutine getCommandArguments(summa1_struc,err,message) ! initialize error control err=0; message='getCommandArguments/' +#ifdef NGEN_ACTIVE + ! no command arguments with NGen + nArgument = 0 + checkHRU = integerMissing + nGRU = 1; nHRU = integerMissing + newOutputFile = noNewFiles + ixProgress = ixProgress_never ! NGen prints own progress + iRunMode = iRunModeGRU +#else ! check number of command-line arguments nArgument = command_argument_count() if (nArgument < 1) then @@ -263,6 +272,7 @@ subroutine getCommandArguments(summa1_struc,err,message) ! set startGRU for full run if (iRunMode==iRunModeFull) startGRU=1 +#endif ! end associate statements end associate summaVars @@ -350,14 +360,14 @@ subroutine stop_program(err,message) integer(i4b) :: endModelRun(8) ! final time integer(i4b) :: localErr ! local error code integer(i4b) :: iFreq ! loop through output frequencies - real(rkind) :: elpSec ! elapsed seconds + real(rkind) :: elpSec ! elapsed seconds ! close any remaining output files ! NOTE: use the direct NetCDF call with no error checking since the file may already be closed do iFreq = 1,size(ncid) if (ncid(iFreq)/=integerMissing) localErr = nf90_close(ncid(iFreq)) end do - +#ifndef NGEN_ACTIVE ! get the final date and time call date_and_time(values=endModelRun) elpSec = elapsedSec(startInit,endModelRun) @@ -398,7 +408,7 @@ subroutine stop_program(err,message) ! print the number of threads write(outunit,"(A,i10,/)") ' number threads = ', nThreads - +#endif ! stop with message if(err==0)then print*,'FORTRAN STOP: '//trim(message) diff --git a/build/source/driver/summa_writeOutput.f90 b/build/source/driver/summa_writeOutput.f90 old mode 100755 new mode 100644 index 32ef3d466..aa333eb45 --- a/build/source/driver/summa_writeOutput.f90 +++ b/build/source/driver/summa_writeOutput.f90 @@ -56,7 +56,7 @@ module summa_writeOutput USE var_lookup,only:iLookDIAG ! named variables for local column model diagnostic variables USE var_lookup,only:iLookPROG ! named variables for local column model prognostic variables USE var_lookup,only:iLookINDEX ! named variables for local column index variables -USE var_lookup,only:iLookFreq ! named variables for the frequency structure +USE var_lookup,only:iLookFREQ ! named variables for the frequency structure ! safety: set private unless specified otherwise implicit none @@ -155,7 +155,7 @@ subroutine summa_writeOutputFiles(modelTimeStep, summa1_struc, err, message) ) ! assignment to variables in the data structures ! --------------------------------------------------------------------------------------- ! initialize error control - err=0; message='summa_manageOutputFiles/' + err=0; message='summa_writeOutputFiles/' ! identify the start of the writing call date_and_time(values=startWrite) @@ -176,7 +176,7 @@ subroutine summa_writeOutputFiles(modelTimeStep, summa1_struc, err, message) finalizeStats(:) = .false. ! do not finalize stats on the first time step ! set stats flag for the timestep-level output - finalizeStats(iLookFreq%timestep)=.true. + finalizeStats(iLookFREQ%timestep)=.true. ! initialize number of hru and gru in global data nGRUrun = nGRU @@ -211,7 +211,7 @@ subroutine summa_writeOutputFiles(modelTimeStep, summa1_struc, err, message) call summa_defineOutputFiles(modelTimeStep, summa1_struc, err, cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - ! re-initalize the indices for model writing + ! re-initialize the indices for model writing outputTimeStep(:)=1 end if ! if defining a new file diff --git a/build/source/dshare/data_types.f90 b/build/source/dshare/data_types.f90 old mode 100755 new mode 100644 index 8785af5d3..df9a6f9ac --- a/build/source/dshare/data_types.f90 +++ b/build/source/dshare/data_types.f90 @@ -23,6 +23,14 @@ MODULE data_types USE nrtype, integerMissing=>nr_integerMissing USE var_lookup,only:maxvarFreq USE var_lookup,only:maxvarStat + USE var_lookup,only:maxvarDecisions ! maximum number of decisions + USE var_lookup,only:iLookPARAM ! lookup indices for model parameters + USE var_lookup,only:iLookFLUX ! lookup indices for flux data + USE var_lookup,only:iLookDERIV ! lookup indices for derivative data + USE var_lookup,only:iLookFORCE ! lookup indices for forcing data + USE var_lookup,only:iLookDIAG ! lookup indices for diagnostic variable data + USE var_lookup,only:iLookDECISIONS ! lookup indices for elements of the decision structure + USE var_lookup,only:iLookPROG ! lookup indices for prognostic variables implicit none ! constants necessary for variable defs private @@ -42,14 +50,14 @@ MODULE data_types ! *********************************************************************************************************** ! define a derived type for the data in the file type,public :: file_info - character(len=256) :: filenmData='notPopulatedYet' ! name of data file - integer(i4b) :: nVars ! number of variables in the file - integer(i4b) :: nTimeSteps ! number of variables in the file - integer(i4b),allocatable :: var_ix(:) ! index of each forcing data variable in the data structure - integer(i4b),allocatable :: data_id(:) ! netcdf variable id for each forcing data variable - character(len=256),allocatable :: varName(:) ! netcdf variable name for each forcing data variable - real(rkind) :: firstJulDay ! first julian day in forcing file - real(rkind) :: convTime2Days ! factor to convert time to days + character(len=256) :: filenmData='notPopulatedYet' ! name of data file + integer(i4b) :: nVars ! number of variables in the file + integer(i4b) :: nTimeSteps ! number of variables in the file + integer(i4b),allocatable :: var_ix(:) ! index of each forcing data variable in the data structure + integer(i4b),allocatable :: data_id(:) ! netcdf variable id for each forcing data variable + character(len=256),allocatable :: varName(:) ! netcdf variable name for each forcing data variable + real(rkind) :: firstJulDay ! first julian day in forcing file + real(rkind) :: convTime2Days ! factor to convert time to days end type file_info ! *********************************************************************************************************** @@ -57,9 +65,9 @@ MODULE data_types ! *********************************************************************************************************** ! define a data type to store model parameter information type,public :: par_info - real(rkind) :: default_val ! default parameter value - real(rkind) :: lower_limit ! lower bound - real(rkind) :: upper_limit ! upper bound + real(rkind) :: default_val ! default parameter value + real(rkind) :: lower_limit ! lower bound + real(rkind) :: upper_limit ! upper bound endtype par_info ! *********************************************************************************************************** @@ -67,24 +75,24 @@ MODULE data_types ! *********************************************************************************************************** ! define derived type for model variables, including name, description, and units type,public :: var_info - character(len=64) :: varname = 'empty' ! variable name - character(len=128) :: vardesc = 'empty' ! variable description - character(len=64) :: varunit = 'empty' ! variable units - integer(i4b) :: vartype = integerMissing ! variable type - integer(i4b),dimension(maxvarFreq) :: ncVarID = integerMissing ! netcdf variable id (missing if frequency is not desired) - integer(i4b),dimension(maxvarFreq) :: statIndex = integerMissing ! index of desired statistic for temporal aggregation - logical(lgt) :: varDesire = .false. ! flag to denote if the variable is desired for model output + character(len=64) :: varname = 'empty' ! variable name + character(len=128) :: vardesc = 'empty' ! variable description + character(len=64) :: varunit = 'empty' ! variable units + integer(i4b) :: vartype = integerMissing ! variable type + integer(i4b),dimension(maxvarFreq) :: ncVarID = integerMissing ! netcdf variable id (missing if frequency is not desired) + integer(i4b),dimension(maxvarFreq) :: statIndex = integerMissing ! index of desired statistic for temporal aggregation + logical(lgt) :: varDesire = .false. ! flag to denote if the variable is desired for model output endtype var_info ! define extended data type (include indices to map onto parent data type) type,extends(var_info),public :: extended_info - integer(i4b) :: ixParent ! index in the parent data structure + integer(i4b) :: ixParent ! index in the parent data structure endtype extended_info ! define extended data type (includes named variables for the states affected by each flux) type,extends(var_info),public :: flux2state - integer(i4b) :: state1 ! named variable of the 1st state affected by the flux - integer(i4b) :: state2 ! named variable of the 2nd state affected by the flux + integer(i4b) :: state1 ! named variable of the 1st state affected by the flux + integer(i4b) :: state2 ! named variable of the 2nd state affected by the flux endtype flux2state ! *********************************************************************************************************** @@ -92,9 +100,9 @@ MODULE data_types ! *********************************************************************************************************** ! data structure information type,public :: struct_info - character(len=32) :: structName ! name of the data structure - character(len=32) :: lookName ! name of the look-up variables - integer(i4b) :: nVar ! number of variables in each data structure + character(len=32) :: structName ! name of the data structure + character(len=32) :: lookName ! name of the look-up variables + integer(i4b) :: nVar ! number of variables in each data structure end type struct_info ! *********************************************************************************************************** @@ -103,47 +111,68 @@ MODULE data_types ! hru info data structure type, public :: hru_info - integer(i4b) :: hru_nc ! index of the hru in the netcdf file - integer(i4b) :: hru_ix ! index of the hru in the run domain - integer(8) :: hru_id ! id (non-sequential number) of the hru - integer(i4b) :: nSnow ! number of snow layers - integer(i4b) :: nSoil ! number of soil layers + integer(i4b) :: hru_nc ! index of the hru in the netcdf file + integer(i4b) :: hru_ix ! index of the hru in the run domain + integer(i8b) :: hru_id ! id (non-sequential number) of the hru + integer(i4b) :: nSnow ! number of snow layers + integer(i4b) :: nSoil ! number of soil layers endtype hru_info ! define mapping from GRUs to the HRUs type, public :: gru2hru_map - integer(8) :: gru_id ! id of the gru - integer(i4b) :: hruCount ! total number of hrus in the gru - type(hru_info), allocatable :: hruInfo(:) ! basic information of HRUs within the gru - integer(i4b) :: gru_nc ! index of gru in the netcdf file + integer(i8b) :: gru_id ! id of the gru + integer(i4b) :: hruCount ! total number of hrus in the gru + type(hru_info), allocatable :: hruInfo(:) ! basic information of HRUs within the gru + integer(i4b) :: gru_nc ! index of gru in the netcdf file endtype gru2hru_map ! define the mapping from the HRUs to the GRUs type, public :: hru2gru_map - integer(i4b) :: gru_ix ! index of gru which the hru belongs to - integer(i4b) :: localHRU_ix ! index of a hru within a gru (start from 1 per gru) + integer(i4b) :: gru_ix ! index of gru which the hru belongs to + integer(i4b) :: localHRU_ix ! index of a hru within a gru (start from 1 per gru) endtype hru2gru_map ! *********************************************************************************************************** ! Define hierarchal derived data types ! *********************************************************************************************************** + ! define derived types to hold look-up tables for each soil layer + ! ** double precision type + type, public :: dLookup + real(rkind),allocatable :: lookup(:) ! lookup(:) + endtype dLookup + ! ** double precision type for a variable number of soil layers; variable length + type, public :: vLookup + type(dLookup),allocatable :: var(:) ! var(:)%lookup(:) + endtype vLookup + ! ** double precision type for a variable number of soil layers + type, public :: zLookup + type(vLookup),allocatable :: z(:) ! z(:)%var(:)%lookup(:) + endtype zLookup + ! ** double precision type for a variable number of soil layers + type, public :: hru_z_vLookup + type(zLookup),allocatable :: hru(:) ! hru(:)%z(:)%var(:)%lookup(:) + endtype hru_z_vLookup + ! ** double precision type for a variable number of soil layers + type, public :: gru_hru_z_vLookup + type(hru_z_vLookup),allocatable :: gru(:) ! gru(:)%hru(:)%z(:)%var(:)%lookup(:) + endtype gru_hru_z_vLookup ! define derived types to hold multivariate data for a single variable (different variables have different length) ! NOTE: use derived types here to facilitate adding the "variable" dimension ! ** double precision type type, public :: dlength - real(rkind),allocatable :: dat(:) ! dat(:) + real(rkind),allocatable :: dat(:) ! dat(:) endtype dlength ! ** integer type (4 byte) type, public :: ilength - integer(i4b),allocatable :: dat(:) ! dat(:) + integer(i4b),allocatable :: dat(:) ! dat(:) endtype ilength ! ** integer type (8 byte) type, public :: i8length - integer(8),allocatable :: dat(:) ! dat(:) + integer(i8b),allocatable :: dat(:) ! dat(:) endtype i8length ! ** logical type type, public :: flagVec - logical(lgt),allocatable :: dat(:) ! dat(:) + logical(lgt),allocatable :: dat(:) ! dat(:) endtype flagVec ! define derived types to hold data for multiple variables @@ -151,132 +180,2201 @@ MODULE data_types ! ** double precision type of variable length type, public :: var_dlength - type(dlength),allocatable :: var(:) ! var(:)%dat + type(dlength),allocatable :: var(:) ! var(:)%dat endtype var_dlength ! ** integer type of variable length (4 byte) type, public :: var_ilength - type(ilength),allocatable :: var(:) ! var(:)%dat + type(ilength),allocatable :: var(:) ! var(:)%dat endtype var_ilength ! ** integer type of variable length (8 byte) type, public :: var_i8length - type(i8length),allocatable :: var(:) ! var(:)%dat + type(i8length),allocatable :: var(:) ! var(:)%dat endtype var_i8length ! ** logical type of variable length type, public :: var_flagVec - type(flagVec),allocatable :: var(:) ! var(:)%dat + type(flagVec),allocatable :: var(:) ! var(:)%dat endtype var_flagVec ! ** double precision type of fixed length type, public :: var_d - real(rkind),allocatable :: var(:) ! var(:) + real(rkind),allocatable :: var(:) ! var(:) endtype var_d ! ** integer type of fixed length (4 byte) type, public :: var_i - integer(i4b),allocatable :: var(:) ! var(:) + integer(i4b),allocatable :: var(:) ! var(:) endtype var_i ! ** integer type of fixed length (8 byte) type, public :: var_i8 - integer(8),allocatable :: var(:) ! var(:) + integer(i8b),allocatable :: var(:) ! var(:) endtype var_i8 ! ** double precision type of fixed length type, public :: hru_d - real(rkind),allocatable :: hru(:) ! hru(:) + real(rkind),allocatable :: hru(:) ! hru(:) endtype hru_d ! ** integer type of fixed length (4 byte) type, public :: hru_i - integer(i4b),allocatable :: hru(:) ! hru(:) + integer(i4b),allocatable :: hru(:) ! hru(:) endtype hru_i ! ** integer type of fixed length (8 byte) type, public :: hru_i8 - integer(8),allocatable :: hru(:) ! hru(:) + integer(i8b),allocatable :: hru(:) ! hru(:) endtype hru_i8 ! define derived types to hold JUST the HRU dimension ! ** double precision type of variable length type, public :: hru_doubleVec - type(var_dlength),allocatable :: hru(:) ! hru(:)%var(:)%dat + type(var_dlength),allocatable :: hru(:) ! hru(:)%var(:)%dat endtype hru_doubleVec ! ** integer type of variable length (4 byte) type, public :: hru_intVec - type(var_ilength),allocatable :: hru(:) ! hru(:)%var(:)%dat + type(var_ilength),allocatable :: hru(:) ! hru(:)%var(:)%dat endtype hru_intVec ! ** integer type of variable length (8 byte) type, public :: hru_int8Vec - type(var_i8length),allocatable :: hru(:) ! hru(:)%var(:)%dat + type(var_i8length),allocatable :: hru(:) ! hru(:)%var(:)%dat endtype hru_int8Vec ! ** double precision type of fixed length type, public :: hru_double - type(var_d),allocatable :: hru(:) ! hru(:)%var(:) + type(var_d),allocatable :: hru(:) ! hru(:)%var(:) endtype hru_double ! ** integer type of fixed length (4 byte) type, public :: hru_int - type(var_i),allocatable :: hru(:) ! hru(:)%var(:) + type(var_i),allocatable :: hru(:) ! hru(:)%var(:) endtype hru_int ! ** integer type of fixed length (8 byte) type, public :: hru_int8 - type(var_i8),allocatable :: hru(:) ! hru(:)%var(:) + type(var_i8),allocatable :: hru(:) ! hru(:)%var(:) endtype hru_int8 ! define derived types to hold JUST the HRU dimension ! ** double precision type of variable length type, public :: gru_doubleVec - type(var_dlength),allocatable :: gru(:) ! gru(:)%var(:)%dat + type(var_dlength),allocatable :: gru(:) ! gru(:)%var(:)%dat endtype gru_doubleVec ! ** integer type of variable length (4 byte) type, public :: gru_intVec - type(var_ilength),allocatable :: gru(:) ! gru(:)%var(:)%dat + type(var_ilength),allocatable :: gru(:) ! gru(:)%var(:)%dat endtype gru_intVec ! ** integer type of variable length (8 byte) type, public :: gru_int8Vec - type(var_i8length),allocatable :: gru(:) ! gru(:)%var(:)%dat + type(var_i8length),allocatable :: gru(:) ! gru(:)%var(:)%dat endtype gru_int8Vec ! ** double precision type of fixed length type, public :: gru_double - type(var_d),allocatable :: gru(:) ! gru(:)%var(:) + type(var_d),allocatable :: gru(:) ! gru(:)%var(:) endtype gru_double ! ** integer type of variable length (4 byte) type, public :: gru_int - type(var_i),allocatable :: gru(:) ! gru(:)%var(:) + type(var_i),allocatable :: gru(:) ! gru(:)%var(:) endtype gru_int ! ** integer type of variable length (8 byte) type, public :: gru_int8 - type(var_i8),allocatable :: gru(:) ! gru(:)%var(:) + type(var_i8),allocatable :: gru(:) ! gru(:)%var(:) endtype gru_int8 ! define derived types to hold BOTH the GRU and HRU dimension ! ** double precision type of variable length type, public :: gru_hru_doubleVec - type(hru_doubleVec),allocatable :: gru(:) ! gru(:)%hru(:)%var(:)%dat + type(hru_doubleVec),allocatable :: gru(:) ! gru(:)%hru(:)%var(:)%dat endtype gru_hru_doubleVec ! ** integer type of variable length (4 byte) type, public :: gru_hru_intVec - type(hru_intVec),allocatable :: gru(:) ! gru(:)%hru(:)%var(:)%dat + type(hru_intVec),allocatable :: gru(:) ! gru(:)%hru(:)%var(:)%dat endtype gru_hru_intVec ! ** integer type of variable length (8 byte) type, public :: gru_hru_int8Vec - type(hru_int8Vec),allocatable :: gru(:) ! gru(:)%hru(:)%var(:)%dat + type(hru_int8Vec),allocatable :: gru(:) ! gru(:)%hru(:)%var(:)%dat endtype gru_hru_int8Vec ! ** double precision type of fixed length type, public :: gru_hru_double - type(hru_double),allocatable :: gru(:) ! gru(:)%hru(:)%var(:) + type(hru_double),allocatable :: gru(:) ! gru(:)%hru(:)%var(:) endtype gru_hru_double ! ** integer type of variable length (4 byte) type, public :: gru_hru_int - type(hru_int),allocatable :: gru(:) ! gru(:)%hru(:)%var(:) + type(hru_int),allocatable :: gru(:) ! gru(:)%hru(:)%var(:) endtype gru_hru_int ! ** integer type of variable length (8 byte) type, public :: gru_hru_int8 - type(hru_int8),allocatable :: gru(:) ! gru(:)%hru(:)%var(:) + type(hru_int8),allocatable :: gru(:) ! gru(:)%hru(:)%var(:) endtype gru_hru_int8 ! ** double precision type of fixed length type, public :: gru_d - type(hru_d),allocatable :: gru(:) ! gru(:)%hru(:) + type(hru_d),allocatable :: gru(:) ! gru(:)%hru(:) endtype gru_d ! ** integer type of fixed length type, public :: gru_i - type(hru_i),allocatable :: gru(:) ! gru(:)%hru(:) + type(hru_i),allocatable :: gru(:) ! gru(:)%hru(:) endtype gru_i -END MODULE data_types + integer(i4b),parameter :: len_msg=256 ! length of character string used in class definitions + + ! *********************************************************************************************************** + ! Define classes used to simplify calls to the subroutines in computFlux + ! *********************************************************************************************************** + ! Note: class procedures are located in the contains block of this (data_types) module + ! ** vegNrgFlux + type, public :: in_type_vegNrgFlux ! class for intent(in) arguments in vegNrgFlux call + logical(lgt) :: firstSubStep ! intent(in): flag to indicate if we are processing the first sub-step + logical(lgt) :: firstFluxCall ! intent(in): flag to indicate if we are processing the first flux call + logical(lgt) :: computeVegFlux ! intent(in): flag to indicate if we need to compute fluxes over vegetation + logical(lgt) :: checkLWBalance ! intent(in): flag to check longwave balance + real(rkind) :: upperBoundTemp ! intent(in): temperature of the upper boundary (K) --> NOTE: use air temperature + real(rkind) :: scalarCanairTempTrial ! intent(in): trial value of the canopy air space temperature (K) + real(rkind) :: scalarCanopyTempTrial ! intent(in): trial value of canopy temperature (K) + real(rkind) :: mLayerTempTrial_1 ! intent(in): trial value of ground temperature (K) + real(rkind) :: scalarCanopyIceTrial ! intent(in): trial value of mass of ice on the vegetation canopy (kg m-2) + real(rkind) :: scalarCanopyLiqTrial ! intent(in): trial value of mass of liquid water on the vegetation canopy (kg m-2) + real(rkind) :: dCanLiq_dTcanopy ! intent(in): derivative in canopy liquid storage w.r.t. canopy temperature (kg m-2 K-1) + contains + procedure :: initialize => initialize_in_vegNrgFlux + end type in_type_vegNrgFlux + + type, public :: out_type_vegNrgFlux ! class for intent(out) arguments in vegNrgFlux call + real(rkind) :: scalarCanopyTranspiration ! intent(out): canopy transpiration (kg m-2 s-1) + real(rkind) :: scalarCanopyEvaporation ! intent(out): canopy evaporation/condensation (kg m-2 s-1) + real(rkind) :: scalarGroundEvaporation ! intent(out): ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) + real(rkind) :: scalarCanairNetNrgFlux ! intent(out): net energy flux for the canopy air space (W m-2) + real(rkind) :: scalarCanopyNetNrgFlux ! intent(out): net energy flux for the vegetation canopy (W m-2) + real(rkind) :: scalarGroundNetNrgFlux ! intent(out): net energy flux for the ground surface (W m-2) + real(rkind) :: dCanairNetFlux_dCanairTemp ! intent(out): derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) + real(rkind) :: dCanairNetFlux_dCanopyTemp ! intent(out): derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) + real(rkind) :: dCanairNetFlux_dGroundTemp ! intent(out): derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) + real(rkind) :: dCanopyNetFlux_dCanairTemp ! intent(out): derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) + real(rkind) :: dCanopyNetFlux_dCanopyTemp ! intent(out): derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) + real(rkind) :: dCanopyNetFlux_dGroundTemp ! intent(out): derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) + real(rkind) :: dGroundNetFlux_dCanairTemp ! intent(out): derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) + real(rkind) :: dGroundNetFlux_dCanopyTemp ! intent(out): derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) + real(rkind) :: dGroundNetFlux_dGroundTemp ! intent(out): derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) + real(rkind) :: dCanopyEvaporation_dCanWat ! intent(out): derivative in canopy evaporation w.r.t. canopy total water content (s-1) + real(rkind) :: dCanopyEvaporation_dTCanair ! intent(out): derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + real(rkind) :: dCanopyEvaporation_dTCanopy ! intent(out): derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + real(rkind) :: dCanopyEvaporation_dTGround ! intent(out): derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) + real(rkind) :: dGroundEvaporation_dCanWat ! intent(out): derivative in ground evaporation w.r.t. canopy total water content (s-1) + real(rkind) :: dGroundEvaporation_dTCanair ! intent(out): derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + real(rkind) :: dGroundEvaporation_dTCanopy ! intent(out): derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + real(rkind) :: dGroundEvaporation_dTGround ! intent(out): derivative in ground evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) + real(rkind) :: dCanopyTrans_dCanWat ! intent(out): derivative in canopy transpiration w.r.t. canopy total water content (s-1) + real(rkind) :: dCanopyTrans_dTCanair ! intent(out): derivative in canopy transpiration w.r.t. canopy air temperature (kg m-2 s-1 K-1) + real(rkind) :: dCanopyTrans_dTCanopy ! intent(out): derivative in canopy transpiration w.r.t. canopy temperature (kg m-2 s-1 K-1) + real(rkind) :: dCanopyTrans_dTGround ! intent(out): derivative in canopy transpiration w.r.t. ground temperature (kg m-2 s-1 K-1) + real(rkind) :: dCanopyNetFlux_dCanWat ! intent(out): derivative in net canopy fluxes w.r.t. canopy total water content (J kg-1 s-1) + real(rkind) :: dGroundNetFlux_dCanWat ! intent(out): derivative in net ground fluxes w.r.t. canopy total water content (J kg-1 s-1) + integer(i4b) :: err ! intent(out): error code + character(len=len_msg) :: cmessage ! intent(out): error message + contains + procedure :: finalize => finalize_out_vegNrgFlux + end type out_type_vegNrgFlux + ! ** end vegNrgFlux + + ! ** ssdNrgFlux + type, public :: in_type_ssdNrgFlux ! class for intent(in) arguments in ssdNrgFlux call + logical(lgt) :: scalarSolution ! intent(in): flag to denote if implementing the scalar solution + real(rkind) :: scalarGroundNetNrgFlux ! intent(in): net energy flux for the ground surface (W m-2) + real(rkind), allocatable :: iLayerLiqFluxSnow(:) ! intent(in): liquid flux at the interface of each snow layer (m s-1) + real(rkind), allocatable :: iLayerLiqFluxSoil(:) ! intent(in): liquid flux at the interface of each soil layer (m s-1) + real(rkind), allocatable :: mLayerTempTrial(:) ! intent(in): temperature in each layer at the current iteration (m) + real(rkind), allocatable :: dThermalC_dWatAbove(:) ! intent(in): derivative in the thermal conductivity w.r.t. water state in the layer above + real(rkind), allocatable :: dThermalC_dWatBelow(:) ! intent(in): derivative in the thermal conductivity w.r.t. water state in the layer above + real(rkind), allocatable :: dThermalC_dTempAbove(:) ! intent(in): derivative in the thermal conductivity w.r.t. energy state in the layer above + real(rkind), allocatable :: dThermalC_dTempBelow(:) ! intent(in): derivative in the thermal conductivity w.r.t. energy state in the layer above + contains + procedure :: initialize => initialize_in_ssdNrgFlux + end type in_type_ssdNrgFlux + + type, public :: io_type_ssdNrgFlux ! class for intent(inout) arguments in ssdNrgFlux call + real(rkind) :: dGroundNetFlux_dGroundTemp ! intent(inout): derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) + contains + procedure :: initialize => initialize_io_ssdNrgFlux + procedure :: finalize => finalize_io_ssdNrgFlux + end type io_type_ssdNrgFlux + + type, public :: out_type_ssdNrgFlux ! class for intent(inout) arguments in ssdNrgFlux call + real(rkind), allocatable :: iLayerNrgFlux(:) ! intent(out): energy flux at the layer interfaces (W m-2) + real(rkind), allocatable :: dNrgFlux_dTempAbove(:) ! intent(out): derivatives in the flux w.r.t. temperature in the layer above (J m-2 s-1 K-1) + real(rkind), allocatable :: dNrgFlux_dTempBelow(:) ! intent(out): derivatives in the flux w.r.t. temperature in the layer below (J m-2 s-1 K-1) + real(rkind), allocatable :: dNrgFlux_dWatAbove(:) ! intent(out): derivatives in the flux w.r.t. water state in the layer above (J m-2 s-1 K-1) + real(rkind), allocatable :: dNrgFlux_dWatBelow(:) ! intent(out): derivatives in the flux w.r.t. water state in the layer below (J m-2 s-1 K-1) + integer(i4b) :: err ! intent(out): error code + character(len=len_msg) :: cmessage ! intent(out): error message + contains + procedure :: finalize => finalize_out_ssdNrgFlux + end type out_type_ssdNrgFlux + ! ** end ssdNrgFlux + + ! ** vegLiqFlux + type, public :: in_type_vegLiqFlux ! class for intent(in) arguments in vegLiqFlux call + logical(lgt) :: computeVegFlux ! intent(in): flag to denote if computing energy flux over vegetation + real(rkind) :: scalarCanopyLiqTrial ! intent(in): trial mass of liquid water on the vegetation canopy at the current iteration (kg m-2) + real(rkind) :: scalarRainfall ! intent(in): rainfall rate (kg m-2 s-1) + contains + procedure :: initialize => initialize_in_vegLiqFlux + end type in_type_vegLiqFlux + + type, public :: out_type_vegLiqFlux ! class for intent(out) arguments in vegLiqFlux call + real(rkind) :: scalarThroughfallRain ! intent(out): rain that reaches the ground without ever touching the canopy (kg m-2 s-1) + real(rkind) :: scalarCanopyLiqDrainage ! intent(out): drainage of liquid water from the vegetation canopy (kg m-2 s-1) + real(rkind) :: scalarThroughfallRainDeriv ! intent(out): derivative in throughfall w.r.t. canopy liquid water (s-1) + real(rkind) :: scalarCanopyLiqDrainageDeriv ! intent(out): derivative in canopy drainage w.r.t. canopy liquid water (s-1) + integer(i4b) :: err ! intent(out): error code + character(len=len_msg) :: cmessage ! intent(out): error message + contains + procedure :: finalize => finalize_out_vegLiqFlux + end type out_type_vegLiqFlux + ! ** end vegLiqFlux + + ! ** snowLiqFlx + type, public :: in_type_snowLiqFlx ! class for intent(in) arguments in snowLiqFlx call + integer(i4b) :: nSnow ! intent(in): number of snow layers + logical(lgt) :: firstFluxCall ! intent(in): the first flux call (compute variables that are constant over the iterations) + logical(lgt) :: scalarSolution ! intent(in): flag to indicate the scalar solution + real(rkind) :: scalarThroughfallRain ! intent(in): rain that reaches the snow surface without ever touching vegetation (kg m-2 s-1) + real(rkind) :: scalarCanopyLiqDrainage ! intent(in): liquid drainage from the vegetation canopy (kg m-2 s-1) + real(rkind), allocatable :: mLayerVolFracLiqTrial(:) ! intent(in): trial value of volumetric fraction of liquid water at the current iteration (-) + contains + procedure :: initialize => initialize_in_snowLiqFlx + end type in_type_snowLiqFlx + + type, public :: io_type_snowLiqFlx ! class for intent(inout) arguments in snowLiqFlx call + real(rkind), allocatable :: iLayerLiqFluxSnow(:) ! intent(inout): vertical liquid water flux at layer interfaces (m s-1) + real(rkind), allocatable :: iLayerLiqFluxSnowDeriv(:) ! intent(inout): derivative in vertical liquid water flux at layer interfaces (m s-1) + contains + procedure :: initialize => initialize_io_snowLiqFlx + procedure :: finalize => finalize_io_snowLiqFlx + end type io_type_snowLiqFlx + + type, public :: out_type_snowLiqFlx ! class for intent(out) arguments in snowLiqFlx call + integer(i4b) :: err ! intent(out): error code + character(len=len_msg) :: cmessage ! intent(out): error message + contains + procedure :: finalize => finalize_out_snowLiqFlx + end type out_type_snowLiqFlx + ! ** end snowLiqFlx + + ! ** soilLiqFlx + type, public :: in_type_soilLiqFlx ! class for intent(in) arguments in soilLiqFlx call + integer(i4b) :: nSoil ! intent(in): number of soil layers + logical(lgt) :: firstSplitOper ! intent(in): flag indicating first flux call in a splitting operation + logical(lgt) :: scalarSolution ! intent(in): flag to indicate the scalar solution + real(rkind) :: scalarAquiferStorageTrial ! intent(in): trial value of aquifer storage (m) + real(rkind), allocatable :: mLayerTempTrial(:) ! intent(in): trial temperature at the current iteration (K) + real(rkind), allocatable :: mLayerMatricHeadTrial(:) ! intent(in): matric potential (m) + real(rkind), allocatable :: mLayerMatricHeadLiqTrial(:) ! intent(in): liquid water matric potential (m) + real(rkind), allocatable :: mLayerVolFracLiqTrial(:) ! intent(in): volumetric fraction of liquid water (-) + real(rkind), allocatable :: mLayerVolFracIceTrial(:) ! intent(in): volumetric fraction of ice (-) + real(rkind), allocatable :: mLayerdTheta_dTk(:) ! intent(in): derivative in volumetric liquid water content w.r.t. temperature (K-1) + real(rkind), allocatable :: dPsiLiq_dTemp(:) ! intent(in): derivative in liquid water matric potential w.r.t. temperature (m K-1) + real(rkind) :: dCanopyTrans_dCanWat ! intent(in): derivative in canopy transpiration w.r.t. canopy total water content (s-1) + real(rkind) :: dCanopyTrans_dTCanair ! intent(in): derivative in canopy transpiration w.r.t. canopy air temperature (kg m-2 s-1 K-1) + real(rkind) :: dCanopyTrans_dTCanopy ! intent(in): derivative in canopy transpiration w.r.t. canopy temperature (kg m-2 s-1 K-1) + real(rkind) :: dCanopyTrans_dTGround ! intent(in): derivative in canopy transpiration w.r.t. ground temperature (kg m-2 s-1 K-1) + real(rkind) :: scalarCanopyTranspiration ! intent(in): canopy transpiration (kg m-2 s-1) + real(rkind) :: scalarGroundEvaporation ! intent(in): ground evaporation (kg m-2 s-1) + real(rkind) :: scalarRainPlusMelt ! intent(in): rain plus melt (m s-1) + contains + procedure :: initialize => initialize_in_soilLiqFlx + end type in_type_soilLiqFlx + + type, public :: io_type_soilLiqFlx ! class for intent(inout) arguments in soilLiqFlx call + real(rkind) :: scalarMaxInfilRate ! intent(inout): maximum infiltration rate (m s-1) + real(rkind) :: scalarInfilArea ! intent(inout): fraction of area where water can infiltrate, may be frozen (-) + real(rkind) :: scalarSaturatedArea ! intent(inout): fraction of area that is considered saturated (-) + real(rkind) :: scalarFrozenArea ! intent(inout): fraction of area that is considered impermeable due to soil ice (-) + real(rkind) :: scalarSoilControl ! intent(inout): soil control on infiltration for derivative + real(rkind) :: scalarSurfaceRunoff ! intent(inout): surface runoff (m s-1) + real(rkind) :: scalarSurfaceRunoff_IE ! intent(inout): infiltration excess surface runoff (m s-1) + real(rkind) :: scalarSurfaceRunoff_SE ! intent(inout): saturation excess surface runoff (m s-1) + real(rkind), allocatable :: mLayerdTheta_dPsi(:) ! intent(inout): derivative in the soil water characteristic w.r.t. psi (m-1) + real(rkind), allocatable :: mLayerdPsi_dTheta(:) ! intent(inout): derivative in the soil water characteristic w.r.t. theta (m) + real(rkind), allocatable :: dHydCond_dMatric(:) ! intent(inout): derivative in hydraulic conductivity w.r.t matric head (s-1) + real(rkind) :: scalarInfiltration ! intent(inout): surface infiltration rate (m s-1) -- controls on infiltration only computed for iter==1 + real(rkind), allocatable :: iLayerLiqFluxSoil(:) ! intent(inout): liquid fluxes at layer interfaces (m s-1) + real(rkind), allocatable :: mLayerTranspire(:) ! intent(inout): transpiration loss from each soil layer (m s-1) + real(rkind), allocatable :: mLayerHydCond(:) ! intent(inout): hydraulic conductivity in each layer (m s-1) + real(rkind), allocatable :: dq_dHydStateAbove(:) ! intent(inout): derivatives in the flux w.r.t. matric head in the layer above (s-1) + real(rkind), allocatable :: dq_dHydStateBelow(:) ! intent(inout): derivatives in the flux w.r.t. matric head in the layer below (s-1) + real(rkind), allocatable :: dq_dHydStateLayerSurfVec(:) ! intent(inout): derivative in surface infiltration w.r.t. hydrology state in above soil snow or canopy and every soil layer (m s-1 or s-1) + real(rkind), allocatable :: dq_dNrgStateAbove(:) ! intent(inout): derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) + real(rkind), allocatable :: dq_dNrgStateBelow(:) ! intent(inout): derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) + real(rkind), allocatable :: dq_dNrgStateLayerSurfVec(:) ! intent(inout): derivative in surface infiltration w.r.t. energy state in above soil snow or canopy and every soil layer (m s-1 K-1) + real(rkind), allocatable :: mLayerdTrans_dTCanair(:) ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. canopy air temperature + real(rkind), allocatable :: mLayerdTrans_dTCanopy(:) ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. canopy temperature + real(rkind), allocatable :: mLayerdTrans_dTGround(:) ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. ground temperature + real(rkind), allocatable :: mLayerdTrans_dCanWat(:) ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. canopy total water + contains + procedure :: initialize => initialize_io_soilLiqFlx + procedure :: finalize => finalize_io_soilLiqFlx + end type io_type_soilLiqFlx + + type, public :: out_type_soilLiqFlx ! class for intent(out) arguments in soilLiqFlx call + integer(i4b) :: err ! intent(out): error code + character(len=len_msg) :: cmessage ! intent(out): error message + contains + procedure :: finalize => finalize_out_soilLiqFlx + end type out_type_soilLiqFlx + ! ** end soilLiqFlx + + ! ** groundwatr + type, public :: in_type_groundwatr ! class for intent(in) arguments in groundwatr call + integer(i4b) :: nSnow ! intent(in): number of snow layers + integer(i4b) :: nSoil ! intent(in): number of soil layers + integer(i4b) :: nLayers ! intent(in): total number of layers + logical(lgt) :: firstFluxCall ! intent(in): logical flag to compute index of the lowest saturated layer + real(rkind), allocatable :: mLayerdTheta_dPsi(:) ! intent(in): derivative in the soil water characteristic w.r.t. matric head in each layer (m-1) + real(rkind), allocatable :: mLayerVolFracLiqTrial(:) ! intent(in): volumetric fraction of liquid water (-) + real(rkind), allocatable :: mLayerVolFracIceTrial(:) ! intent(in): volumetric fraction of ice (-) + contains + procedure :: initialize => initialize_in_groundwatr + end type in_type_groundwatr + + type, public :: io_type_groundwatr ! class for intent(io) arguments in groundwatr call + integer(i4b) :: ixSaturation ! intent(inout): index of lowest saturated layer (NOTE: only computed on the first iteration) + contains + procedure :: initialize => initialize_io_groundwatr + procedure :: finalize => finalize_io_groundwatr + end type io_type_groundwatr + + type, public :: out_type_groundwatr ! class for intent(out) arguments in groundwatr call + real(rkind), allocatable :: mLayerBaseflow(:) ! intent(out): baseflow from each soil layer (m s-1) + real(rkind), allocatable :: dBaseflow_dMatric(:,:) ! intent(out): derivative in baseflow w.r.t. matric head (s-1) + integer(i4b) :: err ! intent(out): error code + character(len=len_msg) :: cmessage ! intent(out): error message + contains + procedure :: finalize => finalize_out_groundwatr + end type out_type_groundwatr + ! ** end groundwatr + + ! ** bigAquifer + type, public :: in_type_bigAquifer ! class for intent(in) arguments in bigAquifer call + real(rkind) :: scalarAquiferStorageTrial ! intent(in): trial value of aquifer storage (m) + real(rkind) :: scalarCanopyTranspiration ! intent(in): canopy transpiration (kg m-2 s-1) + real(rkind) :: scalarSoilDrainage ! intent(in): soil drainage (m s-1) + real(rkind) :: dCanopyTrans_dCanWat ! intent(in): derivative in canopy transpiration w.r.t. canopy total water content (s-1) + real(rkind) :: dCanopyTrans_dTCanair ! intent(in): derivative in canopy transpiration w.r.t. canopy air temperature (kg m-2 s-1 K-1) + real(rkind) :: dCanopyTrans_dTCanopy ! intent(in): derivative in canopy transpiration w.r.t. canopy temperature (kg m-2 s-1 K-1) + real(rkind) :: dCanopyTrans_dTGround ! intent(in): derivative in canopy transpiration w.r.t. ground temperature (kg m-2 s-1 K-1) + contains + procedure :: initialize => initialize_in_bigAquifer + end type in_type_bigAquifer + + type, public :: io_type_bigAquifer ! class for intent(inout) arguments in bigAquifer call + real(rkind) :: dAquiferTrans_dTCanair ! intent(inout): derivatives in the aquifer transpiration flux w.r.t. canopy air temperature + real(rkind) :: dAquiferTrans_dTCanopy ! intent(inout): derivatives in the aquifer transpiration flux w.r.t. canopy temperature + real(rkind) :: dAquiferTrans_dTGround ! intent(inout): derivatives in the aquifer transpiration flux w.r.t. ground temperature + real(rkind) :: dAquiferTrans_dCanWat ! intent(inout): derivatives in the aquifer transpiration flux w.r.t. canopy total water + contains + procedure :: initialize => initialize_io_bigAquifer + procedure :: finalize => finalize_io_bigAquifer + end type io_type_bigAquifer + + type, public :: out_type_bigAquifer ! class for intent(out) arguments in bigAquifer call + real(rkind) :: scalarAquiferTranspire ! intent(out): transpiration loss from the aquifer (m s-1) + real(rkind) :: scalarAquiferRecharge ! intent(out): recharge to the aquifer (m s-1) + real(rkind) :: scalarAquiferBaseflow ! intent(out): total baseflow from the aquifer (m s-1) + real(rkind) :: dBaseflow_dAquifer ! intent(out): change in baseflow flux w.r.t. aquifer storage (s-1) + integer(i4b) :: err ! intent(out): error code + character(len=len_msg) :: cmessage ! intent(out): error message + contains + procedure :: finalize => finalize_out_bigAquifer + end type out_type_bigAquifer + ! ** end bigAquifer + + ! *********************************************************************************************************** + ! Define classes used to simplify calls to the subroutines in soilLiqFlx + ! *********************************************************************************************************** + + ! ** diagv_node + type, public :: in_type_diagv_node ! intent(in) data + ! input: model control + integer(i4b) :: ixRichards ! index defining the option for Richards' equation (moisture or mixdform) + ! input: state and diagnostic variables + real(rkind) :: scalarMatricHeadLiqTrial ! liquid matric head in each layer (m) + real(rkind) :: scalarVolFracLiqTrial ! volumetric fraction of liquid water in a given layer (-) + real(rkind) :: scalarVolFracIceTrial ! volumetric fraction of ice in a given layer (-) + ! input: pre-computed derivatives + real(rkind) :: dTheta_dTk ! derivative in volumetric liquid water content w.r.t. temperature (K-1) + real(rkind) :: dPsiLiq_dTemp ! derivative in liquid water matric potential w.r.t. temperature (m K-1) + ! input: soil parameters + real(rkind) :: vGn_alpha ! van Genuchten "alpha" parameter (m-1) + real(rkind) :: vGn_n ! van Genuchten "n" parameter (-) + real(rkind) :: vGn_m ! van Genuchten "m" parameter (-) + real(rkind) :: mpExp ! empirical exponent in macropore flow equation (-) + real(rkind) :: theta_sat ! soil porosity (-) + real(rkind) :: theta_res ! soil residual volumetric water content (-) + real(rkind) :: theta_mp ! volumetric liquid water content when macropore flow begins (-) + real(rkind) :: f_impede ! ice impedence factor (-) + ! input: saturated hydraulic conductivity + real(rkind) :: scalarSatHydCond ! saturated hydraulic conductivity at the mid-point of a given layer (m s-1) + real(rkind) :: scalarSatHydCondMP ! saturated hydraulic conductivity of macropores at the mid-point of a given layer (m s-1) + contains + procedure :: initialize => initialize_in_diagv_node + end type in_type_diagv_node + + type, public :: out_type_diagv_node ! intent(out) data + ! output: derivative in the soil water characteristic + real(rkind) :: scalardPsi_dTheta ! derivative in the soil water characteristic + real(rkind) :: scalardTheta_dPsi ! derivative in the soil water characteristic + ! output: transmittance + real(rkind) :: scalarHydCond ! hydraulic conductivity at layer mid-points (m s-1) + real(rkind) :: scalarDiffuse ! diffusivity at layer mid-points (m2 s-1) + real(rkind) :: iceImpedeFac ! ice impedence factor in each layer (-) + ! output: transmittance derivatives + real(rkind) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) + real(rkind) :: dDiffuse_dVolLiq ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) + real(rkind) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t matric head (s-1) + real(rkind) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + ! output: error control + integer(i4b) :: err ! error code + character(len=len_msg) :: message ! error message + contains + procedure :: finalize => finalize_out_diagv_node + end type out_type_diagv_node + ! ** end diagv_node + + ! ** surfaceFlx + type, public :: in_type_surfaceFlx ! intent(in) data + ! input: model control + logical(lgt) :: firstSplitOper ! flag indicating if desire to compute infiltration + integer(i4b) :: ixRichards ! index defining the option for Richards' equation (moisture or mixdform) + integer(i4b) :: ixInfRateMax ! index defining the maximum infiltration rate method (GreenAmpt or topmodel_GA) + integer(i4b) :: surfRun_SE ! index defining the saturation excess surface runoff method + integer(i4b) :: bc_upper ! index defining the type of boundary conditions + integer(i4b) :: nRoots ! number of layers that contain roots + integer(i4b) :: ixIce ! index of lowest ice layer + integer(i4b) :: nSoil ! number of soil layers + ! input: state and diagnostic variables + real(rkind),allocatable :: mLayerTemp(:) ! temperature (K) + real(rkind) :: scalarMatricHeadLiq ! liquid matric head in the upper-most soil layer (m) + real(rkind),allocatable :: mLayerMatricHead(:) ! matric head in each soil layer (m) + real(rkind) :: scalarVolFracLiq ! volumetric liquid water content in the upper-most soil layer (-) + real(rkind) :: scalarTotalSoilLiq ! total liquid water in the soil column (kg m-2) + real(rkind),allocatable :: mLayerVolFracLiq(:) ! volumetric liquid water content in each soil layer (-) + real(rkind),allocatable :: mLayerVolFracIce(:) ! volumetric ice content in each soil layer (-) + ! input: pre-computed derivatives (all of these would need to be recomputed if wanted a numerical derivative) + real(rkind),allocatable :: dTheta_dTk(:) ! derivative in volumetric liquid water content w.r.t. temperature (K-1) + real(rkind),allocatable :: dTheta_dPsi(:) ! derivative in the soil water characteristic w.r.t. psi (m-1) + real(rkind),allocatable :: mLayerdPsi_dTheta(:) ! derivative in the soil water characteristic w.r.t. theta (m) + ! input: depth of each soil layer (m) + real(rkind),allocatable :: mLayerDepth(:) ! depth of each soil layer (m) + real(rkind),allocatable :: iLayerHeight(:) ! height at the interface of each layer (m) + ! input: diriclet boundary conditions + real(rkind) :: upperBoundHead ! upper boundary condition for matric head (m) + real(rkind) :: upperBoundTheta ! upper boundary condition for volumetric liquid water content (-) + ! input: flux at the upper boundary + real(rkind) :: scalarRainPlusMelt ! rain plus melt, used as input to the soil zone before computing surface runoff (m s-1) + ! input: transmittance + real(rkind) :: surfaceSatHydCond ! saturated hydraulic conductivity at the surface (m s-1) + real(rkind) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + real(rkind) :: iceImpedeFac ! ice impedence factor in the upper-most soil layer (-) + ! input: soil parameters + real(rkind) :: vGn_alpha ! van Genuchten "alpha" parameter (m-1) + real(rkind) :: vGn_n ! van Genuchten "n" parameter (-) + real(rkind) :: vGn_m ! van Genuchten "m" parameter (-) + real(rkind) :: theta_sat ! soil porosity (-) + real(rkind) :: theta_res ! soil residual volumetric water content (-) + real(rkind) :: qSurfScale ! scaling factor in the surface runoff parameterization (-) + real(rkind) :: zScale_TOPMODEL ! scaling factor used to describe decrease in hydraulic conductivity with depth (m) + real(rkind) :: rootingDepth ! rooting depth (m) + real(rkind) :: wettingFrontSuction ! Green-Ampt wetting front suction (m) + real(rkind) :: soilIceScale ! soil ice scaling factor in Gamma distribution used to define frozen area (m) + real(rkind) :: soilIceCV ! soil ice CV in Gamma distribution used to define frozen area (-) + ! input: FUSE parameters + real(rkind) :: FUSE_Ac_max ! FUSE PRMS max saturated area + real(rkind) :: FUSE_phi_tens ! FUSE PRMS tension fraction + real(rkind) :: FUSE_b ! FUSE ARNO/VIC exponent + real(rkind) :: FUSE_lambda ! FUSE TOPMODEL gamma distribution lambda parameter + real(rkind) :: FUSE_chi ! FUSE TOPMODEL chi distribution lambda parameter + real(rkind) :: FUSE_mu ! FUSE TOPMODEL mu distribution lambda parameter + real(rkind) :: FUSE_n ! FUSE TOPMODEL exponent + contains + procedure :: initialize => initialize_in_surfaceFlx + end type in_type_surfaceFlx + + type, public :: io_type_surfaceFlx ! intent(inout) data + ! input-output: hydraulic conductivity and diffusivity at the surface + ! NOTE: intent(inout) because infiltration may only be computed for the first iteration + real(rkind) :: surfaceHydCond ! hydraulic conductivity (m s-1) + real(rkind) :: surfaceDiffuse ! hydraulic diffusivity at the surface (m + ! input-output: surface runoff and infiltration flux (m s-1) + real(rkind) :: xMaxInfilRate ! maximum infiltration rate (m s-1) + real(rkind) :: scalarInfilArea ! fraction of area where water can infiltrate, may be frozen (-) + real(rkind) :: scalarSaturatedArea ! fraction of area that is considered saturated (-) + real(rkind) :: scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) + real(rkind) :: scalarSoilControl ! soil control on infiltration for derivative + contains + procedure :: initialize => initialize_io_surfaceFlx + procedure :: finalize => finalize_io_surfaceFlx + end type io_type_surfaceFlx + + type, public :: out_type_surfaceFlx ! intent(out) data + ! output: runoff and infiltration + real(rkind) :: scalarSurfaceRunoff ! surface runoff (m s-1) + real(rkind) :: scalarSurfaceRunoff_IE ! infiltration excess surface runoff (m s-1) + real(rkind) :: scalarSurfaceRunoff_SE ! saturation excess surface runoff (m s-1) + real(rkind) :: scalarSurfaceInfiltration ! surface infiltration (m s-1) + ! output: derivatives in surface infiltration w.r.t. ... + real(rkind),allocatable :: dq_dHydStateVec(:) ! ... hydrology state in above soil snow or canopy and every soil layer (m s-1 or s-1) + real(rkind),allocatable :: dq_dNrgStateVec(:) ! ... energy state in above soil snow or canopy and every soil layer (m s-1 K-1) + ! output: error control + integer(i4b) :: err ! error code + character(len=len_msg) :: message ! error message + contains + procedure :: finalize => finalize_out_surfaceFlx + end type out_type_surfaceFlx + ! ** end surfaceFlx + + ! ** iLayerFlux + type, public :: in_type_iLayerFlux ! intent(in) data + ! input: model control + integer(i4b) :: ixRichards ! index defining the option for Richards' equation (moisture or mixdform) + ! input: state variables + real(rkind),allocatable :: nodeMatricHeadLiqTrial(:) ! liquid matric head at the soil nodes (m) + real(rkind),allocatable :: nodeVolFracLiqTrial(:) ! volumetric fraction of liquid water at the soil nodes (-) + ! input: model coordinate variables + real(rkind),allocatable :: nodeHeight(:) ! height at the mid-point of the lower layer (m) + ! input: temperature derivatives + real(rkind),allocatable :: dPsiLiq_dTemp(:) ! derivative in liquid water matric potential w.r.t. temperature (m K-1) + real(rkind),allocatable :: dHydCond_dTemp(:) ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + ! input: transmittance + real(rkind),allocatable :: nodeHydCondTrial(:) ! hydraulic conductivity at layer mid-points (m s-1) + real(rkind),allocatable :: nodeDiffuseTrial(:) ! diffusivity at layer mid-points (m2 s-1) + ! input: transmittance derivatives + real(rkind),allocatable :: dHydCond_dVolLiq(:) ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) + real(rkind),allocatable :: dDiffuse_dVolLiq(:) ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) + real(rkind),allocatable :: dHydCond_dMatric(:) ! derivative in hydraulic conductivity w.r.t matric head (m s-1) + contains + procedure :: initialize => initialize_in_iLayerFlux + end type in_type_iLayerFlux + + type, public :: out_type_iLayerFlux ! intent(out) data + ! output: tranmsmittance at the layer interface (scalars) + real(rkind) :: iLayerHydCond ! hydraulic conductivity at the interface between layers (m s-1) + real(rkind) :: iLayerDiffuse ! hydraulic diffusivity at the interface between layers (m2 s-1) + ! output: vertical flux at the layer interface (scalars) + real(rkind) :: iLayerLiqFluxSoil ! vertical flux of liquid water at the layer interface (m s-1) + ! output: derivatives in fluxes w.r.t. state variables -- matric head or volumetric lquid water -- in the layer above and layer below (m s-1 or s-1) + real(rkind) :: dq_dHydStateAbove ! derivatives in the flux w.r.t. matric head or volumetric lquid water in the layer above (m s-1 or s-1) + real(rkind) :: dq_dHydStateBelow ! derivatives in the flux w.r.t. matric head or volumetric lquid water in the layer below (m s-1 or s-1) + ! output: derivatives in fluxes w.r.t. energy state variables -- now just temperature -- in the layer above and layer below (m s-1 K-1) + real(rkind) :: dq_dNrgStateAbove ! derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) + real(rkind) :: dq_dNrgStateBelow ! derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) + ! output: error control + integer(i4b) :: err ! error code + character(len=len_msg) :: message ! error message + contains + procedure :: finalize => finalize_out_iLayerFlux + end type out_type_iLayerFlux + ! ** end iLayerFlux + + ! ** qDrainFlux + type, public :: in_type_qDrainFlux ! intent(in) data + ! input: model control + integer(i4b) :: ixRichards ! index defining the option for Richards' equation (moisture or mixdform) + integer(i4b) :: bc_lower ! index defining the type of boundary conditions + ! input: state and diagnostic variables + real(rkind) :: nodeMatricHeadLiq ! liquid matric head in the lowest unsaturated node (m) + real(rkind) :: nodeVolFracLiq ! volumetric liquid water content in the lowest unsaturated node (-) + ! input: model coordinate variables + real(rkind) :: nodeDepth ! depth of the lowest unsaturated soil layer (m) + real(rkind) :: nodeHeight ! height of the lowest unsaturated soil node (m) + ! input: diriclet boundary conditions + real(rkind) :: lowerBoundHead ! lower boundary condition for matric head (m) + real(rkind) :: lowerBoundTheta ! lower boundary condition for volumetric liquid water content (-) + ! input: derivative in soil water characteristic + real(rkind) :: node_dPsi_dTheta ! derivative of the soil moisture characteristic w.r.t. theta (m) + real(rkind) :: node_dPsiLiq_dTemp ! derivative in liquid water matric potential w.r.t. temperature (m K-1) + ! input: transmittance + real(rkind) :: surfaceSatHydCond ! saturated hydraulic conductivity at the surface (m s-1) + real(rkind) :: bottomSatHydCond ! saturated hydraulic conductivity at the bottom of the unsaturated zone (m s-1) + real(rkind) :: nodeHydCond ! hydraulic conductivity at the node itself (m s-1) + real(rkind) :: iceImpedeFac ! ice impedence factor in the upper-most soil layer (-) + ! input: transmittance derivatives + real(rkind) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t. volumetric liquid water content (m s-1) + real(rkind) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t. matric head (s-1) + real(rkind) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + ! input: soil parameters + real(rkind) :: vGn_alpha ! van Genuchten "alpha" parameter (m-1) + real(rkind) :: vGn_n ! van Genuchten "n" parameter (-) + real(rkind) :: vGn_m ! van Genuchten "m" parameter (-) + real(rkind) :: theta_sat ! soil porosity (-) + real(rkind) :: theta_res ! soil residual volumetric water content (-) + real(rkind) :: kAnisotropic ! anisotropy factor for lateral hydraulic conductivity (-) + real(rkind) :: zScale_TOPMODEL ! scale factor for TOPMODEL-ish baseflow parameterization (m) + contains + procedure :: initialize => initialize_in_qDrainFlux + end type in_type_qDrainFlux + + type, public :: out_type_qDrainFlux ! intent(out) data + ! output: hydraulic conductivity at the bottom of the unsaturated zone + real(rkind) :: bottomHydCond ! hydraulic conductivity at the bottom of the unsaturated zone (m s-1) + real(rkind) :: bottomDiffuse ! hydraulic diffusivity at the bottom of the unsatuarted zone (m2 s-1) + ! output: drainage flux from the bottom of the soil profile + real(rkind) :: scalarDrainage ! drainage flux from the bottom of the soil profile (m s-1) + ! output: derivatives in drainage flux + real(rkind) :: dq_dHydStateUnsat ! change in drainage flux w.r.t. change in state variable in lowest unsaturated node (m s-1 or s-1) + real(rkind) :: dq_dNrgStateUnsat ! change in drainage flux w.r.t. change in energy state variable in lowest unsaturated node (m s-1 K-1) + ! output: error control + integer(i4b) :: err ! error code + character(len=len_msg) :: message ! error message + contains + procedure :: finalize => finalize_out_qDrainFlux + end type out_type_qDrainFlux + ! ** end qDrainFlux + + ! *********************************************************************************************************** + ! Define classes used to simplify calls to the subroutines in opSplittin + ! *********************************************************************************************************** + ! ** stateFilter + type, public :: out_type_stateFilter ! class for intent(out) arguments in stateFilter call + integer(i4b) :: err ! intent(out): error code + character(len=len_msg) :: cmessage ! intent(out): error message + contains + procedure :: finalize => finalize_out_stateFilter + end type out_type_stateFilter + ! ** end stateFilter + + ! ** indexSplit + type, public :: in_type_indexSplit ! class for intent(in) arguments in indexSplit call + integer(i4b) :: nSnow ! intent(in): number of snow layers + integer(i4b) :: nSoil ! intent(in): number of soil layers + integer(i4b) :: nLayers ! intent(in): total number of layers + integer(i4b) :: nSubset ! intent(in): number of states in the subset + contains + procedure :: initialize => initialize_in_indexSplit + end type in_type_indexSplit + + type, public :: out_type_indexSplit ! class for intent(out) arguments in indexSplit call + integer(i4b) :: err ! intent(out): error code + character(len=len_msg) :: cmessage ! intent(out): error message + contains + procedure :: finalize => finalize_out_indexSplit + end type out_type_indexSplit + ! ** end indexSplit + + ! ** varSubstep + type, public :: in_type_varSubstep ! class for intent(in) arguments in varSubstep call + real(rkind) :: dt ! intent(in): time step (s) + real(rkind) :: dtInit ! intent(in): initial time step (seconds) + real(rkind) :: dt_min ! intent(in): minimum time step (seconds) + real(rkind) :: whole_step ! intent(in): length of whole step for surface drainage and average flux + integer(i4b) :: nSubset ! intent(in): total number of variables in the state subset + logical(lgt) :: doAdjustTemp ! intent(in): flag to indicate if we adjust the temperature + logical(lgt) :: firstSubStep ! intent(in): flag to denote first sub-step + logical(lgt) :: computeVegFlux ! intent(in): flag to denote if computing energy flux over vegetation + logical(lgt) :: scalarSolution ! intent(in): flag to denote computing the scalar solution + integer(i4b) :: iStateSplit ! intent(in): index of the layer in the splitting operation + type(var_flagVec) :: fluxMask ! intent(in): mask for the fluxes used in this given state subset + contains + procedure :: initialize => initialize_in_varSubstep + end type in_type_varSubstep + + type, public :: io_type_varSubstep ! class for intent(inout) arguments in varSubstep call + logical(lgt) :: firstFluxCall ! intent(inout): flag to indicate if we are processing the first flux call + type(var_ilength) :: fluxCount ! intent(inout): number of times fluxes are updated (should equal nsubstep) + integer(i4b) :: ixSaturation ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) + contains + procedure :: initialize => initialize_io_varSubstep + procedure :: finalize => finalize_io_varSubstep + end type io_type_varSubstep + + type, public :: out_type_varSubstep ! class for intent(out) arguments in varSubstep call + real(rkind) :: dtMultiplier ! intent(out): substep multiplier (-) + integer(i4b) :: nSubsteps ! intent(out): number of substeps taken for a given split + logical(lgt) :: failedMinimumStep ! intent(out): flag for failed substeps + logical(lgt) :: reduceCoupledStep ! intent(out): flag to reduce the length of the coupled step + logical(lgt) :: tooMuchMelt ! intent(out): flag to denote that ice is insufficient to support melt + integer(i4b) :: err ! intent(out): error code + character(len=len_msg) :: cmessage ! intent(out): error message + contains + procedure :: finalize => finalize_out_varSubstep + end type out_type_varSubstep + ! ** end varSubstep + + ! *********************************************************************************************************** + ! Define classes used to simplify calls to the subroutines in summaSolve4homegrown + ! *********************************************************************************************************** + + type, public :: in_type_computJacob ! class for intent(in) arguments in computJacob call + ! input: model control + real(rkind) :: dt ! intent(in): length of the time step (seconds) + integer(i4b) :: nSnow ! intent(in): number of snow layers + integer(i4b) :: nSoil ! intent(in): number of soil layers + integer(i4b) :: nLayers ! intent(in): total number of layers in the snow+soil domain + logical(lgt) :: computeVegFlux ! intent(in): flag to indicate if computing fluxes over vegetation + logical(lgt) :: computeBaseflow ! intent(in): flag to indicate if computing baseflow + integer(i4b) :: ixMatrix ! intent(in): form of the Jacobian matrix + contains + procedure :: initialize => initialize_in_computJacob + end type in_type_computJacob + + type, public :: out_type_computJacob ! class for intent(out) arguments in computJacob call + ! output: error control + integer(i4b) :: err ! intent(out): error code + character(len=len_msg) :: cmessage ! intent(out): error message + contains + procedure :: finalize => finalize_out_computJacob + end type out_type_computJacob + + type, public :: in_type_lineSearchRefinement ! class for intent(in) arguments in lineSearchRefinement call + logical(lgt) :: doSearch ! intent(in): flag to do the line search + real(rkind) :: fOld ! intent(in): old function value + contains + procedure :: initialize => initialize_in_lineSearchRefinement + end type in_type_lineSearchRefinement + + type, public :: out_type_lineSearchRefinement ! class for intent(out) arguments in lineSearchRefinement call + real(rkind) :: fNew ! intent(out): new function evaluation + logical(lgt) :: converged ! intent(out): convergence flag + ! output: error control + integer(i4b) :: err ! intent(out): error code + character(len=len_msg) :: message ! intent(out): error message + contains + procedure :: finalize => finalize_out_lineSearchRefinement + end type out_type_lineSearchRefinement + + ! *********************************************************************************************************** + ! Define classes used to simplify calls to the subroutines in systemSolv + ! *********************************************************************************************************** + + type, public :: in_type_summaSolve4homegrown ! class for intent(in) arguments in summaSolve4homegrown call + real(rkind) :: dt_cur ! intent(in): current stepsize + real(rkind) :: dt ! intent(in): entire time step for drainage pond rate + integer(i4b) :: iter ! intent(in): iteration index + integer(i4b) :: nSnow ! intent(in): number of snow layers + integer(i4b) :: nSoil ! intent(in): number of soil layers + integer(i4b) :: nLayers ! intent(in): total number of layers + integer(i4b) :: nLeadDim ! intent(in): length of the leading dimension of the Jacobian matrix (nBands or nState) + integer(i4b) :: nState ! intent(in): total number of state variables + integer(i4b) :: ixMatrix ! intent(in): type of matrix (full or band diagonal) + logical(lgt) :: firstSubStep ! intent(in): flag to indicate if we are processing the first sub-step + logical(lgt) :: computeVegFlux ! intent(in): flag to indicate if computing fluxes over vegetation + logical(lgt) :: scalarSolution ! intent(in): flag to denote if implementing the scalar solution + real(rkind) :: fOld ! intent(in): old function evaluation + contains + procedure :: initialize => initialize_in_summaSolve4homegrown + end type in_type_summaSolve4homegrown + + type, public :: io_type_summaSolve4homegrown ! class for intent(inout) arguments in summaSolve4homegrown call + logical(lgt) :: firstFluxCall ! intent(inout): flag to indicate if we are processing the first flux call + real(rkind) :: xMin,xMax ! intent(inout): brackets of the root + integer(i4b) :: ixSaturation ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) + contains + procedure :: initialize => initialize_io_summaSolve4homegrown + procedure :: finalize => finalize_io_summaSolve4homegrown + end type io_type_summaSolve4homegrown + + type, public :: out_type_summaSolve4homegrown ! class for intent(out) arguments in summaSolve4homegrown call + real(rkind) :: fNew ! intent(out): new function evaluation + logical(lgt) :: converged ! intent(out): convergence flag + integer(i4b) :: err ! intent(out): error code + character(len=len_msg) :: message ! intent(out): error message + contains + procedure :: finalize => finalize_out_summaSolve4homegrown + end type out_type_summaSolve4homegrown + +contains + + ! **** vegNrgFlux **** + subroutine initialize_in_vegNrgFlux(in_vegNrgFlux,firstSubStep,firstFluxCall,computeVegFlux,checkLWBalance,& + scalarCanairTempTrial,scalarCanopyTempTrial,mLayerTempTrial,scalarCanopyIceTrial,& + scalarCanopyLiqTrial,forc_data,deriv_data) + class(in_type_vegNrgFlux),intent(out) :: in_vegNrgFlux ! class object for intent(in) vegNrgFlux arguments + logical(lgt),intent(in) :: firstSubStep ! flag to indicate if we are processing the first sub-step + logical(lgt),intent(in) :: firstFluxCall ! flag to indicate if we are processing the first flux call + logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation + logical(lgt),intent(in) :: checkLWBalance ! flag to check longwave balance + real(rkind),intent(in) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) + real(rkind),intent(in) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) + real(rkind),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) + real(rkind),intent(in) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) + real(rkind),intent(in) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) + type(var_d),intent(in) :: forc_data ! model forcing data + type(var_dlength),intent(in) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + associate(& + upperBoundTemp => forc_data%var(iLookFORCE%airtemp), & ! intent(in): [dp] temperature of the upper boundary of the snow and soil domains (K) + dCanLiq_dTcanopy => deriv_data%var(iLookDERIV%dCanLiq_dTcanopy)%dat(1) ) ! intent(out): [dp] derivative of canopy liquid storage w.r.t. temperature + ! intent(in) arguments + in_vegNrgFlux % firstSubStep=firstSubStep ! intent(in): flag to indicate if we are processing the first sub-step + in_vegNrgFlux % firstFluxCall=firstFluxCall ! intent(in): flag to indicate if we are processing the first flux call + in_vegNrgFlux % computeVegFlux=computeVegFlux ! intent(in): flag to indicate if we need to compute fluxes over vegetation + in_vegNrgFlux % checkLWBalance=checkLWBalance ! intent(in): flag to check longwave balance + in_vegNrgFlux % upperBoundTemp=upperBoundTemp ! intent(in): temperature of the upper boundary (K) --> NOTE: use air temperature + in_vegNrgFlux % scalarCanairTempTrial=scalarCanairTempTrial ! intent(in): trial value of the canopy air space temperature (K) + in_vegNrgFlux % scalarCanopyTempTrial=scalarCanopyTempTrial ! intent(in): trial value of canopy temperature (K) + in_vegNrgFlux % mLayerTempTrial_1=mLayerTempTrial(1) ! intent(in): trial value of ground temperature (K) + in_vegNrgFlux % scalarCanopyIceTrial=scalarCanopyIceTrial ! intent(in): trial value of mass of ice on the vegetation canopy (kg m-2) + in_vegNrgFlux % scalarCanopyLiqTrial=scalarCanopyLiqTrial ! intent(in): trial value of mass of liquid water on the vegetation canopy (kg m-2) + in_vegNrgFlux % dCanLiq_dTcanopy=dCanLiq_dTcanopy ! intent(in): derivative in canopy liquid storage w.r.t. canopy temperature (kg m-2 K-1) + end associate + end subroutine initialize_in_vegNrgFlux + + subroutine finalize_out_vegNrgFlux(out_vegNrgFlux,flux_data,deriv_data,err,cmessage) + class(out_type_vegNrgFlux),intent(in) :: out_vegNrgFlux ! class object for intent(out) vegNrgFlux arguments + type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: cmessage ! error message from ssdNrgFlux + + ! intent(out) arguments: evapotranspiration values and net energy fluxes + associate(& + scalarCanopyTranspiration => flux_data%var(iLookFLUX%scalarCanopyTranspiration)%dat(1), & ! intent(out): [dp] canopy transpiration (kg m-2 s-1) + scalarCanopyEvaporation => flux_data%var(iLookFLUX%scalarCanopyEvaporation)%dat(1), & ! intent(out): [dp] canopy evaporation/condensation (kg m-2 s-1) + scalarGroundEvaporation => flux_data%var(iLookFLUX%scalarGroundEvaporation)%dat(1), & ! intent(out): [dp] ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) + scalarCanairNetNrgFlux => flux_data%var(iLookFLUX%scalarCanairNetNrgFlux)%dat(1), & ! intent(out): [dp] net energy flux for the canopy air space (W m-2) + scalarCanopyNetNrgFlux => flux_data%var(iLookFLUX%scalarCanopyNetNrgFlux)%dat(1), & ! intent(out): [dp] net energy flux for the vegetation canopy (W m-2) + scalarGroundNetNrgFlux => flux_data%var(iLookFLUX%scalarGroundNetNrgFlux)%dat(1) ) ! intent(out): [dp] net energy flux for the ground surface (W m-2) + scalarCanopyTranspiration =out_vegNrgFlux % scalarCanopyTranspiration ! intent(out): canopy transpiration (kg m-2 s-1) + scalarCanopyEvaporation =out_vegNrgFlux % scalarCanopyEvaporation ! intent(out): canopy evaporation/condensation (kg m-2 s-1) + scalarGroundEvaporation =out_vegNrgFlux % scalarGroundEvaporation ! intent(out): ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) + scalarCanairNetNrgFlux =out_vegNrgFlux % scalarCanairNetNrgFlux ! intent(out): net energy flux for the canopy air space (W m-2) + scalarCanopyNetNrgFlux =out_vegNrgFlux % scalarCanopyNetNrgFlux ! intent(out): net energy flux for the vegetation canopy (W m-2) + scalarGroundNetNrgFlux =out_vegNrgFlux % scalarGroundNetNrgFlux ! intent(out): net energy flux for the ground surface (W m-2) + end associate + + ! intent(out) arguments: net canopy flux derivatives + associate(& + dCanairNetFlux_dCanairTemp => deriv_data%var(iLookDERIV%dCanairNetFlux_dCanairTemp)%dat(1), & ! intent(out): [dp] derivative in net canopy air space flux w.r.t. canopy air temperature + dCanairNetFlux_dCanopyTemp => deriv_data%var(iLookDERIV%dCanairNetFlux_dCanopyTemp)%dat(1), & ! intent(out): [dp] derivative in net canopy air space flux w.r.t. canopy temperature + dCanairNetFlux_dGroundTemp => deriv_data%var(iLookDERIV%dCanairNetFlux_dGroundTemp)%dat(1), & ! intent(out): [dp] derivative in net canopy air space flux w.r.t. ground temperature + dCanopyNetFlux_dCanairTemp => deriv_data%var(iLookDERIV%dCanopyNetFlux_dCanairTemp)%dat(1), & ! intent(out): [dp] derivative in net canopy flux w.r.t. canopy air temperature + dCanopyNetFlux_dCanopyTemp => deriv_data%var(iLookDERIV%dCanopyNetFlux_dCanopyTemp)%dat(1), & ! intent(out): [dp] derivative in net canopy flux w.r.t. canopy temperature + dCanopyNetFlux_dGroundTemp => deriv_data%var(iLookDERIV%dCanopyNetFlux_dGroundTemp)%dat(1), & ! intent(out): [dp] derivative in net canopy flux w.r.t. ground temperature + dGroundNetFlux_dCanairTemp => deriv_data%var(iLookDERIV%dGroundNetFlux_dCanairTemp)%dat(1), & ! intent(out): [dp] derivative in net ground flux w.r.t. canopy air temperature + dGroundNetFlux_dCanopyTemp => deriv_data%var(iLookDERIV%dGroundNetFlux_dCanopyTemp)%dat(1), & ! intent(out): [dp] derivative in net ground flux w.r.t. canopy temperature + dGroundNetFlux_dGroundTemp => deriv_data%var(iLookDERIV%dGroundNetFlux_dGroundTemp)%dat(1) ) ! intent(out): [dp] derivative in net ground flux w.r.t. ground temperature + dCanairNetFlux_dCanairTemp =out_vegNrgFlux % dCanairNetFlux_dCanairTemp ! intent(out): derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) + dCanairNetFlux_dCanopyTemp =out_vegNrgFlux % dCanairNetFlux_dCanopyTemp ! intent(out): derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) + dCanairNetFlux_dGroundTemp =out_vegNrgFlux % dCanairNetFlux_dGroundTemp ! intent(out): derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) + dCanopyNetFlux_dCanairTemp =out_vegNrgFlux % dCanopyNetFlux_dCanairTemp ! intent(out): derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) + dCanopyNetFlux_dCanopyTemp =out_vegNrgFlux % dCanopyNetFlux_dCanopyTemp ! intent(out): derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) + dCanopyNetFlux_dGroundTemp =out_vegNrgFlux % dCanopyNetFlux_dGroundTemp ! intent(out): derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) + dGroundNetFlux_dCanairTemp =out_vegNrgFlux % dGroundNetFlux_dCanairTemp ! intent(out): derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) + dGroundNetFlux_dCanopyTemp =out_vegNrgFlux % dGroundNetFlux_dCanopyTemp ! intent(out): derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) + dGroundNetFlux_dGroundTemp =out_vegNrgFlux % dGroundNetFlux_dGroundTemp ! intent(out): derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) + end associate + + ! intent(out) arguments: canopy evaporation derivatives + associate(& + dCanopyEvaporation_dCanWat => deriv_data%var(iLookDERIV%dCanopyEvaporation_dCanWat)%dat(1), & ! intent(out): [dp] derivative in canopy evaporation w.r.t. canopy total water content + dCanopyEvaporation_dTCanair => deriv_data%var(iLookDERIV%dCanopyEvaporation_dTCanair)%dat(1), & ! intent(out): [dp] derivative in canopy evaporation w.r.t. canopy air temperature + dCanopyEvaporation_dTCanopy => deriv_data%var(iLookDERIV%dCanopyEvaporation_dTCanopy)%dat(1), & ! intent(out): [dp] derivative in canopy evaporation w.r.t. canopy temperature + dCanopyEvaporation_dTGround => deriv_data%var(iLookDERIV%dCanopyEvaporation_dTGround)%dat(1), & ! intent(out): [dp] derivative in canopy evaporation w.r.t. ground temperature + dGroundEvaporation_dCanWat => deriv_data%var(iLookDERIV%dGroundEvaporation_dCanWat)%dat(1), & ! intent(out): [dp] derivative in ground evaporation w.r.t. canopy total water content + dGroundEvaporation_dTCanair => deriv_data%var(iLookDERIV%dGroundEvaporation_dTCanair)%dat(1), & ! intent(out): [dp] derivative in ground evaporation w.r.t. canopy air temperature + dGroundEvaporation_dTCanopy => deriv_data%var(iLookDERIV%dGroundEvaporation_dTCanopy)%dat(1), & ! intent(out): [dp] derivative in ground evaporation w.r.t. canopy temperature + dGroundEvaporation_dTGround => deriv_data%var(iLookDERIV%dGroundEvaporation_dTGround)%dat(1) ) ! intent(out): [dp] derivative in ground evaporation w.r.t. ground temperature + dCanopyEvaporation_dCanWat =out_vegNrgFlux % dCanopyEvaporation_dCanWat ! intent(out): derivative in canopy evaporation w.r.t. canopy total water content (s-1) + dCanopyEvaporation_dTCanair=out_vegNrgFlux % dCanopyEvaporation_dTCanair ! intent(out): derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + dCanopyEvaporation_dTCanopy=out_vegNrgFlux % dCanopyEvaporation_dTCanopy ! intent(out): derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + dCanopyEvaporation_dTGround=out_vegNrgFlux % dCanopyEvaporation_dTGround ! intent(out): derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) + dGroundEvaporation_dCanWat =out_vegNrgFlux % dGroundEvaporation_dCanWat ! intent(out): derivative in ground evaporation w.r.t. canopy total water content (s-1) + dGroundEvaporation_dTCanair=out_vegNrgFlux % dGroundEvaporation_dTCanair ! intent(out): derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + dGroundEvaporation_dTCanopy=out_vegNrgFlux % dGroundEvaporation_dTCanopy ! intent(out): derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + dGroundEvaporation_dTGround=out_vegNrgFlux % dGroundEvaporation_dTGround ! intent(out): derivative in ground evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) + end associate + + ! intent(out) arguments: canopy transpiration and net flux derivatives + associate(& + dCanopyTrans_dCanWat => deriv_data%var(iLookDERIV%dCanopyTrans_dCanWat)%dat(1), & ! intent(out): [dp] derivative in canopy transpiration w.r.t. canopy total water content (s-1) + dCanopyTrans_dTCanair => deriv_data%var(iLookDERIV%dCanopyTrans_dTCanair)%dat(1), & ! intent(out): [dp] derivative in canopy transpiration w.r.t. canopy air temperature (kg m-2 s-1 K-1) + dCanopyTrans_dTCanopy => deriv_data%var(iLookDERIV%dCanopyTrans_dTCanopy)%dat(1), & ! intent(out): [dp] derivative in canopy transpiration w.r.t. canopy temperature (kg m-2 s-1 K-1) + dCanopyTrans_dTGround => deriv_data%var(iLookDERIV%dCanopyTrans_dTGround)%dat(1), & ! intent(out): [dp] derivative in canopy transpiration w.r.t. ground temperature (kg m-2 s-1 K-1) + dCanopyNetFlux_dCanWat => deriv_data%var(iLookDERIV%dCanopyNetFlux_dCanWat)%dat(1), & ! intent(out): [dp] derivative in net canopy fluxes w.r.t. canopy total water content + dGroundNetFlux_dCanWat => deriv_data%var(iLookDERIV%dGroundNetFlux_dCanWat)%dat(1) ) ! intent(out): [dp] derivative in net ground fluxes w.r.t. canopy total water content + dCanopyTrans_dCanWat =out_vegNrgFlux % dCanopyTrans_dCanWat ! intent(out): derivative in canopy transpiration w.r.t. canopy total water content (s-1) + dCanopyTrans_dTCanair =out_vegNrgFlux % dCanopyTrans_dTCanair ! intent(out): derivative in canopy transpiration w.r.t. canopy air temperature (kg m-2 s-1 K-1) + dCanopyTrans_dTCanopy =out_vegNrgFlux % dCanopyTrans_dTCanopy ! intent(out): derivative in canopy transpiration w.r.t. canopy temperature (kg m-2 s-1 K-1) + dCanopyTrans_dTGround =out_vegNrgFlux % dCanopyTrans_dTGround ! intent(out): derivative in canopy transpiration w.r.t. ground temperature (kg m-2 s-1 K-1) + dCanopyNetFlux_dCanWat =out_vegNrgFlux % dCanopyNetFlux_dCanWat! intent(out): derivative in net canopy fluxes w.r.t. canopy total water content (J kg-1 s-1) + dGroundNetFlux_dCanWat =out_vegNrgFlux % dGroundNetFlux_dCanWat! intent(out): derivative in net ground fluxes w.r.t. canopy total water content (J kg-1 s-1) + end associate + + ! intent(out) arguments: error control + err =out_vegNrgFlux % err ! intent(out): error code + cmessage =out_vegNrgFlux % cmessage ! intent(out): error message + end subroutine finalize_out_vegNrgFlux + ! **** end vegNrgFlux **** + + ! **** ssdNrgFlux **** + subroutine initialize_in_ssdNrgFlux(in_ssdNrgFlux,scalarSolution,firstFluxCall,mLayerTempTrial,flux_data,deriv_data) + class(in_type_ssdNrgFlux),intent(out) :: in_ssdNrgFlux ! class object for intent(in) ssdNrgFlux arguments + logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution + logical(lgt),intent(in) :: firstFluxCall ! flag to indicate if we are processing the first flux call + real(rkind),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) + type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(in) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + associate(& + scalarGroundNetNrgFlux => flux_data%var(iLookFLUX%scalarGroundNetNrgFlux)%dat(1), & ! intent(out): [dp] net energy flux for the ground surface (W m-2) + iLayerLiqFluxSnow => flux_data%var(iLookFLUX%iLayerLiqFluxSnow)%dat, & ! intent(out): [dp(0:)] vertical liquid water flux at snow layer interfaces (-) + iLayerLiqFluxSoil => flux_data%var(iLookFLUX%iLayerLiqFluxSoil)%dat, & ! intent(out): [dp(0:)] vertical liquid water flux at soil layer interfaces (-) + dThermalC_dWatAbove => deriv_data%var(iLookDERIV%dThermalC_dWatAbove)%dat, & ! intent(in): [dp(:)] derivative in the thermal conductivity w.r.t. water state in the layer above + dThermalC_dWatBelow => deriv_data%var(iLookDERIV%dThermalC_dWatBelow)%dat, & ! intent(in): [dp(:)] derivative in the thermal conductivity w.r.t. water state in the layer above + dThermalC_dTempAbove => deriv_data%var(iLookDERIV%dThermalC_dTempAbove)%dat, & ! intent(in): [dp(:)] derivative in the thermal conductivity w.r.t. energy state in the layer above + dThermalC_dTempBelow => deriv_data%var(iLookDERIV%dThermalC_dTempBelow)%dat ) ! intent(in): [dp(:)] derivative in the thermal conductivity w.r.t. energy state in the layer above + ! intent(in) arguments + in_ssdNrgFlux % scalarSolution=scalarSolution .and. .not.firstFluxCall ! intent(in): flag to denote if implementing the scalar solution + in_ssdNrgFlux % scalarGroundNetNrgFlux=scalarGroundNetNrgFlux ! intent(in): net energy flux for the ground surface (W m-2) + in_ssdNrgFlux % iLayerLiqFluxSnow=iLayerLiqFluxSnow ! intent(in): liquid flux at the interface of each snow layer (m s-1) + in_ssdNrgFlux % iLayerLiqFluxSoil=iLayerLiqFluxSoil ! intent(in): liquid flux at the interface of each soil layer (m s-1) + in_ssdNrgFlux % mLayerTempTrial=mLayerTempTrial ! intent(in): temperature in each layer at the current iteration (m) + in_ssdNrgFlux % dThermalC_dWatAbove=dThermalC_dWatAbove ! intent(in): derivative in the thermal conductivity w.r.t. water state in the layer above + in_ssdNrgFlux % dThermalC_dWatBelow=dThermalC_dWatBelow ! intent(in): derivative in the thermal conductivity w.r.t. water state in the layer above + in_ssdNrgFlux % dThermalC_dTempAbove=dThermalC_dTempAbove ! intent(in): derivative in the thermal conductivity w.r.t. energy state in the layer above + in_ssdNrgFlux % dThermalC_dTempBelow=dThermalC_dTempBelow ! intent(in): derivative in the thermal conductivity w.r.t. energy state in the layer above + end associate + end subroutine initialize_in_ssdNrgFlux + + subroutine initialize_io_ssdNrgFlux(io_ssdNrgFlux,deriv_data) + class(io_type_ssdNrgFlux),intent(out) :: io_ssdNrgFlux ! class object for intent(inout) ssdNrgFlux arguments + type(var_dlength),intent(in) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + associate(& + dGroundNetFlux_dGroundTemp => deriv_data%var(iLookDERIV%dGroundNetFlux_dGroundTemp)%dat(1) ) ! intent(out): [dp] derivative in net ground flux w.r.t. ground temperature + ! intent(inout) arguments + io_ssdNrgFlux % dGroundNetFlux_dGroundTemp=dGroundNetFlux_dGroundTemp ! intent(inout): derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) + end associate + end subroutine initialize_io_ssdNrgFlux + + subroutine finalize_io_ssdNrgFlux(io_ssdNrgFlux,deriv_data) + class(io_type_ssdNrgFlux),intent(in) :: io_ssdNrgFlux ! class object for intent(inout) ssdNrgFlux arguments + type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + associate(& + dGroundNetFlux_dGroundTemp => deriv_data%var(iLookDERIV%dGroundNetFlux_dGroundTemp)%dat(1) ) ! intent(out): [dp] derivative in net ground flux w.r.t. ground temperature + ! intent(inout) arguments + dGroundNetFlux_dGroundTemp=io_ssdNrgFlux % dGroundNetFlux_dGroundTemp ! intent(inout): derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) + end associate + end subroutine finalize_io_ssdNrgFlux + + subroutine finalize_out_ssdNrgFlux(out_ssdNrgFlux,flux_data,deriv_data,err,cmessage) + class(out_type_ssdNrgFlux),intent(in) :: out_ssdNrgFlux ! class object for intent(out) ssdNrgFlux arguments + type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: cmessage ! error message from ssdNrgFlux + associate(& + iLayerNrgFlux => flux_data%var(iLookFLUX%iLayerNrgFlux)%dat, & ! intent(out): [dp(0:)] vertical energy flux at the interface of snow and soil layers + dNrgFlux_dTempAbove => deriv_data%var(iLookDERIV%dNrgFlux_dTempAbove)%dat, & ! intent(out): [dp(:)] derivatives in the flux w.r.t. temperature in the layer above + dNrgFlux_dTempBelow => deriv_data%var(iLookDERIV%dNrgFlux_dTempBelow)%dat, & ! intent(out): [dp(:)] derivatives in the flux w.r.t. temperature in the layer below + dNrgFlux_dWatAbove => deriv_data%var(iLookDERIV%dNrgFlux_dWatAbove)%dat, & ! intent(out): [dp(:)] derivatives in the flux w.r.t. water state in the layer above + dNrgFlux_dWatBelow => deriv_data%var(iLookDERIV%dNrgFlux_dWatBelow)%dat ) ! intent(out): [dp(:)] derivatives in the flux w.r.t. water state in the layer below + ! intent(out) arguments + iLayerNrgFlux =out_ssdNrgFlux % iLayerNrgFlux ! intent(out): energy flux at the layer interfaces (W m-2) + dNrgFlux_dTempAbove=out_ssdNrgFlux % dNrgFlux_dTempAbove ! intent(out): derivatives in the flux w.r.t. temperature in the layer above (J m-2 s-1 K-1) + dNrgFlux_dTempBelow=out_ssdNrgFlux % dNrgFlux_dTempBelow ! intent(out): derivatives in the flux w.r.t. temperature in the layer below (J m-2 s-1 K-1) + dNrgFlux_dWatAbove =out_ssdNrgFlux % dNrgFlux_dWatAbove ! intent(out): derivatives in the flux w.r.t. water state in the layer above (J m-2 s-1 K-1) + dNrgFlux_dWatBelow =out_ssdNrgFlux % dNrgFlux_dWatBelow ! intent(out): derivatives in the flux w.r.t. water state in the layer below (J m-2 s-1 K-1) + err =out_ssdNrgFlux % err ! intent(out): error code + cmessage =out_ssdNrgFlux % cmessage ! intent(out): error message + end associate + end subroutine finalize_out_ssdNrgFlux + ! **** end ssdNrgFlux **** + + ! **** vegLiqFlux **** + subroutine initialize_in_vegLiqFlux(in_vegLiqFlux,computeVegFlux,scalarCanopyLiqTrial,flux_data) + class(in_type_vegLiqFlux),intent(out) :: in_vegLiqFlux ! class object for intent(in) vegLiqFlux arguments + logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation + real(rkind),intent(in) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) + type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU + associate(scalarRainfall => flux_data%var(iLookFLUX%scalarRainfall)%dat(1)) ! intent(in): [dp] rainfall rate (kg m-2 s-1) + ! intent(in) arguments + in_vegLiqFlux % computeVegFlux =computeVegFlux ! intent(in): flag to denote if computing energy flux over vegetation + in_vegLiqFlux % scalarCanopyLiqTrial=scalarCanopyLiqTrial ! intent(in): trial mass of liquid water on the vegetation canopy at the current iteration (kg m-2) + in_vegLiqFlux % scalarRainfall =scalarRainfall ! intent(in): rainfall rate (kg m-2 s-1) + end associate + end subroutine initialize_in_vegLiqFlux + + subroutine finalize_out_vegLiqFlux(out_vegLiqFlux,flux_data,deriv_data,err,cmessage) + class(out_type_vegLiqFlux),intent(in) :: out_vegLiqFlux ! class object for intent(out) vegLiqFlux arguments + type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: cmessage ! error message from vegLiqFlux + associate( & + scalarThroughfallRain => flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1), & ! intent(out): [dp] rain that reaches the ground without ever touching the canopy (kg m-2 s-1) + scalarCanopyLiqDrainage => flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1), & ! intent(out): [dp] drainage of liquid water from the vegetation canopy (kg m-2 s-1) + scalarThroughfallRainDeriv => deriv_data%var(iLookDERIV%scalarThroughfallRainDeriv )%dat(1),& ! intent(out): [dp] derivative in throughfall w.r.t. canopy liquid water + scalarCanopyLiqDrainageDeriv => deriv_data%var(iLookDERIV%scalarCanopyLiqDrainageDeriv)%dat(1) ) ! intent(out): [dp] derivative in canopy drainage w.r.t. canopy liquid water + ! intent(out) arguments + scalarThroughfallRain =out_vegLiqFlux % scalarThroughfallRain ! intent(out): rain that reaches the ground without ever touching the canopy (kg m-2 s-1) + scalarCanopyLiqDrainage =out_vegLiqFlux % scalarCanopyLiqDrainage ! intent(out): drainage of liquid water from the vegetation canopy (kg m-2 s-1) + scalarThroughfallRainDeriv =out_vegLiqFlux % scalarThroughfallRainDeriv ! intent(out): derivative in throughfall w.r.t. canopy liquid water (s-1) + scalarCanopyLiqDrainageDeriv=out_vegLiqFlux % scalarCanopyLiqDrainageDeriv! intent(out): derivative in canopy drainage w.r.t. canopy liquid water (s-1) + err =out_vegLiqFlux % err ! intent(out): error code + cmessage =out_vegLiqFlux % cmessage ! intent(out): error control + end associate + end subroutine finalize_out_vegLiqFlux + ! **** end vegLiqFlux **** + + ! **** snowLiqFlx **** + subroutine initialize_in_snowLiqFlx(in_snowLiqFlx,nSnow,firstFluxCall,scalarSolution,mLayerVolFracLiqTrial,flux_data) + class(in_type_snowLiqFlx),intent(out) :: in_snowLiqFlx ! class object for intent(in) snowLiqFlx arguments + integer(i4b),intent(in) :: nSnow ! number of snow layers + logical(lgt),intent(in) :: firstFluxCall ! flag to indicate if we are processing the first flux call + logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution + real(rkind),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) + type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU + associate(& + scalarThroughfallRain => flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1), & ! intent(out): [dp] rain that reaches the ground without ever touching the canopy (kg m-2 s-1) + scalarCanopyLiqDrainage => flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1)) ! intent(out): [dp] drainage of liquid water from the vegetation canopy (kg m-2 s-1) + ! intent(in) arguments + in_snowLiqFlx % nSnow =nSnow ! intent(in): number of snow layers + in_snowLiqFlx % firstFluxCall =firstFluxCall ! intent(in): the first flux call (compute variables that are constant over the iterations) + in_snowLiqFlx % scalarSolution =(scalarSolution .and. .not.firstFluxCall) ! intent(in): flag to indicate the scalar solution + in_snowLiqFlx % scalarThroughfallRain =scalarThroughfallRain ! intent(in): rain that reaches the snow surface without ever touching vegetation (kg m-2 s-1) + in_snowLiqFlx % scalarCanopyLiqDrainage=scalarCanopyLiqDrainage ! intent(in): liquid drainage from the vegetation canopy (kg m-2 s-1) + in_snowLiqFlx % mLayerVolFracLiqTrial =mLayerVolFracLiqTrial(1:nSnow) ! intent(in): trial value of volumetric fraction of liquid water at the current iteration (-) + end associate + end subroutine initialize_in_snowLiqFlx + + subroutine initialize_io_snowLiqFlx(io_snowLiqFlx,flux_data,deriv_data) + class(io_type_snowLiqFlx),intent(out) :: io_snowLiqFlx ! class object for intent(inout) snowLiqFlx arguments + type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(in) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + associate(& + iLayerLiqFluxSnow => flux_data%var(iLookFLUX%iLayerLiqFluxSnow)%dat, & ! intent(out): [dp(0:)] vertical liquid water flux at snow layer interfaces (-) + iLayerLiqFluxSnowDeriv => deriv_data%var(iLookDERIV%iLayerLiqFluxSnowDeriv)%dat ) ! intent(out): [dp(:)] derivative in vertical liquid water flux at layer interfaces + io_snowLiqFlx % iLayerLiqFluxSnow =iLayerLiqFluxSnow ! intent(inout): vertical liquid water flux at layer interfaces (m s-1) + io_snowLiqFlx % iLayerLiqFluxSnowDeriv =iLayerLiqFluxSnowDeriv ! intent(inout): derivative in vertical liquid water flux at layer interfaces (m s-1) + end associate + end subroutine initialize_io_snowLiqFlx + + subroutine finalize_io_snowLiqFlx(io_snowLiqFlx,flux_data,deriv_data) + class(io_type_snowLiqFlx),intent(in) :: io_snowLiqFlx ! class object for intent(inout) snowLiqFlx arguments + type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + associate(& + iLayerLiqFluxSnow => flux_data%var(iLookFLUX%iLayerLiqFluxSnow)%dat, & ! intent(out): [dp(0:)] vertical liquid water flux at snow layer interfaces (-) + iLayerLiqFluxSnowDeriv => deriv_data%var(iLookDERIV%iLayerLiqFluxSnowDeriv)%dat ) ! intent(out): [dp(:)] derivative in vertical liquid water flux at layer interfaces + ! intent(inout) arguments + iLayerLiqFluxSnow =io_snowLiqFlx % iLayerLiqFluxSnow ! intent(inout): vertical liquid water flux at layer interfaces (m s-1) + iLayerLiqFluxSnowDeriv=io_snowLiqFlx % iLayerLiqFluxSnowDeriv ! intent(inout): derivative in vertical liquid water flux at layer interfaces (m s-1) + end associate + end subroutine finalize_io_snowLiqFlx + + subroutine finalize_out_snowLiqFlx(out_snowLiqFlx,err,cmessage) + class(out_type_snowLiqFlx),intent(in) :: out_snowLiqFlx ! class object for intent(out) snowLiqFlx arguments + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: cmessage ! error message from snowLiqFlx + ! intent(out) arguments + err =out_snowLiqFlx % err ! intent(out): error code + cmessage=out_snowLiqFlx % cmessage ! intent(out): error message + end subroutine finalize_out_snowLiqFlx + ! **** end snowLiqFlx **** + + ! **** soilLiqFlx **** + subroutine initialize_in_soilLiqFlx(in_soilLiqFlx,nSnow,nSoil,nlayers,firstSplitOper,scalarSolution,firstFluxCall,scalarAquiferStorageTrial,& + mLayerTempTrial,mLayerMatricHeadTrial,mLayerMatricHeadLiqTrial,mLayerVolFracLiqTrial,mLayerVolFracIceTrial,& + flux_data,deriv_data) + class(in_type_soilLiqFlx),intent(out) :: in_soilLiqFlx ! class object for intent(in) soilLiqFlx arguments + integer(i4b),intent(in) :: nSnow ! number of snow layers + integer(i4b),intent(in) :: nSoil ! number of soil layers + integer(i4b),intent(in) :: nLayers ! total number of layers + logical(lgt),intent(in) :: firstSplitOper ! flag to indicate if we are processing the first flux call in a splitting operation + logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution + logical(lgt),intent(in) :: firstFluxCall ! flag to indicate if we are processing the first flux call + real(rkind),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) + real(rkind),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) + real(rkind),intent(in) :: mLayerMatricHeadTrial(:) ! trial value for the total water matric potential (m) + real(rkind),intent(in) :: mLayerMatricHeadLiqTrial(:) ! trial value for the liquid water matric potential (m) + real(rkind),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) + real(rkind),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) + type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(in) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + + ! intent(in) arguments: model control + in_soilLiqFlx % nSoil =nSoil ! intent(in): number of soil layers + in_soilLiqFlx % firstSplitOper=firstSplitOper ! intent(in): flag indicating first flux call in a splitting operation + in_soilLiqFlx % scalarSolution=(scalarSolution .and. .not.firstFluxCall) ! intent(in): flag to indicate the scalar solution + ! intent(in) arguments: aquifer variables needed for FUSE parameterizations + in_soilLiqFlx % scalarAquiferStorageTrial = scalarAquiferStorageTrial ! intent(in): trial value of aquifer storage (m) + + ! intent(in) arguments: trial temperature, matric potential, and volumetric fractions + in_soilLiqFlx % mLayerTempTrial=mLayerTempTrial(nSnow+1:nLayers) ! intent(in): trial temperature at the current iteration (K) + in_soilLiqFlx % mLayerMatricHeadTrial =mLayerMatricHeadTrial(1:nSoil) ! intent(in): matric potential (m) + in_soilLiqFlx % mLayerMatricHeadLiqTrial=mLayerMatricHeadLiqTrial(1:nSoil) ! intent(in): liquid water matric potential (m) + in_soilLiqFlx % mLayerVolFracLiqTrial=mLayerVolFracLiqTrial(nSnow+1:nLayers) ! intent(in): volumetric fraction of liquid water (-) + in_soilLiqFlx % mLayerVolFracIceTrial=mLayerVolFracIceTrial(nSnow+1:nLayers) ! intent(in): volumetric fraction of ice (-) + + ! intent(in) arguments: derivatives for liquid water + associate(& + mLayerdTheta_dTk => deriv_data%var(iLookDERIV%mLayerdTheta_dTk)%dat, & ! intent(in): [dp(:)] derivative of volumetric liquid water content w.r.t. temperature + dPsiLiq_dTemp => deriv_data%var(iLookDERIV%dPsiLiq_dTemp)%dat ) ! intent(in): [dp(:)] derivative in the liquid water matric potential w.r.t. temperature + in_soilLiqFlx % mLayerdTheta_dTk=mLayerdTheta_dTk(nSnow+1:nLayers) ! intent(in): derivative in volumetric liquid water content w.r.t. temperature (K-1) + in_soilLiqFlx % dPsiLiq_dTemp=dPsiLiq_dTemp(1:nSoil) ! intent(in): derivative in liquid water matric potential w.r.t. temperature (m K-1) + end associate + + ! intent(in) arguments: canopy transpiration derivatives + associate(& + dCanopyTrans_dCanWat => deriv_data%var(iLookDERIV%dCanopyTrans_dCanWat)%dat(1), & ! intent(out): [dp] derivative in canopy transpiration w.r.t. canopy total water content (s-1) + dCanopyTrans_dTCanair => deriv_data%var(iLookDERIV%dCanopyTrans_dTCanair)%dat(1), & ! intent(out): [dp] derivative in canopy transpiration w.r.t. canopy air temperature (kg m-2 s-1 K-1) + dCanopyTrans_dTCanopy => deriv_data%var(iLookDERIV%dCanopyTrans_dTCanopy)%dat(1), & ! intent(out): [dp] derivative in canopy transpiration w.r.t. canopy temperature (kg m-2 s-1 K-1) + dCanopyTrans_dTGround => deriv_data%var(iLookDERIV%dCanopyTrans_dTGround)%dat(1) ) ! intent(out): [dp] derivative in canopy transpiration w.r.t. ground temperature (kg m-2 s-1 K-1) + in_soilLiqFlx % dCanopyTrans_dCanWat =dCanopyTrans_dCanWat ! intent(in): derivative in canopy transpiration w.r.t. canopy total water content (s-1) + in_soilLiqFlx % dCanopyTrans_dTCanair =dCanopyTrans_dTCanair ! intent(in): derivative in canopy transpiration w.r.t. canopy air temperature (kg m-2 s-1 K-1) + in_soilLiqFlx % dCanopyTrans_dTCanopy =dCanopyTrans_dTCanopy ! intent(in): derivative in canopy transpiration w.r.t. canopy temperature (kg m-2 s-1 K-1) + in_soilLiqFlx % dCanopyTrans_dTGround =dCanopyTrans_dTGround ! intent(in): derivative in canopy transpiration w.r.t. ground temperature (kg m-2 s-1 K-1) + end associate + + ! intent(in) arguments: evaporative fluxes and rain plus melt + associate(& + scalarCanopyTranspiration => flux_data%var(iLookFLUX%scalarCanopyTranspiration)%dat(1), & ! intent(out): [dp] canopy transpiration (kg m-2 s-1) + scalarGroundEvaporation => flux_data%var(iLookFLUX%scalarGroundEvaporation)%dat(1), & ! intent(out): [dp] ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) + scalarRainPlusMelt => flux_data%var(iLookFLUX%scalarRainPlusMelt)%dat(1) ) ! intent(out): [dp] rain plus melt (m s-1) + in_soilLiqFlx % scalarCanopyTranspiration=scalarCanopyTranspiration ! intent(in): canopy transpiration (kg m-2 s-1) + in_soilLiqFlx % scalarGroundEvaporation =scalarGroundEvaporation ! intent(in): ground evaporation (kg m-2 s-1) + in_soilLiqFlx % scalarRainPlusMelt =scalarRainPlusMelt ! intent(in): rain plus melt (m s-1) + end associate + end subroutine initialize_in_soilLiqFlx + + subroutine initialize_io_soilLiqFlx(io_soilLiqFlx,nSoil,dHydCond_dMatric,flux_data,diag_data,deriv_data) + class(io_type_soilLiqFlx),intent(out) :: io_soilLiqFlx ! class object for intent(inout) soilLiqFlx arguments + integer(i4b),intent(in) :: nSoil ! number of soil layers + real(rkind),intent(in) :: dHydCond_dMatric(nSoil) ! derivative in hydraulic conductivity w.r.t matric head (s-1) + type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(in) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + + ! intent(inout) arguments: max infiltration rate, frozen area, and surface runoff + associate(& + scalarMaxInfilRate => flux_data%var(iLookFLUX%scalarMaxInfilRate)%dat(1), & ! intent(out): [dp] maximum infiltration rate (m s-1) + scalarInfilArea => diag_data%var(iLookDIAG%scalarInfilArea )%dat(1), & ! intent(out): [dp] fraction of area where water can infiltrate, may be frozen (-) + scalarSaturatedArea => diag_data%var(iLookDIAG%scalarSaturatedArea)%dat(1), & ! intent(out): [dp] fraction of area that is considered saturated (-) + scalarFrozenArea => diag_data%var(iLookDIAG%scalarFrozenArea )%dat(1), & ! intent(out): [dp] fraction of area that is considered impermeable due to soil ice (-) + scalarSoilControl => diag_data%var(iLookDIAG%scalarSoilControl )%dat(1), & ! intent(out): [dp] soil control on infiltration for derivative + scalarSurfaceRunoff => flux_data%var(iLookFLUX%scalarSurfaceRunoff)%dat(1), & ! intent(out): [dp] surface runoff (m s-1) + scalarSurfaceRunoff_IE => flux_data%var(iLookFLUX%scalarSurfaceRunoff_IE)%dat(1), & ! intent(out): [dp] infiltration excess surface runoff (m s-1) + scalarSurfaceRunoff_SE => flux_data%var(iLookFLUX%scalarSurfaceRunoff_SE)%dat(1) ) ! intent(out): [dp] saturation excess surface runoff (m s-1) + io_soilLiqFlx % scalarMaxInfilRate =scalarMaxInfilRate ! intent(inout): maximum infiltration rate (m s-1) + io_soilLiqFlx % scalarInfilArea =scalarInfilArea ! intent(inout): fraction of area where water can infiltrate, may be frozen (-) + io_soilLiqFlx % scalarSaturatedArea =scalarSaturatedArea ! intent(inout): fraction of area that is considered saturated (-) + io_soilLiqFlx % scalarFrozenArea =scalarFrozenArea ! intent(inout): fraction of area that is considered impermeable due to soil ice (-) + io_soilLiqFlx % scalarSoilControl =scalarSoilControl ! intent(inout): soil control on infiltration for derivative + io_soilLiqFlx % scalarSurfaceRunoff =scalarSurfaceRunoff ! intent(inout): surface runoff (m s-1) + io_soilLiqFlx % scalarSurfaceRunoff_IE =scalarSurfaceRunoff_IE ! intent(inout): infiltration excess surface runoff (m s-1) + io_soilLiqFlx % scalarSurfaceRunoff_SE =scalarSurfaceRunoff_SE ! intent(inout): saturation excess surface runoff (m s-1) + end associate + + ! intent(inout) arguments: derivatives, fluxes, and layer properties + associate(& + mLayerdTheta_dPsi => deriv_data%var(iLookDERIV%mLayerdTheta_dPsi)%dat, & ! intent(out): [dp(:)] derivative in the soil water characteristic w.r.t. psi + mLayerdPsi_dTheta => deriv_data%var(iLookDERIV%mLayerdPsi_dTheta)%dat, & ! intent(out): [dp(:)] derivative in the soil water characteristic w.r.t. theta + scalarInfiltration => flux_data%var(iLookFLUX%scalarInfiltration)%dat(1), & ! intent(out): [dp] infiltration of water into the soil profile (m s-1) + iLayerLiqFluxSoil => flux_data%var(iLookFLUX%iLayerLiqFluxSoil)%dat, & ! intent(out): [dp(0:)] vertical liquid water flux at soil layer interfaces (-) + mLayerTranspire => flux_data%var(iLookFLUX%mLayerTranspire)%dat, & ! intent(out): [dp(:)] transpiration loss from each soil layer (m s-1) + mLayerHydCond => flux_data%var(iLookFLUX%mLayerHydCond)%dat ) ! intent(out): [dp(:)] hydraulic conductivity in each soil layer (m s-1) + io_soilLiqFlx % mLayerdTheta_dPsi =mLayerdTheta_dPsi ! intent(inout): derivative in the soil water characteristic w.r.t. psi (m-1) + io_soilLiqFlx % mLayerdPsi_dTheta =mLayerdPsi_dTheta ! intent(inout): derivative in the soil water characteristic w.r.t. theta (m) + io_soilLiqFlx % dHydCond_dMatric =dHydCond_dMatric ! intent(inout): derivative in hydraulic conductivity w.r.t matric head (s-1) + io_soilLiqFlx % scalarInfiltration =scalarInfiltration ! intent(inout): surface infiltration rate (m s-1) -- controls on infiltration only computed for iter==1 + io_soilLiqFlx % iLayerLiqFluxSoil =iLayerLiqFluxSoil ! intent(inout): liquid fluxes at layer interfaces (m s-1) + io_soilLiqFlx % mLayerTranspire =mLayerTranspire ! intent(inout): transpiration loss from each soil layer (m s-1) + io_soilLiqFlx % mLayerHydCond =mLayerHydCond ! intent(inout): hydraulic conductivity in each layer (m s-1) + end associate + + ! intent(inout) arguments: flux and surface infiltration derivatives + associate(& + dq_dHydStateAbove => deriv_data%var(iLookDERIV%dq_dHydStateAbove)%dat, & ! intent(out): [dp(:)] change in flux at layer interfaces w.r.t. states in the layer above + dq_dHydStateBelow => deriv_data%var(iLookDERIV%dq_dHydStateBelow)%dat, & ! intent(out): [dp(:)] change in flux at layer interfaces w.r.t. states in the layer below + dq_dHydStateLayerSurfVec => deriv_data%var(iLookDERIV%dq_dHydStateLayerSurfVec)%dat, & ! intent(out): [dp(:)] change in the flux in soil surface interface w.r.t. state variables in layers + dq_dNrgStateAbove => deriv_data%var(iLookDERIV%dq_dNrgStateAbove)%dat, & ! intent(out): [dp(:)] change in flux at layer interfaces w.r.t. states in the layer above + dq_dNrgStateBelow => deriv_data%var(iLookDERIV%dq_dNrgStateBelow)%dat, & ! intent(out): [dp(:)] change in flux at layer interfaces w.r.t. states in the layer below + dq_dNrgStateLayerSurfVec => deriv_data%var(iLookDERIV%dq_dNrgStateLayerSurfVec)%dat ) ! intent(out): [dp(:)] change in the flux in soil surface interface w.r.t. state variables in layers + io_soilLiqFlx % dq_dHydStateAbove =dq_dHydStateAbove ! intent(inout): derivatives in the flux w.r.t. matric head in the layer above (s-1) + io_soilLiqFlx % dq_dHydStateBelow =dq_dHydStateBelow ! intent(inout): derivatives in the flux w.r.t. matric head in the layer below (s-1) + io_soilLiqFlx % dq_dHydStateLayerSurfVec=dq_dHydStateLayerSurfVec ! intent(inout): derivative in surface infiltration w.r.t. hydrology state in above soil snow or canopy and every soil layer (m s-1 or s-1) + io_soilLiqFlx % dq_dNrgStateAbove =dq_dNrgStateAbove ! intent(inout): derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) + io_soilLiqFlx % dq_dNrgStateBelow =dq_dNrgStateBelow ! intent(inout): derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) + io_soilLiqFlx % dq_dNrgStateLayerSurfVec=dq_dNrgStateLayerSurfVec ! intent(inout): derivative in surface infiltration w.r.t. energy state in above soil snow or canopy and every soil layer (m s-1 K-1) + end associate + + ! intent(inout) arguments: transpiration flux derivatives + associate(& + mLayerdTrans_dTCanair => deriv_data%var(iLookDERIV%mLayerdTrans_dTCanair)%dat, & ! intent(out): derivatives in the soil layer transpiration flux w.r.t. canopy air temperature + mLayerdTrans_dTCanopy => deriv_data%var(iLookDERIV%mLayerdTrans_dTCanopy)%dat, & ! intent(out): derivatives in the soil layer transpiration flux w.r.t. canopy temperature + mLayerdTrans_dTGround => deriv_data%var(iLookDERIV%mLayerdTrans_dTGround)%dat, & ! intent(out): derivatives in the soil layer transpiration flux w.r.t. ground temperature + mLayerdTrans_dCanWat => deriv_data%var(iLookDERIV%mLayerdTrans_dCanWat)%dat ) ! intent(out): derivatives in the soil layer transpiration flux w.r.t. canopy total water + io_soilLiqFlx % mLayerdTrans_dTCanair =mLayerdTrans_dTCanair ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. canopy air temperature + io_soilLiqFlx % mLayerdTrans_dTCanopy =mLayerdTrans_dTCanopy ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. canopy temperature + io_soilLiqFlx % mLayerdTrans_dTGround =mLayerdTrans_dTGround ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. ground temperature + io_soilLiqFlx % mLayerdTrans_dCanWat =mLayerdTrans_dCanWat ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. canopy total water + end associate + end subroutine initialize_io_soilLiqFlx + + subroutine finalize_io_soilLiqFlx(io_soilLiqFlx,nSoil,dHydCond_dMatric,flux_data,diag_data,deriv_data) + class(io_type_soilLiqFlx),intent(in) :: io_soilLiqFlx ! class object for intent(inout) soilLiqFlx arguments + integer(i4b),intent(in) :: nSoil ! number of soil layers + real(rkind),intent(out) :: dHydCond_dMatric(nSoil) ! derivative in hydraulic conductivity w.r.t matric head (s-1) + type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + + ! intent(inout) arguments: max infiltration rate, frozen area, and surface runoff + associate(& + scalarMaxInfilRate => flux_data%var(iLookFLUX%scalarMaxInfilRate)%dat(1), & ! intent(out): [dp] maximum infiltration rate (m s-1) + scalarInfilArea => diag_data%var(iLookDIAG%scalarInfilArea )%dat(1), & ! intent(out): [dp] fraction of area where water can infiltrate, may be frozen (-) + scalarSaturatedArea => diag_data%var(iLookDIAG%scalarSaturatedArea)%dat(1), & ! intent(out): [dp] fraction of area that is considered saturated (-) + scalarFrozenArea => diag_data%var(iLookDIAG%scalarFrozenArea )%dat(1), & ! intent(out): [dp] fraction of area that is considered impermeable due to soil ice (-) + scalarSoilControl => diag_data%var(iLookDIAG%scalarSoilControl )%dat(1), & ! intent(out): [dp] soil control on infiltration for derivative + scalarSurfaceRunoff => flux_data%var(iLookFLUX%scalarSurfaceRunoff)%dat(1), & ! intent(out): [dp] surface runoff (m s-1) + scalarSurfaceRunoff_IE => flux_data%var(iLookFLUX%scalarSurfaceRunoff_IE)%dat(1), & ! intent(out): [dp] infiltration excess surface runoff (m s-1) + scalarSurfaceRunoff_SE => flux_data%var(iLookFLUX%scalarSurfaceRunoff_SE)%dat(1) ) ! intent(out): [dp] saturation excess surface runoff (m s-1) + scalarMaxInfilRate =io_soilLiqFlx % scalarMaxInfilRate ! intent(inout): maximum infiltration rate (m s-1) + scalarInfilArea =io_soilLiqFlx % scalarInfilArea ! intent(inout): fraction of area where water can infiltrate, may be frozen (-) + scalarSaturatedArea =io_soilLiqFlx % scalarSaturatedArea ! intent(inout): fraction of area that is considered saturated (-) + scalarFrozenArea =io_soilLiqFlx % scalarFrozenArea ! intent(inout): fraction of area that is considered impermeable due to soil ice (-) + scalarSoilControl =io_soilLiqFlx % scalarSoilControl ! intent(inout): soil control on infiltration for derivative + scalarSurfaceRunoff =io_soilLiqFlx % scalarSurfaceRunoff ! intent(inout): surface runoff (m s-1) + scalarSurfaceRunoff_IE =io_soilLiqFlx % scalarSurfaceRunoff_IE ! intent(inout): infiltration excess surface runoff (m s-1) + scalarSurfaceRunoff_SE =io_soilLiqFlx % scalarSurfaceRunoff_SE ! intent(inout): saturation excess surface runoff (m s-1) + end associate + + ! intent(inout) arguments: derivatives, fluxes, and layer properties + associate(& + mLayerdTheta_dPsi => deriv_data%var(iLookDERIV%mLayerdTheta_dPsi)%dat, & ! intent(out): [dp(:)] derivative in the soil water characteristic w.r.t. psi + mLayerdPsi_dTheta => deriv_data%var(iLookDERIV%mLayerdPsi_dTheta)%dat, & ! intent(out): [dp(:)] derivative in the soil water characteristic w.r.t. theta + scalarInfiltration => flux_data%var(iLookFLUX%scalarInfiltration)%dat(1), & ! intent(out): [dp] infiltration of water into the soil profile (m s-1) + iLayerLiqFluxSoil => flux_data%var(iLookFLUX%iLayerLiqFluxSoil)%dat, & ! intent(out): [dp(0:)] vertical liquid water flux at soil layer interfaces (-) + mLayerTranspire => flux_data%var(iLookFLUX%mLayerTranspire)%dat, & ! intent(out): [dp(:)] transpiration loss from each soil layer (m s-1) + mLayerHydCond => flux_data%var(iLookFLUX%mLayerHydCond)%dat ) ! intent(out): [dp(:)] hydraulic conductivity in each soil layer (m s-1) + mLayerdTheta_dPsi =io_soilLiqFlx % mLayerdTheta_dPsi ! intent(inout): derivative in the soil water characteristic w.r.t. psi (m-1) + mLayerdPsi_dTheta =io_soilLiqFlx % mLayerdPsi_dTheta ! intent(inout): derivative in the soil water characteristic w.r.t. theta (m) + dHydCond_dMatric =io_soilLiqFlx % dHydCond_dMatric ! intent(inout): derivative in hydraulic conductivity w.r.t matric head (s-1) + scalarInfiltration =io_soilLiqFlx % scalarInfiltration ! intent(inout): surface infiltration rate (m s-1) -- controls on infiltration only computed for iter==1 + iLayerLiqFluxSoil =io_soilLiqFlx % iLayerLiqFluxSoil ! intent(inout): liquid fluxes at layer interfaces (m s-1) + mLayerTranspire =io_soilLiqFlx % mLayerTranspire ! intent(inout): transpiration loss from each soil layer (m s-1) + mLayerHydCond =io_soilLiqFlx % mLayerHydCond ! intent(inout): hydraulic conductivity in each layer (m s-1) + end associate + + ! intent(inout) arguments: flux and surface infiltration derivatives + associate(& + dq_dHydStateAbove => deriv_data%var(iLookDERIV%dq_dHydStateAbove)%dat, & ! intent(out): [dp(:)] change in flux at layer interfaces w.r.t. states in the layer above + dq_dHydStateBelow => deriv_data%var(iLookDERIV%dq_dHydStateBelow)%dat, & ! intent(out): [dp(:)] change in flux at layer interfaces w.r.t. states in the layer below + dq_dHydStateLayerSurfVec => deriv_data%var(iLookDERIV%dq_dHydStateLayerSurfVec)%dat, & ! intent(out): [dp(:)] change in the flux in soil surface interface w.r.t. state variables in layers + dq_dNrgStateAbove => deriv_data%var(iLookDERIV%dq_dNrgStateAbove)%dat, & ! intent(out): [dp(:)] change in flux at layer interfaces w.r.t. states in the layer above + dq_dNrgStateBelow => deriv_data%var(iLookDERIV%dq_dNrgStateBelow)%dat, & ! intent(out): [dp(:)] change in flux at layer interfaces w.r.t. states in the layer below + dq_dNrgStateLayerSurfVec => deriv_data%var(iLookDERIV%dq_dNrgStateLayerSurfVec)%dat ) ! intent(out): [dp(:)] change in the flux in soil surface interface w.r.t. state variables in layers + dq_dHydStateAbove =io_soilLiqFlx % dq_dHydStateAbove ! intent(inout): derivatives in the flux w.r.t. matric head in the layer above (s-1) + dq_dHydStateBelow =io_soilLiqFlx % dq_dHydStateBelow ! intent(inout): derivatives in the flux w.r.t. matric head in the layer below (s-1) + dq_dHydStateLayerSurfVec=io_soilLiqFlx % dq_dHydStateLayerSurfVec ! intent(inout): derivative in surface infiltration w.r.t. hydrology state in above soil snow or canopy and every soil layer (m s-1 or s-1) + dq_dNrgStateAbove =io_soilLiqFlx % dq_dNrgStateAbove ! intent(inout): derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) + dq_dNrgStateBelow =io_soilLiqFlx % dq_dNrgStateBelow ! intent(inout): derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) + dq_dNrgStateLayerSurfVec=io_soilLiqFlx % dq_dNrgStateLayerSurfVec ! intent(inout): derivative in surface infiltration w.r.t. energy state in above soil snow or canopy and every soil layer (m s-1 K-1) + end associate + + ! intent(inout) arguments: transpiration flux derivatives + associate(& + mLayerdTrans_dTCanair => deriv_data%var(iLookDERIV%mLayerdTrans_dTCanair)%dat, & ! intent(out): derivatives in the soil layer transpiration flux w.r.t. canopy air temperature + mLayerdTrans_dTCanopy => deriv_data%var(iLookDERIV%mLayerdTrans_dTCanopy)%dat, & ! intent(out): derivatives in the soil layer transpiration flux w.r.t. canopy temperature + mLayerdTrans_dTGround => deriv_data%var(iLookDERIV%mLayerdTrans_dTGround)%dat, & ! intent(out): derivatives in the soil layer transpiration flux w.r.t. ground temperature + mLayerdTrans_dCanWat => deriv_data%var(iLookDERIV%mLayerdTrans_dCanWat)%dat ) ! intent(out): derivatives in the soil layer transpiration flux w.r.t. canopy total water + mLayerdTrans_dTCanair =io_soilLiqFlx % mLayerdTrans_dTCanair ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. canopy air temperature + mLayerdTrans_dTCanopy =io_soilLiqFlx % mLayerdTrans_dTCanopy ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. canopy temperature + mLayerdTrans_dTGround =io_soilLiqFlx % mLayerdTrans_dTGround ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. ground temperature + mLayerdTrans_dCanWat =io_soilLiqFlx % mLayerdTrans_dCanWat ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. canopy total water + end associate + end subroutine finalize_io_soilLiqFlx + + subroutine finalize_out_soilLiqFlx(out_soilLiqFlx,err,cmessage) + class(out_type_soilLiqFlx),intent(in) :: out_soilLiqFlx ! class object for intent(out) soilLiqFlx arguments + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: cmessage ! error message from groundwatr + ! intent(out) arguments + err =out_soilLiqFlx % err ! intent(out): error code + cmessage =out_soilLiqFlx % cmessage ! intent(out): error message + end subroutine finalize_out_soilLiqFlx + ! **** end soilLiqFlx **** + + ! **** groundwatr **** + subroutine initialize_in_groundwatr(in_groundwatr,nSnow,nSoil,nLayers,firstFluxCall,mLayerVolFracLiqTrial,mLayerVolFracIceTrial,deriv_data) + class(in_type_groundwatr),intent(out) :: in_groundwatr ! class object for intent(in) groundwatr arguments + integer(i4b),intent(in) :: nSnow ! number of snow layers + integer(i4b),intent(in) :: nSoil ! number of soil layers + integer(i4b),intent(in) :: nLayers ! total number of layers + logical(lgt),intent(in) :: firstFluxCall ! logical flag to compute index of the lowest saturated layer + real(rkind),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) + real(rkind),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) + type(var_dlength),intent(in) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + + associate(& + mLayerdTheta_dPsi => deriv_data%var(iLookDERIV%mLayerdTheta_dPsi)%dat )! intent(out): [dp(:)] derivative in the soil water characteristic w.r.t. psi + ! intent(in) arguments + in_groundwatr % nSnow = nSnow ! intent(in): number of snow layers + in_groundwatr % nSoil = nSoil ! intent(in): number of soil layers + in_groundwatr % nLayers = nLayers ! intent(in): total number of layers + in_groundwatr % firstFluxCall = firstFluxCall ! intent(in): logical flag to compute index of the lowest saturated layer + in_groundwatr % mLayerdTheta_dPsi = mLayerdTheta_dPsi ! intent(in): derivative in the soil water characteristic w.r.t. matric head in each layer (m-1) + in_groundwatr % mLayerVolFracLiqTrial = mLayerVolFracLiqTrial(nSnow+1:nLayers) ! intent(in): volumetric fraction of liquid water (-) + in_groundwatr % mLayerVolFracIceTrial = mLayerVolFracIceTrial(nSnow+1:nLayers) ! intent(in): volumetric fraction of ice (-) + end associate + end subroutine initialize_in_groundwatr + + subroutine initialize_io_groundwatr(io_groundwatr,ixSaturation) + class(io_type_groundwatr),intent(out) :: io_groundwatr ! class object for intent(inout) groundwatr arguments + integer(i4b),intent(in) :: ixSaturation ! index of lowest saturated layer (NOTE: only computed on the first iteration) + ! intent(inout) arguments + io_groundwatr % ixSaturation = ixSaturation ! intent(inout): index of lowest saturated layer (NOTE: only computed on the first iteration) + end subroutine initialize_io_groundwatr + + subroutine finalize_io_groundwatr(io_groundwatr,ixSaturation) + class(io_type_groundwatr),intent(in) :: io_groundwatr ! class object for intent(inout) groundwatr arguments + integer(i4b),intent(out) :: ixSaturation ! index of lowest saturated layer (NOTE: only computed on the first iteration) + ! intent(inout) arguments + ixSaturation = io_groundwatr % ixSaturation ! intent(inout): index of lowest saturated layer (NOTE: only computed on the first iteration) + end subroutine finalize_io_groundwatr + + subroutine finalize_out_groundwatr(out_groundwatr,dBaseflow_dMatric,flux_data,err,cmessage) + class(out_type_groundwatr),intent(in) :: out_groundwatr ! class object for intent(out) groundwatr arguments + real(rkind),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: cmessage ! error message from groundwatr + associate(& + mLayerBaseflow => flux_data%var(iLookFLUX%mLayerBaseflow)%dat ) ! intent(out): [dp(:)] baseflow from each soil layer (m s-1) + ! intent(out) arguments + mLayerBaseflow = out_groundwatr % mLayerBaseflow ! intent(out): baseflow from each soil layer (m s-1) + dBaseflow_dMatric = out_groundwatr % dBaseflow_dMatric ! intent(out): derivative in baseflow w.r.t. matric head (s-1) + err = out_groundwatr % err ! intent(out): error code + cmessage = out_groundwatr % cmessage ! intent(out): error message + end associate + end subroutine finalize_out_groundwatr + ! **** end groundwatr **** + + ! **** bigAquifer **** + subroutine initialize_in_bigAquifer(in_bigAquifer,scalarAquiferStorageTrial,flux_data,deriv_data) + class(in_type_bigAquifer),intent(out) :: in_bigAquifer ! class object for intent(in) bigAquifer arguments + real(rkind),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) + type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(in) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + associate(& + scalarCanopyTranspiration => flux_data%var(iLookFLUX%scalarCanopyTranspiration)%dat(1), & ! intent(out): [dp] canopy transpiration (kg m-2 s-1) + scalarSoilDrainage => flux_data%var(iLookFLUX%scalarSoilDrainage)%dat(1), & ! intent(out): [dp] drainage from the soil profile (m s-1) + dCanopyTrans_dCanWat => deriv_data%var(iLookDERIV%dCanopyTrans_dCanWat)%dat(1), & ! intent(out): [dp] derivative in canopy transpiration w.r.t. canopy total water content (s-1) + dCanopyTrans_dTCanair => deriv_data%var(iLookDERIV%dCanopyTrans_dTCanair)%dat(1), & ! intent(out): [dp] derivative in canopy transpiration w.r.t. canopy air temperature (kg m-2 s-1 K-1) + dCanopyTrans_dTCanopy => deriv_data%var(iLookDERIV%dCanopyTrans_dTCanopy)%dat(1), & ! intent(out): [dp] derivative in canopy transpiration w.r.t. canopy temperature (kg m-2 s-1 K-1) + dCanopyTrans_dTGround => deriv_data%var(iLookDERIV%dCanopyTrans_dTGround)%dat(1) ) ! intent(out): [dp] derivative in canopy transpiration w.r.t. ground temperature (kg m-2 s-1 K-1) + ! intent(in) arguments + in_bigAquifer % scalarAquiferStorageTrial = scalarAquiferStorageTrial ! intent(in): trial value of aquifer storage (m) + in_bigAquifer % scalarCanopyTranspiration = scalarCanopyTranspiration ! intent(in): canopy transpiration (kg m-2 s-1) + in_bigAquifer % scalarSoilDrainage = scalarSoilDrainage ! intent(in): soil drainage (m s-1) + in_bigAquifer % dCanopyTrans_dCanWat = dCanopyTrans_dCanWat ! intent(in): derivative in canopy transpiration w.r.t. canopy total water content (s-1) + in_bigAquifer % dCanopyTrans_dTCanair = dCanopyTrans_dTCanair ! intent(in): derivative in canopy transpiration w.r.t. canopy air temperature (kg m-2 s-1 K-1) + in_bigAquifer % dCanopyTrans_dTCanopy = dCanopyTrans_dTCanopy ! intent(in): derivative in canopy transpiration w.r.t. canopy temperature (kg m-2 s-1 K-1) + in_bigAquifer % dCanopyTrans_dTGround = dCanopyTrans_dTGround ! intent(in): derivative in canopy transpiration w.r.t. ground temperature (kg m-2 s-1 K-1) + end associate + end subroutine initialize_in_bigAquifer + + subroutine initialize_io_bigAquifer(io_bigAquifer,deriv_data) + class(io_type_bigAquifer),intent(out) :: io_bigAquifer ! class object for intent(inout) bigAquifer arguments + type(var_dlength),intent(in) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + associate(& + dAquiferTrans_dTCanair => deriv_data%var(iLookDERIV%dAquiferTrans_dTCanair)%dat(1), & ! intent(out): derivatives in the aquifer transpiration flux w.r.t. canopy air temperature + dAquiferTrans_dTCanopy => deriv_data%var(iLookDERIV%dAquiferTrans_dTCanopy)%dat(1), & ! intent(out): derivatives in the aquifer transpiration flux w.r.t. canopy temperature + dAquiferTrans_dTGround => deriv_data%var(iLookDERIV%dAquiferTrans_dTGround)%dat(1), & ! intent(out): derivatives in the aquifer transpiration flux w.r.t. ground temperature + dAquiferTrans_dCanWat => deriv_data%var(iLookDERIV%dAquiferTrans_dCanWat)%dat(1) ) ! intent(out): derivatives in the aquifer transpiration flux w.r.t. canopy total water + ! intent(inout) arguments + io_bigAquifer % dAquiferTrans_dTCanair = dAquiferTrans_dTCanair ! intent(inout): derivatives in the aquifer transpiration flux w.r.t. canopy air temperature + io_bigAquifer % dAquiferTrans_dTCanopy = dAquiferTrans_dTCanopy ! intent(inout): derivatives in the aquifer transpiration flux w.r.t. canopy temperature + io_bigAquifer % dAquiferTrans_dTGround = dAquiferTrans_dTGround ! intent(inout): derivatives in the aquifer transpiration flux w.r.t. ground temperature + io_bigAquifer % dAquiferTrans_dCanWat = dAquiferTrans_dCanWat ! intent(inout): derivatives in the aquifer transpiration flux w.r.t. canopy total water + end associate + end subroutine initialize_io_bigAquifer + + subroutine finalize_io_bigAquifer(io_bigAquifer,deriv_data) + class(io_type_bigAquifer),intent(in) :: io_bigAquifer ! class object for intent(inout) bigAquifer arguments + type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + associate(& + dAquiferTrans_dTCanair => deriv_data%var(iLookDERIV%dAquiferTrans_dTCanair)%dat(1), & ! intent(out): derivatives in the aquifer transpiration flux w.r.t. canopy air temperature + dAquiferTrans_dTCanopy => deriv_data%var(iLookDERIV%dAquiferTrans_dTCanopy)%dat(1), & ! intent(out): derivatives in the aquifer transpiration flux w.r.t. canopy temperature + dAquiferTrans_dTGround => deriv_data%var(iLookDERIV%dAquiferTrans_dTGround)%dat(1), & ! intent(out): derivatives in the aquifer transpiration flux w.r.t. ground temperature + dAquiferTrans_dCanWat => deriv_data%var(iLookDERIV%dAquiferTrans_dCanWat)%dat(1) ) ! intent(out): derivatives in the aquifer transpiration flux w.r.t. canopy total water + ! intent(inout) arguments + dAquiferTrans_dTCanair = io_bigAquifer % dAquiferTrans_dTCanair ! intent(inout): derivatives in the aquifer transpiration flux w.r.t. canopy air temperature + dAquiferTrans_dTCanopy = io_bigAquifer % dAquiferTrans_dTCanopy ! intent(inout): derivatives in the aquifer transpiration flux w.r.t. canopy temperature + dAquiferTrans_dTGround = io_bigAquifer % dAquiferTrans_dTGround ! intent(inout): derivatives in the aquifer transpiration flux w.r.t. ground temperature + dAquiferTrans_dCanWat = io_bigAquifer % dAquiferTrans_dCanWat ! intent(inout): derivatives in the aquifer transpiration flux w.r.t. canopy total water + end associate + end subroutine finalize_io_bigAquifer + + subroutine finalize_out_bigAquifer(out_bigAquifer,flux_data,deriv_data,err,cmessage) + class(out_type_bigAquifer),intent(in) :: out_bigAquifer ! class object for intent(out) bigAquifer arguments + type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: cmessage ! error message from bigAquifer + associate(& + scalarAquiferTranspire => flux_data%var(iLookFLUX%scalarAquiferTranspire)%dat(1), & ! intent(out): [dp] transpiration loss from the aquifer (m s-1) + scalarAquiferRecharge => flux_data%var(iLookFLUX%scalarAquiferRecharge)%dat(1), & ! intent(out): [dp] recharge to the aquifer (m s-1) + scalarAquiferBaseflow => flux_data%var(iLookFLUX%scalarAquiferBaseflow)%dat(1), & ! intent(out): [dp] total baseflow from the aquifer (m s-1) + dBaseflow_dAquifer => deriv_data%var(iLookDERIV%dBaseflow_dAquifer)%dat(1) ) ! intent(out): [dp(:)] derivative in baseflow flux w.r.t. aquifer storage (s-1) + ! intent(out) arguments + scalarAquiferTranspire = out_bigAquifer % scalarAquiferTranspire ! intent(out): transpiration loss from the aquifer (m s-1) + scalarAquiferRecharge = out_bigAquifer % scalarAquiferRecharge ! intent(out): recharge to the aquifer (m s-1) + scalarAquiferBaseflow = out_bigAquifer % scalarAquiferBaseflow ! intent(out): total baseflow from the aquifer (m s-1) + dBaseflow_dAquifer = out_bigAquifer % dBaseflow_dAquifer ! intent(out): change in baseflow flux w.r.t. aquifer storage (s-1) + err = out_bigAquifer % err ! intent(out): error code + cmessage = out_bigAquifer % cmessage ! intent(out): error message + end associate + end subroutine finalize_out_bigAquifer + ! **** end bigAquifer **** + + ! **** diagv_node **** + subroutine initialize_in_diagv_node(in_diagv_node,iSoil,in_soilLiqFlx,model_decisions,diag_data,mpar_data,flux_data) + class(in_type_diagv_node),intent(out) :: in_diagv_node ! class object for input diagv_node variables + integer(i4b),intent(in) :: iSoil ! index of soil layer + type(in_type_soilLiqFlx),intent(in) :: in_soilLiqFlx ! input data for soilLiqFlx + type(model_options),intent(in) :: model_decisions(maxvarDecisions) ! the model decision structure + type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU + + associate(& + ! intent(in): model control + ixRichards => model_decisions(iLookDECISIONS%f_Richards)%iDecision,& ! index of the form of Richards' equation + ! intent(in): state variables + mLayerMatricHeadLiqTrial => in_soilLiqFlx % mLayerMatricHeadLiqTrial, & ! liquid matric head in each layer at the current iteration (m) + mLayerVolFracLiqTrial => in_soilLiqFlx % mLayerVolFracLiqTrial, & ! volumetric fraction of liquid water at the current iteration (-) + mLayerVolFracIceTrial => in_soilLiqFlx % mLayerVolFracIceTrial, & ! volumetric fraction of ice at the current iteration (-) + mLayerdTheta_dTk => in_soilLiqFlx % mLayerdTheta_dTk, & ! derivative in volumetric liquid water content w.r.t. temperature (K-1) + dPsiLiq_dTemp => in_soilLiqFlx % dPsiLiq_dTemp, & ! derivative in liquid water matric potential w.r.t. temperature (m K-1) + ! intent(in): van Genuchten and other soil parameters.. + vGn_alpha => mpar_data%var(iLookPARAM%vGn_alpha)%dat, & ! "alpha" parameter (m-1) + vGn_n => mpar_data%var(iLookPARAM%vGn_n)%dat, & ! "n" parameter (-) + vGn_m => diag_data%var(iLookDIAG%scalarVGn_m)%dat, & ! "m" parameter (-) + mpExp => mpar_data%var(iLookPARAM%mpExp)%dat(1), & ! empirical exponent in macropore flow equation (-) + theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat, & ! soil porosity (-) + theta_res => mpar_data%var(iLookPARAM%theta_res)%dat, & ! soil residual volumetric water content (-) + theta_mp => mpar_data%var(iLookPARAM%theta_mp)%dat(1), & ! volumetric liquid water content when macropore flow begins (-) + f_impede => mpar_data%var(iLookPARAM%f_impede)%dat(1), & ! ice impedence factor (-) + mLayerSatHydCond => flux_data%var(iLookFLUX%mLayerSatHydCond)%dat, & ! saturated hydraulic conductivity at the mid-point of each layer (m s-1) + mLayerSatHydCondMP => flux_data%var(iLookFLUX%mLayerSatHydCondMP)%dat & ! saturated hydraulic conductivity of macropores at the mid-point of each layer (m s-1) + &) + ! input: model control + in_diagv_node % ixRichards = ixRichards ! index defining the option for Richards' equation (moisture or mixdform) + ! input: state variables + in_diagv_node % scalarMatricHeadLiqTrial = mLayerMatricHeadLiqTrial(iSoil) ! liquid matric head in each layer (m) + in_diagv_node % scalarVolFracLiqTrial = mLayerVolFracLiqTrial(iSoil) ! volumetric fraction of liquid water in a given layer (-) + in_diagv_node % scalarVolFracIceTrial = mLayerVolFracIceTrial(iSoil) ! volumetric fraction of ice in a given layer (-) + in_diagv_node % dTheta_dTk = mLayerdTheta_dTk(iSoil) ! derivative in volumetric liquid water content w.r.t. temperature (K-1) + in_diagv_node % dPsiLiq_dTemp = dPsiLiq_dTemp(iSoil) ! derivative in liquid water matric potential w.r.t. temperature (m K-1) + ! input: soil parameters + in_diagv_node % vGn_alpha = vGn_alpha(iSoil) ! van Genuchten "alpha" parameter (m-1) + in_diagv_node % vGn_n = vGn_n(iSoil) ! van Genuchten "n" parameter (-) + in_diagv_node % vGn_m = vGn_m(iSoil) ! van Genuchten "m" parameter (-) + in_diagv_node % mpExp = mpExp ! empirical exponent in macropore flow equation (-) + in_diagv_node % theta_sat = theta_sat(iSoil) ! soil porosity (-) + in_diagv_node % theta_res = theta_res(iSoil) ! soil residual volumetric water content (-) + in_diagv_node % theta_mp = theta_mp ! volumetric liquid water content when macropore flow begins (-) + in_diagv_node % f_impede = f_impede ! ice impedence factor (-) + in_diagv_node % scalarSatHydCond = mLayerSatHydCond(iSoil) ! saturated hydraulic conductivity at the mid-point of a given layer (m s-1) + in_diagv_node % scalarSatHydCondMP = mLayerSatHydCondMP(iSoil) ! saturated hydraulic conductivity of macropores at the mid-point of a given layer (m s-1) + end associate + end subroutine initialize_in_diagv_node + + subroutine finalize_out_diagv_node(out_diagv_node,iSoil,nSoil,io_soilLiqFlx,mLayerDiffuse,iceImpedeFac,& + &dHydCond_dVolLiq,dDiffuse_dVolLiq,dHydCond_dTemp,err,cmessage) + class(out_type_diagv_node),intent(in) :: out_diagv_node ! class object for output diagv_node variables + integer(i4b),intent(in) :: nSoil,iSoil ! number of soil layers and index + type(io_type_soilLiqFlx),intent(inout) :: io_soilLiqFlx ! input-output class object for soilLiqFlx + real(rkind),intent(inout) :: mLayerDiffuse(1:nSoil) ! diffusivity at layer mid-point (m2 s-1) + real(rkind),intent(inout) :: iceImpedeFac(1:nSoil) ! ice impedence factor at layer mid-points (-) + real(rkind),intent(inout) :: dHydCond_dVolLiq(1:nSoil) ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) + real(rkind),intent(inout) :: dDiffuse_dVolLiq(1:nSoil) ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) + real(rkind),intent(inout) :: dHydCond_dTemp(1:nSoil) ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: cmessage ! error message + + associate(& + ! hydraulic conductivity and derivatives + mLayerdPsi_dTheta => io_soilLiqFlx % mLayerdPsi_dTheta, & ! derivative in the soil water characteristic w.r.t. theta (m) + mLayerdTheta_dPsi => io_soilLiqFlx % mLayerdTheta_dPsi, & ! derivative in the soil water characteristic w.r.t. psi (m-1) + mLayerHydCond => io_soilLiqFlx % mLayerHydCond, & ! hydraulic conductivity in each soil layer (m s-1) + dHydCond_dMatric => io_soilLiqFlx % dHydCond_dMatric & ! derivative in hydraulic conductivity w.r.t matric head (s-1) + &) + ! output: derivative in the soil water characteristic + mLayerdPsi_dTheta(iSoil) = out_diagv_node % scalardPsi_dTheta ! derivative in the soil water characteristic + mLayerdTheta_dPsi(iSoil) = out_diagv_node % scalardTheta_dPsi ! derivative in the soil water characteristic + ! output: transmittance + mLayerHydCond(iSoil) = out_diagv_node % scalarHydCond ! hydraulic conductivity at layer mid-points (m s-1) + mLayerDiffuse(iSoil) = out_diagv_node % scalarDiffuse ! diffusivity at layer mid-points (m2 s-1) + iceImpedeFac(iSoil) = out_diagv_node % iceImpedeFac ! ice impedence factor in each layer (-) + ! output: transmittance derivatives + dHydCond_dVolLiq(iSoil) = out_diagv_node % dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) + dDiffuse_dVolLiq(iSoil) = out_diagv_node % dDiffuse_dVolLiq ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) + dHydCond_dMatric(iSoil) = out_diagv_node % dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t matric head (m s-1) + dHydCond_dTemp(iSoil) = out_diagv_node % dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + ! output: error control + err = out_diagv_node % err ! error code + cmessage = out_diagv_node % message ! error message + end associate + end subroutine finalize_out_diagv_node + ! **** end diagv_node **** + + ! **** surfaceFlx **** + subroutine initialize_in_surfaceFlx(in_surfaceFlx,nRoots,ixIce,nSoil,ibeg,iend,in_soilLiqFlx,io_soilLiqFlx,& + &model_decisions,prog_data,mpar_data,flux_data,diag_data,& + &iLayerHeight,dHydCond_dTemp,iceImpedeFac) + class(in_type_surfaceFlx),intent(out) :: in_surfaceFlx ! input object for surfaceFlx + integer(i4b),intent(in) :: nRoots ! number of soil layers with roots + integer(i4b),intent(in) :: ixIce ! index of the lowest soil layer that contains ice + integer(i4b),intent(in) :: nSoil ! number of soil layers + integer(i4b),intent(in) :: ibeg,iend ! start and end indices of the soil layers in concatanated snow-soil vector + type(in_type_soilLiqFlx),intent(in) :: in_soilLiqFlx ! input data for soilLiqFlx + type(io_type_soilLiqFlx),intent(in) :: io_soilLiqFlx ! input-output class object for soilLiqFlx + type(model_options),intent(in) :: model_decisions(maxvarDecisions) ! the model decision structure + type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU + real(rkind),intent(in) :: iLayerHeight(0:nSoil) ! height of the layer interfaces (m) + real(rkind),intent(in) :: dHydCond_dTemp(1:nSoil) ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + real(rkind),intent(in) :: iceImpedeFac(1:nSoil) ! ice impedence factor at layer mid-points (-) + + associate(& + ! model control + firstSplitOper => in_soilLiqFlx % firstSplitOper, & ! flag to compute infiltration + ixRichards => model_decisions(iLookDECISIONS%f_Richards)%iDecision,& ! index of the form of Richards' equation + ixBcUpperSoilHydrology => model_decisions(iLookDECISIONS%bcUpprSoiH)%iDecision,& ! index defining the type of boundary conditions + ixInfRateMax => model_decisions(iLookDECISIONS%infRateMax)%iDecision,& ! index of the maximum infiltration rate parameterization + surfRun_SE => model_decisions(iLookDECISIONS%surfRun_SE)%iDecision & ! index defining the saturation excess surface runoff method + &) + ! intent(in): model control + in_surfaceFlx % firstSplitOper = firstSplitOper ! flag indicating if desire to compute infiltration + in_surfaceFlx % ixRichards = ixRichards ! index defining the form of Richards' equation (moisture or mixdform) + in_surfaceFlx % bc_upper = ixBcUpperSoilHydrology ! index defining the type of boundary conditions (Neumann or Dirichlet) + in_surfaceFlx % ixInfRateMax = ixInfRateMax ! index defining the maximum infiltration rate parameterization (GreenAmpt or topmodel_GA) + in_surfaceFlx % surfRun_SE = surfRun_SE ! index defining the saturation excess surface runoff method + in_surfaceFlx % nRoots = nRoots ! number of layers that contain roots + in_surfaceFlx % ixIce = ixIce ! index of lowest ice layer + in_surfaceFlx % nSoil = nSoil ! number of soil layers + end associate + + associate(& + ! state variables + mLayerTempTrial => in_soilLiqFlx % mLayerTempTrial, & ! intent(in): temperature in each layer at the current iteration (m) + mLayerMatricHeadLiqTrial => in_soilLiqFlx % mLayerMatricHeadLiqTrial, & ! liquid matric head in each layer at the current iteration (m) + mLayerMatricHeadTrial => in_soilLiqFlx % mLayerMatricHeadTrial, & ! intent(in): matric head in each layer at the current iteration (m) + mLayerVolFracLiqTrial => in_soilLiqFlx % mLayerVolFracLiqTrial, & ! volumetric fraction of liquid water at the current iteration (-) + mLayerVolFracIceTrial => in_soilLiqFlx % mLayerVolFracIceTrial, & ! volumetric fraction of ice at the current iteration (-) + scalarTotalSoilLiq => diag_data%var(iLookDIAG%scalarTotalSoilLiq)%dat(1) & ! total liquid water in the soil column (kg m-2) + &) + ! intent(in): state variables + in_surfaceFlx % mLayerTemp = mLayerTempTrial ! temperature (K) + in_surfaceFlx % scalarMatricHeadLiq = mLayerMatricHeadLiqTrial(1) ! liquid matric head in the upper-most soil layer (m) + in_surfaceFlx % mLayerMatricHead = mLayerMatricHeadTrial ! matric head in each soil layer (m) + in_surfaceFlx % scalarVolFracLiq = mLayerVolFracLiqTrial(1) ! volumetric liquid water content the upper-most soil layer (-) + in_surfaceFlx % scalarTotalSoilLiq = scalarTotalSoilLiq ! total liquid water in the soil column (kg m-2) + in_surfaceFlx % mLayerVolFracLiq = mLayerVolFracLiqTrial ! volumetric liquid water content in each soil layer (-) + in_surfaceFlx % mLayerVolFracIce = mLayerVolFracIceTrial ! volumetric ice content in each soil layer (-) + end associate + + associate(& + ! pre-computed derivatives + mLayerdTheta_dTk => in_soilLiqFlx % mLayerdTheta_dTk, & ! derivative in volumetric liquid water content w.r.t. temperature (K-1) + mLayerdTheta_dPsi => io_soilLiqFlx % mLayerdTheta_dPsi, & ! derivative in the soil water characteristic w.r.t. psi (m-1) + mLayerdPsi_dTheta => io_soilLiqFlx % mLayerdPsi_dTheta & ! derivative in the soil water characteristic w.r.t. theta (m) + &) + ! intent(in): pre-computed derivatives + in_surfaceFlx % dTheta_dTk = mLayerdTheta_dTk ! derivative in volumetric liquid water content w.r.t. temperature (K-1) + in_surfaceFlx % dTheta_dPsi = mLayerdTheta_dPsi ! derivative in the soil water characteristic w.r.t. psi (m-1) + in_surfaceFlx % mLayerdPsi_dTheta = mLayerdPsi_dTheta ! derivative in the soil water characteristic w.r.t. theta (m) + end associate + + associate(& + ! depth of each soil layer (m) + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat(ibeg:iend) & ! depth of the layer (m) + &) + ! intent(in): depth of each soil layer (m) + in_surfaceFlx % mLayerDepth = mLayerDepth ! depth of each soil layer (m) + in_surfaceFlx % iLayerHeight = iLayerHeight ! height at the interface of each layer (m) + end associate + + associate(& + ! boundary conditions + upperBoundHead => mpar_data%var(iLookPARAM%upperBoundHead)%dat(1), & ! upper boundary condition for matric head (m) + upperBoundTheta => mpar_data%var(iLookPARAM%upperBoundTheta)%dat(1) & ! upper boundary condition for volumetric liquid water content (-) + &) + ! intent(in): boundary conditions + in_surfaceFlx % upperBoundHead = upperBoundHead ! upper boundary condition (m) + in_surfaceFlx % upperBoundTheta = upperBoundTheta ! upper boundary condition (-) + end associate + + associate(& + ! flux at the upper boundary + scalarRainPlusMelt => in_soilLiqFlx % scalarRainPlusMelt & ! rain plus melt (m s-1) + &) + ! intent(in): flux at the upper boundary + in_surfaceFlx % scalarRainPlusMelt = scalarRainPlusMelt ! rain plus melt (m s-1) + end associate + + associate(& + ! transmittance + iLayerSatHydCond => flux_data%var(iLookFLUX%iLayerSatHydCond)%dat & ! saturated hydraulic conductivity at the interface of each layer (m s-1) + &) + ! intent(in): transmittance + in_surfaceFlx % surfaceSatHydCond = iLayerSatHydCond(0) ! saturated hydraulic conductivity at the surface (m s-1) + in_surfaceFlx % dHydCond_dTemp = dHydCond_dTemp(1) ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + in_surfaceFlx % iceImpedeFac = iceImpedeFac(1) ! ice impedence factor in the upper-most soil layer (-) + end associate + + associate(& + ! soil parameters + vGn_alpha => mpar_data%var(iLookPARAM%vGn_alpha)%dat, & ! "alpha" parameter (m-1) + vGn_n => mpar_data%var(iLookPARAM%vGn_n)%dat, & ! "n" parameter (-) + vGn_m => diag_data%var(iLookDIAG%scalarVGn_m)%dat, & ! "m" parameter (-) + theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat, & ! soil porosity (-) + theta_res => mpar_data%var(iLookPARAM%theta_res)%dat, & ! soil residual volumetric water content (-) + qSurfScale => mpar_data%var(iLookPARAM%qSurfScale)%dat(1), & ! scaling factor in the surface runoff parameterization (-) + zScale_TOPMODEL => mpar_data%var(iLookPARAM%zScale_TOPMODEL)%dat(1),& ! TOPMODEL scaling factor (m) + rootingDepth => mpar_data%var(iLookPARAM%rootingDepth)%dat(1), & ! rooting depth (m) + wettingFrontSuction => mpar_data%var(iLookPARAM%wettingFrontSuction)%dat(1),& ! Green-Ampt wetting front suction (m) + soilIceScale => mpar_data%var(iLookPARAM%soilIceScale)%dat(1),& ! scaling factor for depth of soil ice, used to get frozen fraction (m) + soilIceCV => mpar_data%var(iLookPARAM%soilIceCV)%dat(1) & ! CV of depth of soil ice, used to get frozen fraction (-) + &) + ! intent(in): soil parameters + in_surfaceFlx % vGn_alpha = vGn_alpha(1) ! van Genuchten "alpha" parameter (m-1) + in_surfaceFlx % vGn_n = vGn_n(1) ! van Genuchten "n" parameter (-) + in_surfaceFlx % vGn_m = vGn_m(1) ! van Genuchten "m" parameter (-) + in_surfaceFlx % theta_sat = theta_sat(1) ! soil porosity (-) + in_surfaceFlx % theta_res = theta_res(1) ! soil residual volumetric water content (-) + in_surfaceFlx % qSurfScale = qSurfScale ! scaling factor in the surface runoff parameterization (-) + in_surfaceFlx % zScale_TOPMODEL = zScale_TOPMODEL ! scaling factor used to describe decrease in hydraulic conductivity with depth (m) + in_surfaceFlx % rootingDepth = rootingDepth ! rooting depth (m) + in_surfaceFlx % wettingFrontSuction = wettingFrontSuction ! Green-Ampt wetting front suction (m) + in_surfaceFlx % soilIceScale = soilIceScale ! soil ice scaling factor in Gamma distribution used to define frozen area (m) + in_surfaceFlx % soilIceCV = soilIceCV ! soil ice CV in Gamma distribution used to define frozen area (-) + end associate + + ! intent(in): FUSE parameters + associate(& + FUSE_Ac_max => mpar_data%var(iLookPARAM%FUSE_Ac_max )%dat(1), & ! FUSE PRMS max saturated area + FUSE_phi_tens => mpar_data%var(iLookPARAM%FUSE_phi_tens)%dat(1), & ! FUSE PRMS tension fraction + FUSE_b => mpar_data%var(iLookPARAM%FUSE_b )%dat(1), & ! FUSE ARNO/VIC exponent + FUSE_lambda => mpar_data%var(iLookPARAM%FUSE_lambda )%dat(1), & ! FUSE TOPMODEL gamma distribution lambda parameter + FUSE_chi => mpar_data%var(iLookPARAM%FUSE_chi )%dat(1), & ! FUSE TOPMODEL chi distribution lambda parameter + FUSE_mu => mpar_data%var(iLookPARAM%FUSE_mu )%dat(1), & ! FUSE TOPMODEL mu distribution lambda parameter + FUSE_n => mpar_data%var(iLookPARAM%FUSE_n )%dat(1) & ! FUSE TOPMODEL exponent + &) + in_surfaceFlx % FUSE_Ac_max = FUSE_Ac_max ! FUSE PRMS max saturated area + in_surfaceFlx % FUSE_phi_tens = FUSE_phi_tens ! FUSE PRMS tension fraction + in_surfaceFlx % FUSE_b = FUSE_b ! FUSE ARNO/VIC exponent + in_surfaceFlx % FUSE_lambda = FUSE_lambda ! FUSE TOPMODEL gamma distribution lambda parameter + in_surfaceFlx % FUSE_chi = FUSE_chi ! FUSE TOPMODEL chi distribution lambda parameter + in_surfaceFlx % FUSE_mu = FUSE_mu ! FUSE TOPMODEL mu distribution lambda parameter + in_surfaceFlx % FUSE_n = FUSE_n ! FUSE TOPMODEL exponent + end associate + end subroutine initialize_in_surfaceFlx + + subroutine initialize_io_surfaceFlx(io_surfaceFlx,nSoil,io_soilLiqFlx,iLayerHydCond,iLayerDiffuse) + class(io_type_surfaceFlx),intent(out) :: io_surfaceFlx ! input-output object for surfaceFlx + integer(i4b),intent(in) :: nSoil ! number of soil layers + type(io_type_soilLiqFlx),intent(in) :: io_soilLiqFlx ! input-output class object for soilLiqFlx + real(rkind),intent(in) :: iLayerHydCond(0:nSoil) ! hydraulic conductivity at layer interface (m s-1) + real(rkind),intent(in) :: iLayerDiffuse(0:nSoil) ! diffusivity at layer interface (m2 s-1) + + associate(& + ! fluxes at layer interfaces and surface runoff + xMaxInfilRate => io_soilLiqFlx % scalarMaxInfilRate, & ! maximum infiltration rate (m s-1) + scalarInfilArea => io_soilLiqFlx % scalarInfilArea, & ! fraction of area where water can infiltrate, may be frozen (-) + scalarSaturatedArea => io_soilLiqFlx % scalarSaturatedArea, & ! fraction of area that is considered saturated (-) + scalarFrozenArea => io_soilLiqFlx % scalarFrozenArea, & ! fraction of area that is considered impermeable due to soil ice (-) + scalarSoilControl => io_soilLiqFlx % scalarSoilControl & ! soil control on infiltration for derivative + &) + ! intent(inout): hydraulic conductivity and diffusivity at the surface + io_surfaceFlx % surfaceHydCond = iLayerHydCond(0) ! hydraulic conductivity at the surface (m s-1) + io_surfaceFlx % surfaceDiffuse = iLayerDiffuse(0) ! hydraulic diffusivity at the surface (m2 s-1) + ! intent(inout): fluxes at layer interfaces and surface runoff + io_surfaceFlx % xMaxInfilRate = xMaxInfilRate ! maximum infiltration rate (m s-1) + io_surfaceFlx % scalarInfilArea = scalarInfilArea ! fraction of area where water can infiltrate, may be frozen (-) + io_surfaceFlx % scalarSaturatedArea = scalarSaturatedArea ! fraction of area that is considered saturated (-) + io_surfaceFlx % scalarFrozenArea = scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) + io_surfaceFlx % scalarSoilControl = scalarSoilControl ! soil control on infiltration for derivative + end associate + end subroutine initialize_io_surfaceFlx + + subroutine finalize_io_surfaceFlx(io_surfaceFlx,nSoil,io_soilLiqFlx,iLayerHydCond,iLayerDiffuse) + class(io_type_surfaceFlx),intent(in) :: io_surfaceFlx ! input-output object for surfaceFlx + integer(i4b),intent(in) :: nSoil ! number of soil layers + type(io_type_soilLiqFlx),intent(inout) :: io_soilLiqFlx ! input-output class object for soilLiqFlx + real(rkind),intent(inout) :: iLayerHydCond(0:nSoil) ! hydraulic conductivity at layer interface (m s-1) + real(rkind),intent(inout) :: iLayerDiffuse(0:nSoil) ! diffusivity at layer interface (m2 s-1) + + associate(& + ! fluxes at layer interfaces and surface runoff + xMaxInfilRate => io_soilLiqFlx % scalarMaxInfilRate, & ! maximum infiltration rate (m s-1) + scalarInfilArea => io_soilLiqFlx % scalarInfilArea, & ! fraction of area where water can infiltrate, may be frozen (-) + scalarSaturatedArea => io_soilLiqFlx % scalarSaturatedArea, & ! fraction of area that is considered saturated (-) + scalarFrozenArea => io_soilLiqFlx % scalarFrozenArea, & ! fraction of area that is considered impermeable due to soil ice (-) + scalarSoilControl => io_soilLiqFlx % scalarSoilControl & ! soil control on infiltration for derivative + &) + ! intent(inout): hydraulic conductivity and diffusivity at the surface + iLayerHydCond(0) = io_surfaceFlx % surfaceHydCond ! hydraulic conductivity at the surface (m s-1) + iLayerDiffuse(0) = io_surfaceFlx % surfaceDiffuse ! hydraulic diffusivity at the surface (m2 s-1) + ! intent(inout): fluxes at layer interfaces and surface runoff + xMaxInfilRate = io_surfaceFlx % xMaxInfilRate ! maximum infiltration rate (m s-1) + scalarInfilArea = io_surfaceFlx % scalarInfilArea ! fraction of area where water can infiltrate, may be frozen (-) + scalarSaturatedArea = io_surfaceFlx % scalarSaturatedArea ! fraction of area that is considered saturated (-) + scalarFrozenArea = io_surfaceFlx % scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) + scalarSoilControl = io_surfaceFlx % scalarSoilControl ! soil control on infiltration for derivative + end associate + end subroutine finalize_io_surfaceFlx + + subroutine finalize_out_surfaceFlx(out_surfaceFlx,io_soilLiqFlx,err,message) + class(out_type_surfaceFlx),intent(in) :: out_surfaceFlx ! output object for surfaceFlx + type(io_type_soilLiqFlx),intent(inout) :: io_soilLiqFlx ! input-output class object for soilLiqFlx + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + + associate(& + ! intent(out): surface runoff and infiltration + scalarSurfaceRunoff => io_soilLiqFlx % scalarSurfaceRunoff, & ! surface runoff (m s-1) + scalarSurfaceRunoff_IE => io_soilLiqFlx % scalarSurfaceRunoff_IE, & ! infiltration excess surface runoff (m s-1) + scalarSurfaceRunoff_SE => io_soilLiqFlx % scalarSurfaceRunoff_SE, & ! saturation excess surface runoff (m s-1) + scalarSurfaceInfiltration => io_soilLiqFlx % scalarInfiltration, & ! surface infiltration rate (m s-1) + ! intent(inout): derivatives in surface infiltration in the upper-most soil layer w.r.t ... + dq_dHydStateLayerSurfVec => io_soilLiqFlx % dq_dHydStateLayerSurfVec, & ! ... hydrology state above soil snow or canopy and every soil layer (m s-1 or s-1) + dq_dNrgStateLayerSurfVec => io_soilLiqFlx % dq_dNrgStateLayerSurfVec & ! ... temperature above soil snow or canopy and every soil layer (m s-1 or s-1) + &) + ! intent(out): surface runoff and infiltration + scalarSurfaceRunoff = out_surfaceFlx % scalarSurfaceRunoff ! surface runoff (m s-1) + scalarSurfaceRunoff_IE = out_surfaceFlx % scalarSurfaceRunoff_IE ! infiltration excess surface runoff (m s-1) + scalarSurfaceRunoff_SE = out_surfaceFlx % scalarSurfaceRunoff_SE ! saturation excess surface runoff (m s-1) + scalarSurfaceInfiltration = out_surfaceFlx % scalarSurfaceInfiltration ! surface infiltration (m s-1) + ! intent(inout): derivatives in surface infiltration in the upper-most soil layer w.r.t. ... + dq_dHydStateLayerSurfVec = out_surfaceFlx % dq_dHydStateVec ! ... hydrology state in above soil snow or canopy and every soil layer (m s-1 or s-1) + dq_dNrgStateLayerSurfVec = out_surfaceFlx % dq_dNrgStateVec ! ... energy state in above soil snow or canopy and every soil layer (m s-1 K-1) + end associate + ! intent(out): error control + err = out_surfaceFlx % err ! error code + message = out_surfaceFlx % message ! error message + end subroutine finalize_out_surfaceFlx + ! **** end surfaceFlx **** + + ! **** iLayerFlux **** + subroutine initialize_in_iLayerFlux(in_iLayerFlux,iLayer,nSoil,ibeg,iend,in_soilLiqFlx,io_soilLiqFlx,model_decisions,& + &prog_data,mLayerDiffuse,dHydCond_dTemp,dHydCond_dVolLiq,dDiffuse_dVolLiq) + class(in_type_iLayerFlux),intent(out) :: in_iLayerFlux ! class object for input iLayerFlux variables + integer(i4b),intent(in) :: nSoil,iLayer ! number of soil layers and index + integer(i4b),intent(in) :: ibeg,iend ! start and end indices of the soil layers in concatanated snow-soil vector + type(in_type_soilLiqFlx),intent(in) :: in_soilLiqFlx ! input class object for soilLiqFlx + type(io_type_soilLiqFlx),intent(in) :: io_soilLiqFlx ! input-output class object for soilLiqFlx + type(model_options),intent(in) :: model_decisions(maxvarDecisions) ! the model decision structure + type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU + real(rkind),intent(in) :: mLayerDiffuse(1:nSoil) ! diffusivity at layer mid-point (m2 s-1) + real(rkind),intent(in) :: dHydCond_dTemp(1:nSoil) ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + real(rkind),intent(in) :: dHydCond_dVolLiq(1:nSoil) ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) + real(rkind),intent(in) :: dDiffuse_dVolLiq(1:nSoil) ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) + + associate(& + ! intent(in): model control + ixRichards => model_decisions(iLookDECISIONS%f_Richards)%iDecision,& ! index of the form of Richards' equation + ! intent(in): state variables (adjacent layers) + mLayerMatricHeadLiqTrial => in_soilLiqFlx % mLayerMatricHeadLiqTrial, & ! liquid matric head in each layer at the current iteration (m) + mLayerVolFracLiqTrial => in_soilLiqFlx % mLayerVolFracLiqTrial, & ! volumetric fraction of liquid water at the current iteration (-) + ! intent(in): model coordinate variables (adjacent layers) + mLayerHeight => prog_data%var(iLookPROG%mLayerHeight)%dat(ibeg:iend), & ! height of the layer mid-point (m) + ! intent(in): temperature derivatives + dPsiLiq_dTemp => in_soilLiqFlx % dPsiLiq_dTemp, & ! derivative in liquid water matric potential w.r.t. temperature (m K-1) + ! intent(in): transmittance (adjacent layers) + mLayerHydCond => io_soilLiqFlx % mLayerHydCond, & ! hydraulic conductivity in each soil layer (m s-1) + ! intent(in): transmittance derivatives (adjacent layers) + dHydCond_dMatric => io_soilLiqFlx % dHydCond_dMatric & ! derivative in hydraulic conductivity w.r.t matric head (s-1) + &) + ! intent(in): model control + in_iLayerFlux % ixRichards = ixRichards ! index defining the form of Richards' equation (moisture or mixdform) + ! intent(in): state variables (adjacent layers) + in_iLayerFlux % nodeMatricHeadLiqTrial = mLayerMatricHeadLiqTrial(iLayer:iLayer+1) ! liquid matric head at the soil nodes (m) + in_iLayerFlux % nodeVolFracLiqTrial = mLayerVolFracLiqTrial(iLayer:iLayer+1) ! volumetric liquid water content at the soil nodes (-) + ! intent(in): model coordinate variables (adjacent layers) + in_iLayerFlux % nodeHeight = mLayerHeight(iLayer:iLayer+1) ! height of the soil nodes (m) + ! intent(in): temperature derivatives + in_iLayerFlux % dPsiLiq_dTemp = dPsiLiq_dTemp(iLayer:iLayer+1) ! derivative in liquid water matric potential w.r.t. temperature (m K-1) + in_iLayerFlux % dHydCond_dTemp = dHydCond_dTemp(iLayer:iLayer+1) ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + ! intent(in): transmittance (adjacent layers) + in_iLayerFlux % nodeHydCondTrial = mLayerHydCond(iLayer:iLayer+1) ! hydraulic conductivity at the soil nodes (m s-1) + in_iLayerFlux % nodeDiffuseTrial = mLayerDiffuse(iLayer:iLayer+1) ! hydraulic diffusivity at the soil nodes (m2 s-1) + ! intent(in): transmittance derivatives (adjacent layers) for hydraulic ... + in_iLayerFlux % dHydCond_dVolLiq = dHydCond_dVolLiq(iLayer:iLayer+1) ! ... conductivity w.r.t. change in volumetric liquid water content (m s-1) + in_iLayerFlux % dDiffuse_dVolLiq = dDiffuse_dVolLiq(iLayer:iLayer+1) ! ... diffusivity w.r.t. change in volumetric liquid water content (m2 s-1) + in_iLayerFlux % dHydCond_dMatric = dHydCond_dMatric(iLayer:iLayer+1) ! ... conductivity w.r.t. change in matric head (s-1) + end associate + end subroutine initialize_in_iLayerFlux + + subroutine finalize_out_iLayerFlux(out_iLayerFlux,iLayer,nSoil,io_soilLiqFlx,iLayerHydCond,iLayerDiffuse,err,cmessage) + class(out_type_iLayerFlux),intent(in) :: out_iLayerFlux ! class object for output iLayerFlux variables + integer(i4b),intent(in) :: nSoil,iLayer ! number of soil layers and index + type(io_type_soilLiqFlx),intent(inout) :: io_soilLiqFlx ! input-output class object for soilLiqFlx + real(rkind),intent(inout) :: iLayerHydCond(0:nSoil) ! hydraulic conductivity at layer interface (m s-1) + real(rkind),intent(inout) :: iLayerDiffuse(0:nSoil) ! diffusivity at layer interface (m2 s-1) + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: cmessage ! error message + + associate(& + ! intent(out): vertical flux at the layer interface (scalars) + iLayerLiqFluxSoil => io_soilLiqFlx % iLayerLiqFluxSoil,& ! liquid flux at soil layer interfaces (m s-1) + ! intent(out): derivatives in fluxes in the layer above and layer below w.r.t ... + dq_dHydStateAbove => io_soilLiqFlx % dq_dHydStateAbove,& ! ... state variables in the layer above + dq_dHydStateBelow => io_soilLiqFlx % dq_dHydStateBelow,& ! ... state variables in the layer below + dq_dNrgStateAbove => io_soilLiqFlx % dq_dNrgStateAbove,& ! ... temperature in the layer above (m s-1 K-1) + dq_dNrgStateBelow => io_soilLiqFlx % dq_dNrgStateBelow & ! ... temperature in the layer below (m s-1 K-1) + &) + ! intent(out): tranmsmittance at the layer interface (scalars) + iLayerHydCond(iLayer) = out_iLayerFlux % iLayerHydCond ! hydraulic conductivity at the interface between layers (m s-1) + iLayerDiffuse(iLayer) = out_iLayerFlux % iLayerDiffuse ! hydraulic diffusivity at the interface between layers (m2 s-1) + ! intent(out): vertical flux at the layer interface (scalars) + iLayerLiqFluxSoil(iLayer) = out_iLayerFlux % iLayerLiqFluxSoil ! vertical flux of liquid water at the layer interface (m s-1) + ! intent(out): derivatives in fluxes in the layer above and layer below w.r.t. ... + dq_dHydStateAbove(iLayer) = out_iLayerFlux % dq_dHydStateAbove ! ... matric head or volumetric lquid water in the layer above (m s-1 or s-1) + dq_dHydStateBelow(iLayer) = out_iLayerFlux % dq_dHydStateBelow ! ... matric head or volumetric lquid water in the layer below (m s-1 or s-1) + dq_dNrgStateAbove(iLayer) = out_iLayerFlux % dq_dNrgStateAbove ! ... temperature in the layer above (m s-1 K-1) + dq_dNrgStateBelow(iLayer) = out_iLayerFlux % dq_dNrgStateBelow ! ... temperature in the layer below (m s-1 K-1) + ! intent(out): error control + err = out_iLayerFlux % err ! error code + cmessage = out_iLayerFlux % message ! error message + end associate + end subroutine finalize_out_iLayerFlux + ! **** end iLayerFlux **** + + ! **** qDrainFlux **** + subroutine initialize_in_qDrainFlux(in_qDrainFlux,nSoil,ibeg,iend,in_soilLiqFlx,io_soilLiqFlx,model_decisions,& + &prog_data,mpar_data,flux_data,diag_data,iceImpedeFac,& + &dHydCond_dVolLiq,dHydCond_dTemp) + class(in_type_qDrainFlux),intent(out) :: in_qDrainFlux ! class object for input qDrainFlux variables + integer(i4b),intent(in) :: nSoil ! number of soil layers + integer(i4b),intent(in) :: ibeg,iend ! start and end indices of the soil layers in concatanated snow-soil vector + type(in_type_soilLiqFlx),intent(in) :: in_soilLiqFlx ! input class object for soilLiqFlx + type(io_type_soilLiqFlx),intent(in) :: io_soilLiqFlx ! input-output class object for soilLiqFlx + type(model_options),intent(in) :: model_decisions(maxvarDecisions) ! the model decision structure + type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU + real(rkind),intent(in) :: iceImpedeFac(1:nSoil) ! ice impedence factor at layer mid-points (-) + real(rkind),intent(in) :: dHydCond_dVolLiq(1:nSoil) ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) + real(rkind),intent(in) :: dHydCond_dTemp(1:nSoil) ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + + associate(& + ! intent(in): model control + ixRichards => model_decisions(iLookDECISIONS%f_Richards)%iDecision,& ! index of the form of Richards' equation + ixBcLowerSoilHydrology => model_decisions(iLookDECISIONS%bcLowrSoiH)%iDecision,& ! index of the lower boundary conditions for soil hydrology + ! intent(in): state variables + mLayerMatricHeadLiqTrial => in_soilLiqFlx % mLayerMatricHeadLiqTrial, & ! liquid matric head in each layer at the current iteration (m) + mLayerVolFracLiqTrial => in_soilLiqFlx % mLayerVolFracLiqTrial, & ! volumetric fraction of liquid water at the current iteration (-) + ! intent(in): model coordinate variables + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat(ibeg:iend), & ! depth of the layer (m) + mLayerHeight => prog_data%var(iLookPROG%mLayerHeight)%dat(ibeg:iend),& ! height of the layer mid-point (m) + ! intent(in): boundary conditions + lowerBoundHead => mpar_data%var(iLookPARAM%lowerBoundHead)%dat(1), & ! lower boundary condition for matric head (m) + lowerBoundTheta => mpar_data%var(iLookPARAM%lowerBoundTheta)%dat(1),& ! lower boundary condition for volumetric liquid water content (-) + ! intent(in): derivative in the soil water characteristic + mLayerdPsi_dTheta => io_soilLiqFlx % mLayerdPsi_dTheta, & ! derivative in the soil water characteristic w.r.t. theta (m) + dPsiLiq_dTemp => in_soilLiqFlx % dPsiLiq_dTemp, & ! derivative in liquid water matric potential w.r.t. temperature (m K-1) + ! intent(in): transmittance + iLayerSatHydCond => flux_data%var(iLookFLUX%iLayerSatHydCond)%dat,& ! saturated hydraulic conductivity at the interface of each layer (m s-1) + mLayerHydCond => io_soilLiqFlx % mLayerHydCond, & ! hydraulic conductivity in each soil layer (m s-1) + ! intent(in): transmittance derivatives + dHydCond_dMatric => io_soilLiqFlx % dHydCond_dMatric,& ! derivative in hydraulic conductivity w.r.t matric head (s-1) + ! intent(in): soil parameters + vGn_alpha => mpar_data%var(iLookPARAM%vGn_alpha)%dat, & ! "alpha" parameter (m-1) + vGn_n => mpar_data%var(iLookPARAM%vGn_n)%dat, & ! "n" parameter (-) + vGn_m => diag_data%var(iLookDIAG%scalarVGn_m)%dat, & ! "m" parameter (-) + theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat, & ! soil porosity (-) + theta_res => mpar_data%var(iLookPARAM%theta_res)%dat, & ! soil residual volumetric water content (-) + kAnisotropic => mpar_data%var(iLookPARAM%kAnisotropic)%dat(1), & ! intent(in): anisotropy factor for lateral hydraulic conductivity (-) + zScale_TOPMODEL => mpar_data%var(iLookPARAM%zScale_TOPMODEL)%dat(1) & ! TOPMODEL scaling factor (m) + &) + ! intent(in): model control + in_qDrainFlux % ixRichards = ixRichards ! index defining the form of Richards' equation (moisture or mixdform) + in_qDrainFlux % bc_lower = ixBcLowerSoilHydrology ! index defining the type of boundary conditions + ! intent(in): state variables + in_qDrainFlux % nodeMatricHeadLiq = mLayerMatricHeadLiqTrial(nSoil) ! liquid matric head in the lowest unsaturated node (m) + in_qDrainFlux % nodeVolFracLiq = mLayerVolFracLiqTrial(nSoil) ! volumetric liquid water content the lowest unsaturated node (-) + ! intent(in): model coordinate variables + in_qDrainFlux % nodeDepth = mLayerDepth(nSoil) ! depth of the lowest unsaturated soil layer (m) + in_qDrainFlux % nodeHeight = mLayerHeight(nSoil) ! height of the lowest unsaturated soil node (m) + ! intent(in): boundary conditions + in_qDrainFlux % lowerBoundHead = lowerBoundHead ! lower boundary condition (m) + in_qDrainFlux % lowerBoundTheta = lowerBoundTheta ! lower boundary condition (-) + ! intent(in): derivative in the soil water characteristic + in_qDrainFlux % node_dPsi_dTheta = mLayerdPsi_dTheta(nSoil) ! derivative in the soil water characteristic + in_qDrainFlux % node_dPsiLiq_dTemp = dPsiLiq_dTemp(nSoil) ! derivative in liquid water matric potential w.r.t. temperature (m K-1) + ! intent(in): transmittance + in_qDrainFlux % surfaceSatHydCond = iLayerSatHydCond(0) ! saturated hydraulic conductivity at the surface (m s-1) + in_qDrainFlux % bottomSatHydCond = iLayerSatHydCond(nSoil) ! saturated hydraulic conductivity at the bottom of the unsaturated zone (m s-1) + in_qDrainFlux % nodeHydCond = mLayerHydCond(nSoil) ! hydraulic conductivity at the node itself (m s-1) + in_qDrainFlux % iceImpedeFac = iceImpedeFac(nSoil) ! ice impedence factor in the lower-most soil layer (-) + ! intent(in): derivatives in hydraulic conductivity w.r.t. ... + in_qDrainFlux % dHydCond_dVolLiq = dHydCond_dVolLiq(nSoil) ! ... volumetric liquid water content (m s-1) + in_qDrainFlux % dHydCond_dMatric = dHydCond_dMatric(nSoil) ! ... matric head (s-1) + in_qDrainFlux % dHydCond_dTemp = dHydCond_dTemp(nSoil) ! ... temperature (m s-1 K-1) + ! intent(in): soil parameters + in_qDrainFlux % vGn_alpha = vGn_alpha(nSoil) ! van Genuchten "alpha" parameter (m-1) + in_qDrainFlux % vGn_n = vGn_n(nSoil) ! van Genuchten "n" parameter (-) + in_qDrainFlux % vGn_m = vGn_m(nSoil) ! van Genuchten "m" parameter (-) + in_qDrainFlux % theta_sat = theta_sat(nSoil) ! soil porosity (-) + in_qDrainFlux % theta_res = theta_res(nSoil) ! soil residual volumetric water content (-) + in_qDrainFlux % kAnisotropic = kAnisotropic ! anisotropy factor for lateral hydraulic conductivity (-) + in_qDrainFlux % zScale_TOPMODEL = zScale_TOPMODEL ! TOPMODEL scaling factor (m) + end associate + end subroutine initialize_in_qDrainFlux + + subroutine finalize_out_qDrainFlux(out_qDrainFlux,nSoil,io_soilLiqFlx,iLayerHydCond,iLayerDiffuse,err,cmessage) + class(out_type_qDrainFlux),intent(in) :: out_qDrainFlux ! class object for output qDrainFlux variables + integer(i4b),intent(in) :: nSoil ! number of soil layers + type(io_type_soilLiqFlx),intent(inout) :: io_soilLiqFlx ! input-output class object for soilLiqFlx + real(rkind),intent(inout) :: iLayerHydCond(0:nSoil) ! hydraulic conductivity at layer interface (m s-1) + real(rkind),intent(inout) :: iLayerDiffuse(0:nSoil) ! diffusivity at layer interface (m2 s-1) + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: cmessage ! error message + + associate(& + ! intent(out): drainage flux + iLayerLiqFluxSoil => io_soilLiqFlx % iLayerLiqFluxSoil,& ! liquid flux at soil layer interfaces (m s-1) + ! intent(out): derivatives in drainage flux w.r.t. ... + dq_dHydStateAbove => io_soilLiqFlx % dq_dHydStateAbove,& ! ... state variables in the layer above + dq_dNrgStateAbove => io_soilLiqFlx % dq_dNrgStateAbove & ! ... temperature in the layer above (m s-1 K-1) + &) + ! intent(out): hydraulic conductivity and diffusivity at the surface + iLayerHydCond(nSoil) = out_qDrainFlux % bottomHydCond ! hydraulic conductivity at the bottom of the unsatuarted zone (m s-1) + iLayerDiffuse(nSoil) = out_qDrainFlux % bottomDiffuse ! hydraulic diffusivity at the bottom of the unsatuarted zone (m2 s-1) + ! intent(out): drainage flux + iLayerLiqFluxSoil(nSoil) = out_qDrainFlux % scalarDrainage ! drainage flux (m s-1) + ! intent(out): derivatives in drainage flux w.r.t. ... + dq_dHydStateAbove(nSoil) = out_qDrainFlux % dq_dHydStateUnsat ! ... change in hydrology state in lowest unsaturated node (m s-1 or s-1) + dq_dNrgStateAbove(nSoil) = out_qDrainFlux % dq_dNrgStateUnsat ! ... change in energy state in lowest unsaturated node (m s-1 or s-1) + end associate + ! intent(out): error control + err = out_qDrainFlux % err ! error code + cmessage = out_qDrainFlux % message ! error message + end subroutine finalize_out_qDrainFlux + ! **** end qDrainFlux **** + + ! **** stateFilter **** + subroutine finalize_out_stateFilter(out_stateFilter,err,cmessage) + class(out_type_stateFilter),intent(in) :: out_stateFilter ! class object for intent(out) stateFilter arguments + integer(i4b),intent(out) :: err ! intent(out): error code + character(*),intent(out) :: cmessage ! intent(out): error message + err = out_stateFilter % err ! intent(out): error code + cmessage = out_stateFilter % cmessage ! intent(out): error message + end subroutine finalize_out_stateFilter + ! **** end stateFilter **** + + ! **** indexSplit **** + subroutine initialize_in_indexSplit(in_indexSplit,nSnow,nSoil,nLayers,nSubset) + class(in_type_indexSplit),intent(out) :: in_indexSplit ! class object for intent(in) indexSplit arguments + integer(i4b),intent(in) :: nSnow ! intent(in): number of snow layers + integer(i4b),intent(in) :: nSoil ! intent(in): number of soil layers + integer(i4b),intent(in) :: nLayers ! intent(in): total number of layers + integer(i4b),intent(in) :: nSubset ! intent(in): number of states in the subset + in_indexSplit % nSnow = nSnow ! intent(in): number of snow layers + in_indexSplit % nSoil = nSoil ! intent(in): number of soil layers + in_indexSplit % nLayers = nLayers ! intent(in): total number of layers + in_indexSplit % nSubset = nSubset ! intent(in): number of states in the subset + end subroutine initialize_in_indexSplit + + subroutine finalize_out_indexSplit(out_indexSplit,err,cmessage) + class(out_type_indexSplit),intent(in) :: out_indexSplit ! class object for intent(out) indexSplit arguments + integer(i4b),intent(out) :: err ! intent(out): error code + character(*),intent(out) :: cmessage ! intent(out): error message + err = out_indexSplit % err ! intent(out): error code + cmessage = out_indexSplit % cmessage ! intent(out): error message + end subroutine finalize_out_indexSplit + ! **** end indexSplit **** + + ! **** varSubstep **** + subroutine initialize_in_varSubstep(in_varSubstep,dt,dtInit,dt_min,whole_step,nSubset,& + doAdjustTemp,firstSubStep,computeVegFlux,ixSolution,scalar,iStateSplit,fluxMask) + class(in_type_varSubstep),intent(out) :: in_varSubstep ! class object for intent(in) varSubstep arguments + real(rkind),intent(in) :: dt ! time step (s) + real(rkind),intent(in) :: dtInit ! initial time step (s) + real(rkind),intent(in) :: dt_min ! minimum time step (s) + real(rkind),intent(in) :: whole_step ! length of whole step for surface drainage and average flux + integer(i4b),intent(in) :: nSubset ! total number of variables in the state subset + logical(lgt),intent(in) :: doAdjustTemp ! flag to indicate if we adjust the temperature + logical(lgt),intent(in) :: firstSubStep ! flag to denote first sub-step + logical(lgt),intent(in) :: computeVegFlux ! flag to denote if computing energy flux over vegetation + integer(i4b),intent(in) :: ixSolution ! index of solution method + integer(i4b),intent(in) :: scalar ! scalar solution method + integer(i4b),intent(in) :: iStateSplit ! index of the layer in the splitting operation + type(var_flagVec),intent(in) :: fluxMask ! mask for the fluxes used in this given state subset + + ! intent(in) arguments + in_varSubstep % dt = dt ! intent(in): time step (s) + in_varSubstep % dtInit = dtInit ! intent(in): initial time step (s) + in_varSubstep % dt_min = dt_min ! intent(in): minimum time step (s) + in_varSubstep % whole_step = whole_step ! intent(in): length of whole step for surface drainage and average flux + in_varSubstep % nSubset = nSubset ! intent(in): total number of variables in the state subset + in_varSubstep % doAdjustTemp = doAdjustTemp ! intent(in): flag to indicate if we adjust the temperature + in_varSubstep % firstSubStep = firstSubStep ! intent(in): flag to denote first sub-step + in_varSubstep % computeVegFlux = computeVegFlux ! intent(in): flag to denote if computing energy flux over vegetation + in_varSubstep % scalarSolution = (ixSolution==scalar) ! intent(in): flag to denote computing the scalar solution + in_varSubstep % iStateSplit = iStateSplit ! intent(in): index of the layer in the splitting operation + in_varSubstep % fluxMask = fluxMask ! intent(in): mask for the fluxes used in this given state subset + end subroutine initialize_in_varSubstep + + subroutine initialize_io_varSubstep(io_varSubstep,firstFluxCall,fluxCount,ixSaturation) + class(io_type_varSubstep),intent(out) :: io_varSubstep ! class object for intent(inout) varSubstep arguments + logical(lgt),intent(in) :: firstFluxCall ! flag to indicate if we are processing the first flux call + type(var_ilength),intent(in) :: fluxCount ! number of times fluxes are updated (should equal nsubstep) + integer(i4b),intent(in) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) + + ! intent(inout) arguments + io_varSubstep % firstFluxCall = firstFluxCall ! intent(inout): flag to indicate if we are processing the first flux call + io_varSubstep % fluxCount = fluxCount ! intent(inout): number of times fluxes are updated (should equal nsubstep) + io_varSubstep % ixSaturation = ixSaturation ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) + end subroutine initialize_io_varSubstep + + subroutine finalize_io_varSubstep(io_varSubstep,firstFluxCall,fluxCount,ixSaturation) + class(io_type_varSubstep),intent(in) :: io_varSubstep ! class object for intent(inout) varSubstep arguments + logical(lgt),intent(out) :: firstFluxCall ! flag to indicate if we are processing the first flux call + type(var_ilength),intent(out) :: fluxCount ! number of times fluxes are updated (should equal nsubstep) + integer(i4b),intent(out) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) + + ! intent(inout) arguments + firstFluxCall = io_varSubstep % firstFluxCall ! intent(inout): flag to indicate if we are processing the first flux call + fluxCount = io_varSubstep % fluxCount ! intent(inout): number of times fluxes are updated (should equal nsubstep) + ixSaturation = io_varSubstep % ixSaturation ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) + end subroutine finalize_io_varSubstep + + subroutine finalize_out_varSubstep(out_varSubstep,dtMultiplier,nSubsteps,failedMinimumStep,reduceCoupledStep,tooMuchMelt,err,cmessage) + class(out_type_varSubstep),intent(in) :: out_varSubstep ! class object for intent(out) varSubstep arguments + real(rkind),intent(out) :: dtMultiplier ! substep multiplier (-) + integer(i4b),intent(out) :: nSubsteps ! number of substeps taken for a given split + logical(lgt),intent(out) :: failedMinimumStep ! flag for failed substeps + logical(lgt),intent(out) :: reduceCoupledStep ! flag to reduce the length of the coupled step + logical(lgt),intent(out) :: tooMuchMelt ! flag to denote that ice is insufficient to support melt + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: cmessage ! error message + + ! intent(out) arguments + dtMultiplier = out_varSubstep % dtMultiplier ! intent(out): substep multiplier (-) + nSubsteps = out_varSubstep % nSubsteps ! intent(out): number of substeps taken for a given split + failedMinimumStep = out_varSubstep % failedMinimumStep ! intent(out): flag for failed substeps + reduceCoupledStep = out_varSubstep % reduceCoupledStep ! intent(out): flag to reduce the length of the coupled step + tooMuchMelt = out_varSubstep % tooMuchMelt ! intent(out): flag to denote that ice is insufficient to support melt + err = out_varSubstep % err ! intent(out): error code + cmessage = out_varSubstep % cmessage ! intent(out): error message + end subroutine finalize_out_varSubstep + ! **** end varSubstep **** + + ! **** computJacob **** + subroutine initialize_in_computJacob(in_computJacob,dt,nSnow,nSoil,nLayers,computeVegFlux,computeBaseflow,ixMatrix) + class(in_type_computJacob),intent(out) :: in_computJacob ! class object for intent(in) computJacob arguments + real(rkind),intent(in) :: dt ! intent(in): length of the time step (seconds) + integer(i4b),intent(in) :: nSnow ! intent(in): number of snow layers + integer(i4b),intent(in) :: nSoil ! intent(in): number of soil layers + integer(i4b),intent(in) :: nLayers ! intent(in): total number of layers in the snow+soil domain + logical(lgt),intent(in) :: computeVegFlux ! intent(in): flag to indicate if computing fluxes over vegetation + logical(lgt),intent(in) :: computeBaseflow ! intent(in): flag to indicate if computing baseflow + integer(i4b),intent(in) :: ixMatrix ! intent(in): form of the Jacobian matrix + + ! intent(in) arguments + in_computJacob % dt = dt ! intent(in): length of the time step (seconds) + in_computJacob % nSnow = nSnow ! intent(in): number of snow layers + in_computJacob % nSoil = nSoil ! intent(in): number of soil layers + in_computJacob % nLayers = nLayers ! intent(in): total number of layers in the snow+soil domain + in_computJacob % computeVegFlux = computeVegFlux ! intent(in): flag to indicate if computing fluxes over vegetation + in_computJacob % computeBaseflow = computeBaseflow ! intent(in): flag to indicate if computing baseflow + in_computJacob % ixMatrix = ixMatrix ! intent(in): form of the Jacobian matrix + end subroutine initialize_in_computJacob + + subroutine finalize_out_computJacob(out_computJacob,err,cmessage) + class(out_type_computJacob),intent(in) :: out_computJacob ! class object for intent(out) computJacob arguments + integer(i4b),intent(out) :: err ! intent(out): error code + character(*),intent(out) :: cmessage ! intent(out): error message + ! intent(out) arguments + err = out_computJacob % err ! intent(out): error code + cmessage = out_computJacob % cmessage ! intent(out): error message + end subroutine finalize_out_computJacob + + ! **** lineSearchRefinement **** + subroutine initialize_in_lineSearchRefinement(in_lineSearchRefinement,doSearch,fOld) + class(in_type_lineSearchRefinement),intent(out) :: in_lineSearchRefinement ! class object for intent(out) arguments + logical(lgt),intent(in) :: doSearch ! intent(in): flag to do the line search + real(rkind) ,intent(in) :: fOld ! intent(in): old function value + in_lineSearchRefinement % doSearch = doSearch ! intent(in): flag to do the line search + in_lineSearchRefinement % fOld = fOld ! intent(in): old function value + end subroutine initialize_in_lineSearchRefinement + + subroutine finalize_out_lineSearchRefinement(out_lineSearchRefinement,fNew,converged,err,message) + class(out_type_lineSearchRefinement),intent(in) :: out_lineSearchRefinement ! class object for intent(out) arguments + real(rkind) ,intent(out) :: fNew ! intent(out): new function evaluation + logical(lgt),intent(out) :: converged ! intent(out): convergence flag + integer(i4b),intent(out) :: err ! intent(out): error code + character(*),intent(out) :: message ! intent(out): error message + fNew = out_lineSearchRefinement % fNew ! intent(out): new function evaluation + converged = out_lineSearchRefinement % converged ! intent(out): convergence flag + err = out_lineSearchRefinement % err ! intent(out): error code + message = out_lineSearchRefinement % message ! intent(out): error message + end subroutine finalize_out_lineSearchRefinement + + ! **** summaSolve4homegrown **** + + subroutine initialize_in_summaSolve4homegrown(in_SS4NR,dt_cur,dt,iter,nSnow,nSoil,nLayers,nLeadDim,nState,ixMatrix,firstSubStep,computeVegFlux,scalarSolution,fOld) + class(in_type_summaSolve4homegrown),intent(out) :: in_SS4NR ! class object for intent(out) arguments + real(rkind) ,intent(in) :: dt_cur ! intent(in): current stepsize + real(rkind) ,intent(in) :: dt ! intent(in): entire time step for drainage pond rate + integer(i4b),intent(in) :: iter ! intent(in): iteration index + integer(i4b),intent(in) :: nSnow ! intent(in): number of snow layers + integer(i4b),intent(in) :: nSoil ! intent(in): number of soil layers + integer(i4b),intent(in) :: nLayers ! intent(in): total number of layers + integer(i4b),intent(in) :: nLeadDim ! intent(in): length of the leading dimension of the Jacobian matrix (nBands or nState) + integer(i4b),intent(in) :: nState ! intent(in): total number of state variables + integer(i4b),intent(in) :: ixMatrix ! intent(in): type of matrix (full or band diagonal) + logical(lgt),intent(in) :: firstSubStep ! intent(in): flag to indicate if we are processing the first sub-step + logical(lgt),intent(in) :: computeVegFlux ! intent(in): flag to indicate if computing fluxes over vegetation + logical(lgt),intent(in) :: scalarSolution ! intent(in): flag to denote if implementing the scalar solution + real(rkind) ,intent(in) :: fOld ! intent(in): old function evaluation + + in_SS4NR % dt_cur = dt_cur + in_SS4NR % dt = dt + in_SS4NR % iter = iter + in_SS4NR % nSnow = nSnow + in_SS4NR % nSoil = nSoil + in_SS4NR % nLayers = nLayers + in_SS4NR % nLeadDim = nLeadDim + in_SS4NR % nState = nState + in_SS4NR % ixMatrix = ixMatrix + in_SS4NR % firstSubStep = firstSubStep + in_SS4NR % computeVegFlux = computeVegFlux + in_SS4NR % scalarSolution = scalarSolution + in_SS4NR % fOld = fOld + end subroutine initialize_in_summaSolve4homegrown + + subroutine initialize_io_summaSolve4homegrown(io_SS4NR,firstFluxCall,xMin,xMax,ixSaturation) + class(io_type_summaSolve4homegrown),intent(out) :: io_SS4NR ! class object for intent(inout) arguments + logical(lgt),intent(in) :: firstFluxCall ! intent(inout): flag to indicate if we are processing the first flux call + real(rkind) ,intent(in) :: xMin,xMax ! intent(inout): brackets of the root + integer(i4b),intent(in) :: ixSaturation ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) + + io_SS4NR % firstFluxCall = firstFluxCall + io_SS4NR % xMin = xMin + io_SS4NR % xMax = xMax + io_SS4NR % ixSaturation = ixSaturation + end subroutine initialize_io_summaSolve4homegrown + + subroutine finalize_io_summaSolve4homegrown(io_SS4NR,firstFluxCall,xMin,xMax,ixSaturation) + class(io_type_summaSolve4homegrown),intent(in) :: io_SS4NR ! class object for intent(inout) arguments + logical(lgt),intent(out) :: firstFluxCall ! intent(inout): flag to indicate if we are processing the first flux call + real(rkind) ,intent(out) :: xMin,xMax ! intent(inout): brackets of the root + integer(i4b),intent(out) :: ixSaturation ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) + + firstFluxCall = io_SS4NR % firstFluxCall + xMin = io_SS4NR % xMin + xMax = io_SS4NR % xMax + ixSaturation = io_SS4NR % ixSaturation + end subroutine finalize_io_summaSolve4homegrown + + subroutine finalize_out_summaSolve4homegrown(out_SS4NR,fNew,converged,err,message) + class(out_type_summaSolve4homegrown),intent(in) :: out_SS4NR ! class object for intent(out) arguments + real(rkind) ,intent(out) :: fNew ! intent(out): new function evaluation + logical(lgt),intent(out) :: converged ! intent(out): convergence flag + integer(i4b),intent(out) :: err ! intent(out): error code + character(*),intent(out) :: message ! intent(out): error message + + fNew = out_SS4NR % fNew + converged = out_SS4NR % converged + err = out_SS4NR % err + message = out_SS4NR % message + end subroutine finalize_out_summaSolve4homegrown + +END MODULE data_types diff --git a/build/source/dshare/flxMapping.f90 b/build/source/dshare/flxMapping.f90 old mode 100755 new mode 100644 index 1195a53a4..95294e621 --- a/build/source/dshare/flxMapping.f90 +++ b/build/source/dshare/flxMapping.f90 @@ -7,24 +7,25 @@ module flxMapping_module subroutine flxMapping(err,message) USE nrtype ! data types - USE data_types, only: var_info ! data type for metadata structure - USE data_types, only: flux2state ! data type for extended metadata structure, for flux-to-state mapping + USE data_types, only: var_info ! data type for metadata structure + USE data_types, only: flux2state ! data type for extended metadata structure, for flux-to-state mapping ! structures of named variables - USE var_lookup, only: iLookFLUX ! named variables for local flux variables + USE var_lookup, only: iLookFLUX ! named variables for local flux variables ! metadata structures - USE globalData, only: flux_meta ! data structure for model fluxes - USE globalData, only: flux2state_orig ! data structure for flux-to-state mapping (original state variables) - USE globalData, only: flux2state_liq ! data structure for flux-to-state mapping (liquid water state variables) + USE globalData, only: flux_meta ! data structure for model fluxes + USE globalData, only: flux2state_orig ! data structure for flux-to-state mapping (original state variables) + USE globalData, only: flux2state_liq ! data structure for flux-to-state mapping (liquid water state variables) ! named variables to describe the state variable type - USE globalData, only: iname_nrgCanair ! named variable defining the energy of the canopy air space - USE globalData, only: iname_nrgCanopy ! named variable defining the energy of the vegetation canopy - USE globalData, only: iname_watCanopy ! named variable defining the mass of total water on the vegetation canopy - USE globalData, only: iname_liqCanopy ! named variable defining the mass of liquid water on the vegetation canopy - USE globalData, only: iname_nrgLayer ! named variable defining the energy state variable for snow+soil layers - USE globalData, only: iname_watLayer ! named variable defining the total water state variable for snow+soil layers - USE globalData, only: iname_liqLayer ! named variable defining the liquid water state variable for snow+soil layers - USE globalData, only: iname_matLayer ! named variable defining the matric head state variable for soil layers - USE globalData, only: iname_lmpLayer ! named variable defining the liquid matric potential state variable for soil layers + USE globalData, only: iname_nrgCanair ! named variable defining the energy of the canopy air space + USE globalData, only: iname_nrgCanopy ! named variable defining the energy of the vegetation canopy + USE globalData, only: iname_watCanopy ! named variable defining the mass of total water on the vegetation canopy + USE globalData, only: iname_liqCanopy ! named variable defining the mass of liquid water on the vegetation canopy + USE globalData, only: iname_nrgLayer ! named variable defining the energy state variable for snow+soil layers + USE globalData, only: iname_watLayer ! named variable defining the total water state variable for snow+soil layers + USE globalData, only: iname_liqLayer ! named variable defining the liquid water state variable for snow+soil layers + USE globalData, only: iname_matLayer ! named variable defining the matric head state variable for soil layers + USE globalData, only: iname_lmpLayer ! named variable defining the liquid matric potential state variable for soil layers + USE globalData, only: iname_watAquifer ! named variable defining the total water in the aquifer ! access missing values USE globalData,only:integerMissing ! missing integer implicit none @@ -97,7 +98,7 @@ subroutine flxMapping(err,message) flux2state_orig(iLookFLUX%scalarGroundResistance) = flux2state(state1=iname_nrgCanopy, state2=iname_nrgLayer) flux2state_orig(iLookFLUX%scalarCanopyResistance) = flux2state(state1=iname_nrgCanopy, state2=integerMissing) flux2state_orig(iLookFLUX%scalarLeafResistance) = flux2state(state1=iname_nrgCanopy, state2=integerMissing) - flux2state_orig(iLookFLUX%scalarSoilResistance) = flux2state(state1=iname_nrgCanopy, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarSoilResistance) = flux2state(state1=iname_nrgCanopy, state2=iname_nrgLayer) flux2state_orig(iLookFLUX%scalarSenHeatTotal) = flux2state(state1=iname_nrgCanopy, state2=iname_nrgLayer) flux2state_orig(iLookFLUX%scalarSenHeatCanopy) = flux2state(state1=iname_nrgCanopy, state2=integerMissing) flux2state_orig(iLookFLUX%scalarSenHeatGround) = flux2state(state1=iname_nrgCanopy, state2=iname_nrgLayer) @@ -122,6 +123,7 @@ subroutine flxMapping(err,message) flux2state_orig(iLookFLUX%scalarCanopyTranspiration) = flux2state(state1=iname_nrgCanopy, state2=iname_nrgLayer) flux2state_orig(iLookFLUX%scalarCanopyEvaporation) = flux2state(state1=iname_nrgCanopy, state2=integerMissing) flux2state_orig(iLookFLUX%scalarGroundEvaporation) = flux2state(state1=iname_nrgCanopy, state2=iname_nrgLayer) + flux2state_orig(iLookFLUX%scalarAquiferTranspire) = flux2state(state1=iname_watAquifer,state2=iname_watCanopy) flux2state_orig(iLookFLUX%mLayerTranspire) = flux2state(state1=iname_matLayer, state2=integerMissing) ! liquid and solid water fluxes through the canopy @@ -148,6 +150,8 @@ subroutine flxMapping(err,message) flux2state_orig(iLookFLUX%scalarInfiltration) = flux2state(state1=iname_matLayer, state2=integerMissing) flux2state_orig(iLookFLUX%scalarExfiltration) = flux2state(state1=iname_matLayer, state2=integerMissing) flux2state_orig(iLookFLUX%scalarSurfaceRunoff) = flux2state(state1=iname_matLayer, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarSurfaceRunoff_IE) = flux2state(state1=iname_matLayer, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarSurfaceRunoff_SE) = flux2state(state1=iname_matLayer, state2=integerMissing) flux2state_orig(iLookFLUX%mLayerSatHydCondMP) = flux2state(state1=integerMissing, state2=integerMissing) flux2state_orig(iLookFLUX%mLayerSatHydCond) = flux2state(state1=integerMissing, state2=integerMissing) flux2state_orig(iLookFLUX%iLayerSatHydCond) = flux2state(state1=integerMissing, state2=integerMissing) @@ -159,9 +163,10 @@ subroutine flxMapping(err,message) flux2state_orig(iLookFLUX%mLayerColumnOutflow) = flux2state(state1=iname_matLayer, state2=integerMissing) flux2state_orig(iLookFLUX%scalarSoilBaseflow) = flux2state(state1=iname_matLayer, state2=integerMissing) flux2state_orig(iLookFLUX%scalarSoilDrainage) = flux2state(state1=iname_matLayer, state2=integerMissing) - flux2state_orig(iLookFLUX%scalarAquiferRecharge) = flux2state(state1=iname_matLayer, state2=integerMissing) - flux2state_orig(iLookFLUX%scalarAquiferTranspire) = flux2state(state1=iname_matLayer, state2=integerMissing) - flux2state_orig(iLookFLUX%scalarAquiferBaseflow) = flux2state(state1=iname_matLayer, state2=integerMissing) + + ! liquid water fluxes for the aquifer domain + flux2state_orig(iLookFLUX%scalarAquiferRecharge) = flux2state(state1=iname_watAquifer,state2=iname_matLayer) + flux2state_orig(iLookFLUX%scalarAquiferBaseflow) = flux2state(state1=iname_watAquifer,state2=integerMissing) ! derived variables flux2state_orig(iLookFLUX%scalarTotalET) = flux2state(state1=iname_nrgCanopy, state2=iname_nrgLayer) diff --git a/build/source/dshare/get_ixname.f90 b/build/source/dshare/get_ixname.f90 old mode 100755 new mode 100644 index 8243d20a2..4daed6c20 --- a/build/source/dshare/get_ixname.f90 +++ b/build/source/dshare/get_ixname.f90 @@ -24,19 +24,19 @@ module get_ixname_module implicit none private public::get_ixdecisions -public::get_ixtime -public::get_ixattr -public::get_ixtype -public::get_ixid -public::get_ixforce -public::get_ixparam -public::get_ixprog -public::get_ixdiag -public::get_ixflux -public::get_ixderiv -public::get_ixindex -public::get_ixbpar -public::get_ixbvar +public::get_ixTime +public::get_ixAttr +public::get_ixType +public::get_ixId +public::get_ixForce +public::get_ixParam +public::get_ixProg +public::get_ixDiag +public::get_ixFlux +public::get_ixDeriv +public::get_ixIndex +public::get_ixBpar +public::get_ixBvar public::get_ixVarType public::get_varTypeName public::get_ixUnknown @@ -57,7 +57,7 @@ function get_ixdecisions(varName) integer(i4b) :: get_ixdecisions ! index of the named variable ! get the index of the named variables select case(trim(varName)) - case('soilCatTbl' ); get_ixdecisions=iLookDECISIONS%soilCatTbl ! soil-category dateset + case('soilCatTbl' ); get_ixdecisions=iLookDECISIONS%soilCatTbl ! soil-category dataset case('vegeParTbl' ); get_ixdecisions=iLookDECISIONS%vegeParTbl ! vegetation category dataset case('soilStress' ); get_ixdecisions=iLookDECISIONS%soilStress ! choice of function for the soil moisture control on stomatal resistance case('stomResist' ); get_ixdecisions=iLookDECISIONS%stomResist ! choice of function for stomatal resistance @@ -95,6 +95,10 @@ function get_ixdecisions(varName) case('subRouting' ); get_ixdecisions=iLookDECISIONS%subRouting ! choice of method for sub-grid routing case('snowDenNew' ); get_ixdecisions=iLookDECISIONS%snowDenNew ! choice of method for new snow density case('snowUnload' ); get_ixdecisions=iLookDECISIONS%snowUnload ! choice of parameterization for snow unloading from canopy + case('nrgConserv' ); get_ixdecisions=iLookDECISIONS%nrgConserv ! choice of variable in either energy backward Euler residual or IDA state variable + case('aquiferIni' ); get_ixdecisions=iLookDECISIONS%aquiferIni ! choice of full or empty aquifer at start + case('infRateMax' ); get_ixdecisions=iLookDECISIONS%infRateMax ! choice of maximum infiltration rate method + case('surfRun_SE' ); get_ixdecisions=iLookDECISIONS%surfRun_SE ! choice of parameterization for saturation excess surface runoff ! get to here if cannot find the variable case default get_ixdecisions = integerMissing @@ -103,54 +107,54 @@ end function get_ixdecisions ! ******************************************************************************************************************* - ! public function get_ixtime: get the index of the named variables for the model time + ! public function get_ixTime: get the index of the named variables for the model time ! ******************************************************************************************************************* - function get_ixtime(varName) + function get_ixTime(varName) USE var_lookup,only:iLookTIME ! indices of the named variables implicit none ! define dummy variables character(*), intent(in) :: varName ! variable name - integer(i4b) :: get_ixtime ! index of the named variable + integer(i4b) :: get_ixTime ! index of the named variable ! get the index of the named variables select case(trim(varName)) - case('iyyy' ); get_ixtime = iLookTIME%iyyy ! year - case('im' ); get_ixtime = iLookTIME%im ! month - case('id' ); get_ixtime = iLookTIME%id ! day - case('ih' ); get_ixtime = iLookTIME%ih ! hour - case('imin' ); get_ixtime = iLookTIME%imin ! minute - case('ih_tz' ); get_ixtime = iLookTIME%ih_tz ! hour for time zone offset - case('imin_tz' ); get_ixtime = iLookTIME%imin_tz ! minute for time zone offset + case('iyyy' ); get_ixTime = iLookTIME%iyyy ! year + case('im' ); get_ixTime = iLookTIME%im ! month + case('id' ); get_ixTime = iLookTIME%id ! day + case('ih' ); get_ixTime = iLookTIME%ih ! hour + case('imin' ); get_ixTime = iLookTIME%imin ! minute + case('ih_tz' ); get_ixTime = iLookTIME%ih_tz ! hour for time zone offset + case('imin_tz' ); get_ixTime = iLookTIME%imin_tz ! minute for time zone offset ! get to here if cannot find the variable case default - get_ixtime = integerMissing + get_ixTime = integerMissing end select - end function get_ixtime + end function get_ixTime ! ******************************************************************************************************************* - ! public function get_ixforce: get the index of the named variables for the model forcing data + ! public function get_ixForce: get the index of the named variables for the model forcing data ! ******************************************************************************************************************* - function get_ixforce(varName) + function get_ixForce(varName) USE var_lookup,only:iLookFORCE ! indices of the named variables implicit none ! define dummy variables character(*), intent(in) :: varName ! variable name - integer(i4b) :: get_ixforce ! index of the named variable + integer(i4b) :: get_ixForce ! index of the named variable ! get the index of the named variables select case(trim(varName)) - case('time' ); get_ixforce = iLookFORCE%time ! time since time reference (s) - case('pptrate' ); get_ixforce = iLookFORCE%pptrate ! precipitation rate (kg m-2 s-1) - case('airtemp' ); get_ixforce = iLookFORCE%airtemp ! air temperature (K) - case('spechum' ); get_ixforce = iLookFORCE%spechum ! specific humidity (g/g) - case('windspd' ); get_ixforce = iLookFORCE%windspd ! windspeed (m/s) - case('SWRadAtm' ); get_ixforce = iLookFORCE%SWRadAtm ! downwelling shortwave radiaiton (W m-2) - case('LWRadAtm' ); get_ixforce = iLookFORCE%LWRadAtm ! downwelling longwave radiation (W m-2) - case('airpres' ); get_ixforce = iLookFORCE%airpres ! pressure (Pa) + case('time' ); get_ixForce = iLookFORCE%time ! time since time reference (s) + case('pptrate' ); get_ixForce = iLookFORCE%pptrate ! precipitation rate (kg m-2 s-1) + case('airtemp' ); get_ixForce = iLookFORCE%airtemp ! air temperature (K) + case('spechum' ); get_ixForce = iLookFORCE%spechum ! specific humidity (g/g) + case('windspd' ); get_ixForce = iLookFORCE%windspd ! windspeed (m/s) + case('SWRadAtm' ); get_ixForce = iLookFORCE%SWRadAtm ! downwelling shortwave radiaiton (W m-2) + case('LWRadAtm' ); get_ixForce = iLookFORCE%LWRadAtm ! downwelling longwave radiation (W m-2) + case('airpres' ); get_ixForce = iLookFORCE%airpres ! pressure (Pa) ! get to here if cannot find the variable case default - get_ixforce = integerMissing + get_ixForce = integerMissing end select - end function get_ixforce + end function get_ixForce ! ******************************************************************************************************************* @@ -213,6 +217,8 @@ function get_ixId(varName) ! get the index of the named variables select case(trim(varName)) case('hruId' ); get_ixId = iLookID%hruId ! id defining HRU index + case('gruId' ); get_ixId = iLookID%gruId ! id defining GRU index + case('hru2gruId' ); get_ixId = iLookID%hru2gruId ! id defining the GRU to which the HRU belongs ! get to here if cannot find the variable case default get_ixId = integerMissing @@ -221,541 +227,659 @@ end function get_ixId ! ******************************************************************************************************************* - ! public function get_ixparam: get the index of the named variables for the model parameters + ! public function get_ixParam: get the index of the named variables for the model parameters ! ******************************************************************************************************************* - function get_ixparam(varName) + function get_ixParam(varName) USE var_lookup,only:iLookPARAM ! indices of the named variables implicit none ! define dummy variables character(*), intent(in) :: varName ! variable name - integer(i4b) :: get_ixparam ! index of the named variable + integer(i4b) :: get_ixParam ! index of the named variable ! get the index of the named variables select case(trim(varName)) ! boundary conditions - case('upperBoundHead' ); get_ixparam = iLookPARAM%upperBoundHead ! matric head of the upper boundary (m) - case('lowerBoundHead' ); get_ixparam = iLookPARAM%lowerBoundHead ! matric head of the lower boundary (m) - case('upperBoundTheta' ); get_ixparam = iLookPARAM%upperBoundTheta ! volumetric liquid water content at the upper boundary (-) - case('lowerBoundTheta' ); get_ixparam = iLookPARAM%lowerBoundTheta ! volumetric liquid water content at the lower boundary (-) - case('upperBoundTemp' ); get_ixparam = iLookPARAM%upperBoundTemp ! temperature of the upper boundary (K) - case('lowerBoundTemp' ); get_ixparam = iLookPARAM%lowerBoundTemp ! temperature of the lower boundary (K) + case('upperBoundHead' ); get_ixParam = iLookPARAM%upperBoundHead ! matric head of the upper boundary (m) + case('lowerBoundHead' ); get_ixParam = iLookPARAM%lowerBoundHead ! matric head of the lower boundary (m) + case('upperBoundTheta' ); get_ixParam = iLookPARAM%upperBoundTheta ! volumetric liquid water content at the upper boundary (-) + case('lowerBoundTheta' ); get_ixParam = iLookPARAM%lowerBoundTheta ! volumetric liquid water content at the lower boundary (-) + case('upperBoundTemp' ); get_ixParam = iLookPARAM%upperBoundTemp ! temperature of the upper boundary (K) + case('lowerBoundTemp' ); get_ixParam = iLookPARAM%lowerBoundTemp ! temperature of the lower boundary (K) ! precipitation partitioning - case('tempCritRain' ); get_ixparam = iLookPARAM%tempCritRain ! critical temperature where precipitation is rain (K) - case('tempRangeTimestep' ); get_ixparam = iLookPARAM%tempRangeTimestep ! temperature range over the time step (K) - case('frozenPrecipMultip' ); get_ixparam = iLookPARAM%frozenPrecipMultip ! frozen precipitation multiplier (-) + case('tempCritRain' ); get_ixParam = iLookPARAM%tempCritRain ! critical temperature where precipitation is rain (K) + case('tempRangeTimestep' ); get_ixParam = iLookPARAM%tempRangeTimestep ! temperature range over the time step (K) + case('frozenPrecipMultip' ); get_ixParam = iLookPARAM%frozenPrecipMultip ! frozen precipitation multiplier (-) ! freezing curve for snow - case('snowfrz_scale' ); get_ixparam = iLookPARAM%snowfrz_scale ! scaling parameter for the freezing curve for snow (K-1) - case('fixedThermalCond_snow' ); get_ixparam = iLookPARAM%fixedThermalCond_snow ! temporally constant thermal conductivity for snow (W m-1 K-1) + case('snowfrz_scale' ); get_ixParam = iLookPARAM%snowfrz_scale ! scaling parameter for the freezing curve for snow (K-1) + case('fixedThermalCond_snow' ); get_ixParam = iLookPARAM%fixedThermalCond_snow ! temporally constant thermal conductivity for snow (W m-1 K-1) ! snow albedo - case('albedoMax' ); get_ixparam = iLookPARAM%albedoMax ! maximum snow albedo for a single spectral band (-) - case('albedoMinWinter' ); get_ixparam = iLookPARAM%albedoMinWinter ! minimum snow albedo during winter for a single spectral band (-) - case('albedoMinSpring' ); get_ixparam = iLookPARAM%albedoMinSpring ! minimum snow albedo during spring for a single spectral band (-) - case('albedoMaxVisible' ); get_ixparam = iLookPARAM%albedoMaxVisible ! maximum snow albedo in the visible part of the spectrum (-) - case('albedoMinVisible' ); get_ixparam = iLookPARAM%albedoMinVisible ! minimum snow albedo in the visible part of the spectrum (-) - case('albedoMaxNearIR' ); get_ixparam = iLookPARAM%albedoMaxNearIR ! maximum snow albedo in the near infra-red part of the spectrum (-) - case('albedoMinNearIR' ); get_ixparam = iLookPARAM%albedoMinNearIR ! minimum snow albedo in the near infra-red part of the spectrum (-) - case('albedoDecayRate' ); get_ixparam = iLookPARAM%albedoDecayRate ! albedo decay rate (s) - case('albedoSootLoad' ); get_ixparam = iLookPARAM%albedoSootLoad ! soot load factor (-) - case('albedoRefresh' ); get_ixparam = iLookPARAM%albedoRefresh ! critical mass necessary for albedo refreshment (kg m-2) + case('albedoMax' ); get_ixParam = iLookPARAM%albedoMax ! maximum snow albedo for a single spectral band (-) + case('albedoMinWinter' ); get_ixParam = iLookPARAM%albedoMinWinter ! minimum snow albedo during winter for a single spectral band (-) + case('albedoMinSpring' ); get_ixParam = iLookPARAM%albedoMinSpring ! minimum snow albedo during spring for a single spectral band (-) + case('albedoMaxVisible' ); get_ixParam = iLookPARAM%albedoMaxVisible ! maximum snow albedo in the visible part of the spectrum (-) + case('albedoMinVisible' ); get_ixParam = iLookPARAM%albedoMinVisible ! minimum snow albedo in the visible part of the spectrum (-) + case('albedoMaxNearIR' ); get_ixParam = iLookPARAM%albedoMaxNearIR ! maximum snow albedo in the near infra-red part of the spectrum (-) + case('albedoMinNearIR' ); get_ixParam = iLookPARAM%albedoMinNearIR ! minimum snow albedo in the near infra-red part of the spectrum (-) + case('albedoDecayRate' ); get_ixParam = iLookPARAM%albedoDecayRate ! albedo decay rate (s) + case('albedoSootLoad' ); get_ixParam = iLookPARAM%albedoSootLoad ! soot load factor (-) + case('albedoRefresh' ); get_ixParam = iLookPARAM%albedoRefresh ! critical mass necessary for albedo refreshment (kg m-2) ! radiation transfer - case('radExt_snow' ); get_ixparam = iLookPARAM%radExt_snow ! extinction coefficient for radiation penetration within the snowpack (m-1) - case('directScale' ); get_ixparam = iLookPARAM%directScale ! scaling factor for fractional driect radiaion parameterization (-) - case('Frad_direct' ); get_ixparam = iLookPARAM%Frad_direct ! maximum fraction of direct radiation (-) - case('Frad_vis' ); get_ixparam = iLookPARAM%Frad_vis ! fraction of radiation in the visible part of the spectrum (-) + case('radExt_snow' ); get_ixParam = iLookPARAM%radExt_snow ! extinction coefficient for radiation penetration within the snowpack (m-1) + case('directScale' ); get_ixParam = iLookPARAM%directScale ! scaling factor for fractional driect radiaion parameterization (-) + case('Frad_direct' ); get_ixParam = iLookPARAM%Frad_direct ! maximum fraction of direct radiation (-) + case('Frad_vis' ); get_ixParam = iLookPARAM%Frad_vis ! fraction of radiation in the visible part of the spectrum (-) ! new snow density - case('newSnowDenMin' ); get_ixparam = iLookPARAM%newSnowDenMin ! minimum new snow density (kg m-3) - case('newSnowDenMult' ); get_ixparam = iLookPARAM%newSnowDenMult ! multiplier for new snow density (kg m-3) - case('newSnowDenScal' ); get_ixparam = iLookPARAM%newSnowDenScal ! scaling factor for new snow density (K) - case('constSnowDen' ); get_ixparam = iLookPARAM%constSnowDen ! Constant new snow density (kg m-3) - case('newSnowDenAdd' ); get_ixparam = iLookPARAM%newSnowDenAdd ! Pahaut 1976, additive factor for new snow density (kg m-3) - case('newSnowDenMultTemp' ); get_ixparam = iLookPARAM%newSnowDenMultTemp ! Pahaut 1976, multiplier for new snow density applied to air temperature (kg m-3 K-1) - case('newSnowDenMultWind' ); get_ixparam = iLookPARAM%newSnowDenMultWind ! Pahaut 1976, multiplier for new snow density applied to wind speed (kg m-7/2 s-1/2) - case('newSnowDenMultAnd' ); get_ixparam = iLookPARAM%newSnowDenMultAnd ! Anderson 1976, multiplier for new snow density for Anderson function (K-1) - case('newSnowDenBase' ); get_ixparam = iLookPARAM%newSnowDenBase ! Anderson 1976, base value that is rasied to the (3/2) power (K) + case('newSnowDenMin' ); get_ixParam = iLookPARAM%newSnowDenMin ! minimum new snow density (kg m-3) + case('newSnowDenMult' ); get_ixParam = iLookPARAM%newSnowDenMult ! multiplier for new snow density (kg m-3) + case('newSnowDenScal' ); get_ixParam = iLookPARAM%newSnowDenScal ! scaling factor for new snow density (K) + case('constSnowDen' ); get_ixParam = iLookPARAM%constSnowDen ! Constant new snow density (kg m-3) + case('newSnowDenAdd' ); get_ixParam = iLookPARAM%newSnowDenAdd ! Pahaut 1976, additive factor for new snow density (kg m-3) + case('newSnowDenMultTemp' ); get_ixParam = iLookPARAM%newSnowDenMultTemp ! Pahaut 1976, multiplier for new snow density applied to air temperature (kg m-3 K-1) + case('newSnowDenMultWind' ); get_ixParam = iLookPARAM%newSnowDenMultWind ! Pahaut 1976, multiplier for new snow density applied to wind speed (kg m-7/2 s-1/2) + case('newSnowDenMultAnd' ); get_ixParam = iLookPARAM%newSnowDenMultAnd ! Anderson 1976, multiplier for new snow density for Anderson function (K-1) + case('newSnowDenBase' ); get_ixParam = iLookPARAM%newSnowDenBase ! Anderson 1976, base value that is rasied to the (3/2) power (K) ! snow compaction - case('densScalGrowth' ); get_ixparam = iLookPARAM%densScalGrowth ! density scaling factor for grain growth (kg-1 m3) - case('tempScalGrowth' ); get_ixparam = iLookPARAM%tempScalGrowth ! temperature scaling factor for grain growth (K-1) - case('grainGrowthRate' ); get_ixparam = iLookPARAM%grainGrowthRate ! rate of grain growth (s-1) - case('densScalOvrbdn' ); get_ixparam = iLookPARAM%densScalOvrbdn ! density scaling factor for overburden pressure (kg-1 m3) - case('tempScalOvrbdn' ); get_ixparam = iLookPARAM%tempScalOvrbdn ! temperature scaling factor for overburden pressure (K-1) - case('baseViscosity' ); get_ixparam = iLookPARAM%baseViscosity ! viscosity coefficient at T=T_frz and snow density=0 (kg s m-2) + case('densScalGrowth' ); get_ixParam = iLookPARAM%densScalGrowth ! density scaling factor for grain growth (kg-1 m3) + case('tempScalGrowth' ); get_ixParam = iLookPARAM%tempScalGrowth ! temperature scaling factor for grain growth (K-1) + case('grainGrowthRate' ); get_ixParam = iLookPARAM%grainGrowthRate ! rate of grain growth (s-1) + case('densScalOvrbdn' ); get_ixParam = iLookPARAM%densScalOvrbdn ! density scaling factor for overburden pressure (kg-1 m3) + case('tempScalOvrbdn' ); get_ixParam = iLookPARAM%tempScalOvrbdn ! temperature scaling factor for overburden pressure (K-1) + case('baseViscosity' ); get_ixParam = iLookPARAM%baseViscosity ! viscosity coefficient at T=T_frz and snow density=0 (kg s m-2) ! water flow through snow - case('Fcapil' ); get_ixparam = iLookPARAM%Fcapil ! capillary retention as a fraction of the total pore volume (-) - case('k_snow' ); get_ixparam = iLookPARAM%k_snow ! hydraulic conductivity of snow (m s-1), 0.0055 = approx. 20 m/hr, from UEB - case('mw_exp' ); get_ixparam = iLookPARAM%mw_exp ! exponent for meltwater flow (-) + case('Fcapil' ); get_ixParam = iLookPARAM%Fcapil ! capillary retention as a fraction of the total pore volume (-) + case('k_snow' ); get_ixParam = iLookPARAM%k_snow ! hydraulic conductivity of snow (m s-1), 0.0055 = approx. 20 m/hr, from UEB + case('mw_exp' ); get_ixParam = iLookPARAM%mw_exp ! exponent for meltwater flow (-) ! turbulent heat fluxes - case('z0Snow' ); get_ixparam = iLookPARAM%z0Snow ! roughness length of snow (m) - case('z0Soil' ); get_ixparam = iLookPARAM%z0Soil ! roughness length of bare soil below the canopy (m) - case('z0Canopy' ); get_ixparam = iLookPARAM%z0Canopy ! roughness length of the canopy (m) - case('zpdFraction' ); get_ixparam = iLookPARAM%zpdFraction ! zero plane displacement / canopy height (-) - case('critRichNumber' ); get_ixparam = iLookPARAM%critRichNumber ! critical value for the bulk Richardson number (-) - case('Louis79_bparam' ); get_ixparam = iLookPARAM%Louis79_bparam ! parameter in Louis (1979) stability function (-) - case('Louis79_cStar' ); get_ixparam = iLookPARAM%Louis79_cStar ! parameter in Louis (1979) stability function (-) - case('Mahrt87_eScale' ); get_ixparam = iLookPARAM%Mahrt87_eScale ! exponential scaling factor in the Mahrt (1987) stability function (-) - case('leafExchangeCoeff' ); get_ixparam = iLookPARAM%leafExchangeCoeff ! turbulent exchange coeff between canopy surface and canopy air ( m s-(1/2) ) - case('windReductionParam' ); get_ixparam = iLookPARAM%windReductionParam ! canopy wind reduction parameter (-) + case('z0Snow' ); get_ixParam = iLookPARAM%z0Snow ! roughness length of snow (m) + case('z0Soil' ); get_ixParam = iLookPARAM%z0Soil ! roughness length of bare soil below the canopy (m) + case('z0Canopy' ); get_ixParam = iLookPARAM%z0Canopy ! roughness length of the canopy (m), only used if decision veg_traits==vegTypeTable + case('zpdFraction' ); get_ixParam = iLookPARAM%zpdFraction ! zero plane displacement / canopy height (-) + case('critRichNumber' ); get_ixParam = iLookPARAM%critRichNumber ! critical value for the bulk Richardson number (-) + case('Louis79_bparam' ); get_ixParam = iLookPARAM%Louis79_bparam ! parameter in Louis (1979) stability function (-) + case('Louis79_cStar' ); get_ixParam = iLookPARAM%Louis79_cStar ! parameter in Louis (1979) stability function (-) + case('Mahrt87_eScale' ); get_ixParam = iLookPARAM%Mahrt87_eScale ! exponential scaling factor in the Mahrt (1987) stability function (-) + case('leafExchangeCoeff' ); get_ixParam = iLookPARAM%leafExchangeCoeff ! turbulent exchange coeff between canopy surface and canopy air ( m s-(1/2) ) + case('windReductionParam' ); get_ixParam = iLookPARAM%windReductionParam ! canopy wind reduction parameter (-) ! stomatal conductance - case('Kc25' ); get_ixparam = iLookPARAM%Kc25 ! Michaelis-Menten constant for CO2 at 25 degrees C (umol mol-1) - case('Ko25' ); get_ixparam = iLookPARAM%Ko25 ! Michaelis-Menten constant for O2 at 25 degrees C (mol mol-1) - case('Kc_qFac' ); get_ixparam = iLookPARAM%Kc_qFac ! factor in the q10 function defining temperature controls on Kc (-) - case('Ko_qFac' ); get_ixparam = iLookPARAM%Ko_qFac ! factor in the q10 function defining temperature controls on Ko (-) - case('kc_Ha' ); get_ixparam = iLookPARAM%kc_Ha ! activation energy for the Michaelis-Menten constant for CO2 (J mol-1) - case('ko_Ha' ); get_ixparam = iLookPARAM%ko_Ha ! activation energy for the Michaelis-Menten constant for CO2 (J mol-1) - case('vcmax25_canopyTop' ); get_ixparam = iLookPARAM%vcmax25_canopyTop ! potential carboxylation rate at 25 degrees C at the canopy top (umol co2 m-2 s-1) - case('vcmax_qFac' ); get_ixparam = iLookPARAM%vcmax_qFac ! factor in the q10 function defining temperature controls on vcmax (-) - case('vcmax_Ha' ); get_ixparam = iLookPARAM%vcmax_Ha ! activation energy in the vcmax function (J mol-1) - case('vcmax_Hd' ); get_ixparam = iLookPARAM%vcmax_Hd ! deactivation energy in the vcmax function (J mol-1) - case('vcmax_Sv' ); get_ixparam = iLookPARAM%vcmax_Sv ! entropy term in the vcmax function (J mol-1 K-1) - case('vcmax_Kn' ); get_ixparam = iLookPARAM%vcmax_Kn ! foliage nitrogen decay coefficient (-) - case('jmax25_scale' ); get_ixparam = iLookPARAM%jmax25_scale ! scaling factor to relate jmax25 to vcmax25 (-) - case('jmax_Ha' ); get_ixparam = iLookPARAM%jmax_Ha ! activation energy in the jmax function (J mol-1) - case('jmax_Hd' ); get_ixparam = iLookPARAM%jmax_Hd ! deactivation energy in the jmax function (J mol-1) - case('jmax_Sv' ); get_ixparam = iLookPARAM%jmax_Sv ! entropy term in the jmax function (J mol-1 K-1) - case('fractionJ' ); get_ixparam = iLookPARAM%fractionJ ! fraction of light lost by other than the chloroplast lamellae (-) - case('quantamYield' ); get_ixparam = iLookPARAM%quantamYield ! quantam yield (mol e mol-1 quanta) - case('vpScaleFactor' ); get_ixparam = iLookPARAM%vpScaleFactor ! vapor pressure scaling factor in stomatal conductance function (Pa) - case('cond2photo_slope' ); get_ixparam = iLookPARAM%cond2photo_slope ! slope of conductance-photosynthesis relationship (-) - case('minStomatalConductance' ); get_ixparam = iLookPARAM%minStomatalConductance ! minimum stomatal conductance (umol H2O m-2 s-1) + case('Kc25' ); get_ixParam = iLookPARAM%Kc25 ! Michaelis-Menten constant for CO2 at 25 degrees C (umol mol-1) + case('Ko25' ); get_ixParam = iLookPARAM%Ko25 ! Michaelis-Menten constant for O2 at 25 degrees C (mol mol-1) + case('Kc_qFac' ); get_ixParam = iLookPARAM%Kc_qFac ! factor in the q10 function defining temperature controls on Kc (-) + case('Ko_qFac' ); get_ixParam = iLookPARAM%Ko_qFac ! factor in the q10 function defining temperature controls on Ko (-) + case('kc_Ha' ); get_ixParam = iLookPARAM%kc_Ha ! activation energy for the Michaelis-Menten constant for CO2 (J mol-1) + case('ko_Ha' ); get_ixParam = iLookPARAM%ko_Ha ! activation energy for the Michaelis-Menten constant for CO2 (J mol-1) + case('vcmax25_canopyTop' ); get_ixParam = iLookPARAM%vcmax25_canopyTop ! potential carboxylation rate at 25 degrees C at the canopy top (umol co2 m-2 s-1) + case('vcmax_qFac' ); get_ixParam = iLookPARAM%vcmax_qFac ! factor in the q10 function defining temperature controls on vcmax (-) + case('vcmax_Ha' ); get_ixParam = iLookPARAM%vcmax_Ha ! activation energy in the vcmax function (J mol-1) + case('vcmax_Hd' ); get_ixParam = iLookPARAM%vcmax_Hd ! deactivation energy in the vcmax function (J mol-1) + case('vcmax_Sv' ); get_ixParam = iLookPARAM%vcmax_Sv ! entropy term in the vcmax function (J mol-1 K-1) + case('vcmax_Kn' ); get_ixParam = iLookPARAM%vcmax_Kn ! foliage nitrogen decay coefficient (-) + case('jmax25_scale' ); get_ixParam = iLookPARAM%jmax25_scale ! scaling factor to relate jmax25 to vcmax25 (-) + case('jmax_Ha' ); get_ixParam = iLookPARAM%jmax_Ha ! activation energy in the jmax function (J mol-1) + case('jmax_Hd' ); get_ixParam = iLookPARAM%jmax_Hd ! deactivation energy in the jmax function (J mol-1) + case('jmax_Sv' ); get_ixParam = iLookPARAM%jmax_Sv ! entropy term in the jmax function (J mol-1 K-1) + case('fractionJ' ); get_ixParam = iLookPARAM%fractionJ ! fraction of light lost by other than the chloroplast lamellae (-) + case('quantamYield' ); get_ixParam = iLookPARAM%quantamYield ! quantam yield (mol e mol-1 quanta) + case('vpScaleFactor' ); get_ixParam = iLookPARAM%vpScaleFactor ! vapor pressure scaling factor in stomatal conductance function (Pa) + case('cond2photo_slope' ); get_ixParam = iLookPARAM%cond2photo_slope ! slope of conductance-photosynthesis relationship (-) + case('minStomatalConductance' ); get_ixParam = iLookPARAM%minStomatalConductance ! minimum stomatal conductance (umol H2O m-2 s-1) ! vegetation properties - case('winterSAI' ); get_ixparam = iLookPARAM%winterSAI ! stem area index prior to the start of the growing season (m2 m-2) - case('summerLAI' ); get_ixparam = iLookPARAM%summerLAI ! maximum leaf area index at the peak of the growing season (m2 m-2) - case('rootScaleFactor1' ); get_ixparam = iLookPARAM%rootScaleFactor1 ! 1st scaling factor (a) in Y = 1 - 0.5*( exp(-aZ) + exp(-bZ) ) (m-1) - case('rootScaleFactor2' ); get_ixparam = iLookPARAM%rootScaleFactor2 ! 2nd scaling factor (b) in Y = 1 - 0.5*( exp(-aZ) + exp(-bZ) ) (m-1) - case('rootingDepth' ); get_ixparam = iLookPARAM%rootingDepth ! rooting depth (m) - case('rootDistExp' ); get_ixparam = iLookPARAM%rootDistExp ! exponent for the vertical distriution of root density (-) - case('plantWiltPsi' ); get_ixparam = iLookPARAM%plantWiltPsi ! matric head at wilting point (m) - case('soilStressParam' ); get_ixparam = iLookPARAM%soilStressParam ! parameter in the exponential soil stress function - case('critSoilWilting' ); get_ixparam = iLookPARAM%critSoilWilting ! critical vol. liq. water content when plants are wilting (-) - case('critSoilTranspire' ); get_ixparam = iLookPARAM%critSoilTranspire ! critical vol. liq. water content when transpiration is limited (-) - case('critAquiferTranspire' ); get_ixparam = iLookPARAM%critAquiferTranspire ! critical aquifer storage value when transpiration is limited (m) - case('minStomatalResistance' ); get_ixparam = iLookPARAM%minStomatalResistance ! minimum canopy resistance (s m-1) - case('leafDimension' ); get_ixparam = iLookPARAM%leafDimension ! characteristic leaf dimension (m) - case('heightCanopyTop' ); get_ixparam = iLookPARAM%heightCanopyTop ! height of top of the vegetation canopy above ground surface (m) - case('heightCanopyBottom' ); get_ixparam = iLookPARAM%heightCanopyBottom ! height of bottom of the vegetation canopy above ground surface (m) - case('specificHeatVeg' ); get_ixparam = iLookPARAM%specificHeatVeg ! specific heat of vegetation (J kg-1 K-1) - case('maxMassVegetation' ); get_ixparam = iLookPARAM%maxMassVegetation ! maximum mass of vegetation (full foliage) (kg m-2) - case('throughfallScaleSnow' ); get_ixparam = iLookPARAM%throughfallScaleSnow ! scaling factor for throughfall (snow) (-) - case('throughfallScaleRain' ); get_ixparam = iLookPARAM%throughfallScaleRain ! scaling factor for throughfall (rain) (-) - case('refInterceptCapSnow' ); get_ixparam = iLookPARAM%refInterceptCapSnow ! reference canopy interception capacity per unit leaf area (snow) (kg m-2) - case('refInterceptCapRain' ); get_ixparam = iLookPARAM%refInterceptCapRain ! canopy interception capacity per unit leaf area (rain) (kg m-2) - case('snowUnloadingCoeff' ); get_ixparam = iLookPARAM%snowUnloadingCoeff ! time constant for unloading of snow from the forest canopy (s-1) - case('canopyDrainageCoeff' ); get_ixparam = iLookPARAM%canopyDrainageCoeff ! time constant for drainage of liquid water from the forest canopy (s-1) - case('ratioDrip2Unloading' ); get_ixparam = iLookPARAM%ratioDrip2Unloading ! ratio of canopy drip to unloading of snow from the forest canopy (-) - case('canopyWettingFactor' ); get_ixparam = iLookPARAM%canopyWettingFactor ! maximum wetted fraction of the canopy (-) - case('canopyWettingExp' ); get_ixparam = iLookPARAM%canopyWettingExp ! exponent in canopy wetting function (-) - case('minTempUnloading' ); get_ixparam = iLookPARAM%minTempUnloading ! min temp for unloading in windySnow (K) - case('rateTempUnloading' ); get_ixparam = iLookPARAM%rateTempUnloading ! how quickly to unload due to temperature (K s) - case('minWindUnloading' ); get_ixparam = iLookPARAM%minWindUnloading ! min wind speed for unloading in windySnow (m s-1) - case('rateWindUnloading' ); get_ixparam = iLookPARAM%rateWindUnloading ! how quickly to unload due to wind (m) + case('winterSAI' ); get_ixParam = iLookPARAM%winterSAI ! stem area index prior to the start of the growing season (m2 m-2) + case('summerLAI' ); get_ixParam = iLookPARAM%summerLAI ! maximum leaf area index at the peak of the growing season (m2 m-2) + case('rootScaleFactor1' ); get_ixParam = iLookPARAM%rootScaleFactor1 ! 1st scaling factor (a) in Y = 1 - 0.5*( exp(-aZ) + exp(-bZ) ) (m-1) + case('rootScaleFactor2' ); get_ixParam = iLookPARAM%rootScaleFactor2 ! 2nd scaling factor (b) in Y = 1 - 0.5*( exp(-aZ) + exp(-bZ) ) (m-1) + case('rootingDepth' ); get_ixParam = iLookPARAM%rootingDepth ! rooting depth (m) + case('rootDistExp' ); get_ixParam = iLookPARAM%rootDistExp ! exponent for the vertical distriution of root density (-) + case('plantWiltPsi' ); get_ixParam = iLookPARAM%plantWiltPsi ! matric head at wilting point (m) + case('soilStressParam' ); get_ixParam = iLookPARAM%soilStressParam ! parameter in the exponential soil stress function + case('critSoilWilting' ); get_ixParam = iLookPARAM%critSoilWilting ! critical vol. liq. water content when plants are wilting (-) + case('critSoilTranspire' ); get_ixParam = iLookPARAM%critSoilTranspire ! critical vol. liq. water content when transpiration is limited (-) + case('critAquiferTranspire' ); get_ixParam = iLookPARAM%critAquiferTranspire ! critical aquifer storage value when transpiration is limited (m) + case('minStomatalResistance' ); get_ixParam = iLookPARAM%minStomatalResistance ! minimum canopy resistance (s m-1) + case('leafDimension' ); get_ixParam = iLookPARAM%leafDimension ! characteristic leaf dimension (m) + case('heightCanopyTop' ); get_ixParam = iLookPARAM%heightCanopyTop ! height of top of the vegetation canopy above ground surface (m) + case('heightCanopyBottom' ); get_ixParam = iLookPARAM%heightCanopyBottom ! height of bottom of the vegetation canopy above ground surface (m) + case('specificHeatVeg' ); get_ixParam = iLookPARAM%specificHeatVeg ! specific heat of vegetation (J kg-1 K-1) + case('maxMassVegetation' ); get_ixParam = iLookPARAM%maxMassVegetation ! maximum mass of vegetation (full foliage) (kg m-2) + case('throughfallScaleSnow' ); get_ixParam = iLookPARAM%throughfallScaleSnow ! scaling factor for throughfall (snow) (-) + case('throughfallScaleRain' ); get_ixParam = iLookPARAM%throughfallScaleRain ! scaling factor for throughfall (rain) (-) + case('refInterceptCapSnow' ); get_ixParam = iLookPARAM%refInterceptCapSnow ! reference canopy interception capacity per unit leaf area (snow) (kg m-2) + case('refInterceptCapRain' ); get_ixParam = iLookPARAM%refInterceptCapRain ! canopy interception capacity per unit leaf area (rain) (kg m-2) + case('snowUnloadingCoeff' ); get_ixParam = iLookPARAM%snowUnloadingCoeff ! time constant for unloading of snow from the forest canopy (s-1) + case('canopyDrainageCoeff' ); get_ixParam = iLookPARAM%canopyDrainageCoeff ! time constant for drainage of liquid water from the forest canopy (s-1) + case('ratioDrip2Unloading' ); get_ixParam = iLookPARAM%ratioDrip2Unloading ! ratio of canopy drip to unloading of snow from the forest canopy (-) + case('canopyWettingFactor' ); get_ixParam = iLookPARAM%canopyWettingFactor ! maximum wetted fraction of the canopy (-) + case('canopyWettingExp' ); get_ixParam = iLookPARAM%canopyWettingExp ! exponent in canopy wetting function (-) + case('minTempUnloading' ); get_ixParam = iLookPARAM%minTempUnloading ! min temp for unloading in windySnow (K) + case('rateTempUnloading' ); get_ixParam = iLookPARAM%rateTempUnloading ! how quickly to unload due to temperature (K s) + case('minWindUnloading' ); get_ixParam = iLookPARAM%minWindUnloading ! min wind speed for unloading in windySnow (m s-1) + case('rateWindUnloading' ); get_ixParam = iLookPARAM%rateWindUnloading ! how quickly to unload due to wind (m) ! soil properties - case('soil_dens_intr' ); get_ixparam = iLookPARAM%soil_dens_intr ! intrinsic soil density (kg m-3) - case('thCond_soil' ); get_ixparam = iLookPARAM%thCond_soil ! thermal conductivity of soil (W m-1 K-1) - case('frac_sand' ); get_ixparam = iLookPARAM%frac_sand ! fraction of sand (-) - case('frac_silt' ); get_ixparam = iLookPARAM%frac_silt ! fraction of silt (-) - case('frac_clay' ); get_ixparam = iLookPARAM%frac_clay ! fraction of clay (-) - case('fieldCapacity' ); get_ixparam = iLookPARAM%fieldCapacity ! field capacity (-) - case('wettingFrontSuction' ); get_ixparam = iLookPARAM%wettingFrontSuction ! Green-Ampt wetting front suction (m) - case('theta_mp' ); get_ixparam = iLookPARAM%theta_mp ! volumetric liquid water content when macropore flow begins (-) - case('theta_sat' ); get_ixparam = iLookPARAM%theta_sat ! soil porosity (-) - case('theta_res' ); get_ixparam = iLookPARAM%theta_res ! volumetric residual water content (-) - case('vGn_alpha' ); get_ixparam = iLookPARAM%vGn_alpha ! van Genuchten "alpha" parameter (m-1) - case('vGn_n' ); get_ixparam = iLookPARAM%vGn_n ! van Genuchten "n" parameter (-) - case('mpExp' ); get_ixparam = iLookPARAM%mpExp ! empirical exponent in macropore flow equation (-) - case('k_soil' ); get_ixparam = iLookPARAM%k_soil ! saturated hydraulic conductivity (m s-1) - case('k_macropore' ); get_ixparam = iLookPARAM%k_macropore ! saturated hydraulic conductivity for the macropores (m s-1) - case('kAnisotropic' ); get_ixparam = iLookPARAM%kAnisotropic ! anisotropy factor for lateral hydraulic conductivity (-) - case('zScale_TOPMODEL' ); get_ixparam = iLookPARAM%zScale_TOPMODEL ! TOPMODEL scaling factor used in lower boundary condition for soil (m) - case('compactedDepth' ); get_ixparam = iLookPARAM%compactedDepth ! depth where k_soil reaches the compacted value given by CH78 (m) - case('aquiferBaseflowRate' ); get_ixparam = iLookPARAM%aquiferBaseflowRate ! baseflow rate when aquifer storage = aquiferScaleFactor (m s-1) - case('aquiferScaleFactor' ); get_ixparam = iLookPARAM%aquiferScaleFactor ! scaling factor for aquifer storage in the big bucket (m) - case('aquiferBaseflowExp' ); get_ixparam = iLookPARAM%aquiferBaseflowExp ! baseflow exponent (-) - case('qSurfScale' ); get_ixparam = iLookPARAM%qSurfScale ! scaling factor in the surface runoff parameterization (-) - case('specificYield' ); get_ixparam = iLookPARAM%specificYield ! specific yield (-) - case('specificStorage' ); get_ixparam = iLookPARAM%specificStorage ! specific storage coefficient (m-1) - case('f_impede' ); get_ixparam = iLookPARAM%f_impede ! ice impedence factor (-) - case('soilIceScale' ); get_ixparam = iLookPARAM%soilIceScale ! scaling factor for depth of soil ice, used to get frozen fraction (m) - case('soilIceCV' ); get_ixparam = iLookPARAM%soilIceCV ! CV of depth of soil ice, used to get frozen fraction (-) + case('soil_dens_intr' ); get_ixParam = iLookPARAM%soil_dens_intr ! intrinsic soil density (kg m-3) + case('thCond_soil' ); get_ixParam = iLookPARAM%thCond_soil ! thermal conductivity of soil (W m-1 K-1) + case('frac_sand' ); get_ixParam = iLookPARAM%frac_sand ! fraction of sand (-) + case('frac_silt' ); get_ixParam = iLookPARAM%frac_silt ! fraction of silt (-) + case('frac_clay' ); get_ixParam = iLookPARAM%frac_clay ! fraction of clay (-) + case('fieldCapacity' ); get_ixParam = iLookPARAM%fieldCapacity ! field capacity (-) + case('wettingFrontSuction' ); get_ixParam = iLookPARAM%wettingFrontSuction ! Green-Ampt wetting front suction (m) + case('theta_mp' ); get_ixParam = iLookPARAM%theta_mp ! volumetric liquid water content when macropore flow begins (-) + case('theta_sat' ); get_ixParam = iLookPARAM%theta_sat ! soil porosity (-) + case('theta_res' ); get_ixParam = iLookPARAM%theta_res ! volumetric residual water content (-) + case('vGn_alpha' ); get_ixParam = iLookPARAM%vGn_alpha ! van Genuchten "alpha" parameter (m-1) + case('vGn_n' ); get_ixParam = iLookPARAM%vGn_n ! van Genuchten "n" parameter (-) + case('mpExp' ); get_ixParam = iLookPARAM%mpExp ! empirical exponent in macropore flow equation (-) + case('k_soil' ); get_ixParam = iLookPARAM%k_soil ! saturated hydraulic conductivity (m s-1) + case('k_macropore' ); get_ixParam = iLookPARAM%k_macropore ! saturated hydraulic conductivity for the macropores (m s-1) + case('kAnisotropic' ); get_ixParam = iLookPARAM%kAnisotropic ! anisotropy factor for lateral hydraulic conductivity (-) + case('zScale_TOPMODEL' ); get_ixParam = iLookPARAM%zScale_TOPMODEL ! TOPMODEL scaling factor used in lower boundary condition for soil (m) + case('compactedDepth' ); get_ixParam = iLookPARAM%compactedDepth ! depth where k_soil reaches the compacted value given by CH78 (m) + case('aquiferBaseflowRate' ); get_ixParam = iLookPARAM%aquiferBaseflowRate ! baseflow rate when aquifer storage = aquiferScaleFactor (m s-1) + case('aquiferScaleFactor' ); get_ixParam = iLookPARAM%aquiferScaleFactor ! scaling factor for aquifer storage in the big bucket (m) + case('aquiferBaseflowExp' ); get_ixParam = iLookPARAM%aquiferBaseflowExp ! baseflow exponent (-) + case('qSurfScale' ); get_ixParam = iLookPARAM%qSurfScale ! scaling factor in the surface runoff parameterization (-) + case('specificYield' ); get_ixParam = iLookPARAM%specificYield ! specific yield (-) + case('specificStorage' ); get_ixParam = iLookPARAM%specificStorage ! specific storage coefficient (m-1) + case('f_impede' ); get_ixParam = iLookPARAM%f_impede ! ice impedence factor (-) + case('soilIceScale' ); get_ixParam = iLookPARAM%soilIceScale ! scaling factor for depth of soil ice, used to get frozen fraction (m) + case('soilIceCV' ); get_ixParam = iLookPARAM%soilIceCV ! CV of depth of soil ice, used to get frozen fraction (-) + ! conceptual parameters for surface runoff + case('FUSE_Ac_max' ); get_ixParam = iLookPARAM%FUSE_Ac_max ! FUSE PRMS max saturated area + case('FUSE_phi_tens' ); get_ixParam = iLookPARAM%FUSE_phi_tens ! FUSE PRMS tension storage fraction + case('FUSE_b' ); get_ixParam = iLookPARAM%FUSE_b ! FUSE ARNO/VIC exponent + case('FUSE_lambda' ); get_ixParam = iLookPARAM%FUSE_lambda ! FUSE TOPMODEL gamma distribution lambda parameter + case('FUSE_chi' ); get_ixParam = iLookPARAM%FUSE_chi ! FUSE TOPMODEL gamma distribution chi parameter + case('FUSE_mu' ); get_ixParam = iLookPARAM%FUSE_mu ! FUSE TOPMODEL gamma distribution mu parameter + case('FUSE_n' ); get_ixParam = iLookPARAM%FUSE_n ! FUSE TOPMODEL exponent ! algorithmic control parameters - case('minwind' ); get_ixparam = iLookPARAM%minwind ! minimum wind speed (m s-1) - case('minstep' ); get_ixparam = iLookPARAM%minstep ! minimum length of the time step - case('maxstep' ); get_ixparam = iLookPARAM%maxstep ! maximum length of the time step - case('wimplicit' ); get_ixparam = iLookPARAM%wimplicit ! weight assigned to start-of-step fluxes - case('maxiter' ); get_ixparam = iLookPARAM%maxiter ! maximum number of iterations - case('relConvTol_liquid' ); get_ixparam = iLookPARAM%relConvTol_liquid ! relative convergence tolerance for vol frac liq water (-) - case('absConvTol_liquid' ); get_ixparam = iLookPARAM%absConvTol_liquid ! absolute convergence tolerance for vol frac liq water (-) - case('relConvTol_matric' ); get_ixparam = iLookPARAM%relConvTol_matric ! relative convergence tolerance for matric head (-) - case('absConvTol_matric' ); get_ixparam = iLookPARAM%absConvTol_matric ! absolute convergence tolerance for matric head (m) - case('relConvTol_energy' ); get_ixparam = iLookPARAM%relConvTol_energy ! relative convergence tolerance for energy (-) - case('absConvTol_energy' ); get_ixparam = iLookPARAM%absConvTol_energy ! absolute convergence tolerance for energy (J m-3) - case('relConvTol_aquifr' ); get_ixparam = iLookPARAM%relConvTol_aquifr ! relative convergence tolerance for aquifer storage (-) - case('absConvTol_aquifr' ); get_ixparam = iLookPARAM%absConvTol_aquifr ! absolute convergence tolerance for aquifer storage (m) - case('zmin' ); get_ixparam = iLookPARAM%zmin ! minimum layer depth (m) - case('zmax' ); get_ixparam = iLookPARAM%zmax ! maximum layer depth (m) - case('zminLayer1' ); get_ixparam = iLookPARAM%zminLayer1 ! minimum layer depth for the 1st (top) layer (m) - case('zminLayer2' ); get_ixparam = iLookPARAM%zminLayer2 ! minimum layer depth for the 2nd layer (m) - case('zminLayer3' ); get_ixparam = iLookPARAM%zminLayer3 ! minimum layer depth for the 3rd layer (m) - case('zminLayer4' ); get_ixparam = iLookPARAM%zminLayer4 ! minimum layer depth for the 4th layer (m) - case('zminLayer5' ); get_ixparam = iLookPARAM%zminLayer5 ! minimum layer depth for the 5th (bottom) layer (m) - case('zmaxLayer1_lower' ); get_ixparam = iLookPARAM%zmaxLayer1_lower ! maximum layer depth for the 1st (top) layer when only 1 layer (m) - case('zmaxLayer2_lower' ); get_ixparam = iLookPARAM%zmaxLayer2_lower ! maximum layer depth for the 2nd layer when only 2 layers (m) - case('zmaxLayer3_lower' ); get_ixparam = iLookPARAM%zmaxLayer3_lower ! maximum layer depth for the 3rd layer when only 3 layers (m) - case('zmaxLayer4_lower' ); get_ixparam = iLookPARAM%zmaxLayer4_lower ! maximum layer depth for the 4th layer when only 4 layers (m) - case('zmaxLayer1_upper' ); get_ixparam = iLookPARAM%zmaxLayer1_upper ! maximum layer depth for the 1st (top) layer when > 1 layer (m) - case('zmaxLayer2_upper' ); get_ixparam = iLookPARAM%zmaxLayer2_upper ! maximum layer depth for the 2nd layer when > 2 layers (m) - case('zmaxLayer3_upper' ); get_ixparam = iLookPARAM%zmaxLayer3_upper ! maximum layer depth for the 3rd layer when > 3 layers (m) - case('zmaxLayer4_upper' ); get_ixparam = iLookPARAM%zmaxLayer4_upper ! maximum layer depth for the 4th layer when > 4 layers (m) + case('minwind' ); get_ixParam = iLookPARAM%minwind ! minimum wind speed (m s-1) + case('minstep' ); get_ixParam = iLookPARAM%minstep ! minimum length of the time step homegrown + case('maxstep' ); get_ixParam = iLookPARAM%maxstep ! maximum length of the time step (data window) + case('be_steps' ); get_ixParam = iLookPARAM%be_steps ! number of equal substeps to dividing the data window for BE + case('wimplicit' ); get_ixParam = iLookPARAM%wimplicit ! weight assigned to start-of-step fluxes homegrown, not currently used + case('maxiter' ); get_ixParam = iLookPARAM%maxiter ! maximum number of iterations homegrown and kinsol + case('relConvTol_liquid' ); get_ixParam = iLookPARAM%relConvTol_liquid ! BE relative convergence tolerance for vol frac liq water (-) homegrown + case('absConvTol_liquid' ); get_ixParam = iLookPARAM%absConvTol_liquid ! BE absolute convergence tolerance for vol frac liq water (-) homegrown + case('relConvTol_matric' ); get_ixParam = iLookPARAM%relConvTol_matric ! BE relative convergence tolerance for matric head (-) homegrown + case('absConvTol_matric' ); get_ixParam = iLookPARAM%absConvTol_matric ! BE absolute convergence tolerance for matric head (m) homegrown + case('relConvTol_energy' ); get_ixParam = iLookPARAM%relConvTol_energy ! BE relative convergence tolerance for energy (-) homegrown + case('absConvTol_energy' ); get_ixParam = iLookPARAM%absConvTol_energy ! BE absolute convergence tolerance for energy (J m-3) homegrown + case('relConvTol_aquifr' ); get_ixParam = iLookPARAM%relConvTol_aquifr ! BE relative convergence tolerance for aquifer storage (-) homegrown + case('absConvTol_aquifr' ); get_ixParam = iLookPARAM%absConvTol_aquifr ! BE absolute convergence tolerance for aquifer storage (m) homegrown + case('relTolTempCas' ); get_ixParam = iLookPARAM%relTolTempCas ! IDA relative error tolerance for canopy temperature state variable + case('absTolTempCas' ); get_ixParam = iLookPARAM%absTolTempCas ! IDA absolute error tolerance for canopy temperature state variable + case('relTolTempVeg' ); get_ixParam = iLookPARAM%relTolTempVeg ! IDA relative error tolerance for vegitation temp state var + case('absTolTempVeg' ); get_ixParam = iLookPARAM%absTolTempVeg ! IDA absolute error tolerance for vegitation temp state var + case('relTolWatVeg' ); get_ixParam = iLookPARAM%relTolWatVeg ! IDA relative error tolerance for vegitation hydrology + case('absTolWatVeg' ); get_ixParam = iLookPARAM%absTolWatVeg ! IDA absolute error tolerance for vegitation hydrology + case('relTolTempSoilSnow' ); get_ixParam = iLookPARAM%relTolTempSoilSnow ! IDA relative error tolerance for snow+soil energy + case('absTolTempSoilSnow' ); get_ixParam = iLookPARAM%absTolTempSoilSnow ! IDA absolute error tolerance for snow+soil energy + case('relTolWatSnow' ); get_ixParam = iLookPARAM%relTolWatSnow ! IDA relative error tolerance for snow hydrology + case('absTolWatSnow' ); get_ixParam = iLookPARAM%absTolWatSnow ! IDA absolute error tolerance for snow hydrology + case('relTolMatric' ); get_ixParam = iLookPARAM%relTolMatric ! IDA relative error tolerance for matric head + case('absTolMatric' ); get_ixParam = iLookPARAM%absTolMatric ! IDA absolute error tolerance for matric head + case('relTolAquifr' ); get_ixParam = iLookPARAM%relTolAquifr ! IDA relative error tolerance for aquifer hydrology + case('absTolAquifr' ); get_ixParam = iLookPARAM%absTolAquifr ! IDA absolute error tolerance for aquifer hydrology + case('idaMaxOrder' ); get_ixParam = iLookPARAM%idaMaxOrder ! maximum order for IDA + case('idaMaxInternalSteps' ); get_ixParam = iLookPARAM%idaMaxInternalSteps ! maximum number of internal steps for IDA before tout + case('idaInitStepSize' ); get_ixParam = iLookPARAM%idaInitStepSize ! initial step size for IDA + case('idaMinStepSize' ); get_ixParam = iLookPARAM%idaMinStepSize ! minimum step size for IDA + case('idaMaxStepSize' ); get_ixParam = iLookPARAM%idaMaxStepSize ! maximum step size for IDA + case('idaMaxErrTestFail' ); get_ixParam = iLookPARAM%idaMaxErrTestFail ! maximum number of error test failures for IDA + case('idaMaxDataWindowSteps' ); get_ixParam = iLookPARAM%idaMaxDataWindowSteps ! maximum number of steps with event detection for IDA per data window + case('idaDetectEvents' ); get_ixParam = iLookPARAM%idaDetectEvents ! flag to turn on event detection in IDA, 0=off, 1=on + case('zmin' ); get_ixParam = iLookPARAM%zmin ! minimum layer depth (m) + case('zmax' ); get_ixParam = iLookPARAM%zmax ! maximum layer depth (m) + case('zminLayer1' ); get_ixParam = iLookPARAM%zminLayer1 ! minimum layer depth for the 1st (top) layer (m) + case('zminLayer2' ); get_ixParam = iLookPARAM%zminLayer2 ! minimum layer depth for the 2nd layer (m) + case('zminLayer3' ); get_ixParam = iLookPARAM%zminLayer3 ! minimum layer depth for the 3rd layer (m) + case('zminLayer4' ); get_ixParam = iLookPARAM%zminLayer4 ! minimum layer depth for the 4th layer (m) + case('zminLayer5' ); get_ixParam = iLookPARAM%zminLayer5 ! minimum layer depth for the 5th (bottom) layer (m) + case('zmaxLayer1_lower' ); get_ixParam = iLookPARAM%zmaxLayer1_lower ! maximum layer depth for the 1st (top) layer when only 1 layer (m) + case('zmaxLayer2_lower' ); get_ixParam = iLookPARAM%zmaxLayer2_lower ! maximum layer depth for the 2nd layer when only 2 layers (m) + case('zmaxLayer3_lower' ); get_ixParam = iLookPARAM%zmaxLayer3_lower ! maximum layer depth for the 3rd layer when only 3 layers (m) + case('zmaxLayer4_lower' ); get_ixParam = iLookPARAM%zmaxLayer4_lower ! maximum layer depth for the 4th layer when only 4 layers (m) + case('zmaxLayer1_upper' ); get_ixParam = iLookPARAM%zmaxLayer1_upper ! maximum layer depth for the 1st (top) layer when > 1 layer (m) + case('zmaxLayer2_upper' ); get_ixParam = iLookPARAM%zmaxLayer2_upper ! maximum layer depth for the 2nd layer when > 2 layers (m) + case('zmaxLayer3_upper' ); get_ixParam = iLookPARAM%zmaxLayer3_upper ! maximum layer depth for the 3rd layer when > 3 layers (m) + case('zmaxLayer4_upper' ); get_ixParam = iLookPARAM%zmaxLayer4_upper ! maximum layer depth for the 4th layer when > 4 layers (m) ! get to here if cannot find the variable case default - get_ixparam = integerMissing + get_ixParam = integerMissing end select - end function get_ixparam + end function get_ixParam ! ******************************************************************************************************************* - ! public function get_ixprog: get the index of the named variables for the prognostic (state) variables + ! public function get_ixProg: get the index of the named variables for the prognostic (state) variables ! ******************************************************************************************************************* - function get_ixprog(varName) + function get_ixProg(varName) USE var_lookup,only:iLookPROG ! indices of the named variables implicit none ! define dummy variables character(*), intent(in) :: varName ! variable name - integer(i4b) :: get_ixprog ! index of the named variable + integer(i4b) :: get_ixProg ! index of the named variable ! get the index of the named variables select case(trim(varName)) ! variables for time stepping - case('dt_init' ); get_ixprog = iLookPROG%dt_init ! length of initial time step at start of next data interval (s) + case('dt_init' ); get_ixProg = iLookPROG%dt_init ! length of initial time step at start of next data interval (s) ! state variables for vegetation - case('scalarCanopyIce' ); get_ixprog = iLookPROG%scalarCanopyIce ! mass of ice on the vegetation canopy (kg m-2) - case('scalarCanopyLiq' ); get_ixprog = iLookPROG%scalarCanopyLiq ! mass of liquid water on the vegetation canopy (kg m-2) - case('scalarCanopyWat' ); get_ixprog = iLookPROG%scalarCanopyWat ! mass of total water on the vegetation canopy (kg m-2) - case('scalarCanairTemp' ); get_ixprog = iLookPROG%scalarCanairTemp ! temperature of the canopy air space (K) - case('scalarCanopyTemp' ); get_ixprog = iLookPROG%scalarCanopyTemp ! temperature of the vegetation canopy (K) + case('scalarCanopyIce' ); get_ixProg = iLookPROG%scalarCanopyIce ! mass of ice on the vegetation canopy (kg m-2) + case('scalarCanopyLiq' ); get_ixProg = iLookPROG%scalarCanopyLiq ! mass of liquid water on the vegetation canopy (kg m-2) + case('scalarCanopyWat' ); get_ixProg = iLookPROG%scalarCanopyWat ! mass of total water on the vegetation canopy (kg m-2) + case('scalarCanairTemp' ); get_ixProg = iLookPROG%scalarCanairTemp ! temperature of the canopy air space (K) + case('scalarCanopyTemp' ); get_ixProg = iLookPROG%scalarCanopyTemp ! temperature of the vegetation canopy (K) ! state variables for snow - case('spectralSnowAlbedoDiffuse' ); get_ixprog = iLookPROG%spectralSnowAlbedoDiffuse ! diffuse snow albedo for individual spectral bands (-) - case('scalarSnowAlbedo' ); get_ixprog = iLookPROG%scalarSnowAlbedo ! snow albedo for the entire spectral band (-) - case('scalarSnowDepth' ); get_ixprog = iLookPROG%scalarSnowDepth ! total snow depth (m) - case('scalarSWE' ); get_ixprog = iLookPROG%scalarSWE ! snow water equivalent (kg m-2) - case('scalarSfcMeltPond' ); get_ixprog = iLookPROG%scalarSfcMeltPond ! ponded water caused by melt of the "snow without a layer" (kg m-2) + case('spectralSnowAlbedoDiffuse' ); get_ixProg = iLookPROG%spectralSnowAlbedoDiffuse ! diffuse snow albedo for individual spectral bands (-) + case('scalarSnowAlbedo' ); get_ixProg = iLookPROG%scalarSnowAlbedo ! snow albedo for the entire spectral band (-) + case('scalarSnowDepth' ); get_ixProg = iLookPROG%scalarSnowDepth ! total snow depth (m) + case('scalarSWE' ); get_ixProg = iLookPROG%scalarSWE ! snow water equivalent (kg m-2) + case('scalarSfcMeltPond' ); get_ixProg = iLookPROG%scalarSfcMeltPond ! ponded water caused by melt of the "snow without a layer" (kg m-2) ! state variables for the snow+soil domain - case('mLayerTemp' ); get_ixprog = iLookPROG%mLayerTemp ! temperature of each layer (K) - case('mLayerVolFracIce' ); get_ixprog = iLookPROG%mLayerVolFracIce ! volumetric fraction of icein each layer (-) - case('mLayerVolFracLiq' ); get_ixprog = iLookPROG%mLayerVolFracLiq ! volumetric fraction of liquid water in each layer (-) - case('mLayerVolFracWat' ); get_ixprog = iLookPROG%mLayerVolFracWat ! volumetric fraction of total water in each layer (-) - case('mLayerMatricHead' ); get_ixprog = iLookPROG%mLayerMatricHead ! matric head of water in the soil (m) + case('mLayerTemp' ); get_ixProg = iLookPROG%mLayerTemp ! temperature of each layer (K) + case('mLayerVolFracIce' ); get_ixProg = iLookPROG%mLayerVolFracIce ! volumetric fraction of icein each layer (-) + case('mLayerVolFracLiq' ); get_ixProg = iLookPROG%mLayerVolFracLiq ! volumetric fraction of liquid water in each layer (-) + case('mLayerVolFracWat' ); get_ixProg = iLookPROG%mLayerVolFracWat ! volumetric fraction of total water in each layer (-) + case('mLayerMatricHead' ); get_ixProg = iLookPROG%mLayerMatricHead ! matric head of water in the soil (m) + ! enthalpy + case('scalarCanairEnthalpy' ); get_ixProg = iLookPROG%scalarCanairEnthalpy ! enthalpy of the canopy air space (J m-3) + case('scalarCanopyEnthalpy' ); get_ixProg = iLookPROG%scalarCanopyEnthalpy ! enthalpy of the vegetation canopy (J m-3) + case('mLayerEnthalpy' ); get_ixProg = iLookPROG%mLayerEnthalpy ! enthalpy of the snow+soil layers (J m-3) ! other state variables - case('scalarAquiferStorage' ); get_ixprog = iLookPROG%scalarAquiferStorage ! relative aquifer storage -- above bottom of the soil profile (m) - case('scalarSurfaceTemp' ); get_ixprog = iLookPROG%scalarSurfaceTemp ! surface temperature (K) + case('scalarAquiferStorage' ); get_ixProg = iLookPROG%scalarAquiferStorage ! relative aquifer storage -- above bottom of the soil profile (m) + case('scalarSurfaceTemp' ); get_ixProg = iLookPROG%scalarSurfaceTemp ! surface temperature (K) ! coordinate variables - case('mLayerDepth' ); get_ixprog = iLookPROG%mLayerDepth ! depth of each layer (m) - case('mLayerHeight' ); get_ixprog = iLookPROG%mLayerHeight ! height at the midpoint of each layer (m) - case('iLayerHeight' ); get_ixprog = iLookPROG%iLayerHeight ! height at the interface of each layer (m) + case('mLayerDepth' ); get_ixProg = iLookPROG%mLayerDepth ! depth of each layer (m) + case('mLayerHeight' ); get_ixProg = iLookPROG%mLayerHeight ! height at the midpoint of each layer (m) + case('iLayerHeight' ); get_ixProg = iLookPROG%iLayerHeight ! height at the interface of each layer (m) ! get to here if cannot find the variable case default - get_ixprog = integerMissing + get_ixProg = integerMissing end select - end function get_ixprog + end function get_ixProg ! ******************************************************************************************************************* - ! public function get_ixdiag: get the index of the named variables for the diagnostic variables + ! public function get_ixDiag: get the index of the named variables for the diagnostic variables ! ******************************************************************************************************************* - function get_ixdiag(varName) + function get_ixDiag(varName) USE var_lookup,only:iLookDIAG ! indices of the named variables implicit none ! define dummy variables character(*), intent(in) :: varName ! variable name - integer(i4b) :: get_ixdiag ! index of the named variable + integer(i4b) :: get_ixDiag ! index of the named variable ! get the index of the named variables select case(trim(varName)) ! local properties - case('scalarCanopyDepth' ); get_ixdiag = iLookDIAG%scalarCanopyDepth ! canopy depth (m) - case('scalarGreenVegFraction' ); get_ixdiag = iLookDIAG%scalarGreenVegFraction ! green vegetation fraction used to compute LAI (-) - case('scalarBulkVolHeatCapVeg' ); get_ixdiag = iLookDIAG%scalarBulkVolHeatCapVeg ! bulk volumetric heat capacity of vegetation (J m-3 K-1) - case('scalarCanopyEmissivity' ); get_ixdiag = iLookDIAG%scalarCanopyEmissivity ! effective canopy emissivity (-) - case('scalarRootZoneTemp' ); get_ixdiag = iLookDIAG%scalarRootZoneTemp ! average temperature of the root zone (K) - case('scalarLAI' ); get_ixdiag = iLookDIAG%scalarLAI ! one-sided leaf area index (m2 m-2) - case('scalarSAI' ); get_ixdiag = iLookDIAG%scalarSAI ! one-sided stem area index (m2 m-2) - case('scalarExposedLAI' ); get_ixdiag = iLookDIAG%scalarExposedLAI ! exposed leaf area index after burial by snow (m2 m-2) - case('scalarExposedSAI' ); get_ixdiag = iLookDIAG%scalarExposedSAI ! exposed stem area index after burial by snow (m2 m-2) - case('scalarAdjMeasHeight' ); get_ixdiag = iLookDIAG%scalarAdjMeasHeight ! adjusted measurement height for cases snowDepth>mHeight (m) - case('scalarCanopyIceMax' ); get_ixdiag = iLookDIAG%scalarCanopyIceMax ! maximum interception storage capacity for ice (kg m-2) - case('scalarCanopyLiqMax' ); get_ixdiag = iLookDIAG%scalarCanopyLiqMax ! maximum interception storage capacity for liquid water (kg m-2) - case('scalarGrowingSeasonIndex' ); get_ixdiag = iLookDIAG%scalarGrowingSeasonIndex ! growing season index (0=off, 1=on) - case('scalarVolHtCap_air' ); get_ixdiag = iLookDIAG%scalarVolHtCap_air ! volumetric heat capacity air (J m-3 K-1) - case('scalarVolHtCap_ice' ); get_ixdiag = iLookDIAG%scalarVolHtCap_ice ! volumetric heat capacity ice (J m-3 K-1) - case('scalarVolHtCap_soil' ); get_ixdiag = iLookDIAG%scalarVolHtCap_soil ! volumetric heat capacity dry soil (J m-3 K-1) - case('scalarVolHtCap_water' ); get_ixdiag = iLookDIAG%scalarVolHtCap_water ! volumetric heat capacity liquid wat (J m-3 K-1) - case('mLayerVolHtCapBulk' ); get_ixdiag = iLookDIAG%mLayerVolHtCapBulk ! volumetric heat capacity in each layer (J m-3 K-1) - case('scalarLambda_drysoil' ); get_ixdiag = iLookDIAG%scalarLambda_drysoil ! thermal conductivity of dry soil (W m-1) - case('scalarLambda_wetsoil' ); get_ixdiag = iLookDIAG%scalarLambda_wetsoil ! thermal conductivity of wet soil (W m-1) - case('mLayerThermalC' ); get_ixdiag = iLookDIAG%mLayerThermalC ! thermal conductivity at the mid-point of each layer (W m-1 K-1) - case('iLayerThermalC' ); get_ixdiag = iLookDIAG%iLayerThermalC ! thermal conductivity at the interface of each layer (W m-1 K-1) + case('scalarCanopyDepth' ); get_ixDiag = iLookDIAG%scalarCanopyDepth ! canopy depth (m) + case('scalarBulkVolHeatCapVeg' ); get_ixDiag = iLookDIAG%scalarBulkVolHeatCapVeg ! bulk volumetric heat capacity of vegetation (J m-3 K-1) + case('scalarCanopyCm' ); get_ixDiag = iLookDIAG%scalarCanopyCm ! Cm for vegetation canopy (J kg-1) + case('scalarCanopyEmissivity' ); get_ixDiag = iLookDIAG%scalarCanopyEmissivity ! effective canopy emissivity (-) + case('scalarRootZoneTemp' ); get_ixDiag = iLookDIAG%scalarRootZoneTemp ! average temperature of the root zone (K) + case('scalarLAI' ); get_ixDiag = iLookDIAG%scalarLAI ! one-sided leaf area index (m2 m-2) + case('scalarSAI' ); get_ixDiag = iLookDIAG%scalarSAI ! one-sided stem area index (m2 m-2) + case('scalarExposedLAI' ); get_ixDiag = iLookDIAG%scalarExposedLAI ! exposed leaf area index after burial by snow (m2 m-2) + case('scalarExposedSAI' ); get_ixDiag = iLookDIAG%scalarExposedSAI ! exposed stem area index after burial by snow (m2 m-2) + case('scalarAdjMeasHeight' ); get_ixDiag = iLookDIAG%scalarAdjMeasHeight ! adjusted measurement height for cases snowDepth>mHeight (m) + case('scalarCanopyIceMax' ); get_ixDiag = iLookDIAG%scalarCanopyIceMax ! maximum interception storage capacity for ice (kg m-2) + case('scalarCanopyLiqMax' ); get_ixDiag = iLookDIAG%scalarCanopyLiqMax ! maximum interception storage capacity for liquid water (kg m-2) + case('scalarGrowingSeasonIndex' ); get_ixDiag = iLookDIAG%scalarGrowingSeasonIndex ! growing season index (0=off, 1=on) + case('scalarVolHtCap_air' ); get_ixDiag = iLookDIAG%scalarVolHtCap_air ! volumetric heat capacity air (J m-3 K-1) + case('scalarVolHtCap_ice' ); get_ixDiag = iLookDIAG%scalarVolHtCap_ice ! volumetric heat capacity ice (J m-3 K-1) + case('scalarVolHtCap_soil' ); get_ixDiag = iLookDIAG%scalarVolHtCap_soil ! volumetric heat capacity dry soil (J m-3 K-1) + case('scalarVolHtCap_water' ); get_ixDiag = iLookDIAG%scalarVolHtCap_water ! volumetric heat capacity liquid wat (J m-3 K-1) + case('mLayerVolHtCapBulk' ); get_ixDiag = iLookDIAG%mLayerVolHtCapBulk ! volumetric heat capacity in each layer (J m-3 K-1) + case('mLayerCm' ); get_ixDiag = iLookDIAG%mLayerCm ! Cm for each layer (J m-3) + case('scalarLambda_drysoil' ); get_ixDiag = iLookDIAG%scalarLambda_drysoil ! thermal conductivity of dry soil (W m-1) + case('scalarLambda_wetsoil' ); get_ixDiag = iLookDIAG%scalarLambda_wetsoil ! thermal conductivity of wet soil (W m-1) + case('mLayerThermalC' ); get_ixDiag = iLookDIAG%mLayerThermalC ! thermal conductivity at the mid-point of each layer (W m-1 K-1) + case('iLayerThermalC' ); get_ixDiag = iLookDIAG%iLayerThermalC ! thermal conductivity at the interface of each layer (W m-1 K-1) + ! enthalpy + case('scalarCanopyEnthTemp' ); get_ixDiag = iLookDIAG%scalarCanopyEnthTemp ! temperature component of enthalpy of the vegetation canopy (J m-3) + case('mLayerEnthTemp' ); get_ixDiag = iLookDIAG%mLayerEnthTemp ! temperature component of enthalpy of the snow+soil layers (J m-3) + case('scalarTotalSoilEnthalpy' ); get_ixDiag = iLookDIAG%scalarTotalSoilEnthalpy ! total enthalpy of the soil column (J m-3) + case('scalarTotalSnowEnthalpy' ); get_ixDiag = iLookDIAG%scalarTotalSnowEnthalpy ! total enthalpy of the snow column (J m-3) ! forcing - case('scalarVPair' ); get_ixdiag = iLookDIAG%scalarVPair ! vapor pressure of the air above the vegetation canopy (Pa) - case('scalarVP_CanopyAir' ); get_ixdiag = iLookDIAG%scalarVP_CanopyAir ! vapor pressure of the canopy air space (Pa) - case('scalarTwetbulb' ); get_ixdiag = iLookDIAG%scalarTwetbulb ! wetbulb temperature (K) - case('scalarSnowfallTemp' ); get_ixdiag = iLookDIAG%scalarSnowfallTemp ! temperature of fresh snow (K) - case('scalarNewSnowDensity' ); get_ixdiag = iLookDIAG%scalarNewSnowDensity ! density of fresh snow, should snow be falling in this time step (kg m-3) - case('scalarO2air' ); get_ixdiag = iLookDIAG%scalarO2air ! atmospheric o2 concentration (Pa) - case('scalarCO2air' ); get_ixdiag = iLookDIAG%scalarCO2air ! atmospheric co2 concentration (Pa) + case('scalarVPair' ); get_ixDiag = iLookDIAG%scalarVPair ! vapor pressure of the air above the vegetation canopy (Pa) + case('scalarVP_CanopyAir' ); get_ixDiag = iLookDIAG%scalarVP_CanopyAir ! vapor pressure of the canopy air space (Pa) + case('scalarTwetbulb' ); get_ixDiag = iLookDIAG%scalarTwetbulb ! wetbulb temperature (K) + case('scalarSnowfallTemp' ); get_ixDiag = iLookDIAG%scalarSnowfallTemp ! temperature of fresh snow (K) + case('scalarNewSnowDensity' ); get_ixDiag = iLookDIAG%scalarNewSnowDensity ! density of fresh snow, should snow be falling in this time step (kg m-3) + case('scalarO2air' ); get_ixDiag = iLookDIAG%scalarO2air ! atmospheric o2 concentration (Pa) + case('scalarCO2air' ); get_ixDiag = iLookDIAG%scalarCO2air ! atmospheric co2 concentration (Pa) + case('windspd_x' ); get_ixDiag = iLookDIAG%windspd_x ! wind speed at 10 meter height in x-direction (m s-1) + case('windspd_y' ); get_ixDiag = iLookDIAG%windspd_y ! wind speed at 10 meter height in y-direction (m s-1) ! shortwave radiation - case('scalarCosZenith' ); get_ixdiag = iLookDIAG%scalarCosZenith ! cosine of the solar zenith angle (0-1) - case('scalarFractionDirect' ); get_ixdiag = iLookDIAG%scalarFractionDirect ! fraction of direct radiation (0-1) - case('scalarCanopySunlitFraction' ); get_ixdiag = iLookDIAG%scalarCanopySunlitFraction ! sunlit fraction of canopy (-) - case('scalarCanopySunlitLAI' ); get_ixdiag = iLookDIAG%scalarCanopySunlitLAI ! sunlit leaf area (-) - case('scalarCanopyShadedLAI' ); get_ixdiag = iLookDIAG%scalarCanopyShadedLAI ! shaded leaf area (-) - case('spectralAlbGndDirect' ); get_ixdiag = iLookDIAG%spectralAlbGndDirect ! direct albedo of underlying surface for each spectral band (-) - case('spectralAlbGndDiffuse' ); get_ixdiag = iLookDIAG%spectralAlbGndDiffuse ! diffuse albedo of underlying surface for each spectral band (-) - case('scalarGroundAlbedo' ); get_ixdiag = iLookDIAG%scalarGroundAlbedo ! albedo of the ground surface (-) + case('scalarCosZenith' ); get_ixDiag = iLookDIAG%scalarCosZenith ! cosine of the solar zenith angle (0-1) + case('scalarFractionDirect' ); get_ixDiag = iLookDIAG%scalarFractionDirect ! fraction of direct radiation (0-1) + case('scalarCanopySunlitFraction' ); get_ixDiag = iLookDIAG%scalarCanopySunlitFraction ! sunlit fraction of canopy (-) + case('scalarCanopySunlitLAI' ); get_ixDiag = iLookDIAG%scalarCanopySunlitLAI ! sunlit leaf area (-) + case('scalarCanopyShadedLAI' ); get_ixDiag = iLookDIAG%scalarCanopyShadedLAI ! shaded leaf area (-) + case('spectralAlbGndDirect' ); get_ixDiag = iLookDIAG%spectralAlbGndDirect ! direct albedo of underlying surface for each spectral band (-) + case('spectralAlbGndDiffuse' ); get_ixDiag = iLookDIAG%spectralAlbGndDiffuse ! diffuse albedo of underlying surface for each spectral band (-) + case('scalarGroundAlbedo' ); get_ixDiag = iLookDIAG%scalarGroundAlbedo ! albedo of the ground surface (-) ! turbulent heat transfer - case('scalarLatHeatSubVapCanopy' ); get_ixdiag = iLookDIAG%scalarLatHeatSubVapCanopy ! latent heat of sublimation/vaporization used for veg canopy (J kg-1) - case('scalarLatHeatSubVapGround' ); get_ixdiag = iLookDIAG%scalarLatHeatSubVapGround ! latent heat of sublimation/vaporization used for ground surface (J kg-1) - case('scalarSatVP_CanopyTemp' ); get_ixdiag = iLookDIAG%scalarSatVP_CanopyTemp ! saturation vapor pressure at the temperature of vegetation canopy (Pa) - case('scalarSatVP_GroundTemp' ); get_ixdiag = iLookDIAG%scalarSatVP_GroundTemp ! saturation vapor pressure at the temperature of the ground (Pa) - case('scalarZ0Canopy' ); get_ixdiag = iLookDIAG%scalarZ0Canopy ! roughness length of the canopy (m) - case('scalarWindReductionFactor' ); get_ixdiag = iLookDIAG%scalarWindReductionFactor ! canopy wind reduction factor (-) - case('scalarZeroPlaneDisplacement' ); get_ixdiag = iLookDIAG%scalarZeroPlaneDisplacement ! zero plane displacement (m) - case('scalarRiBulkCanopy' ); get_ixdiag = iLookDIAG%scalarRiBulkCanopy ! bulk Richardson number for the canopy (-) - case('scalarRiBulkGround' ); get_ixdiag = iLookDIAG%scalarRiBulkGround ! bulk Richardson number for the ground surface (-) - case('scalarCanopyStabilityCorrection'); get_ixdiag = iLookDIAG%scalarCanopyStabilityCorrection ! stability correction for the canopy (-) - case('scalarGroundStabilityCorrection'); get_ixdiag = iLookDIAG%scalarGroundStabilityCorrection ! stability correction for the ground surface (-) + case('scalarLatHeatSubVapCanopy' ); get_ixDiag = iLookDIAG%scalarLatHeatSubVapCanopy ! latent heat of sublimation/vaporization used for veg canopy (J kg-1) + case('scalarLatHeatSubVapGround' ); get_ixDiag = iLookDIAG%scalarLatHeatSubVapGround ! latent heat of sublimation/vaporization used for ground surface (J kg-1) + case('scalarSatVP_CanopyTemp' ); get_ixDiag = iLookDIAG%scalarSatVP_CanopyTemp ! saturation vapor pressure at the temperature of vegetation canopy (Pa) + case('scalarSatVP_GroundTemp' ); get_ixDiag = iLookDIAG%scalarSatVP_GroundTemp ! saturation vapor pressure at the temperature of the ground (Pa) + case('scalarZ0Canopy' ); get_ixDiag = iLookDIAG%scalarZ0Canopy ! roughness length of the canopy (m) + case('scalarWindReductionFactor' ); get_ixDiag = iLookDIAG%scalarWindReductionFactor ! canopy wind reduction factor (-) + case('scalarZeroPlaneDisplacement' ); get_ixDiag = iLookDIAG%scalarZeroPlaneDisplacement ! zero plane displacement (m) + case('scalarRiBulkCanopy' ); get_ixDiag = iLookDIAG%scalarRiBulkCanopy ! bulk Richardson number for the canopy (-) + case('scalarRiBulkGround' ); get_ixDiag = iLookDIAG%scalarRiBulkGround ! bulk Richardson number for the ground surface (-) + case('scalarCanopyStabilityCorrection'); get_ixDiag = iLookDIAG%scalarCanopyStabilityCorrection ! stability correction for the canopy (-) + case('scalarGroundStabilityCorrection'); get_ixDiag = iLookDIAG%scalarGroundStabilityCorrection ! stability correction for the ground surface (-) ! evapotranspiration - case('scalarIntercellularCO2Sunlit' ); get_ixdiag = iLookDIAG%scalarIntercellularCO2Sunlit ! carbon dioxide partial pressure of leaf interior (sunlit leaves) (Pa) - case('scalarIntercellularCO2Shaded' ); get_ixdiag = iLookDIAG%scalarIntercellularCO2Shaded ! carbon dioxide partial pressure of leaf interior (shaded leaves) (Pa) - case('scalarTranspireLim' ); get_ixdiag = iLookDIAG%scalarTranspireLim ! aggregate soil moisture and aquifer storage limit on transpiration (-) - case('scalarTranspireLimAqfr' ); get_ixdiag = iLookDIAG%scalarTranspireLimAqfr ! aquifer storage limit on transpiration (-) - case('scalarFoliageNitrogenFactor' ); get_ixdiag = iLookDIAG%scalarFoliageNitrogenFactor ! foliage nitrogen concentration, 1=saturated (-) - case('scalarSoilRelHumidity' ); get_ixdiag = iLookDIAG%scalarSoilRelHumidity ! relative humidity in the soil pores in the upper-most soil layer (-) - case('mLayerTranspireLim' ); get_ixdiag = iLookDIAG%mLayerTranspireLim ! moisture avail factor limiting transpiration in each layer (-) - case('mLayerRootDensity' ); get_ixdiag = iLookDIAG%mLayerRootDensity ! fraction of roots in each soil layer (-) - case('scalarAquiferRootFrac' ); get_ixdiag = iLookDIAG%scalarAquiferRootFrac ! fraction of roots below the soil profile (-) + case('scalarIntercellularCO2Sunlit' ); get_ixDiag = iLookDIAG%scalarIntercellularCO2Sunlit ! carbon dioxide partial pressure of leaf interior (sunlit leaves) (Pa) + case('scalarIntercellularCO2Shaded' ); get_ixDiag = iLookDIAG%scalarIntercellularCO2Shaded ! carbon dioxide partial pressure of leaf interior (shaded leaves) (Pa) + case('scalarTranspireLim' ); get_ixDiag = iLookDIAG%scalarTranspireLim ! aggregate soil moisture and aquifer storage limit on transpiration (-) + case('scalarTranspireLimAqfr' ); get_ixDiag = iLookDIAG%scalarTranspireLimAqfr ! aquifer storage limit on transpiration (-) + case('scalarFoliageNitrogenFactor' ); get_ixDiag = iLookDIAG%scalarFoliageNitrogenFactor ! foliage nitrogen concentration, 1=saturated (-) + case('scalarSoilRelHumidity' ); get_ixDiag = iLookDIAG%scalarSoilRelHumidity ! relative humidity in the soil pores in the upper-most soil layer (-) + case('mLayerTranspireLim' ); get_ixDiag = iLookDIAG%mLayerTranspireLim ! moisture avail factor limiting transpiration in each layer (-) + case('mLayerRootDensity' ); get_ixDiag = iLookDIAG%mLayerRootDensity ! fraction of roots in each soil layer (-) + case('scalarAquiferRootFrac' ); get_ixDiag = iLookDIAG%scalarAquiferRootFrac ! fraction of roots below the soil profile (-) ! canopy hydrology - case('scalarFracLiqVeg' ); get_ixdiag = iLookDIAG%scalarFracLiqVeg ! fraction of liquid water on vegetation (-) - case('scalarCanopyWetFraction' ); get_ixdiag = iLookDIAG%scalarCanopyWetFraction ! fraction of canopy that is wet + case('scalarFracLiqVeg' ); get_ixDiag = iLookDIAG%scalarFracLiqVeg ! fraction of liquid water on vegetation (-) + case('scalarCanopyWetFraction' ); get_ixDiag = iLookDIAG%scalarCanopyWetFraction ! fraction of canopy that is wet ! snow hydrology - case('scalarSnowAge' ); get_ixdiag = iLookDIAG%scalarSnowAge ! non-dimensional snow age (-) - case('scalarGroundSnowFraction' ); get_ixdiag = iLookDIAG%scalarGroundSnowFraction ! fraction of ground that is covered with snow (-) - case('spectralSnowAlbedoDirect' ); get_ixdiag = iLookDIAG%spectralSnowAlbedoDirect ! direct snow albedo for individual spectral bands (-) - case('mLayerFracLiqSnow' ); get_ixdiag = iLookDIAG%mLayerFracLiqSnow ! fraction of liquid water in each snow layer (-) - case('mLayerThetaResid' ); get_ixdiag = iLookDIAG%mLayerThetaResid ! residual volumetric water content in each snow layer (-) - case('mLayerPoreSpace' ); get_ixdiag = iLookDIAG%mLayerPoreSpace ! total pore space in each snow layer (-) - case('mLayerMeltFreeze' ); get_ixdiag = iLookDIAG%mLayerMeltFreeze ! ice content change from melt/freeze in each layer (kg m-3) + case('scalarSnowAge' ); get_ixDiag = iLookDIAG%scalarSnowAge ! non-dimensional snow age (-) + case('scalarGroundSnowFraction' ); get_ixDiag = iLookDIAG%scalarGroundSnowFraction ! fraction of ground that is covered with snow (-) + case('spectralSnowAlbedoDirect' ); get_ixDiag = iLookDIAG%spectralSnowAlbedoDirect ! direct snow albedo for individual spectral bands (-) + case('mLayerFracLiqSnow' ); get_ixDiag = iLookDIAG%mLayerFracLiqSnow ! fraction of liquid water in each snow layer (-) + case('mLayerThetaResid' ); get_ixDiag = iLookDIAG%mLayerThetaResid ! residual volumetric water content in each snow layer (-) + case('mLayerPoreSpace' ); get_ixDiag = iLookDIAG%mLayerPoreSpace ! total pore space in each snow layer (-) + case('mLayerMeltFreeze' ); get_ixDiag = iLookDIAG%mLayerMeltFreeze ! ice content change from melt/freeze in each layer (kg m-3) ! soil hydrology - case('scalarInfilArea' ); get_ixdiag = iLookDIAG%scalarInfilArea ! fraction of unfrozen area where water can infiltrate (-) - case('scalarFrozenArea' ); get_ixdiag = iLookDIAG%scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) - case('scalarSoilControl' ); get_ixdiag = iLookDIAG%scalarSoilControl ! soil control on infiltration: 1=controlling; 0=not (-) - case('mLayerVolFracAir' ); get_ixdiag = iLookDIAG%mLayerVolFracAir ! volumetric fraction of air in each layer (-) - case('mLayerTcrit' ); get_ixdiag = iLookDIAG%mLayerTcrit ! critical soil temperature above which all water is unfrozen (K) - case('mLayerCompress' ); get_ixdiag = iLookDIAG%mLayerCompress ! change in volumetric water content due to compression of soil (-) - case('scalarSoilCompress' ); get_ixdiag = iLookDIAG%scalarSoilCompress ! change in total soil storage due to compression of the soil matrix (kg m-2) - case('mLayerMatricHeadLiq' ); get_ixdiag = iLookDIAG%mLayerMatricHeadLiq ! matric potential of liquid water (m) + case('scalarInfilArea' ); get_ixDiag = iLookDIAG%scalarInfilArea ! fraction of area where water can infiltrate, may be frozen (-) + case('scalarSaturatedArea' ); get_ixDiag = iLookDIAG%scalarSaturatedArea ! fraction of area that is considered saturated (-) + case('scalarFrozenArea' ); get_ixDiag = iLookDIAG%scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) + case('scalarSoilControl' ); get_ixDiag = iLookDIAG%scalarSoilControl ! soil control on infiltration for derivative + case('mLayerVolFracAir' ); get_ixDiag = iLookDIAG%mLayerVolFracAir ! volumetric fraction of air in each layer (-) + case('mLayerTcrit' ); get_ixDiag = iLookDIAG%mLayerTcrit ! critical soil temperature above which all water is unfrozen (K) + case('mLayerCompress' ); get_ixDiag = iLookDIAG%mLayerCompress ! change in volumetric water content due to compression of soil (s-1) + case('scalarSoilCompress' ); get_ixDiag = iLookDIAG%scalarSoilCompress ! change in total soil storage due to compression of the soil matrix (kg m-2 s-1) + case('mLayerMatricHeadLiq' ); get_ixDiag = iLookDIAG%mLayerMatricHeadLiq ! matric potential of liquid water (m) ! mass balance check - case('scalarSoilWatBalError' ); get_ixdiag = iLookDIAG%scalarSoilWatBalError ! error in the total soil water balance (kg m-2) - case('scalarAquiferBalError' ); get_ixdiag = iLookDIAG%scalarAquiferBalError ! error in the aquifer water balance (kg m-2) - case('scalarTotalSoilLiq' ); get_ixdiag = iLookDIAG%scalarTotalSoilLiq ! total mass of liquid water in the soil (kg m-2) - case('scalarTotalSoilIce' ); get_ixdiag = iLookDIAG%scalarTotalSoilIce ! total mass of ice in the soil (kg m-2) - case('scalarTotalSoilWat' ); get_ixdiag = iLookDIAG%scalarTotalSoilWat ! total mass of water in the soil (kg m-2) + case('scalarTotalSoilLiq' ); get_ixDiag = iLookDIAG%scalarTotalSoilLiq ! total mass of liquid water in the soil (kg m-2) + case('scalarTotalSoilIce' ); get_ixDiag = iLookDIAG%scalarTotalSoilIce ! total mass of ice in the soil (kg m-2) + case('scalarTotalSoilWat' ); get_ixDiag = iLookDIAG%scalarTotalSoilWat ! total mass of water in the soil (kg m-2) ! variable shortcuts - case('scalarVGn_m' ); get_ixdiag = iLookDIAG%scalarVGn_m ! van Genuchten "m" parameter (-) - case('scalarKappa' ); get_ixdiag = iLookDIAG%scalarKappa ! constant in the freezing curve function (m K-1) - case('scalarVolLatHt_fus' ); get_ixdiag = iLookDIAG%scalarVolLatHt_fus ! volumetric latent heat of fusion (J m-3) + case('scalarVGn_m' ); get_ixDiag = iLookDIAG%scalarVGn_m ! van Genuchten "m" parameter (-) + case('scalarKappa' ); get_ixDiag = iLookDIAG%scalarKappa ! constant in the freezing curve function (m K-1) + case('scalarVolLatHt_fus' ); get_ixDiag = iLookDIAG%scalarVolLatHt_fus ! volumetric latent heat of fusion (J m-3) ! timing information - case('numFluxCalls' ); get_ixdiag = iLookDIAG%numFluxCalls ! number of flux calls (-) - case('wallClockTime' ); get_ixdiag = iLookDIAG%wallClockTime ! wall clock time (s) + case('numFluxCalls' ); get_ixDiag = iLookDIAG%numFluxCalls ! number of flux calls (-) + case('wallClockTime' ); get_ixDiag = iLookDIAG%wallClockTime ! wall clock time for physics routines (s) + case('meanStepSize' ); get_ixDiag = iLookDIAG%meanStepSize ! mean time step size (s) over data window + ! balances + case('balanceCasNrg' ); get_ixDiag = iLookDIAG%balanceCasNrg ! balance of energy in the canopy air space (W m-3) + case('balanceVegNrg' ); get_ixDiag = iLookDIAG%balanceVegNrg ! balance of energy in the vegetation canopy (W m-3) + case('balanceLayerNrg' ); get_ixDiag = iLookDIAG%balanceLayerNrg ! balance of energy in each snow+soil layer (W m-3) + case('balanceSnowNrg' ); get_ixDiag = iLookDIAG%balanceSnowNrg ! balance of energy in the snow (W m-3) + case('balanceSoilNrg' ); get_ixDiag = iLookDIAG%balanceSoilNrg ! balance of energy in the soil (W m-3) + case('balanceVegMass' ); get_ixDiag = iLookDIAG%balanceVegMass ! balance of water in the vegetation canopy (kg m-3 s-1) + case('balanceLayerMass' ); get_ixDiag = iLookDIAG%balanceLayerMass ! balance of water in each snow+soil layer (kg m-3 s-1) + case('balanceSnowMass' ); get_ixDiag = iLookDIAG%balanceSnowMass ! balance of water in the snow (kg m-3 s-1) + case('balanceSoilMass' ); get_ixDiag = iLookDIAG%balanceSoilMass ! balance of water in the soil (kg m-3 s-1) + case('balanceAqMass' ); get_ixDiag = iLookDIAG%balanceAqMass ! balance of water in the aquifer (kg m-2 s-1) (no depth to aquifer) + ! sundials integrator stats + case('numSteps' ); get_ixDiag = iLookDIAG%numSteps + case('numResEvals' ); get_ixDiag = iLookDIAG%numResEvals + case('numLinSolvSetups' ); get_ixDiag = iLookDIAG%numLinSolvSetups + case('numErrTestFails' ); get_ixDiag = iLookDIAG%numErrTestFails + case('kLast' ); get_ixDiag = iLookDIAG%kLast + case('kCur' ); get_ixDiag = iLookDIAG%kCur + case('hInitUsed' ); get_ixDiag = iLookDIAG%hInitUsed + case('hLast' ); get_ixDiag = iLookDIAG%hLast + case('hCur' ); get_ixDiag = iLookDIAG%hCur + case('tCur' ); get_ixDiag = iLookDIAG%tCur ! get to here if cannot find the variable case default - get_ixdiag = integerMissing + get_ixDiag = integerMissing end select - end function get_ixdiag + end function get_ixDiag ! ******************************************************************************************************************* - ! public function get_ixdiag: get the index of the named variables for the fluxes + ! public function get_ixDiag: get the index of the named variables for the fluxes ! ******************************************************************************************************************* - function get_ixflux(varName) + function get_ixFlux(varName) USE var_lookup,only:iLookFLUX ! indices of the named variables implicit none ! define dummy variables character(*), intent(in) :: varName ! variable name - integer(i4b) :: get_ixflux ! index of the named variable + integer(i4b) :: get_ixFlux ! index of the named variable ! get the index of the named variables select case(trim(varName)) ! net energy and mass fluxes for the vegetation domain - case('scalarCanairNetNrgFlux' ); get_ixflux = iLookFLUX%scalarCanairNetNrgFlux ! net energy flux for the canopy air space (W m-2) - case('scalarCanopyNetNrgFlux' ); get_ixflux = iLookFLUX%scalarCanopyNetNrgFlux ! net energy flux for the vegetation canopy (W m-2) - case('scalarGroundNetNrgFlux' ); get_ixflux = iLookFLUX%scalarGroundNetNrgFlux ! net energy flux for the ground surface (W m-2) - case('scalarCanopyNetLiqFlux' ); get_ixflux = iLookFLUX%scalarCanopyNetLiqFlux ! net liquid water flux for the vegetation canopy (kg m-2 s-1) + case('scalarCanairNetNrgFlux' ); get_ixFlux = iLookFLUX%scalarCanairNetNrgFlux ! net energy flux for the canopy air space (W m-2) + case('scalarCanopyNetNrgFlux' ); get_ixFlux = iLookFLUX%scalarCanopyNetNrgFlux ! net energy flux for the vegetation canopy (W m-2) + case('scalarGroundNetNrgFlux' ); get_ixFlux = iLookFLUX%scalarGroundNetNrgFlux ! net energy flux for the ground surface (W m-2) + case('scalarCanopyNetLiqFlux' ); get_ixFlux = iLookFLUX%scalarCanopyNetLiqFlux ! net liquid water flux for the vegetation canopy (kg m-2 s-1) ! forcing - case('scalarRainfall' ); get_ixflux = iLookFLUX%scalarRainfall ! computed rainfall rate (kg m-2 s-1) - case('scalarSnowfall' ); get_ixflux = iLookFLUX%scalarSnowfall ! computed snowfall rate (kg m-2 s-1) + case('scalarRainfall' ); get_ixFlux = iLookFLUX%scalarRainfall ! computed rainfall rate (kg m-2 s-1) + case('scalarSnowfall' ); get_ixFlux = iLookFLUX%scalarSnowfall ! computed snowfall rate (kg m-2 s-1) ! shortwave radiation - case('spectralIncomingDirect' ); get_ixflux = iLookFLUX%spectralIncomingDirect ! incoming direct solar radiation in each wave band (W m-2) - case('spectralIncomingDiffuse' ); get_ixflux = iLookFLUX%spectralIncomingDiffuse ! incoming diffuse solar radiation in each wave band (W m-2) - case('scalarCanopySunlitPAR' ); get_ixflux = iLookFLUX%scalarCanopySunlitPAR ! average absorbed par for sunlit leaves (w m-2) - case('scalarCanopyShadedPAR' ); get_ixflux = iLookFLUX%scalarCanopyShadedPAR ! average absorbed par for shaded leaves (w m-2) - case('spectralBelowCanopyDirect' ); get_ixflux = iLookFLUX%spectralBelowCanopyDirect ! downward direct flux below veg layer for each spectral band W m-2) - case('spectralBelowCanopyDiffuse' ); get_ixflux = iLookFLUX%spectralBelowCanopyDiffuse ! downward diffuse flux below veg layer for each spectral band (W m-2) - case('scalarBelowCanopySolar' ); get_ixflux = iLookFLUX%scalarBelowCanopySolar ! solar radiation transmitted below the canopy (W m-2) - case('scalarCanopyAbsorbedSolar' ); get_ixflux = iLookFLUX%scalarCanopyAbsorbedSolar ! solar radiation absorbed by canopy (W m-2) - case('scalarGroundAbsorbedSolar' ); get_ixflux = iLookFLUX%scalarGroundAbsorbedSolar ! solar radiation absorbed by ground (W m-2) + case('spectralIncomingDirect' ); get_ixFlux = iLookFLUX%spectralIncomingDirect ! incoming direct solar radiation in each wave band (W m-2) + case('spectralIncomingDiffuse' ); get_ixFlux = iLookFLUX%spectralIncomingDiffuse ! incoming diffuse solar radiation in each wave band (W m-2) + case('scalarCanopySunlitPAR' ); get_ixFlux = iLookFLUX%scalarCanopySunlitPAR ! average absorbed par for sunlit leaves (w m-2) + case('scalarCanopyShadedPAR' ); get_ixFlux = iLookFLUX%scalarCanopyShadedPAR ! average absorbed par for shaded leaves (w m-2) + case('spectralBelowCanopyDirect' ); get_ixFlux = iLookFLUX%spectralBelowCanopyDirect ! downward direct flux below veg layer for each spectral band W m-2) + case('spectralBelowCanopyDiffuse' ); get_ixFlux = iLookFLUX%spectralBelowCanopyDiffuse ! downward diffuse flux below veg layer for each spectral band (W m-2) + case('scalarBelowCanopySolar' ); get_ixFlux = iLookFLUX%scalarBelowCanopySolar ! solar radiation transmitted below the canopy (W m-2) + case('scalarCanopyAbsorbedSolar' ); get_ixFlux = iLookFLUX%scalarCanopyAbsorbedSolar ! solar radiation absorbed by canopy (W m-2) + case('scalarGroundAbsorbedSolar' ); get_ixFlux = iLookFLUX%scalarGroundAbsorbedSolar ! solar radiation absorbed by ground (W m-2) ! longwave radiation - case('scalarLWRadCanopy' ); get_ixflux = iLookFLUX%scalarLWRadCanopy ! longwave radiation emitted from the canopy (W m-2) - case('scalarLWRadGround' ); get_ixflux = iLookFLUX%scalarLWRadGround ! longwave radiation emitted at the ground surface (W m-2) - case('scalarLWRadUbound2Canopy' ); get_ixflux = iLookFLUX%scalarLWRadUbound2Canopy ! downward atmospheric longwave radiation absorbed by the canopy (W m-2) - case('scalarLWRadUbound2Ground' ); get_ixflux = iLookFLUX%scalarLWRadUbound2Ground ! downward atmospheric longwave radiation absorbed by the ground (W m-2) - case('scalarLWRadUbound2Ubound' ); get_ixflux = iLookFLUX%scalarLWRadUbound2Ubound ! atmospheric radiation refl by ground + lost thru upper boundary (W m-2) - case('scalarLWRadCanopy2Ubound' ); get_ixflux = iLookFLUX%scalarLWRadCanopy2Ubound ! longwave radiation emitted from canopy lost thru upper boundary (W m-2) - case('scalarLWRadCanopy2Ground' ); get_ixflux = iLookFLUX%scalarLWRadCanopy2Ground ! longwave radiation emitted from canopy absorbed by the ground (W m-2) - case('scalarLWRadCanopy2Canopy' ); get_ixflux = iLookFLUX%scalarLWRadCanopy2Canopy ! canopy longwave reflected from ground and absorbed by the canopy (W m-2) - case('scalarLWRadGround2Ubound' ); get_ixflux = iLookFLUX%scalarLWRadGround2Ubound ! longwave radiation emitted from ground lost thru upper boundary (W m-2) - case('scalarLWRadGround2Canopy' ); get_ixflux = iLookFLUX%scalarLWRadGround2Canopy ! longwave radiation emitted from ground and absorbed by the canopy (W m-2) - case('scalarLWNetCanopy' ); get_ixflux = iLookFLUX%scalarLWNetCanopy ! net longwave radiation at the canopy (W m-2) - case('scalarLWNetGround' ); get_ixflux = iLookFLUX%scalarLWNetGround ! net longwave radiation at the ground surface (W m-2) - case('scalarLWNetUbound' ); get_ixflux = iLookFLUX%scalarLWNetUbound ! net longwave radiation at the upper atmospheric boundary (W m-2) + case('scalarLWRadCanopy' ); get_ixFlux = iLookFLUX%scalarLWRadCanopy ! longwave radiation emitted from the canopy (W m-2) + case('scalarLWRadGround' ); get_ixFlux = iLookFLUX%scalarLWRadGround ! longwave radiation emitted at the ground surface (W m-2) + case('scalarLWRadUbound2Canopy' ); get_ixFlux = iLookFLUX%scalarLWRadUbound2Canopy ! downward atmospheric longwave radiation absorbed by the canopy (W m-2) + case('scalarLWRadUbound2Ground' ); get_ixFlux = iLookFLUX%scalarLWRadUbound2Ground ! downward atmospheric longwave radiation absorbed by the ground (W m-2) + case('scalarLWRadUbound2Ubound' ); get_ixFlux = iLookFLUX%scalarLWRadUbound2Ubound ! atmospheric radiation refl by ground + lost thru upper boundary (W m-2) + case('scalarLWRadCanopy2Ubound' ); get_ixFlux = iLookFLUX%scalarLWRadCanopy2Ubound ! longwave radiation emitted from canopy lost thru upper boundary (W m-2) + case('scalarLWRadCanopy2Ground' ); get_ixFlux = iLookFLUX%scalarLWRadCanopy2Ground ! longwave radiation emitted from canopy absorbed by the ground (W m-2) + case('scalarLWRadCanopy2Canopy' ); get_ixFlux = iLookFLUX%scalarLWRadCanopy2Canopy ! canopy longwave reflected from ground and absorbed by the canopy (W m-2) + case('scalarLWRadGround2Ubound' ); get_ixFlux = iLookFLUX%scalarLWRadGround2Ubound ! longwave radiation emitted from ground lost thru upper boundary (W m-2) + case('scalarLWRadGround2Canopy' ); get_ixFlux = iLookFLUX%scalarLWRadGround2Canopy ! longwave radiation emitted from ground and absorbed by the canopy (W m-2) + case('scalarLWNetCanopy' ); get_ixFlux = iLookFLUX%scalarLWNetCanopy ! net longwave radiation at the canopy (W m-2) + case('scalarLWNetGround' ); get_ixFlux = iLookFLUX%scalarLWNetGround ! net longwave radiation at the ground surface (W m-2) + case('scalarLWNetUbound' ); get_ixFlux = iLookFLUX%scalarLWNetUbound ! net longwave radiation at the upper atmospheric boundary (W m-2) ! turbulent heat transfer - case('scalarEddyDiffusCanopyTop' ); get_ixflux = iLookFLUX%scalarEddyDiffusCanopyTop ! eddy diffusivity for heat at the top of the canopy (m2 s-1) - case('scalarFrictionVelocity' ); get_ixflux = iLookFLUX%scalarFrictionVelocity ! friction velocity - canopy momentum sink (m s-1) - case('scalarWindspdCanopyTop' ); get_ixflux = iLookFLUX%scalarWindspdCanopyTop ! windspeed at the top of the canopy (m s-1) - case('scalarWindspdCanopyBottom' ); get_ixflux = iLookFLUX%scalarWindspdCanopyBottom ! windspeed at the height of the bottom of the canopy (m s-1) - case('scalarGroundResistance' ); get_ixflux = iLookFLUX%scalarGroundResistance ! below canopy aerodynamic resistance (s m-1) - case('scalarCanopyResistance' ); get_ixflux = iLookFLUX%scalarCanopyResistance ! above canopy aerodynamic resistance (s m-1) - case('scalarLeafResistance' ); get_ixflux = iLookFLUX%scalarLeafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) - case('scalarSoilResistance' ); get_ixflux = iLookFLUX%scalarSoilResistance ! soil surface resistance (s m-1) - case('scalarSenHeatTotal' ); get_ixflux = iLookFLUX%scalarSenHeatTotal ! sensible heat from the canopy air space to the atmosphere (W m-2) - case('scalarSenHeatCanopy' ); get_ixflux = iLookFLUX%scalarSenHeatCanopy ! sensible heat from the canopy to the canopy air space (W m-2) - case('scalarSenHeatGround' ); get_ixflux = iLookFLUX%scalarSenHeatGround ! sensible heat from the ground (below canopy or non-vegetated) (W m-2) - case('scalarLatHeatTotal' ); get_ixflux = iLookFLUX%scalarLatHeatTotal ! latent heat from the canopy air space to the atmosphere (W m-2) - case('scalarLatHeatCanopyEvap' ); get_ixflux = iLookFLUX%scalarLatHeatCanopyEvap ! evaporation latent heat from the canopy to the canopy air space (W m-2) - case('scalarLatHeatCanopyTrans' ); get_ixflux = iLookFLUX%scalarLatHeatCanopyTrans ! transpiration latent heat from the canopy to the canopy air space (W m-2) - case('scalarLatHeatGround' ); get_ixflux = iLookFLUX%scalarLatHeatGround ! latent heat from the ground (below canopy or non-vegetated) (W m-2) - case('scalarCanopyAdvectiveHeatFlux' ); get_ixflux = iLookFLUX%scalarCanopyAdvectiveHeatFlux ! heat advected to the canopy surface with rain + snow (W m-2) - case('scalarGroundAdvectiveHeatFlux' ); get_ixflux = iLookFLUX%scalarGroundAdvectiveHeatFlux ! heat advected to the ground surface with throughfall and unloading/drainage (W m-2) - case('scalarCanopySublimation' ); get_ixflux = iLookFLUX%scalarCanopySublimation ! canopy sublimation/frost (kg m-2 s-1) - case('scalarSnowSublimation' ); get_ixflux = iLookFLUX%scalarSnowSublimation ! snow sublimation/frost (below canopy or non-vegetated) (kg m-2 s-1) + case('scalarEddyDiffusCanopyTop' ); get_ixFlux = iLookFLUX%scalarEddyDiffusCanopyTop ! eddy diffusivity for heat at the top of the canopy (m2 s-1) + case('scalarFrictionVelocity' ); get_ixFlux = iLookFLUX%scalarFrictionVelocity ! friction velocity - canopy momentum sink (m s-1) + case('scalarWindspdCanopyTop' ); get_ixFlux = iLookFLUX%scalarWindspdCanopyTop ! windspeed at the top of the canopy (m s-1) + case('scalarWindspdCanopyBottom' ); get_ixFlux = iLookFLUX%scalarWindspdCanopyBottom ! windspeed at the height of the bottom of the canopy (m s-1) + case('scalarGroundResistance' ); get_ixFlux = iLookFLUX%scalarGroundResistance ! below canopy aerodynamic resistance (s m-1) + case('scalarCanopyResistance' ); get_ixFlux = iLookFLUX%scalarCanopyResistance ! above canopy aerodynamic resistance (s m-1) + case('scalarLeafResistance' ); get_ixFlux = iLookFLUX%scalarLeafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) + case('scalarSoilResistance' ); get_ixFlux = iLookFLUX%scalarSoilResistance ! soil surface resistance (s m-1) + case('scalarSenHeatTotal' ); get_ixFlux = iLookFLUX%scalarSenHeatTotal ! sensible heat from the canopy air space to the atmosphere (W m-2) + case('scalarSenHeatCanopy' ); get_ixFlux = iLookFLUX%scalarSenHeatCanopy ! sensible heat from the canopy to the canopy air space (W m-2) + case('scalarSenHeatGround' ); get_ixFlux = iLookFLUX%scalarSenHeatGround ! sensible heat from the ground (below canopy or non-vegetated) (W m-2) + case('scalarLatHeatTotal' ); get_ixFlux = iLookFLUX%scalarLatHeatTotal ! latent heat from the canopy air space to the atmosphere (W m-2) + case('scalarLatHeatCanopyEvap' ); get_ixFlux = iLookFLUX%scalarLatHeatCanopyEvap ! evaporation latent heat from the canopy to the canopy air space (W m-2) + case('scalarLatHeatCanopyTrans' ); get_ixFlux = iLookFLUX%scalarLatHeatCanopyTrans ! transpiration latent heat from the canopy to the canopy air space (W m-2) + case('scalarLatHeatGround' ); get_ixFlux = iLookFLUX%scalarLatHeatGround ! latent heat from the ground (below canopy or non-vegetated) (W m-2) + case('scalarCanopyAdvectiveHeatFlux' ); get_ixFlux = iLookFLUX%scalarCanopyAdvectiveHeatFlux ! heat advected to the canopy surface with rain + snow (W m-2) + case('scalarGroundAdvectiveHeatFlux' ); get_ixFlux = iLookFLUX%scalarGroundAdvectiveHeatFlux ! heat advected to the ground surface with throughfall and unloading/drainage (W m-2) + case('scalarCanopySublimation' ); get_ixFlux = iLookFLUX%scalarCanopySublimation ! canopy sublimation/frost (kg m-2 s-1) + case('scalarSnowSublimation' ); get_ixFlux = iLookFLUX%scalarSnowSublimation ! snow sublimation/frost (below canopy or non-vegetated) (kg m-2 s-1) ! liquid water fluxes associated with evapotranspiration - case('scalarStomResistSunlit' ); get_ixflux = iLookFLUX%scalarStomResistSunlit ! stomatal resistance for sunlit leaves (s m-1) - case('scalarStomResistShaded' ); get_ixflux = iLookFLUX%scalarStomResistShaded ! stomatal resistance for shaded leaves (s m-1) - case('scalarPhotosynthesisSunlit' ); get_ixflux = iLookFLUX%scalarPhotosynthesisSunlit ! sunlit photosynthesis (umolco2 m-2 s-1) - case('scalarPhotosynthesisShaded' ); get_ixflux = iLookFLUX%scalarPhotosynthesisShaded ! shaded photosynthesis (umolco2 m-2 s-1) - case('scalarCanopyTranspiration' ); get_ixflux = iLookFLUX%scalarCanopyTranspiration ! canopy transpiration (kg m-2 s-1) - case('scalarCanopyEvaporation' ); get_ixflux = iLookFLUX%scalarCanopyEvaporation ! canopy evaporation/condensation (kg m-2 s-1) - case('scalarGroundEvaporation' ); get_ixflux = iLookFLUX%scalarGroundEvaporation ! ground evaporation/condensation (below canopy or non-vegetated) (kg m-2 s-1) - case('mLayerTranspire' ); get_ixflux = iLookFLUX%mLayerTranspire ! transpiration loss from each soil layer (kg m-2 s-1) + case('scalarStomResistSunlit' ); get_ixFlux = iLookFLUX%scalarStomResistSunlit ! stomatal resistance for sunlit leaves (s m-1) + case('scalarStomResistShaded' ); get_ixFlux = iLookFLUX%scalarStomResistShaded ! stomatal resistance for shaded leaves (s m-1) + case('scalarPhotosynthesisSunlit' ); get_ixFlux = iLookFLUX%scalarPhotosynthesisSunlit ! sunlit photosynthesis (umolco2 m-2 s-1) + case('scalarPhotosynthesisShaded' ); get_ixFlux = iLookFLUX%scalarPhotosynthesisShaded ! shaded photosynthesis (umolco2 m-2 s-1) + case('scalarCanopyTranspiration' ); get_ixFlux = iLookFLUX%scalarCanopyTranspiration ! canopy transpiration (kg m-2 s-1) + case('scalarCanopyEvaporation' ); get_ixFlux = iLookFLUX%scalarCanopyEvaporation ! canopy evaporation/condensation (kg m-2 s-1) + case('scalarGroundEvaporation' ); get_ixFlux = iLookFLUX%scalarGroundEvaporation ! ground evaporation/condensation (below canopy or non-vegetated) (kg m-2 s-1) + case('mLayerTranspire' ); get_ixFlux = iLookFLUX%mLayerTranspire ! transpiration loss from each soil layer (kg m-2 s-1) ! liquid and solid water fluxes through the canopy - case('scalarThroughfallSnow' ); get_ixflux = iLookFLUX%scalarThroughfallSnow ! snow that reaches the ground without ever touching the canopy (kg m-2 s-1) - case('scalarThroughfallRain' ); get_ixflux = iLookFLUX%scalarThroughfallRain ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) - case('scalarCanopySnowUnloading' ); get_ixflux = iLookFLUX%scalarCanopySnowUnloading ! unloading of snow from the vegetion canopy (kg m-2 s-1) - case('scalarCanopyLiqDrainage' ); get_ixflux = iLookFLUX%scalarCanopyLiqDrainage ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) - case('scalarCanopyMeltFreeze' ); get_ixflux = iLookFLUX%scalarCanopyMeltFreeze ! melt/freeze of water stored in the canopy (kg m-2 s-1) + case('scalarThroughfallSnow' ); get_ixFlux = iLookFLUX%scalarThroughfallSnow ! snow that reaches the ground without ever touching the canopy (kg m-2 s-1) + case('scalarThroughfallRain' ); get_ixFlux = iLookFLUX%scalarThroughfallRain ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) + case('scalarCanopySnowUnloading' ); get_ixFlux = iLookFLUX%scalarCanopySnowUnloading ! unloading of snow from the vegetion canopy (kg m-2 s-1) + case('scalarCanopyLiqDrainage' ); get_ixFlux = iLookFLUX%scalarCanopyLiqDrainage ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) + case('scalarCanopyMeltFreeze' ); get_ixFlux = iLookFLUX%scalarCanopyMeltFreeze ! melt/freeze of water stored in the canopy (kg m-2 s-1) ! energy fluxes and for the snow and soil domains - case('iLayerConductiveFlux' ); get_ixflux = iLookFLUX%iLayerConductiveFlux ! conductive energy flux at layer interfaces at end of time step (W m-2) - case('iLayerAdvectiveFlux' ); get_ixflux = iLookFLUX%iLayerAdvectiveFlux ! advective energy flux at layer interfaces at end of time step (W m-2) - case('iLayerNrgFlux' ); get_ixflux = iLookFLUX%iLayerNrgFlux ! energy flux at layer interfaces at the end of the time step (W m-2) - case('mLayerNrgFlux' ); get_ixflux = iLookFLUX%mLayerNrgFlux ! net energy flux for each layer in the snow+soil domain (J m-3 s-1) + case('iLayerConductiveFlux' ); get_ixFlux = iLookFLUX%iLayerConductiveFlux ! conductive energy flux at layer interfaces at end of time step (W m-2) + case('iLayerAdvectiveFlux' ); get_ixFlux = iLookFLUX%iLayerAdvectiveFlux ! advective energy flux at layer interfaces at end of time step (W m-2) + case('iLayerNrgFlux' ); get_ixFlux = iLookFLUX%iLayerNrgFlux ! energy flux at layer interfaces at the end of the time step (W m-2) + case('mLayerNrgFlux' ); get_ixFlux = iLookFLUX%mLayerNrgFlux ! net energy flux for each layer in the snow+soil domain (J m-3 s-1) ! liquid water fluxes for the snow domain - case('scalarSnowDrainage' ); get_ixflux = iLookFLUX%scalarSnowDrainage ! drainage from the bottom of the snow profile (m s-1) - case('iLayerLiqFluxSnow' ); get_ixflux = iLookFLUX%iLayerLiqFluxSnow ! liquid flux at snow layer interfaces at the end of the time step (m s-1) - case('mLayerLiqFluxSnow' ); get_ixflux = iLookFLUX%mLayerLiqFluxSnow ! net liquid water flux for each snow layer (s-1) + case('scalarSnowDrainage' ); get_ixFlux = iLookFLUX%scalarSnowDrainage ! drainage from the bottom of the snow profile (m s-1) + case('iLayerLiqFluxSnow' ); get_ixFlux = iLookFLUX%iLayerLiqFluxSnow ! liquid flux at snow layer interfaces at the end of the time step (m s-1) + case('mLayerLiqFluxSnow' ); get_ixFlux = iLookFLUX%mLayerLiqFluxSnow ! net liquid water flux for each snow layer (s-1) ! liquid water fluxes for the soil domain - case('scalarRainPlusMelt' ); get_ixflux = iLookFLUX%scalarRainPlusMelt ! rain plus melt, as input to soil before calculating surface runoff (m s-1) - case('scalarMaxInfilRate' ); get_ixflux = iLookFLUX%scalarMaxInfilRate ! maximum infiltration rate (m s-1) - case('scalarInfiltration' ); get_ixflux = iLookFLUX%scalarInfiltration ! infiltration of water into the soil profile (m s-1) - case('scalarExfiltration' ); get_ixflux = iLookFLUX%scalarExfiltration ! exfiltration of water from the top of the soil profile (m s-1) - case('scalarSurfaceRunoff' ); get_ixflux = iLookFLUX%scalarSurfaceRunoff ! surface runoff (m s-1) - case('mLayerSatHydCondMP' ); get_ixflux = iLookFLUX%mLayerSatHydCondMP ! saturated hydraulic conductivity of macropores in each layer (m s-1) - case('mLayerSatHydCond' ); get_ixflux = iLookFLUX%mLayerSatHydCond ! saturated hydraulic conductivity in each layer (m s-1) - case('iLayerSatHydCond' ); get_ixflux = iLookFLUX%iLayerSatHydCond ! saturated hydraulic conductivity in each layer interface (m s-1) - case('mLayerHydCond' ); get_ixflux = iLookFLUX%mLayerHydCond ! hydraulic conductivity in each layer (m s-1) - case('iLayerLiqFluxSoil' ); get_ixflux = iLookFLUX%iLayerLiqFluxSoil ! liquid flux at soil layer interfaces at the end of the time step (m s-1) - case('mLayerLiqFluxSoil' ); get_ixflux = iLookFLUX%mLayerLiqFluxSoil ! net liquid water flux for each soil layer (s-1) - case('mLayerBaseflow' ); get_ixflux = iLookFLUX%mLayerBaseflow ! baseflow from each soil layer (m s-1) - case('mLayerColumnInflow' ); get_ixflux = iLookFLUX%mLayerColumnInflow ! total inflow to each layer in a given soil column (m3 s-1) - case('mLayerColumnOutflow' ); get_ixflux = iLookFLUX%mLayerColumnOutflow ! total outflow from each layer in a given soil column (m3 s-1) - case('scalarSoilBaseflow' ); get_ixflux = iLookFLUX%scalarSoilBaseflow ! total baseflow from throughout the soil profile (m s-1) - case('scalarSoilDrainage' ); get_ixflux = iLookFLUX%scalarSoilDrainage ! drainage from the bottom of the soil profile (m s-1) - case('scalarAquiferRecharge' ); get_ixflux = iLookFLUX%scalarAquiferRecharge ! recharge to the aquifer (m s-1) - case('scalarAquiferTranspire' ); get_ixflux = iLookFLUX%scalarAquiferTranspire ! transpiration from the aquifer (m s-1) - case('scalarAquiferBaseflow' ); get_ixflux = iLookFLUX%scalarAquiferBaseflow ! baseflow from the aquifer (m s-1) + case('scalarRainPlusMelt' ); get_ixFlux = iLookFLUX%scalarRainPlusMelt ! rain plus melt, as input to soil before calculating surface runoff (m s-1) + case('scalarMaxInfilRate' ); get_ixFlux = iLookFLUX%scalarMaxInfilRate ! maximum infiltration rate (m s-1) + case('scalarInfiltration' ); get_ixFlux = iLookFLUX%scalarInfiltration ! infiltration of water into the soil profile (m s-1) + case('scalarExfiltration' ); get_ixFlux = iLookFLUX%scalarExfiltration ! exfiltration of water from the top of the soil profile (m s-1) + case('scalarSurfaceRunoff' ); get_ixFlux = iLookFLUX%scalarSurfaceRunoff ! surface runoff (m s-1) + case('scalarSurfaceRunoff_IE' ); get_ixFlux = iLookFLUX%scalarSurfaceRunoff_IE ! infiltration excess surface runoff (m s-1) + case('scalarSurfaceRunoff_SE' ); get_ixFlux = iLookFLUX%scalarSurfaceRunoff_SE ! saturation excess surface runoff (m s-1) + case('mLayerSatHydCondMP' ); get_ixFlux = iLookFLUX%mLayerSatHydCondMP ! saturated hydraulic conductivity of macropores in each layer (m s-1) + case('mLayerSatHydCond' ); get_ixFlux = iLookFLUX%mLayerSatHydCond ! saturated hydraulic conductivity in each layer (m s-1) + case('iLayerSatHydCond' ); get_ixFlux = iLookFLUX%iLayerSatHydCond ! saturated hydraulic conductivity in each layer interface (m s-1) + case('mLayerHydCond' ); get_ixFlux = iLookFLUX%mLayerHydCond ! hydraulic conductivity in each layer (m s-1) + case('iLayerLiqFluxSoil' ); get_ixFlux = iLookFLUX%iLayerLiqFluxSoil ! liquid flux at soil layer interfaces at the end of the time step (m s-1) + case('mLayerLiqFluxSoil' ); get_ixFlux = iLookFLUX%mLayerLiqFluxSoil ! net liquid water flux for each soil layer (s-1) + case('mLayerBaseflow' ); get_ixFlux = iLookFLUX%mLayerBaseflow ! baseflow from each soil layer (m s-1) + case('mLayerColumnInflow' ); get_ixFlux = iLookFLUX%mLayerColumnInflow ! total inflow to each layer in a given soil column (m3 s-1) + case('mLayerColumnOutflow' ); get_ixFlux = iLookFLUX%mLayerColumnOutflow ! total outflow from each layer in a given soil column (m3 s-1) + case('scalarSoilBaseflow' ); get_ixFlux = iLookFLUX%scalarSoilBaseflow ! total baseflow from throughout the soil profile (m s-1) + case('scalarSoilDrainage' ); get_ixFlux = iLookFLUX%scalarSoilDrainage ! drainage from the bottom of the soil profile (m s-1) + case('scalarAquiferRecharge' ); get_ixFlux = iLookFLUX%scalarAquiferRecharge ! recharge to the aquifer (m s-1) + case('scalarAquiferTranspire' ); get_ixFlux = iLookFLUX%scalarAquiferTranspire ! transpiration from the aquifer (m s-1) + case('scalarAquiferBaseflow' ); get_ixFlux = iLookFLUX%scalarAquiferBaseflow ! baseflow from the aquifer (m s-1) ! derived variables - case('scalarTotalET' ); get_ixflux = iLookFLUX%scalarTotalET ! total ET (kg m-2 s-1) - case('scalarTotalRunoff' ); get_ixflux = iLookFLUX%scalarTotalRunoff ! total runoff (m s-1) - case('scalarNetRadiation' ); get_ixflux = iLookFLUX%scalarNetRadiation ! net radiation (W m-2) + case('scalarTotalET' ); get_ixFlux = iLookFLUX%scalarTotalET ! total ET (kg m-2 s-1) + case('scalarTotalRunoff' ); get_ixFlux = iLookFLUX%scalarTotalRunoff ! total runoff (m s-1) + case('scalarNetRadiation' ); get_ixFlux = iLookFLUX%scalarNetRadiation ! net radiation (W m-2) ! return missing if variable not found case default - get_ixflux = integerMissing + get_ixFlux = integerMissing end select - end function get_ixflux + end function get_ixFlux ! ******************************************************************************************************************* - ! public function get_ixderiv: get the index of the named variables for the model derivatives + ! public function get_ixDeriv: get the index of the named variables for the model derivatives ! ******************************************************************************************************************* - function get_ixderiv(varName) + function get_ixDeriv(varName) USE var_lookup,only:iLookDERIV ! indices of the named variables implicit none ! define dummy variables character(*), intent(in) :: varName ! parameter name - integer(i4b) :: get_ixderiv ! index of the named variable + integer(i4b) :: get_ixDeriv ! index of the named variable ! get the index of the named variables select case(trim(varName)) ! derivatives in net vegetation energy fluxes w.r.t. relevant state variables - case('dCanairNetFlux_dCanairTemp' ); get_ixderiv = iLookDERIV%dCanairNetFlux_dCanairTemp ! derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) - case('dCanairNetFlux_dCanopyTemp' ); get_ixderiv = iLookDERIV%dCanairNetFlux_dCanopyTemp ! derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) - case('dCanairNetFlux_dGroundTemp' ); get_ixderiv = iLookDERIV%dCanairNetFlux_dGroundTemp ! derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) - case('dCanopyNetFlux_dCanairTemp' ); get_ixderiv = iLookDERIV%dCanopyNetFlux_dCanairTemp ! derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) - case('dCanopyNetFlux_dCanopyTemp' ); get_ixderiv = iLookDERIV%dCanopyNetFlux_dCanopyTemp ! derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) - case('dCanopyNetFlux_dGroundTemp' ); get_ixderiv = iLookDERIV%dCanopyNetFlux_dGroundTemp ! derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) - case('dCanopyNetFlux_dCanLiq' ); get_ixderiv = iLookDERIV%dCanopyNetFlux_dCanLiq ! derivative in net canopy fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - case('dGroundNetFlux_dCanairTemp' ); get_ixderiv = iLookDERIV%dGroundNetFlux_dCanairTemp ! derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) - case('dGroundNetFlux_dCanopyTemp' ); get_ixderiv = iLookDERIV%dGroundNetFlux_dCanopyTemp ! derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) - case('dGroundNetFlux_dGroundTemp' ); get_ixderiv = iLookDERIV%dGroundNetFlux_dGroundTemp ! derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) - case('dGroundNetFlux_dCanLiq' ); get_ixderiv = iLookDERIV%dGroundNetFlux_dCanLiq ! derivative in net ground fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + case('dCanairNetFlux_dCanairTemp' ); get_ixDeriv = iLookDERIV%dCanairNetFlux_dCanairTemp ! derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) + case('dCanairNetFlux_dCanopyTemp' ); get_ixDeriv = iLookDERIV%dCanairNetFlux_dCanopyTemp ! derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) + case('dCanairNetFlux_dGroundTemp' ); get_ixDeriv = iLookDERIV%dCanairNetFlux_dGroundTemp ! derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) + case('dCanopyNetFlux_dCanairTemp' ); get_ixDeriv = iLookDERIV%dCanopyNetFlux_dCanairTemp ! derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) + case('dCanopyNetFlux_dCanopyTemp' ); get_ixDeriv = iLookDERIV%dCanopyNetFlux_dCanopyTemp ! derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) + case('dCanopyNetFlux_dGroundTemp' ); get_ixDeriv = iLookDERIV%dCanopyNetFlux_dGroundTemp ! derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) + case('dCanopyNetFlux_dCanWat' ); get_ixDeriv = iLookDERIV%dCanopyNetFlux_dCanWat ! derivative in net canopy fluxes w.r.t. canopy total water content (J kg-1 s-1) + case('dGroundNetFlux_dCanairTemp' ); get_ixDeriv = iLookDERIV%dGroundNetFlux_dCanairTemp ! derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) + case('dGroundNetFlux_dCanopyTemp' ); get_ixDeriv = iLookDERIV%dGroundNetFlux_dCanopyTemp ! derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) + case('dGroundNetFlux_dGroundTemp' ); get_ixDeriv = iLookDERIV%dGroundNetFlux_dGroundTemp ! derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) + case('dGroundNetFlux_dCanWat' ); get_ixDeriv = iLookDERIV%dGroundNetFlux_dCanWat ! derivative in net ground fluxes w.r.t. canopy total water content (J kg-1 s-1) ! derivatives in evaporative fluxes w.r.t. relevant state variables - case('dCanopyEvaporation_dTCanair' ); get_ixderiv = iLookDERIV%dCanopyEvaporation_dTCanair ! derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) - case('dCanopyEvaporation_dTCanopy' ); get_ixderiv = iLookDERIV%dCanopyEvaporation_dTCanopy ! derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) - case('dCanopyEvaporation_dTGround' ); get_ixderiv = iLookDERIV%dCanopyEvaporation_dTGround ! derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) - case('dCanopyEvaporation_dCanLiq' ); get_ixderiv = iLookDERIV%dCanopyEvaporation_dCanLiq ! derivative in canopy evaporation w.r.t. canopy liquid water content (s-1) - case('dGroundEvaporation_dTCanair' ); get_ixderiv = iLookDERIV%dGroundEvaporation_dTCanair ! derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) - case('dGroundEvaporation_dTCanopy' ); get_ixderiv = iLookDERIV%dGroundEvaporation_dTCanopy ! derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) - case('dGroundEvaporation_dTGround' ); get_ixderiv = iLookDERIV%dGroundEvaporation_dTGround ! derivative in ground evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) - case('dGroundEvaporation_dCanLiq' ); get_ixderiv = iLookDERIV%dGroundEvaporation_dCanLiq ! derivative in ground evaporation w.r.t. canopy liquid water content (s-1) + case('dCanopyEvaporation_dTCanair' ); get_ixDeriv = iLookDERIV%dCanopyEvaporation_dTCanair ! derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + case('dCanopyEvaporation_dTCanopy' ); get_ixDeriv = iLookDERIV%dCanopyEvaporation_dTCanopy ! derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + case('dCanopyEvaporation_dTGround' ); get_ixDeriv = iLookDERIV%dCanopyEvaporation_dTGround ! derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) + case('dCanopyEvaporation_dCanWat' ); get_ixDeriv = iLookDERIV%dCanopyEvaporation_dCanWat ! derivative in canopy evaporation w.r.t. canopy total water content (s-1) + case('dGroundEvaporation_dTCanair' ); get_ixDeriv = iLookDERIV%dGroundEvaporation_dTCanair ! derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + case('dGroundEvaporation_dTCanopy' ); get_ixDeriv = iLookDERIV%dGroundEvaporation_dTCanopy ! derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + case('dGroundEvaporation_dTGround' ); get_ixDeriv = iLookDERIV%dGroundEvaporation_dTGround ! derivative in ground evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) + case('dGroundEvaporation_dCanWat' ); get_ixDeriv = iLookDERIV%dGroundEvaporation_dCanWat ! derivative in ground evaporation w.r.t. canopy total water content (s-1) + ! derivatives in transpiration + case('dCanopyTrans_dTCanair' ); get_ixDeriv = iLookDERIV%dCanopyTrans_dTCanair ! derivative in canopy transpiration w.r.t. canopy air temperature (kg m-2 s-1 K-1) + case('dCanopyTrans_dTCanopy' ); get_ixDeriv = iLookDERIV%dCanopyTrans_dTCanopy ! derivative in canopy transpiration w.r.t. canopy temperature (kg m-2 s-1 K-1) + case('dCanopyTrans_dTGround' ); get_ixDeriv = iLookDERIV%dCanopyTrans_dTGround ! derivative in canopy transpiration w.r.t. ground temperature (kg m-2 s-1 K-1) + case('dCanopyTrans_dCanWat' ); get_ixDeriv = iLookDERIV%dCanopyTrans_dCanWat ! derivative in canopy transpiration w.r.t. canopy total water content (s-1) ! derivatives in canopy water w.r.t canopy temperature - case('dTheta_dTkCanopy' ); get_ixderiv = iLookDERIV%dTheta_dTkCanopy ! derivative of volumetric liquid water content w.r.t. temperature (K-1) - case('dCanLiq_dTcanopy' ); get_ixderiv = iLookDERIV%dCanLiq_dTcanopy ! derivative of canopy liquid storage w.r.t. temperature (kg m-2 K-1) + case('dTheta_dTkCanopy' ); get_ixDeriv = iLookDERIV%dTheta_dTkCanopy ! derivative of volumetric liquid water content w.r.t. temperature (K-1) + case('d2Theta_dTkCanopy2' ); get_ixDeriv = iLookDERIV%d2Theta_dTkCanopy2 ! second derivative of volumetric liquid water content w.r.t. temperature + case('dCanLiq_dTcanopy' ); get_ixDeriv = iLookDERIV%dCanLiq_dTcanopy ! derivative of canopy liquid storage w.r.t. temperature (kg m-2 K-1) + case('dFracLiqVeg_dTkCanopy' ); get_ixDeriv = iLookDERIV%dFracLiqVeg_dTkCanopy ! derivative in fraction of (throughfall + drainage) w.r.t. temperature ! derivatives in canopy liquid fluxes w.r.t. canopy water - case('scalarCanopyLiqDeriv' ); get_ixderiv = iLookDERIV%scalarCanopyLiqDeriv ! derivative in (throughfall + canopy drainage) w.r.t. canopy liquid water (s-1) - case('scalarThroughfallRainDeriv' ); get_ixderiv = iLookDERIV%scalarThroughfallRainDeriv ! derivative in throughfall w.r.t. canopy liquid water (s-1) - case('scalarCanopyLiqDrainageDeriv' ); get_ixderiv = iLookDERIV%scalarCanopyLiqDrainageDeriv ! derivative in canopy drainage w.r.t. canopy liquid water (s-1) - ! derivatives in energy fluxes at the interface of snow+soil layers w.r.t. temperature in layers above and below - case('dNrgFlux_dTempAbove' ); get_ixderiv = iLookDERIV%dNrgFlux_dTempAbove ! derivatives in the flux w.r.t. temperature in the layer above (J m-2 s-1 K-1) - case('dNrgFlux_dTempBelow ' ); get_ixderiv = iLookDERIV%dNrgFlux_dTempBelow ! derivatives in the flux w.r.t. temperature in the layer below (J m-2 s-1 K-1) + case('scalarCanopyLiqDeriv' ); get_ixDeriv = iLookDERIV%scalarCanopyLiqDeriv ! derivative in (throughfall + canopy drainage) w.r.t. canopy liquid water (s-1) + case('scalarThroughfallRainDeriv' ); get_ixDeriv = iLookDERIV%scalarThroughfallRainDeriv ! derivative in throughfall w.r.t. canopy liquid water (s-1) + case('scalarCanopyLiqDrainageDeriv' ); get_ixDeriv = iLookDERIV%scalarCanopyLiqDrainageDeriv ! derivative in canopy drainage w.r.t. canopy liquid water (s-1) + ! energy derivatives that might be treated as constant if heat capacity and thermal conductivity not updated + case('dVolHtCapBulk_dPsi0' ); get_ixDeriv = iLookDERIV%dVolHtCapBulk_dPsi0 ! derivative in bulk heat capacity w.r.t. matric potential + case('dVolHtCapBulk_dTheta' ); get_ixDeriv = iLookDERIV%dVolHtCapBulk_dTheta ! derivative in bulk heat capacity w.r.t. volumetric water content + case('dVolHtCapBulk_dCanWat' ); get_ixDeriv = iLookDERIV%dVolHtCapBulk_dCanWat ! derivative in bulk heat capacity w.r.t. canopy volumetric water content + case('dVolHtCapBulk_dTk' ); get_ixDeriv = iLookDERIV%dVolHtCapBulk_dTk ! derivative in bulk heat capacity w.r.t. temperature + case('dVolHtCapBulk_dTkCanopy' ); get_ixDeriv = iLookDERIV%dVolHtCapBulk_dTkCanopy ! derivative in bulk heat capacity w.r.t. canopy temperature + case('dThermalC_dTempAbove' ); get_ixDeriv = iLookDERIV%dThermalC_dTempAbove ! derivative in the thermal conductivity w.r.t. energy state in the layer above + case('dThermalC_dTempBelow' ); get_ixDeriv = iLookDERIV%dThermalC_dTempBelow ! derivative in the thermal conductivity w.r.t. energy state in the layer above + case('dThermalC_dWatAbove' ); get_ixDeriv = iLookDERIV%dThermalC_dWatAbove ! derivative in the thermal conductivity w.r.t. water state in the layer above + case('dThermalC_dWatBelow' ); get_ixDeriv = iLookDERIV%dThermalC_dWatBelow ! derivative in the thermal conductivity w.r.t. water state in the layer above + case('dNrgFlux_dTempAbove' ); get_ixDeriv = iLookDERIV%dNrgFlux_dTempAbove ! derivatives in the flux w.r.t. temperature in the layer above (J m-2 s-1 K-1) + case('dNrgFlux_dTempBelow' ); get_ixDeriv = iLookDERIV%dNrgFlux_dTempBelow ! derivatives in the flux w.r.t. temperature in the layer below (J m-2 s-1 K-1) + ! energy derivatives that might be treated as constant if Cm not updated + case('dCm_dPsi0' ); get_ixDeriv = iLookDERIV%dCm_dPsi0 ! derivative in Cm w.r.t. matric potential (J kg-1) + case('dCm_dTk' ); get_ixDeriv = iLookDERIV%dCm_dTk ! derivative in Cm w.r.t. temperature (J kg K-2) + case('dCm_dTkCanopy' ); get_ixDeriv = iLookDERIV%dCm_dTkCanopy ! derivative in Cm w.r.t. canopy temperature (J kg K-2) + ! derivatives in energy fluxes at the interface of snow+soil layers w.r.t. water state in layers above and below + case('dNrgFlux_dWatAbove' ); get_ixDeriv = iLookDERIV%dNrgFlux_dWatAbove ! derivatives in the flux w.r.t. water state temperature in the layer above + case('dNrgFlux_dWatBelow' ); get_ixDeriv = iLookDERIV%dNrgFlux_dWatBelow ! derivatives in the flux w.r.t. water state in the layer below ! derivative in liquid water fluxes at the interface of snow layers w.r.t. volumetric liquid water content in the layer above - case('iLayerLiqFluxSnowDeriv' ); get_ixderiv = iLookDERIV%iLayerLiqFluxSnowDeriv ! derivative in vertical liquid water flux at layer interfaces (m s-1) + case('iLayerLiqFluxSnowDeriv' ); get_ixDeriv = iLookDERIV%iLayerLiqFluxSnowDeriv ! derivative in vertical liquid water flux at layer interfaces (m s-1) ! derivative in liquid water fluxes for the soil domain w.r.t hydrology state variables - case('dVolTot_dPsi0' ); get_ixderiv = iLookDERIV%dVolTot_dPsi0 ! derivative in total water content w.r.t. total water matric potential (m-1) - case('dq_dHydStateAbove' ); get_ixderiv = iLookDERIV%dq_dHydStateAbove ! change in the flux in layer interfaces w.r.t. state variables in the layer above - case('dq_dHydStateBelow' ); get_ixderiv = iLookDERIV%dq_dHydStateBelow ! change in the flux in layer interfaces w.r.t. state variables in the layer below - case('mLayerdTheta_dPsi' ); get_ixderiv = iLookDERIV%mLayerdTheta_dPsi ! derivative in the soil water characteristic w.r.t. psi (m-1) - case('mLayerdPsi_dTheta' ); get_ixderiv = iLookDERIV%mLayerdPsi_dTheta ! derivative in the soil water characteristic w.r.t. theta (m) - case('dCompress_dPsi' ); get_ixderiv = iLookDERIV%dCompress_dPsi ! derivative in compressibility w.r.t matric head (m-1) + case('dVolTot_dPsi0' ); get_ixDeriv = iLookDERIV%dVolTot_dPsi0 ! derivative in total water content w.r.t. total water matric potential (m-1) + case('d2VolTot_dPsi02' ); get_ixDeriv = iLookDERIV%d2VolTot_dPsi02 ! second derivative in total water content w.r.t. total water matric potential + case('dq_dHydStateAbove' ); get_ixDeriv = iLookDERIV%dq_dHydStateAbove ! change in the flux in layer interfaces w.r.t. state variables in the layer above + case('dq_dHydStateBelow' ); get_ixDeriv = iLookDERIV%dq_dHydStateBelow ! change in the flux in layer interfaces w.r.t. state variables in the layer below + case('dq_dHydStateLayerSurfVec' ); get_ixDeriv = iLookDERIV%dq_dHydStateLayerSurfVec ! change in the flux in soil surface interface w.r.t. state variables in layers + case('mLayerdTheta_dPsi' ); get_ixDeriv = iLookDERIV%mLayerdTheta_dPsi ! derivative in the soil water characteristic w.r.t. psi (m-1) + case('mLayerdPsi_dTheta' ); get_ixDeriv = iLookDERIV%mLayerdPsi_dTheta ! derivative in the soil water characteristic w.r.t. theta (m) + case('dCompress_dPsi' ); get_ixDeriv = iLookDERIV%dCompress_dPsi ! derivative in compressibility w.r.t matric head (m-1) ! derivative in baseflow flux w.r.t. aquifer storage - case('dBaseflow_dAquifer' ); get_ixderiv = iLookDERIV%dBaseflow_dAquifer ! derivative in baseflow flux w.r.t. aquifer storage (s-1) + case('dBaseflow_dAquifer' ); get_ixDeriv = iLookDERIV%dBaseflow_dAquifer ! derivative in baseflow flux w.r.t. aquifer storage (s-1) ! derivative in liquid water fluxes for the soil domain w.r.t energy state variables - case('dq_dNrgStateAbove' ); get_ixderiv = iLookDERIV%dq_dNrgStateAbove ! change in the flux in layer interfaces w.r.t. state variables in the layer above - case('dq_dNrgStateBelow' ); get_ixderiv = iLookDERIV%dq_dNrgStateBelow ! change in the flux in layer interfaces w.r.t. state variables in the layer below - case('mLayerdTheta_dTk' ); get_ixderiv = iLookDERIV%mLayerdTheta_dTk ! derivative of volumetric liquid water content w.r.t. temperature (K-1) - case('dPsiLiq_dTemp' ); get_ixderiv = iLookDERIV%dPsiLiq_dTemp ! derivative in the liquid water matric potential w.r.t. temperature (m K-1) - case('dPsiLiq_dPsi0' ); get_ixderiv = iLookDERIV%dPsiLiq_dPsi0 ! derivative in liquid matric potential w.r.t. total matric potential (-) + case('dq_dNrgStateAbove' ); get_ixDeriv = iLookDERIV%dq_dNrgStateAbove ! change in the flux in layer interfaces w.r.t. state variables in the layer above + case('dq_dNrgStateBelow' ); get_ixDeriv = iLookDERIV%dq_dNrgStateBelow ! change in the flux in layer interfaces w.r.t. state variables in the layer below + case('dq_dNrgStateLayerSurfVec' ); get_ixDeriv = iLookDERIV%dq_dNrgStateLayerSurfVec ! change in the flux in soil surface interface w.r.t. state variables in layers + case('dPsiLiq_dTemp' ); get_ixDeriv = iLookDERIV%dPsiLiq_dTemp ! derivative in the liquid water matric potential w.r.t. temperature (m K-1) + case('dPsiLiq_dPsi0' ); get_ixDeriv = iLookDERIV%dPsiLiq_dPsi0 ! derivative in liquid matric potential w.r.t. total matric potential (-) + ! derivatives in soil transpiration w.r.t. canopy state variables + case('mLayerdTrans_dTCanair' ); get_ixDeriv = iLookDERIV%mLayerdTrans_dTCanair ! derivatives in the soil layer transpiration flux w.r.t. canopy air temperature + case('mLayerdTrans_dTCanopy' ); get_ixDeriv = iLookDERIV%mLayerdTrans_dTCanopy ! derivatives in the soil layer transpiration flux w.r.t. canopy temperature + case('mLayerdTrans_dTGround' ); get_ixDeriv = iLookDERIV%mLayerdTrans_dTGround ! derivatives in the soil layer transpiration flux w.r.t. ground temperature + case('mLayerdTrans_dCanWat' ); get_ixDeriv = iLookDERIV%mLayerdTrans_dCanWat ! derivatives in the soil layer transpiration flux w.r.t. canopy total water + ! derivatives in aquifer transpiration w.r.t. canopy state variables + case('dAquiferTrans_dTCanair' ); get_ixDeriv = iLookDERIV%dAquiferTrans_dTCanair ! derivative in the aquifer transpiration flux w.r.t. canopy air temperature + case('dAquiferTrans_dTCanopy' ); get_ixDeriv = iLookDERIV%dAquiferTrans_dTCanopy ! derivative in the aquifer transpiration flux w.r.t. canopy temperature + case('dAquiferTrans_dTGround' ); get_ixDeriv = iLookDERIV%dAquiferTrans_dTGround ! derivative in the aquifer transpiration flux w.r.t. ground temperature + case('dAquiferTrans_dCanWat' ); get_ixDeriv = iLookDERIV%dAquiferTrans_dCanWat ! derivative in the aquifer transpiration flux w.r.t. canopy total water + ! derivative in liquid water fluxes for the soil and snow domain w.r.t temperature + case('dFracLiqWat_dTk' ); get_ixDeriv = iLookDERIV%dFracLiqWat_dTk ! derivative in fraction of liquid water w.r.t. temperature + case('mLayerdTheta_dTk' ); get_ixDeriv = iLookDERIV%mLayerdTheta_dTk ! derivative of volumetric liquid water content w.r.t. temperature (K-1) + case('mLayerd2Theta_dTk2' ); get_ixDeriv = iLookDERIV%mLayerd2Theta_dTk2 ! second derivative of volumetric liquid water content w.r.t. temperature + ! derivatives in time + case('mLayerdTemp_dt' ); get_ixDeriv = iLookDERIV%mLayerdTemp_dt ! timestep change in layer temperature + case('scalarCanopydTemp_dt' ); get_ixDeriv = iLookDERIV%scalarCanopydTemp_dt ! timestep change in canopy temperature + case('mLayerdWat_dt' ); get_ixDeriv = iLookDERIV%mLayerdWat_dt ! timestep change in layer volumetric fraction of total water + case('scalarCanopydWat_dt' ); get_ixDeriv = iLookDERIV%scalarCanopydWat_dt ! timestep change in canopy water content + ! derivatives of temperature if enthalpy is the state variable + case('dCanairTemp_dEnthalpy' ); get_ixDeriv = iLookDERIV%dCanairTemp_dEnthalpy ! derivative of canopy air temperature w.r.t. enthalpy + case('dCanopyTemp_dEnthalpy' ); get_ixDeriv = iLookDERIV%dCanopyTemp_dEnthalpy ! derivative of canopy temperature w.r.t. enthalpy + case('dTemp_dEnthalpy' ); get_ixDeriv = iLookDERIV%dTemp_dEnthalpy ! derivative of temperature w.r.t. enthalpy + case('dCanopyTemp_dCanWat' ); get_ixDeriv = iLookDERIV%dCanopyTemp_dCanWat ! derivative of canopy temperature w.r.t. volumetric water content + case('dTemp_dTheta' ); get_ixDeriv = iLookDERIV%dTemp_dTheta ! derivative of temperature w.r.t. volumetric water content + case('dTemp_dPsi0' ); get_ixDeriv = iLookDERIV%dTemp_dPsi0 ! derivative of temperature w.r.t. total water matric potential case default - get_ixderiv = integerMissing + get_ixDeriv = integerMissing end select - end function get_ixderiv + end function get_ixDeriv ! ******************************************************************************************************************* - ! public function get_ixindex: get the index of the named variables for the model indices + ! public function get_ixIndex: get the index of the named variables for the model indices ! ******************************************************************************************************************* - function get_ixindex(varName) + function get_ixIndex(varName) USE var_lookup,only:iLookINDEX ! indices of the named variables implicit none ! define dummy variables @@ -819,87 +943,87 @@ function get_ixindex(varName) case('ixNrgCanair' ); get_ixINDEX = iLookINDEX%ixNrgCanair ! indices IN THE FULL VECTOR for energy states in canopy air space domain (-) case('ixNrgCanopy' ); get_ixINDEX = iLookINDEX%ixNrgCanopy ! indices IN THE FULL VECTOR for energy states in the canopy domain (-) case('ixHydCanopy' ); get_ixINDEX = iLookINDEX%ixHydCanopy ! indices IN THE FULL VECTOR for hydrology states in the canopy domain (-) - case('ixNrgLayer' ); get_ixINDEX = iLookINDEX%ixNrgLayer ! indices IN THE FULL VECTOR for energy states in the snow+soil domain (-) - case('ixHydLayer' ); get_ixINDEX = iLookINDEX%ixHydLayer ! indices IN THE FULL VECTOR for hydrology states in the snow+soil domain (-) - case('ixWatAquifer' ); get_ixINDEX = iLookINDEX%ixWatAquifer ! indices IN THE FULL VECTOR for storage of water in the aquifer (-) + case('ixNrgLayer' ); get_ixINDEX = iLookINDEX%ixNrgLayer ! indices IN THE FULL VECTOR for energy states in the snow+soil domain (-) + case('ixHydLayer' ); get_ixINDEX = iLookINDEX%ixHydLayer ! indices IN THE FULL VECTOR for hydrology states in the snow+soil domain (-) + case('ixWatAquifer' ); get_ixINDEX = iLookINDEX%ixWatAquifer ! indices IN THE FULL VECTOR for storage of water in the aquifer (-) ! vectors of indices for specific state types IN SPECIFIC SUB-DOMAINS - case('ixVolFracWat' ); get_ixINDEX = iLookINDEX%ixVolFracWat ! indices IN THE SNOW+SOIL VECTOR for hyd states (-) - case('ixMatricHead' ); get_ixINDEX = iLookINDEX%ixMatricHead ! indices IN THE SOIL VECTOR for hyd states (-) + case('ixVolFracWat' ); get_ixINDEX = iLookINDEX%ixVolFracWat ! indices IN THE SNOW+SOIL VECTOR for hyd states (-) + case('ixMatricHead' ); get_ixINDEX = iLookINDEX%ixMatricHead ! indices IN THE SOIL VECTOR for hyd states (-) ! indices within state vectors - case('ixAllState' ); get_ixINDEX = iLookINDEX%ixAllState ! list of indices for all model state variables (-) - case('ixSoilState' ); get_ixINDEX = iLookINDEX%ixSoilState ! list of indices for all soil layers (-) - case('ixLayerState' ); get_ixINDEX = iLookINDEX%ixLayerState ! list of indices for all model layers (-) - case('ixLayerActive' ); get_ixINDEX = iLookINDEX%ixLayerActive ! list of indices for all active model layers (-) + case('ixAllState' ); get_ixINDEX = iLookINDEX%ixAllState ! list of indices for all model state variables (-) + case('ixSoilState' ); get_ixINDEX = iLookINDEX%ixSoilState ! list of indices for all soil layers (-) + case('ixLayerState' ); get_ixINDEX = iLookINDEX%ixLayerState ! list of indices for all model layers (-) + case('ixLayerActive' ); get_ixINDEX = iLookINDEX%ixLayerActive ! list of indices for all active model layers (-) ! number of trials - case('numberFluxCalc' ); get_ixINDEX = iLookINDEX%numberFluxCalc ! number of flux calculations (-) - case('numberStateSplit' ); get_ixINDEX = iLookINDEX%numberStateSplit ! number of state splitting solutions (-) - case('numberDomainSplitNrg' ); get_ixINDEX = iLookINDEX%numberDomainSplitNrg ! number of domain splitting solutions for energy (-) - case('numberDomainSplitMass'); get_ixINDEX = iLookINDEX%numberDomainSplitMass ! number of domain splitting solutions for mass (-) - case('numberScalarSolutions'); get_ixINDEX = iLookINDEX%numberScalarSolutions ! number of scalar solutions (-) + case('numberFluxCalc' ); get_ixINDEX = iLookINDEX%numberFluxCalc ! number of flux calculations (-) + case('numberStateSplit' ); get_ixINDEX = iLookINDEX%numberStateSplit ! number of state splitting solutions (-) + case('numberDomainSplitNrg' ); get_ixINDEX = iLookINDEX%numberDomainSplitNrg ! number of domain splitting solutions for energy (-) + case('numberDomainSplitMass'); get_ixINDEX = iLookINDEX%numberDomainSplitMass ! number of domain splitting solutions for mass (-) + case('numberScalarSolutions'); get_ixINDEX = iLookINDEX%numberScalarSolutions ! number of scalar solutions (-) ! default case default - get_ixindex = integerMissing + get_ixIndex = integerMissing end select - end function get_ixindex + end function get_ixIndex ! ******************************************************************************************************************* - ! public function get_ixbpar: get the index of the named variables for the basin-average variables + ! public function get_ixBpar: get the index of the named variables for the basin-average variables ! ******************************************************************************************************************* - function get_ixbpar(varName) + function get_ixBpar(varName) USE var_lookup,only:iLookBPAR ! indices of the named variables implicit none ! define dummy variables character(*), intent(in) :: varName ! parameter name - integer(i4b) :: get_ixbpar ! index of the named variable + integer(i4b) :: get_ixBpar ! index of the named variable ! get the index of the named variables select case(trim(varName)) ! baseflow - case('basin__aquiferHydCond' ); get_ixbpar = iLookBPAR%basin__aquiferHydCond ! hydraulic conductivity of the basin aquifer (m s-1) - case('basin__aquiferScaleFactor'); get_ixbpar = iLookBPAR%basin__aquiferScaleFactor ! scaling factor for aquifer storage in the big bucket (m) - case('basin__aquiferBaseflowExp'); get_ixbpar = iLookBPAR%basin__aquiferBaseflowExp ! baseflow exponent for the big bucket (-) + case('basin__aquiferHydCond' ); get_ixBpar = iLookBPAR%basin__aquiferHydCond ! hydraulic conductivity of the basin aquifer (m s-1) + case('basin__aquiferScaleFactor'); get_ixBpar = iLookBPAR%basin__aquiferScaleFactor ! scaling factor for aquifer storage in the big bucket (m) + case('basin__aquiferBaseflowExp'); get_ixBpar = iLookBPAR%basin__aquiferBaseflowExp ! baseflow exponent for the big bucket (-) ! sub-grid routing - case('routingGammaShape' ); get_ixbpar = iLookBPAR%routingGammaShape ! shape parameter in Gamma distribution used for sub-grid routing (-) - case('routingGammaScale' ); get_ixbpar = iLookBPAR%routingGammaScale ! scale parameter in Gamma distribution used for sub-grid routing (s) + case('routingGammaShape' ); get_ixBpar = iLookBPAR%routingGammaShape ! shape parameter in Gamma distribution used for sub-grid routing (-) + case('routingGammaScale' ); get_ixBpar = iLookBPAR%routingGammaScale ! scale parameter in Gamma distribution used for sub-grid routing (s) ! get to here if cannot find the variable case default - get_ixbpar = integerMissing + get_ixBpar = integerMissing end select - end function get_ixbpar + end function get_ixBpar ! ******************************************************************************************************************* - ! public function get_ixbvar: get the index of the named variables for the basin-average variables + ! public function get_ixBvar: get the index of the named variables for the basin-average variables ! ******************************************************************************************************************* - function get_ixbvar(varName) + function get_ixBvar(varName) USE var_lookup,only:iLookBVAR ! indices of the named variables implicit none ! define dummy variables character(*), intent(in) :: varName ! parameter name - integer(i4b) :: get_ixbvar ! index of the named variable + integer(i4b) :: get_ixBvar ! index of the named variable ! get the index of the named variables select case(trim(varName)) ! derived variables - case('basin__TotalArea' ); get_ixbvar = iLookBVAR%basin__totalArea ! total basin area (m2) + case('basin__TotalArea' ); get_ixBvar = iLookBVAR%basin__totalArea ! total basin area (m2) ! scalar variables -- basin-average runoff and aquifer fluxes - case('basin__SurfaceRunoff' ); get_ixbvar = iLookBVAR%basin__SurfaceRunoff ! surface runoff (m s-1) - case('basin__ColumnOutflow' ); get_ixbvar = iLookBVAR%basin__ColumnOutflow ! outflow from all "outlet" HRUs (those with no downstream HRU) - case('basin__AquiferStorage' ); get_ixbvar = iLookBVAR%basin__AquiferStorage ! aquifer storage (m s-1) - case('basin__AquiferRecharge' ); get_ixbvar = iLookBVAR%basin__AquiferRecharge ! recharge to the aquifer (m s-1) - case('basin__AquiferBaseflow' ); get_ixbvar = iLookBVAR%basin__AquiferBaseflow ! baseflow from the aquifer (m s-1) - case('basin__AquiferTranspire' ); get_ixbvar = iLookBVAR%basin__AquiferTranspire ! transpiration from the aquifer (m s-1) - case('basin__TotalRunoff' ); get_ixbvar = iLookBVAR%basin__TotalRunoff ! total runoff to channel from all active components (m s-1) - case('basin__SoilDrainage' ); get_ixbvar = iLookBVAR%basin__SoilDrainage ! soil drainage (m s-1) + case('basin__SurfaceRunoff' ); get_ixBvar = iLookBVAR%basin__SurfaceRunoff ! surface runoff (m s-1) + case('basin__ColumnOutflow' ); get_ixBvar = iLookBVAR%basin__ColumnOutflow ! outflow from all "outlet" HRUs (those with no downstream HRU) + case('basin__AquiferStorage' ); get_ixBvar = iLookBVAR%basin__AquiferStorage ! aquifer storage (m s-1) + case('basin__AquiferRecharge' ); get_ixBvar = iLookBVAR%basin__AquiferRecharge ! recharge to the aquifer (m s-1) + case('basin__AquiferBaseflow' ); get_ixBvar = iLookBVAR%basin__AquiferBaseflow ! baseflow from the aquifer (m s-1) + case('basin__AquiferTranspire' ); get_ixBvar = iLookBVAR%basin__AquiferTranspire ! transpiration from the aquifer (m s-1) + case('basin__TotalRunoff' ); get_ixBvar = iLookBVAR%basin__TotalRunoff ! total runoff to channel from all active components (m s-1) + case('basin__SoilDrainage' ); get_ixBvar = iLookBVAR%basin__SoilDrainage ! soil drainage (m s-1) ! variables to compute runoff - case('routingRunoffFuture' ); get_ixbvar = iLookBVAR%routingRunoffFuture ! runoff in future time steps (m s-1) - case('routingFractionFuture' ); get_ixbvar = iLookBVAR%routingFractionFuture ! fraction of runoff in future time steps (-) - case('averageInstantRunoff' ); get_ixbvar = iLookBVAR%averageInstantRunoff ! instantaneous runoff (m s-1) - case('averageRoutedRunoff' ); get_ixbvar = iLookBVAR%averageRoutedRunoff ! routed runoff (m s-1) + case('routingRunoffFuture' ); get_ixBvar = iLookBVAR%routingRunoffFuture ! runoff in future time steps (m s-1) + case('routingFractionFuture' ); get_ixBvar = iLookBVAR%routingFractionFuture ! fraction of runoff in future time steps (-) + case('averageInstantRunoff' ); get_ixBvar = iLookBVAR%averageInstantRunoff ! instantaneous runoff (m s-1) + case('averageRoutedRunoff' ); get_ixBvar = iLookBVAR%averageRoutedRunoff ! routed runoff (m s-1) ! get to here if cannot find the variable case default - get_ixbvar = integerMissing + get_ixBvar = integerMissing end select - end function get_ixbvar + end function get_ixBvar ! ********************************************************************************************************* ! public function get_ixVarType: get the index of the named variable type @@ -984,19 +1108,20 @@ subroutine get_ixUnknown(varName,typeName,vDex,err,message) ! poll variable index plus return which structure it was found in do iStruc = 1,size(structInfo) select case(trim(structInfo(iStruc)%structName)) - case ('time' ); vDex = get_ixTime(trim(varName)) - case ('forc' ); vDex = get_ixForce(trim(varName)) - case ('attr' ); vDex = get_ixAttr(trim(varName)) - case ('type' ); vDex = get_ixType(trim(varName)) - case ('id' ); vDex = get_ixId(trim(varName)) - case ('mpar' ); vDex = get_ixParam(trim(varName)) - case ('indx' ); vDex = get_ixIndex(trim(varName)) - case ('prog' ); vDex = get_ixProg(trim(varName)) - case ('diag' ); vDex = get_ixDiag(trim(varName)) - case ('flux' ); vDex = get_ixFlux(trim(varName)) - case ('bpar' ); vDex = get_ixBpar(trim(varName)) - case ('bvar' ); vDex = get_ixBvar(trim(varName)) - case ('deriv'); vDex = get_ixDeriv(trim(varName)) + case ('time' ); vDex = get_ixTime(trim(varName)) + case ('forc' ); vDex = get_ixForce(trim(varName)) + case ('attr' ); vDex = get_ixAttr(trim(varName)) + case ('type' ); vDex = get_ixType(trim(varName)) + case ('id' ); vDex = get_ixId(trim(varName)) + case ('mpar' ); vDex = get_ixParam(trim(varName)) + case ('indx' ); vDex = get_ixIndex(trim(varName)) + case ('prog' ); vDex = get_ixProg(trim(varName)) + case ('diag' ); vDex = get_ixDiag(trim(varName)) + case ('flux' ); vDex = get_ixFlux(trim(varName)) + case ('bpar' ); vDex = get_ixBpar(trim(varName)) + case ('bvar' ); vDex = get_ixBvar(trim(varName)) + case ('deriv'); vDex = get_ixDeriv(trim(varName)) + case ('lookup'); vDex = get_ixLookup(trim(varName)) end select if (vDex>0) then; typeName=trim(structInfo(iStruc)%structName); return; end if end do @@ -1007,44 +1132,64 @@ subroutine get_ixUnknown(varName,typeName,vDex,err,message) end subroutine get_ixUnknown ! ******************************************************************************************************************* - ! public function get_ixfreq: get the index of the named variables for the output frequencies + ! public function get_ixFreq: get the index of the named variables for the output frequencies ! ******************************************************************************************************************* - function get_ixfreq(varName) - USE var_lookup,only:iLookFreq ! indices of the named variables + function get_ixLookup(varName) + USE var_lookup,only:iLookLOOKUP ! indices of the named variables implicit none ! define dummy variables character(*), intent(in) :: varName ! variable name - integer(i4b) :: get_ixfreq ! index of the named variable + integer(i4b) :: get_ixLookup ! index of the named variable ! get the index of the named variables select case(trim(varName)) - case('day' ); get_ixFreq = iLookFreq%day ! daily aggregation - case('month' ); get_ixFreq = iLookFreq%month ! monthly aggregation - case('annual' ); get_ixFreq = iLookFreq%annual ! yearly (annual) aggregation - case('timestep'); get_ixFreq = iLookFreq%timestep ! timestep-level output (no temporal aggregation) + case('temperature'); get_ixLookup = iLookLOOKUP%temperature ! temperature (K) + case('psiLiq_int' ); get_ixLookup = iLookLOOKUP%psiLiq_int ! integral of mLayerPsiLiq from Tfreeze to Tk (K) + case('deriv2' ); get_ixLookup = iLookLOOKUP%deriv2 ! secind derivative of the interpolating function ! get to here if cannot find the variable case default - get_ixfreq = integerMissing + get_ixLookup = integerMissing end select - end function get_ixfreq + end function get_ixLookup + + ! ******************************************************************************************************************* + ! public function get_ixFreq: get the index of the named variables for the output frequencies + ! ******************************************************************************************************************* + function get_ixFreq(varName) + USE var_lookup,only:iLookFREQ ! indices of the named variables + implicit none + ! define dummy variables + character(*), intent(in) :: varName ! variable name + integer(i4b) :: get_ixFreq ! index of the named variable + ! get the index of the named variables + select case(trim(varName)) + case('day' ); get_ixFreq = iLookFREQ%day ! daily aggregation + case('month' ); get_ixFreq = iLookFREQ%month ! monthly aggregation + case('annual' ); get_ixFreq = iLookFREQ%annual ! yearly (annual) aggregation + case('timestep'); get_ixFreq = iLookFREQ%timestep ! timestep-level output (no temporal aggregation) + ! get to here if cannot find the variable + case default + get_ixFreq = integerMissing + end select + end function get_ixFreq ! *************************************************************************************************************** ! public function get_ixStat: get the named variables for the statistics ! *************************************************************************************************************** function get_ixStat(varName) - USE var_lookup,only:iLookStat ! indices of the possible output statistics + USE var_lookup,only:iLookSTAT ! indices of the possible output statistics implicit none ! define dummy variables character(*), intent(in) :: varName ! variable name integer(i4b) :: get_ixStat ! index of the named variable ! get the index of the named variables select case(trim(varName)) - case('total' ); get_ixStat = iLookStat%totl - case('instant' ); get_ixStat = iLookStat%inst - case('mean' ); get_ixStat = iLookStat%mean - case('variance'); get_ixStat = iLookStat%vari - case('minimum' ); get_ixStat = iLookStat%mini - case('maximum' ); get_ixStat = iLookStat%maxi - case('mode' ); get_ixStat = iLookStat%mode + case('total' ); get_ixStat = iLookSTAT%totl + case('instant' ); get_ixStat = iLookSTAT%inst + case('mean' ); get_ixStat = iLookSTAT%mean + case('variance'); get_ixStat = iLookSTAT%vari + case('minimum' ); get_ixStat = iLookSTAT%mini + case('maximum' ); get_ixStat = iLookSTAT%maxi + case('mode' ); get_ixStat = iLookSTAT%mode ! get to here if cannot find the variable case default get_ixStat = integerMissing @@ -1055,17 +1200,17 @@ end function get_ixStat ! public function get_freqName: get the name of the output frequency type ! *************************************************************************************************************** function get_freqName(ifreq) - USE var_lookup,only:iLookFreq ! indices of the possible output frequencies + USE var_lookup,only:iLookFREQ ! indices of the possible output frequencies implicit none ! define dummy variables integer(i4b), intent(in) :: ifreq ! output frequency index character(LEN=10) :: get_freqName ! name of the output frequency ! get the index of the named variables select case(ifreq) - case(iLookFreq%day); get_freqName='day' - case(iLookFreq%month); get_freqName='month' - case(iLookFreq%annual); get_freqName='annual' - case(iLookFreq%timestep); get_freqName='timestep' + case(iLookFREQ%day); get_freqName='day' + case(iLookFREQ%month); get_freqName='month' + case(iLookFREQ%annual); get_freqName='annual' + case(iLookFREQ%timestep); get_freqName='timestep' ! get to here if cannot find the variable case default get_freqName = 'unknown' @@ -1076,20 +1221,20 @@ end function get_freqName ! public function get_statName: get the name of the output statistics type ! *************************************************************************************************************** function get_statName(istat) - USE var_lookup,only:iLookStat ! indices of the possible output statistics + USE var_lookup,only:iLookSTAT ! indices of the possible output statistics implicit none ! define dummy variables integer(i4b), intent(in) :: istat ! stat type name character(LEN=10) :: get_statName ! name of the statistic ! get the index of the named variables select case(istat) - case(iLookStat%totl);get_statName='total' - case(iLookStat%inst);get_statName='instant' - case(iLookStat%mean);get_statName='mean' - case(iLookStat%vari);get_statName='variance' - case(iLookStat%mini);get_statName='minimum' - case(iLookStat%maxi);get_statName='maximum' - case(iLookStat%mode);get_statName='mode' + case(iLookSTAT%totl);get_statName='total' + case(iLookSTAT%inst);get_statName='instant' + case(iLookSTAT%mean);get_statName='mean' + case(iLookSTAT%vari);get_statName='variance' + case(iLookSTAT%mini);get_statName='minimum' + case(iLookSTAT%maxi);get_statName='maximum' + case(iLookSTAT%mode);get_statName='mode' ! get to here if cannot find the variable case default get_statName = 'unknown' diff --git a/build/source/dshare/globalData.f90 b/build/source/dshare/globalData.f90 old mode 100755 new mode 100644 index faaa52d05..b1e7267c2 --- a/build/source/dshare/globalData.f90 +++ b/build/source/dshare/globalData.f90 @@ -23,323 +23,258 @@ ! ---------------------------------------------------------------------------------------------------------------- MODULE globalData - ! data types - USE nrtype - USE netcdf - USE,intrinsic :: ieee_arithmetic ! IEEE arithmetic - USE data_types,only:gru2hru_map ! mapping between the GRUs and HRUs - USE data_types,only:hru2gru_map ! mapping between the GRUs and HRUs - USE data_types,only:model_options ! the model decision structure - USE data_types,only:file_info ! metadata for model forcing datafile - USE data_types,only:par_info ! default parameter values and parameter bounds - USE data_types,only:var_info ! metadata for variables in each model structure - USE data_types,only:flux2state ! extended metadata to define flux-to-state mapping - USE data_types,only:extended_info ! extended metadata for variables in each model structure - USE data_types,only:struct_info ! summary information on all data structures - USE data_types,only:var_i ! vector of integers - ! number of variables in each data structure - USE var_lookup,only:maxvarTime ! time: maximum number variables - USE var_lookup,only:maxvarForc ! forcing data: maximum number variables - USE var_lookup,only:maxvarAttr ! attributes: maximum number variables - USE var_lookup,only:maxvarType ! type index: maximum number variables - USE var_lookup,only:maxvarId ! IDs index: maximum number variables - USE var_lookup,only:maxvarProg ! prognostic variables: maximum number variables - USE var_lookup,only:maxvarDiag ! diagnostic variables: maximum number variables - USE var_lookup,only:maxvarFlux ! model fluxes: maximum number variables - USE var_lookup,only:maxvarDeriv ! model derivatives: maximum number variables - USE var_lookup,only:maxvarIndx ! model indices: maximum number variables - USE var_lookup,only:maxvarMpar ! model parameters: maximum number variables - USE var_lookup,only:maxvarBvar ! basin-average variables: maximum number variables - USE var_lookup,only:maxvarBpar ! basin-average parameters: maximum number variables - USE var_lookup,only:maxvarDecisions ! maximum number of decisions - USE var_lookup,only:maxvarFreq ! maximum number of output files - implicit none - private - - ! ---------------------------------------------------------------------------------------------------------------- - ! * part 1: parameters that are fixed across multiple instantiations - ! ---------------------------------------------------------------------------------------------------------------- - - ! define missing values - real(rkind),parameter,public :: quadMissing = nr_quadMissing ! (from nrtype) missing quadruple precision number - real(rkind),parameter,public :: realMissing = nr_realMissing ! (from nrtype) missing double precision number - integer(i4b),parameter,public :: integerMissing = nr_integerMissing ! (from nrtype) missing integer - - ! define run modes - integer(i4b),parameter,public :: iRunModeFull=1 ! named variable defining running mode as full run (all GRUs) - integer(i4b),parameter,public :: iRunModeGRU=2 ! named variable defining running mode as GRU-parallelization run (GRU subset) - integer(i4b),parameter,public :: iRunModeHRU=3 ! named variable defining running mode as single-HRU run (ONE HRU) - - ! define progress modes - integer(i4b),parameter,public :: ixProgress_im=1000 ! named variable to print progress once per month - integer(i4b),parameter,public :: ixProgress_id=1001 ! named variable to print progress once per day - integer(i4b),parameter,public :: ixProgress_ih=1002 ! named variable to print progress once per hour - integer(i4b),parameter,public :: ixProgress_never=1003 ! named variable to print progress never - integer(i4b),parameter,public :: ixProgress_it=1004 ! named variable to print progress every timestep - - ! define restart frequency - integer(i4b),parameter,public :: ixRestart_iy=1000 ! named variable to print a re-start file once per year - integer(i4b),parameter,public :: ixRestart_im=1001 ! named variable to print a re-start file once per month - integer(i4b),parameter,public :: ixRestart_id=1002 ! named variable to print a re-start file once per day - integer(i4b),parameter,public :: ixRestart_end=1003 ! named variable to print a re-start file at the end of a run - integer(i4b),parameter,public :: ixRestart_never=1004 ! named variable to print a re-start file never - - ! define output file frequency - integer(i4b),parameter,public :: noNewFiles=1001 ! no new output files - integer(i4b),parameter,public :: newFileEveryOct1=1002 ! create a new file on Oct 1 every year (start of the USA water year) -! =======------- - ! define vectors of metadata - !type(var_info),save,public :: time_meta(maxvarTime) ! model time information - !type(var_info),save,public :: forc_meta(maxvarForc) ! model forcing data - !type(var_info),save,public :: attr_meta(maxvarAttr) ! local attributes - !type(var_info),save,public :: type_meta(maxvarType) ! local classification of veg, soil, etc. - !type(var_info),save,public :: id_meta(maxvarId) ! local labels of hru and gru IDs - !type(var_info),save,public :: mpar_meta(maxvarMpar) ! local model parameters for each HRU - !type(var_info),save,public :: indx_meta(maxvarIndx) ! local model indices for each HRU - !type(var_info),save,public :: prog_meta(maxvarProg) ! local state variables for each HRU - !type(var_info),save,public :: diag_meta(maxvarDiag) ! local diagnostic variables for each HRU - !type(var_info),save,public :: flux_meta(maxvarFlux) ! local model fluxes for each HRU - !type(var_info),save,public :: deriv_meta(maxvarDeriv) ! local model derivatives for each HRU - !type(var_info),save,public :: bpar_meta(maxvarBpar) ! basin parameters for aggregated processes - !type(var_info),save,public :: bvar_meta(maxvarBvar) ! basin variables for aggregated processes - - ! ancillary metadata structures - !type(flux2state), save,public :: flux2state_orig(maxvarFlux) ! named variables for the states affected by each flux (original) - !type(flux2state), save,public :: flux2state_liq(maxvarFlux) ! named variables for the states affected by each flux (liquid water) - !type(extended_info),save,public,allocatable :: averageFlux_meta(:) ! timestep-average model fluxes - - ! define summary information on all data structures - !integer(i4b),parameter :: nStruct=13 ! number of data structures - !type(struct_info),parameter,public,dimension(nStruct) :: structInfo=(/& - ! struct_info('time', 'TIME' , maxvarTime ), & ! the time data structure - ! struct_info('forc', 'FORCE', maxvarForc ), & ! the forcing data structure - ! struct_info('attr', 'ATTR' , maxvarAttr ), & ! the attribute data structure - ! struct_info('type', 'TYPE' , maxvarType ), & ! the type data structure - ! struct_info('id', 'ID' , maxvarId ), & ! the IDs data structure - ! struct_info('mpar', 'PARAM', maxvarMpar ), & ! the model parameter data structure - ! struct_info('bpar', 'BPAR' , maxvarBpar ), & ! the basin parameter data structure - ! struct_info('bvar', 'BVAR' , maxvarBvar ), & ! the basin variable data structure - ! struct_info('indx', 'INDEX', maxvarIndx ), & ! the model index data structure - ! struct_info('prog', 'PROG', maxvarProg ), & ! the prognostic (state) variable data structure - ! struct_info('diag', 'DIAG' , maxvarDiag ), & ! the diagnostic variable data structure - ! struct_info('flux', 'FLUX' , maxvarFlux ), & ! the flux data structure - ! struct_info('deriv', 'DERIV', maxvarDeriv) /) ! the model derivative data structure - - ! define named variables for "yes" and "no" - integer(i4b),parameter,public :: no=0 ! .false. - integer(i4b),parameter,public :: yes=1 ! .true. - - ! define named variables to describe the domain type - integer(i4b),parameter,public :: iname_cas =1000 ! named variable to denote a canopy air space state variable - integer(i4b),parameter,public :: iname_veg =1001 ! named variable to denote a vegetation state variable - integer(i4b),parameter,public :: iname_soil=1002 ! named variable to denote a soil layer - integer(i4b),parameter,public :: iname_snow=1003 ! named variable to denote a snow layer - integer(i4b),parameter,public :: iname_aquifer=1004 ! named variable to denote a snow layer - - ! define named variables to describe the state variable type - integer(i4b),parameter,public :: iname_nrgCanair=2001 ! named variable defining the energy of the canopy air space - integer(i4b),parameter,public :: iname_nrgCanopy=2002 ! named variable defining the energy of the vegetation canopy - integer(i4b),parameter,public :: iname_watCanopy=2003 ! named variable defining the mass of total water on the vegetation canopy - integer(i4b),parameter,public :: iname_liqCanopy=2004 ! named variable defining the mass of liquid water on the vegetation canopy - integer(i4b),parameter,public :: iname_nrgLayer=3001 ! named variable defining the energy state variable for snow+soil layers - integer(i4b),parameter,public :: iname_watLayer=3002 ! named variable defining the total water state variable for snow+soil layers - integer(i4b),parameter,public :: iname_liqLayer=3003 ! named variable defining the liquid water state variable for snow+soil layers - integer(i4b),parameter,public :: iname_matLayer=3004 ! named variable defining the matric head state variable for soil layers - integer(i4b),parameter,public :: iname_lmpLayer=3005 ! named variable defining the liquid matric potential state variable for soil layers - integer(i4b),parameter,public :: iname_watAquifer=3006 ! named variable defining the water storage in the aquifer - - ! define named variables to describe the form and structure of the band-diagonal matrices used in the numerical solver - ! NOTE: This indexing scheme provides the matrix structure expected by lapack. Specifically, lapack requires kl extra rows for additional storage. - ! Consequently, all indices are offset by kl and the total number of bands for storage is 2*kl+ku+1 instead of kl+ku+1. - integer(i4b),parameter,public :: nRHS=1 ! number of unknown variables on the RHS of the linear system A.X=B - integer(i4b),parameter,public :: ku=3 ! number of super-diagonal bands - integer(i4b),parameter,public :: kl=4 ! number of sub-diagonal bands - integer(i4b),parameter,public :: ixDiag=kl+ku+1 ! index for the diagonal band - integer(i4b),parameter,public :: nBands=2*kl+ku+1 ! length of the leading dimension of the band diagonal matrix - - ! define named variables for the type of matrix used in the numerical solution. - integer(i4b),parameter,public :: ixFullMatrix=1001 ! named variable for the full Jacobian matrix - integer(i4b),parameter,public :: ixBandMatrix=1002 ! named variable for the band diagonal matrix - - ! define indices describing the first and last layers of the Jacobian to print (for debugging) - integer(i4b),parameter,public :: iJac1=16 ! first layer of the Jacobian to print - integer(i4b),parameter,public :: iJac2=20 ! last layer of the Jacobian to print - - ! define limit checks - real(rkind),parameter,public :: verySmall=tiny(1.0_rkind) ! a very small number - real(rkind),parameter,public :: veryBig=1.e+20_rkind ! a very big number - - ! define algorithmic control parameters - real(rkind),parameter,public :: dx = 1.e-8_rkind ! finite difference increment - - ! define summary information on all data structures - integer(i4b),parameter :: nStruct=13 ! number of data structures - type(struct_info),parameter,public,dimension(nStruct) :: structInfo=(/& - struct_info('time', 'TIME' , maxvarTime ), & ! the time data structure - struct_info('forc', 'FORCE', maxvarForc ), & ! the forcing data structure - struct_info('attr', 'ATTR' , maxvarAttr ), & ! the attribute data structure - struct_info('type', 'TYPE' , maxvarType ), & ! the type data structure - struct_info('id' , 'ID' , maxvarId ), & ! the type data structure - struct_info('mpar', 'PARAM', maxvarMpar ), & ! the model parameter data structure - struct_info('bpar', 'BPAR' , maxvarBpar ), & ! the basin parameter data structure - struct_info('bvar', 'BVAR' , maxvarBvar ), & ! the basin variable data structure - struct_info('indx', 'INDEX', maxvarIndx ), & ! the model index data structure - struct_info('prog', 'PROG', maxvarProg ), & ! the prognostic (state) variable data structure - struct_info('diag', 'DIAG' , maxvarDiag ), & ! the diagnostic variable data structure - struct_info('flux', 'FLUX' , maxvarFlux ), & ! the flux data structure - struct_info('deriv', 'DERIV', maxvarDeriv) /) ! the model derivative data structure - - ! fixed model decisions - logical(lgt) , parameter, public :: overwriteRSMIN=.false. ! flag to overwrite RSMIN - integer(i4b) , parameter, public :: maxSoilLayers=10000 ! Maximum Number of Soil Layers - - ! ---------------------------------------------------------------------------------------------------------------- - ! * part 2: globally constant variables/structures that require initialization - ! ---------------------------------------------------------------------------------------------------------------- + ! data types + USE nrtype + USE netcdf + USE,intrinsic :: ieee_arithmetic ! IEEE arithmetic + USE data_types,only:gru2hru_map ! mapping between the GRUs and HRUs + USE data_types,only:hru2gru_map ! mapping between the GRUs and HRUs + USE data_types,only:model_options ! the model decision structure + USE data_types,only:file_info ! metadata for model forcing datafile + USE data_types,only:par_info ! default parameter values and parameter bounds + USE data_types,only:var_info ! metadata for variables in each model structure + USE data_types,only:flux2state ! extended metadata to define flux-to-state mapping + USE data_types,only:extended_info ! extended metadata for variables in each model structure + USE data_types,only:struct_info ! summary information on all data structures + USE data_types,only:var_i ! vector of integers + ! number of variables in each data structure + USE var_lookup,only:maxvarTime ! time: maximum number variables + USE var_lookup,only:maxvarForc ! forcing data: maximum number variables + USE var_lookup,only:maxvarAttr ! attributes: maximum number variables + USE var_lookup,only:maxvarType ! type index: maximum number variables + USE var_lookup,only:maxvarId ! IDs index: maximum number variables + USE var_lookup,only:maxvarProg ! prognostic variables: maximum number variables + USE var_lookup,only:maxvarDiag ! diagnostic variables: maximum number variables + USE var_lookup,only:maxvarFlux ! model fluxes: maximum number variables + USE var_lookup,only:maxvarDeriv ! model derivatives: maximum number variables + USE var_lookup,only:maxvarIndx ! model indices: maximum number variables + USE var_lookup,only:maxvarMpar ! model parameters: maximum number variables + USE var_lookup,only:maxvarBvar ! basin-average variables: maximum number variables + USE var_lookup,only:maxvarBpar ! basin-average parameters: maximum number variables + USE var_lookup,only:maxvarDecisions ! maximum number of decisions + USE var_lookup,only:maxvarFreq ! maximum number of output files + USE var_lookup,only:maxvarLookup ! maximum number of variables in the lookup + implicit none + private + + ! ---------------------------------------------------------------------------------------------------------------- + ! * part 1: parameters that are fixed across multiple instantiations + ! ---------------------------------------------------------------------------------------------------------------- + + ! define missing values + real(rkind),parameter,public :: quadMissing = nr_quadMissing ! (from nrtype) missing quadruple precision number + real(rkind),parameter,public :: realMissing = nr_realMissing ! (from nrtype) missing real number + integer(i4b),parameter,public :: integerMissing = nr_integerMissing ! (from nrtype) missing integer + ! define run modes + integer(i4b),parameter,public :: iRunModeFull=1 ! named variable defining running mode as full run (all GRUs) + integer(i4b),parameter,public :: iRunModeGRU=2 ! named variable defining running mode as GRU-parallelization run (GRU subset) + integer(i4b),parameter,public :: iRunModeHRU=3 ! named variable defining running mode as single-HRU run (ONE HRU) + ! define progress modes + integer(i4b),parameter,public :: ixProgress_im=1000 ! named variable to print progress once per month + integer(i4b),parameter,public :: ixProgress_id=1001 ! named variable to print progress once per day + integer(i4b),parameter,public :: ixProgress_ih=1002 ! named variable to print progress once per hour + integer(i4b),parameter,public :: ixProgress_never=1003 ! named variable to print progress never + integer(i4b),parameter,public :: ixProgress_it=1004 ! named variable to print progress every timestep + ! define restart frequency + integer(i4b),parameter,public :: ixRestart_iy=1000 ! named variable to print a re-start file once per year + integer(i4b),parameter,public :: ixRestart_im=1001 ! named variable to print a re-start file once per month + integer(i4b),parameter,public :: ixRestart_id=1002 ! named variable to print a re-start file once per day + integer(i4b),parameter,public :: ixRestart_end=1003 ! named variable to print a re-start file at the end of a run + integer(i4b),parameter,public :: ixRestart_never=1004 ! named variable to print a re-start file never + ! define output file frequency + integer(i4b),parameter,public :: noNewFiles=1001 ! no new output files + integer(i4b),parameter,public :: newFileEveryOct1=1002 ! create a new file on Oct 1 every year (start of the USA water year) + ! define named variables for "yes" and "no" + integer(i4b),parameter,public :: no=0 ! .false. + integer(i4b),parameter,public :: yes=1 ! .true. + ! define named variables to describe the domain type + integer(i4b),parameter,public :: iname_cas =1000 ! named variable to denote a canopy air space state variable + integer(i4b),parameter,public :: iname_veg =1001 ! named variable to denote a vegetation state variable + integer(i4b),parameter,public :: iname_soil=1002 ! named variable to denote a soil layer + integer(i4b),parameter,public :: iname_snow=1003 ! named variable to denote a snow layer + integer(i4b),parameter,public :: iname_aquifer=1004 ! named variable to denote a snow layer + ! define named variables to describe the state variable type + integer(i4b),parameter,public :: iname_nrgCanair=2001 ! named variable defining the energy of the canopy air space + integer(i4b),parameter,public :: iname_nrgCanopy=2002 ! named variable defining the energy of the vegetation canopy + integer(i4b),parameter,public :: iname_watCanopy=2003 ! named variable defining the mass of total water on the vegetation canopy + integer(i4b),parameter,public :: iname_liqCanopy=2004 ! named variable defining the mass of liquid water on the vegetation canopy + integer(i4b),parameter,public :: iname_nrgLayer=3001 ! named variable defining the energy state variable for snow+soil layers + integer(i4b),parameter,public :: iname_watLayer=3002 ! named variable defining the total water state variable for snow+soil layers + integer(i4b),parameter,public :: iname_liqLayer=3003 ! named variable defining the liquid water state variable for snow+soil layers + integer(i4b),parameter,public :: iname_matLayer=3004 ! named variable defining the matric head state variable for soil layers + integer(i4b),parameter,public :: iname_lmpLayer=3005 ! named variable defining the liquid matric potential state variable for soil layers + integer(i4b),parameter,public :: iname_watAquifer=3006 ! named variable defining the water storage in the aquifer + ! define named variables to describe the form and structure of the band-diagonal matrices used in the numerical solver + ! NOTE: This indexing scheme provides the matrix structure expected by lapack and sundials. Specifically, they require kl extra rows for additional storage. + ! Consequently, all indices are offset by kl and the total number of bands for storage is 2*kl+ku+1 instead of kl+ku+1. + integer(i4b),parameter,public :: nRHS=1 ! number of unknown variables on the RHS of the linear system A.X=B + integer(i4b),parameter,public :: ku=3 ! number of super-diagonal bands, ku>=3 to accommodate coupled layer above + integer(i4b),parameter,public :: kl=4 ! number of sub-diagonal bands, kl>=4 to accommodate vegetation + integer(i4b),parameter,public :: ixDiag=kl+ku+1 ! index for the diagonal band + integer(i4b),parameter,public :: nBands=2*kl+ku+1 ! length of the leading dimension of the band diagonal matrix + ! define named variables for the type of matrix used in the numerical solution. + integer(i4b),parameter,public :: ixFullMatrix=1001 ! named variable for the full Jacobian matrix + integer(i4b),parameter,public :: ixBandMatrix=1002 ! named variable for the band diagonal matrix + ! define indices describing the first and last layers of the Jacobian to print (for debugging) + integer(i4b),parameter,public :: iJac1=1 ! first layer of the Jacobian to print + integer(i4b),parameter,public :: iJac2=100 ! last layer of the Jacobian to print + ! define limit checks + real(rkind),parameter,public :: maxVolIceContent=0.7 ! snow maximum volumetric ice content to store water (-) + real(rkind),parameter,public :: verySmall=1.e-6_rkind ! a small number used as an additive constant to check if substantial difference among real numbers + real(rkind),parameter,public :: verySmaller=1.e-12_rkind ! a smaller number used as an additive constant to check if substantial difference among real numbers + real(rkind),parameter,public :: veryBig=1.e+20_rkind ! a very big number + ! define summary information on all data structures + integer(i4b),parameter :: nStruct=14 ! number of data structures + type(struct_info),parameter,public,dimension(nStruct) :: structInfo=(/& + struct_info('time', 'TIME' , maxvarTime ), & ! the time data structure + struct_info('forc', 'FORCE', maxvarForc ), & ! the forcing data structure + struct_info('attr', 'ATTR' , maxvarAttr ), & ! the attribute data structure + struct_info('type', 'TYPE' , maxvarType ), & ! the type data structure + struct_info('id' , 'ID' , maxvarId ), & ! the type data structure + struct_info('mpar', 'PARAM', maxvarMpar ), & ! the model parameter data structure + struct_info('bpar', 'BPAR' , maxvarBpar ), & ! the basin parameter data structure + struct_info('bvar', 'BVAR' , maxvarBvar ), & ! the basin variable data structure + struct_info('indx', 'INDEX', maxvarIndx ), & ! the model index data structure + struct_info('prog', 'PROG', maxvarProg ), & ! the prognostic (state) variable data structure + struct_info('diag', 'DIAG' , maxvarDiag ), & ! the diagnostic variable data structure + struct_info('flux', 'FLUX' , maxvarFlux ), & ! the flux data structure + struct_info('deriv', 'DERIV', maxvarDeriv), & ! the model derivative data structure + struct_info('lookup','LOOKUP',maxvarLookup) /) ! the lookup table data structure + ! fixed model decisions + logical(lgt) , parameter, public :: overwriteRSMIN=.false. ! flag to overwrite RSMIN + integer(i4b) , parameter, public :: maxSoilLayers=10000 ! Maximum Number of Soil Layers + + ! ---------------------------------------------------------------------------------------------------------------- + ! * part 2: globally constant variables/structures that require initialization + ! ---------------------------------------------------------------------------------------------------------------- ! define Not-a-Number (NaN) - real(rkind),save,public :: dNaN - - ! define default parameter values and parameter bounds - type(par_info),save,public :: localParFallback(maxvarMpar) ! local column default parameters - type(par_info),save,public :: basinParFallback(maxvarBpar) ! basin-average default parameters - - ! define vectors of metadata - type(var_info),save,public :: time_meta(maxvarTime) ! model time information - type(var_info),save,public :: forc_meta(maxvarForc) ! model forcing data - type(var_info),save,public :: attr_meta(maxvarAttr) ! local attributes - type(var_info),save,public :: type_meta(maxvarType) ! local classification of veg, soil, etc. - type(var_info),save,public :: id_meta(maxvarId) ! local classification of veg, soil, etc. - type(var_info),save,public :: mpar_meta(maxvarMpar) ! local model parameters for each HRU - type(var_info),save,public :: indx_meta(maxvarIndx) ! local model indices for each HRU - type(var_info),save,public :: prog_meta(maxvarProg) ! local state variables for each HRU - type(var_info),save,public :: diag_meta(maxvarDiag) ! local diagnostic variables for each HRU - type(var_info),save,public :: flux_meta(maxvarFlux) ! local model fluxes for each HRU - type(var_info),save,public :: deriv_meta(maxvarDeriv) ! local model derivatives for each HRU - type(var_info),save,public :: bpar_meta(maxvarBpar) ! basin parameters for aggregated processes - type(var_info),save,public :: bvar_meta(maxvarBvar) ! basin variables for aggregated processes - - ! ancillary metadata structures - type(flux2state), save,public :: flux2state_orig(maxvarFlux) ! named variables for the states affected by each flux (original) - type(flux2state), save,public :: flux2state_liq(maxvarFlux) ! named variables for the states affected by each flux (liquid water) - type(extended_info),save,public,allocatable :: averageFlux_meta(:) ! timestep-average model fluxes - - ! mapping from original to child structures - integer(i4b),save,public,allocatable :: forcChild_map(:) ! index of the child data structure: stats forc - integer(i4b),save,public,allocatable :: progChild_map(:) ! index of the child data structure: stats prog - integer(i4b),save,public,allocatable :: diagChild_map(:) ! index of the child data structure: stats diag - integer(i4b),save,public,allocatable :: fluxChild_map(:) ! index of the child data structure: stats flux - integer(i4b),save,public,allocatable :: indxChild_map(:) ! index of the child data structure: stats indx - integer(i4b),save,public,allocatable :: bvarChild_map(:) ! index of the child data structure: stats bvar - - ! child metadata structures - type(extended_info),save,public,allocatable :: statForc_meta(:) ! child metadata for stats - type(extended_info),save,public,allocatable :: statProg_meta(:) ! child metadata for stats - type(extended_info),save,public,allocatable :: statDiag_meta(:) ! child metadata for stats - type(extended_info),save,public,allocatable :: statFlux_meta(:) ! child metadata for stats - type(extended_info),save,public,allocatable :: statIndx_meta(:) ! child metadata for stats - type(extended_info),save,public,allocatable :: statBvar_meta(:) ! child metadata for stats - - ! ---------------------------------------------------------------------------------------------------------------- - ! * part 3: run time variables - ! ---------------------------------------------------------------------------------------------------------------- - - ! define the model decisions - type(model_options),save,public :: model_decisions(maxvarDecisions) ! the model decision structure - - ! define metadata for model forcing datafile - type(file_info),save,public,allocatable :: forcFileInfo(:) ! file info for model forcing data - - ! define index variables describing the indices of the first and last HRUs in the forcing file - integer(i4b),save,public :: ixHRUfile_min ! minimum index - integer(i4b),save,public :: ixHRUfile_max ! maximum index - - ! define indices in the forcing data files - integer(i4b),save,public :: iFile=1 ! index of current forcing file from forcing file list - integer(i4b),save,public :: forcingStep=integerMissing ! index of current time step in current forcing file - integer(i4b),save,public :: forcNcid=integerMissing ! netcdf id for current netcdf forcing file - - ! define mapping structures - type(gru2hru_map),allocatable,save,public :: gru_struc(:) ! gru2hru map - type(hru2gru_map),allocatable,save,public :: index_map(:) ! hru2gru map - - ! define variables used for the vegetation phenology - real(rkind),dimension(12), save , public :: greenVegFrac_monthly ! fraction of green vegetation in each month (0-1) - - ! define the model output file - character(len=256),save,public :: fileout='' ! output filename - character(len=256),save,public :: output_fileSuffix='' ! suffix for the output file - - ! define controls on model output - integer(i4b),dimension(maxvarFreq),save,public :: statCounter=0 ! time counter for stats - integer(i4b),dimension(maxvarFreq),save,public :: outputTimeStep=0 ! timestep in output files - logical(lgt),dimension(maxvarFreq),save,public :: resetStats=.true. ! flags to reset statistics - logical(lgt),dimension(maxvarFreq),save,public :: finalizeStats=.false. ! flags to reset statistics - integer(i4b),save,public :: maxLayers ! maximum number of layers - integer(i4b),save,public :: maxSnowLayers ! maximum number of snow layers - - ! define control variables - integer(i4b),save,public :: startGRU ! index of the starting GRU for parallelization run - integer(i4b),save,public :: checkHRU ! index of the HRU for a single HRU run - integer(i4b),save,public :: iRunMode ! define the current running mode - integer(i4b),save,public :: nThreads=1 ! number of threads - integer(i4b),save,public :: ixProgress=ixProgress_id ! define frequency to write progress - integer(i4b),save,public :: ixRestart=ixRestart_never ! define frequency to write restart files - integer(i4b),save,public :: newOutputFile=noNewFiles ! define option for new output files - - ! define common variables - integer(i4b),save,public :: numtim ! number of time steps - integer(i4b),save,public :: nHRUrun ! number of HRUs in the run domain - integer(i4b),save,public :: nGRUrun ! number of GRUs in the run domain - real(rkind),save,public :: data_step ! time step of the data - real(rkind),save,public :: refJulday ! reference time in fractional julian days - real(rkind),save,public :: refJulday_data ! reference time in fractional julian days (data files) - real(rkind),save,public :: fracJulday ! fractional julian days since the start of year - real(rkind),save,public :: dJulianStart ! julian day of start time of simulation - real(rkind),save,public :: dJulianFinsh ! julian day of end time of simulation - real(rkind),save,public :: tmZoneOffsetFracDay ! time zone offset in fractional days - integer(i4b),save,public :: nHRUfile ! number of HRUs in the file - integer(i4b),save,public :: yearLength ! number of days in the current year - integer(i4b),save,public :: urbanVegCategory ! vegetation category for urban areas - logical(lgt),save,public :: doJacobian=.false. ! flag to compute the Jacobian - logical(lgt),save,public :: globalPrintFlag=.false. ! flag to compute the Jacobian - integer(i4b),save,public :: chunksize=1024 ! chunk size for the netcdf read/write - integer(i4b),save,public :: outputPrecision=nf90_double ! variable type - integer(i4b),save,public :: outputCompressionLevel=4 ! output netcdf file deflate level: 0-9. 0 is no compression. - - ! define result from the time calls - integer(i4b),dimension(8),save,public :: startInit,endInit ! date/time for the start and end of the initialization - integer(i4b),dimension(8),save,public :: startSetup,endSetup ! date/time for the start and end of the parameter setup - integer(i4b),dimension(8),save,public :: startRestart,endRestart ! date/time for the start and end to read restart data - integer(i4b),dimension(8),save,public :: startRead,endRead ! date/time for the start and end of the data read - integer(i4b),dimension(8),save,public :: startWrite,endWrite ! date/time for the start and end of the stats/write - integer(i4b),dimension(8),save,public :: startPhysics,endPhysics ! date/time for the start and end of the physics - + real(rkind),save,public :: dNaN + ! define default parameter values and parameter bounds + type(par_info),save,public :: localParFallback(maxvarMpar) ! local column default parameters + type(par_info),save,public :: basinParFallback(maxvarBpar) ! basin-average default parameters + ! define vectors of metadata + type(var_info),save,public :: time_meta(maxvarTime) ! model time information + type(var_info),save,public :: forc_meta(maxvarForc) ! model forcing data + type(var_info),save,public :: attr_meta(maxvarAttr) ! local attributes + type(var_info),save,public :: type_meta(maxvarType) ! local classification of veg, soil, etc. + type(var_info),save,public :: id_meta(maxvarId) ! local classification of veg, soil, etc. + type(var_info),save,public :: mpar_meta(maxvarMpar) ! local model parameters for each HRU + type(var_info),save,public :: indx_meta(maxvarIndx) ! local model indices for each HRU + type(var_info),save,public :: prog_meta(maxvarProg) ! local state variables for each HRU + type(var_info),save,public :: diag_meta(maxvarDiag) ! local diagnostic variables for each HRU + type(var_info),save,public :: flux_meta(maxvarFlux) ! local model fluxes for each HRU + type(var_info),save,public :: deriv_meta(maxvarDeriv) ! local model derivatives for each HRU + type(var_info),save,public :: lookup_meta(maxvarLookup) ! local lookup tables for each HRU + type(var_info),save,public :: bpar_meta(maxvarBpar) ! basin parameters for aggregated processes + type(var_info),save,public :: bvar_meta(maxvarBvar) ! basin variables for aggregated processes + ! ancillary metadata structures + type(flux2state), save,public :: flux2state_orig(maxvarFlux) ! named variables for the states affected by each flux (original) + type(flux2state), save,public :: flux2state_liq(maxvarFlux) ! named variables for the states affected by each flux (liquid water) + type(extended_info),save,public,allocatable :: averageFlux_meta(:) ! timestep-average model fluxes + ! mapping from original to child structures + integer(i4b),save,public,allocatable :: forcChild_map(:) ! index of the child data structure: stats forc + integer(i4b),save,public,allocatable :: progChild_map(:) ! index of the child data structure: stats prog + integer(i4b),save,public,allocatable :: diagChild_map(:) ! index of the child data structure: stats diag + integer(i4b),save,public,allocatable :: fluxChild_map(:) ! index of the child data structure: stats flux + integer(i4b),save,public,allocatable :: indxChild_map(:) ! index of the child data structure: stats indx + integer(i4b),save,public,allocatable :: bvarChild_map(:) ! index of the child data structure: stats bvar + ! child metadata structures + type(extended_info),save,public,allocatable :: statForc_meta(:) ! child metadata for stats + type(extended_info),save,public,allocatable :: statProg_meta(:) ! child metadata for stats + type(extended_info),save,public,allocatable :: statDiag_meta(:) ! child metadata for stats + type(extended_info),save,public,allocatable :: statFlux_meta(:) ! child metadata for stats + type(extended_info),save,public,allocatable :: statIndx_meta(:) ! child metadata for stats + type(extended_info),save,public,allocatable :: statBvar_meta(:) ! child metadata for stats + + ! ---------------------------------------------------------------------------------------------------------------- + ! * part 3: run time variables + ! ---------------------------------------------------------------------------------------------------------------- + + ! define the model decisions + type(model_options),save,public :: model_decisions(maxvarDecisions) ! the model decision structure + ! define index variables describing the indices of the first and last HRUs in the forcing file + integer(i4b),save,public :: ixHRUfile_min ! minimum index + integer(i4b),save,public :: ixHRUfile_max ! maximum index + ! define mapping structures + type(gru2hru_map),allocatable,save,public :: gru_struc(:) ! gru2hru map + type(hru2gru_map),allocatable,save,public :: index_map(:) ! hru2gru map + ! define variables used for the vegetation phenology + real(rkind),dimension(12),save,public :: greenVegFrac_monthly ! fraction of green vegetation in each month (0-1) + real(rkind),save,public :: minExpLogHgtFac=0.02_rkind ! factor for minimum height of transition from the exponential to the logarithmic wind profile + ! define the model output file + character(len=256),save,public :: fileout='' ! output filename + character(len=256),save,public :: output_fileSuffix='' ! suffix for the output file + ! define controls on model output + logical(lgt),dimension(maxvarFreq),save,public :: finalizeStats=.false. ! flags to finalize statistics + integer(i4b),save,public :: maxLayers ! maximum number of layers + integer(i4b),save,public :: maxSnowLayers ! maximum number of snow layers + ! define control variables + integer(i4b),save,public :: startGRU ! index of the starting GRU for parallelization run + integer(i4b),save,public :: checkHRU ! index of the HRU for a single HRU run + integer(i4b),save,public :: iRunMode ! define the current running mode + integer(i4b),save,public :: nThreads=1 ! number of threads + integer(i4b),save,public :: ixProgress=ixProgress_id ! define frequency to write progress + integer(i4b),save,public :: ixRestart=ixRestart_never ! define frequency to write restart files + integer(i4b),save,public :: newOutputFile=noNewFiles ! define option for new output files + ! define common variables + integer(i4b),save,public :: numtim ! number of time steps + integer(i4b),save,public :: nHRUrun ! number of HRUs in the run domain + integer(i4b),save,public :: nGRUrun ! number of GRUs in the run domain + real(rkind),save,public :: data_step ! length of the time_step + real(rkind),save,public :: refJulDay ! reference time in fractional julian days + real(rkind),save,public :: refJulDay_data ! reference time in fractional julian days (data files) + real(rkind),save,public :: dJulianStart ! julian day of start time of simulation + real(rkind),save,public :: dJulianFinsh ! julian day of end time of simulation + integer(i4b),save,public :: nHRUfile ! number of HRUs in the file + integer(i4b),save,public :: urbanVegCategory ! vegetation category for urban areas + logical(lgt),save,public :: globalPrintFlag=.false. ! flag to compute the Jacobian, residual, and step progress + integer(i4b),save,public :: chunksize=1024 ! chunk size for the netcdf read/write + integer(i4b),save,public :: outputPrecision=nf90_double ! variable type + integer(i4b),save,public :: outputCompressionLevel=4 ! output netcdf file deflate level: 0-9. 0 is no compression. + ! define result from the time calls + integer(i4b),dimension(8),save,public :: startInit,endInit ! date/time for the start and end of the initialization + integer(i4b),dimension(8),save,public :: startSetup,endSetup ! date/time for the start and end of the parameter setup + integer(i4b),dimension(8),save,public :: startRestart,endRestart ! date/time for the start and end to read restart data + integer(i4b),dimension(8),save,public :: startRead,endRead ! date/time for the start and end of the data read + integer(i4b),dimension(8),save,public :: startWrite,endWrite ! date/time for the start and end of the stats/write + integer(i4b),dimension(8),save,public :: startPhysics,endPhysics ! date/time for the start and end of the physics ! define elapsed time - real(rkind),save,public :: elapsedInit ! elapsed time for the initialization - real(rkind),save,public :: elapsedSetup ! elapsed time for the parameter setup - real(rkind),save,public :: elapsedRestart ! elapsed time to read restart data - real(rkind),save,public :: elapsedRead ! elapsed time for the data read - real(rkind),save,public :: elapsedWrite ! elapsed time for the stats/write - real(rkind),save,public :: elapsedPhysics ! elapsed time for the physics - - ! define ancillary data structures - type(var_i),save,public :: startTime ! start time for the model simulation - type(var_i),save,public :: finshTime ! end time for the model simulation - type(var_i),save,public :: refTime ! reference time for the model simulation - type(var_i),save,public :: oldTime ! time for the previous model time step - - ! output file information - logical(lgt),dimension(maxvarFreq),save,public :: outFreq ! true if the output frequency is desired - integer(i4b),dimension(maxvarFreq),save,public :: ncid ! netcdf output file id - - ! look-up values for the choice of the time zone information (formerly in modelDecisions module) - integer(i4b),parameter,public :: ncTime=1 ! time zone information from NetCDF file (timeOffset = longitude/15. - ncTimeOffset) - integer(i4b),parameter,public :: utcTime=2 ! all times in UTC (timeOffset = longitude/15. hours) - integer(i4b),parameter,public :: localTime=3 ! all times local (timeOffset = 0) - - ! define fixed dimensions - integer(i4b),parameter,public :: nBand=2 ! number of spectral bands - integer(i4b),parameter,public :: nTimeDelay=2000 ! number of time steps in the time delay histogram (default: ~1 season = 24*365/4) - + real(rkind),save,public :: elapsedInit ! elapsed time for the initialization + real(rkind),save,public :: elapsedSetup ! elapsed time for the parameter setup + real(rkind),save,public :: elapsedRestart ! elapsed time to read restart data + real(rkind),save,public :: elapsedRead ! elapsed time for the data read + real(rkind),save,public :: elapsedWrite ! elapsed time for the stats/write + real(rkind),save,public :: elapsedPhysics ! elapsed time for the physics + ! define ancillary data structures + type(var_i),save,public :: startTime ! start time for the model simulation + type(var_i),save,public :: finshTime ! end time for the model simulation + type(var_i),save,public :: refTime ! reference time for the model simulation + type(var_i),save,public :: oldTime ! time for the previous model time step + ! output file information + logical(lgt),dimension(maxvarFreq),save,public :: outFreq ! true if the output frequency is desired + integer(i4b),dimension(maxvarFreq),save,public :: ncid ! netcdf output file id + ! look-up values for the choice of the time zone information (formerly in modelDecisions module) + integer(i4b),parameter,public :: ncTime=1 ! time zone information from NetCDF file (timeOffset = longitude/15. - ncTimeOffset) + integer(i4b),parameter,public :: utcTime=2 ! all times in UTC (timeOffset = longitude/15. hours) + integer(i4b),parameter,public :: localTime=3 ! all times local (timeOffset = 0) + ! define metadata for model forcing datafile non-Actors + type(file_info),save,public,allocatable :: forcFileInfo(:) ! file info for model forcing data + ! define indices in the forcing data files non-Actors + integer(i4b),save,public :: iFile=1 ! index of current forcing file from forcing file list + integer(i4b),save,public :: forcingStep=integerMissing ! index of current time step in current forcing file + integer(i4b),save,public :: forcNcid=integerMissing ! netcdf id for current netcdf forcing file + ! define controls on model output non-Actors + integer(i4b),dimension(maxvarFreq),save,public :: statCounter=0 ! time counter for stats + integer(i4b),dimension(maxvarFreq),save,public :: outputTimeStep=0 ! timestep in output files + logical(lgt),dimension(maxvarFreq),save,public :: resetStats=.true. ! flags to reset statistics + ! define common variables non-Actors + real(rkind),save,public :: fracJulDay ! fractional julian days since the start of year + real(rkind),save,public :: tmZoneOffsetFracDay ! time zone offset in fractional days + integer(i4b),save,public :: yearLength ! number of days in the current year + ! define fixed dimensions + integer(i4b),parameter,public :: nSpecBand=2 ! number of spectral bands + integer(i4b),parameter,public :: nTimeDelay=2000 ! number of time steps in the time delay histogram (default: ~1 season = 24*365/4) + ! printing step frequency + integer(i4b),parameter,public :: print_step_freq = 1000 ! frequency (in time steps) to print number of steps taken in solver END MODULE globalData diff --git a/build/source/dshare/multiconst.f90 b/build/source/dshare/multiconst.f90 old mode 100755 new mode 100644 index b1f007a1a..7d1a48519 --- a/build/source/dshare/multiconst.f90 +++ b/build/source/dshare/multiconst.f90 @@ -38,7 +38,7 @@ MODULE multiconst real(rkind), PARAMETER :: LH_fus = 333700.0_rkind ! latent heat of fusion (J kg-1) real(rkind), PARAMETER :: LH_vap = 2501000.0_rkind ! latent heat of vaporization (J kg-1) real(rkind), PARAMETER :: LH_sub = 2834700.0_rkind ! latent heat of sublimation (J kg-1) - real(rkind), PARAMETER :: sb = 5.6705d-8 ! Stefan Boltzman constant (W m-2 K-4) + real(rkind), PARAMETER :: sb = 5.6705d-8 ! Stefan Boltzman constant (W m-2 K-4) real(rkind), PARAMETER :: em_sno = 0.99_rkind ! emissivity of snow (-) real(rkind), PARAMETER :: lambda_air = 0.026_rkind ! thermal conductivity of air (W m-1 K-1) real(rkind), PARAMETER :: lambda_ice = 2.50_rkind ! thermal conductivity of ice (W m-1 K-1) diff --git a/build/source/dshare/outpt_stat.f90 b/build/source/dshare/outpt_stat.f90 old mode 100755 new mode 100644 index 9bae9b83b..d0c12ff63 --- a/build/source/dshare/outpt_stat.f90 +++ b/build/source/dshare/outpt_stat.f90 @@ -35,7 +35,7 @@ subroutine calcStats(stat,dat,meta,resetStats,finalizeStats,statCounter,err,mess USE nrtype USE data_types,only:extended_info,dlength,ilength ! metadata structure type USE var_lookup,only:iLookVarType ! named variables for variable types - USE var_lookup,only:iLookStat ! named variables for output statistics types + USE var_lookup,only:iLookSTAT ! named variables for output statistics types implicit none ! input variables @@ -54,7 +54,7 @@ subroutine calcStats(stat,dat,meta,resetStats,finalizeStats,statCounter,err,mess character(256) :: cmessage ! error message integer(i4b) :: iVar ! index for varaiable loop integer(i4b) :: pVar ! index into parent structure - real(rkind) :: tdata ! dummy for pulling info from dat structure + real(rkind) :: tdata ! dummy for pulling info from dat structure ! initialize error control err=0; message='calcStats/' @@ -81,7 +81,7 @@ subroutine calcStats(stat,dat,meta,resetStats,finalizeStats,statCounter,err,mess ! calculate statistics if (trim(meta(iVar)%varName)=='time') then - stat(iVar)%dat(iLookStat%inst) = tdata + stat(iVar)%dat(iLookSTAT%inst) = tdata else call calc_stats(meta(iVar),stat(iVar),tdata,resetStats,finalizeStats,statCounter,err,cmessage) end if @@ -107,14 +107,14 @@ subroutine calc_stats(meta,stat,tdata,resetStats,finalizeStats,statCounter,err,m USE globalData,only:data_step ! forcing timestep ! structures of named variables USE var_lookup,only:iLookVarType ! named variables for variable types - USE var_lookup,only:iLookFreq ! named variables for output frequency + USE var_lookup,only:iLookFREQ ! named variables for output frequency USE var_lookup,only:iLookSTAT ! named variables for output statistics USE var_lookup,only:iLookTIME ! named variables for time information implicit none ! input variables class(var_info),intent(in) :: meta ! meta data structure class(*) ,intent(inout) :: stat ! statistics structure - real(rkind) ,intent(in) :: tdata ! data value + real(rkind) ,intent(in) :: tdata ! data value logical(lgt) ,intent(in) :: resetStats(:) ! vector of flags to reset statistics logical(lgt) ,intent(in) :: finalizeStats(:) ! vector of flags to reset statistics integer(i4b) ,intent(in) :: statCounter(:) ! number of time steps in each output frequency @@ -122,7 +122,7 @@ subroutine calc_stats(meta,stat,tdata,resetStats,finalizeStats,statCounter,err,m integer(i4b) ,intent(out) :: err ! error code character(*) ,intent(out) :: message ! error message ! internals - real(rkind),dimension(maxvarFreq*2) :: tstat ! temporary stats vector + real(rkind),dimension(maxvarFreq*2):: tstat ! temporary stats vector integer(i4b) :: iFreq ! index of output frequency ! initialize error control err=0; message='calc_stats/' @@ -143,20 +143,20 @@ subroutine calc_stats(meta,stat,tdata,resetStats,finalizeStats,statCounter,err,m if(meta%varType/=iLookVarType%outstat) cycle ! only calculate stats for scalars select case(meta%statIndex(iFreq)) ! act depending on the statistic ! ------------------------------------------------------------------------------------- - case (iLookStat%totl) ! * summation over period + case (iLookSTAT%totl) ! * summation over period tstat(iFreq) = 0._rkind ! - resets stat at beginning of period - case (iLookStat%mean) ! * mean over period + case (iLookSTAT%mean) ! * mean over period tstat(iFreq) = 0._rkind ! - resets stat at beginning of period - case (iLookStat%vari) ! * variance over period + case (iLookSTAT%vari) ! * variance over period tstat(iFreq) = 0._rkind ! - resets E[X^2] term in var calc tstat(maxVarFreq+iFreq) = 0._rkind ! - resets E[X]^2 term - case (iLookStat%mini) ! * minimum over period + case (iLookSTAT%mini) ! * minimum over period tstat(iFreq) = huge(tstat(iFreq)) ! - resets stat at beginning of period - case (iLookStat%maxi) ! * maximum over period + case (iLookSTAT%maxi) ! * maximum over period tstat(iFreq) = -huge(tstat(iFreq)) ! - resets stat at beginning of period - case (iLookStat%mode) ! * mode over period + case (iLookSTAT%mode) ! * mode over period tstat(iFreq) = realMissing ! - does not work - case (iLookStat%inst) ! * instantaneous -- no need to reset + case (iLookSTAT%inst) ! * instantaneous -- no need to reset case default message=trim(message)//'unable to identify type of statistic [reset]' err=20; return @@ -173,20 +173,20 @@ subroutine calc_stats(meta,stat,tdata,resetStats,finalizeStats,statCounter,err,m if(meta%varType/=iLookVarType%outstat) cycle ! only calculate stats for scalars select case(meta%statIndex(iFreq)) ! act depending on the statistic ! ------------------------------------------------------------------------------------- - case (iLookStat%inst) ! * instantaneous value + case (iLookSTAT%inst) ! * instantaneous value tstat(iFreq) = tdata ! - data at a given time - case (iLookStat%totl) ! * summation over period + case (iLookSTAT%totl) ! * summation over period tstat(iFreq) = tstat(iFreq) + tdata*data_step ! - increment data - case (iLookStat%mean) ! * mean over period + case (iLookSTAT%mean) ! * mean over period tstat(iFreq) = tstat(iFreq) + tdata ! - increment data - case (iLookStat%vari) ! * variance over period + case (iLookSTAT%vari) ! * variance over period tstat(iFreq) = tstat(iFreq) + tdata**2 ! - E[X^2] term in var calc tstat(maxVarFreq+iFreq) = tstat(maxVarFreq+iFreq) + tdata ! - E[X]^2 term - case (iLookStat%mini) ! * minimum over period + case (iLookSTAT%mini) ! * minimum over period if (tdatatstat(iFreq)) tstat(iFreq) = tdata ! - check value - case (iLookStat%mode) ! * mode over period (does not workind) + case (iLookSTAT%mode) ! * mode over period (does not workind) tstat(iFreq) = realMissing case default message=trim(message)//'unable to identify type of statistic [calculating stats]' @@ -204,9 +204,9 @@ subroutine calc_stats(meta,stat,tdata,resetStats,finalizeStats,statCounter,err,m if(meta%varType/=iLookVarType%outstat) cycle ! only calculate stats for scalars select case(meta%statIndex(iFreq)) ! act depending on the statistic ! ------------------------------------------------------------------------------------- - case (iLookStat%mean) ! * mean over period + case (iLookSTAT%mean) ! * mean over period tstat(iFreq) = tstat(iFreq)/statCounter(iFreq) ! - normalize sum into mean - case (iLookStat%vari) ! * variance over period + case (iLookSTAT%vari) ! * variance over period tstat(maxVarFreq+iFreq) = tstat(maxVarFreq+1)/statCounter(iFreq) ! E[X] term tstat(iFreq) = tstat(iFreq)/statCounter(iFreq) - tstat(maxVarFreq+iFreq)**2 ! full variance case default ! do nothing -- don't need finalization for most stats diff --git a/build/source/dshare/popMetadat.f90 b/build/source/dshare/popMetadat.f90 old mode 100755 new mode 100644 index 7d741d292..9340c3949 --- a/build/source/dshare/popMetadat.f90 +++ b/build/source/dshare/popMetadat.f90 @@ -15,1018 +15,1136 @@ module popMetadat_module public::popMetadat contains - subroutine popMetadat(err,message) - ! data structures - USE data_types, only: var_info ! data type for metadata structure - USE globalData, only: time_meta ! data structure for time metadata - USE globalData, only: forc_meta ! data structure for forcing metadata - USE globalData, only: type_meta ! data structure for categorical metadata - USE globalData, only: id_meta ! data structure for hru and gru ID metadata - USE globalData, only: attr_meta ! data structure for attribute metadata - USE globalData, only: mpar_meta ! data structure for local parameter metadata - USE globalData, only: bpar_meta ! data structure for basin parameter metadata - USE globalData, only: bvar_meta ! data structure for basin model variable metadata - USE globalData, only: indx_meta ! data structure for index metadata - USE globalData, only: prog_meta ! data structure for local prognostic (state) variables - USE globalData, only: diag_meta ! data structure for local diagnostic variables - USE globalData, only: flux_meta ! data structure for local flux variables - USE globalData, only: deriv_meta ! data structure for local flux derivatives - ! structures of named variables - USE var_lookup, only: iLookTIME ! named variables for time data structure - USE var_lookup, only: iLookFORCE ! named variables for forcing data structure - USE var_lookup, only: iLookTYPE ! named variables for categorical attribute data structure - USE var_lookup, only: iLookID ! named variables for hru and gru ID metadata - USE var_lookup, only: iLookATTR ! named variables for real valued attribute data structure - USE var_lookup, only: iLookPARAM ! named variables for local parameter data structure - USE var_lookup, only: iLookBPAR ! named variables for basin parameter data structure - USE var_lookup, only: iLookBVAR ! named variables for basin model variable data structure - USE var_lookup, only: iLookINDEX ! named variables for index variable data structure - USE var_lookup, only: iLookPROG ! named variables for local state variables - USE var_lookup, only: iLookDIAG ! named variables for local diagnostic variables - USE var_lookup, only: iLookFLUX ! named variables for local flux variables - USE var_lookup, only: iLookDERIV ! named variables for local flux derivatives - USE var_lookup, only: maxvarFreq ! number of output frequencies - USE var_lookup, only: maxvarStat ! number of statistics - USE get_ixName_module,only:get_ixVarType ! to turn vartype strings to integers - implicit none - ! dummy variables - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! internals - character(256) :: cmessage ! error message - integer,dimension(maxVarFreq) :: iMissVec ! vector of missing integers - ! initialize error control - err=0; message='popMetadat/' - - ! init arrays for structure constructors - iMissVec(:) = integerMissing - ! ----- - ! * model time structures... - ! -------------------------- - time_meta(iLookTIME%iyyy) = var_info('iyyy' , 'year' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - time_meta(iLookTIME%im) = var_info('im' , 'month' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - time_meta(iLookTIME%id) = var_info('id' , 'day' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - time_meta(iLookTIME%ih) = var_info('ih' , 'hour' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - time_meta(iLookTIME%imin) = var_info('imin' , 'minute' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - time_meta(iLookTIME%ih_tz) = var_info('ih_tz' , 'hour for time zone offset' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - time_meta(iLookTIME%imin_tz) = var_info('imin_tz', 'minute for time zone offset', '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - - ! ----- - ! * model forcing data... - ! ----------------------- - forc_meta(iLookFORCE%time) = var_info('time' , 'time since time reference' , 'seconds since 1990-1-1 0:0:0.0 -0:00', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - forc_meta(iLookFORCE%pptrate) = var_info('pptrate' , 'precipitation rate' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - forc_meta(iLookFORCE%SWRadAtm) = var_info('SWRadAtm', 'downward shortwave radiation at the upper boundary', 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - forc_meta(iLookFORCE%LWRadAtm) = var_info('LWRadAtm', 'downward longwave radiation at the upper boundary' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - forc_meta(iLookFORCE%airtemp) = var_info('airtemp' , 'air temperature at the measurement height' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - forc_meta(iLookFORCE%windspd) = var_info('windspd' , 'wind speed at the measurement height' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - forc_meta(iLookFORCE%airpres) = var_info('airpres' , 'air pressure at the the measurement height' , 'Pa' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - forc_meta(iLookFORCE%spechum) = var_info('spechum' , 'specific humidity at the measurement height' , 'g g-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - - ! ----- - ! * categorical data... - ! --------------------- - type_meta(iLookTYPE%vegTypeIndex) = var_info('vegTypeIndex' , 'index defining vegetation type' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - type_meta(iLookTYPE%soilTypeIndex) = var_info('soilTypeIndex' , 'index defining soil type' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - type_meta(iLookTYPE%slopeTypeIndex) = var_info('slopeTypeIndex', 'index defining slope' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - type_meta(iLookTYPE%downHRUindex) = var_info('downHRUindex' , 'index of downslope HRU (0 = basin outlet)' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - - ! ----- - ! * hru and gru ID data... - ! --------------------- - id_meta(iLookID%hruId) = var_info('hruId' , 'ID defining the hydrologic response unit' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - - ! ----- - ! * site characteristics... - ! ------------------------- - attr_meta(iLookATTR%latitude) = var_info('latitude' , 'latitude' , 'degrees north', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - attr_meta(iLookATTR%longitude) = var_info('longitude' , 'longitude' , 'degrees east' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - attr_meta(iLookATTR%elevation) = var_info('elevation' , 'elevation' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - attr_meta(iLookATTR%tan_slope) = var_info('tan_slope' , 'tan water table slope (tan local ground surface slope)', '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - attr_meta(iLookATTR%contourLength) = var_info('contourLength' , 'length of contour at downslope edge of HRU' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - attr_meta(iLookATTR%HRUarea) = var_info('HRUarea' , 'area of each HRU' , 'm2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - attr_meta(iLookATTR%mHeight) = var_info('mHeight' , 'measurement height above bare ground' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - attr_meta(iLookATTR%aspect) = var_info('aspect' , 'mean azimuth of HRU in degrees East of North (0)' , 'degrees' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - - ! ----- - ! * local parameter data... - ! ------------------------- - ! boundary conditions - mpar_meta(iLookPARAM%upperBoundHead) = var_info('upperBoundHead' , 'matric head at the upper boundary' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%lowerBoundHead) = var_info('lowerBoundHead' , 'matric head at the lower boundary' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%upperBoundTheta) = var_info('upperBoundTheta' , 'volumetric liquid water content at the upper boundary' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%lowerBoundTheta) = var_info('lowerBoundTheta' , 'volumetric liquid water content at the lower boundary' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%upperBoundTemp) = var_info('upperBoundTemp' , 'temperature of the upper boundary' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%lowerBoundTemp) = var_info('lowerBoundTemp' , 'temperature of the lower boundary' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! precipitation partitioning - mpar_meta(iLookPARAM%tempCritRain) = var_info('tempCritRain' , 'critical temperature where precipitation is rain' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%tempRangeTimestep) = var_info('tempRangeTimestep' , 'temperature range over the time step' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%frozenPrecipMultip) = var_info('frozenPrecipMultip' , 'frozen precipitation multiplier' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! snow properties - mpar_meta(iLookPARAM%snowfrz_scale) = var_info('snowfrz_scale' , 'scaling parameter for the freezing curve for snow' , 'K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%fixedThermalCond_snow) = var_info('fixedThermalCond_snow' , 'temporally constant thermal conductivity for snow' , 'W m-1 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! snow albedo - mpar_meta(iLookPARAM%albedoMax) = var_info('albedoMax' , 'maximum snow albedo (single spectral band)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%albedoMinWinter) = var_info('albedoMinWinter' , 'minimum snow albedo during winter (single spectral band)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%albedoMinSpring) = var_info('albedoMinSpring' , 'minimum snow albedo during spring (single spectral band)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%albedoMaxVisible) = var_info('albedoMaxVisible' , 'maximum snow albedo in the visible part of the spectrum' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%albedoMinVisible) = var_info('albedoMinVisible' , 'minimum snow albedo in the visible part of the spectrum' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%albedoMaxNearIR) = var_info('albedoMaxNearIR' , 'maximum snow albedo in the near infra-red part of the spectrum' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%albedoMinNearIR) = var_info('albedoMinNearIR' , 'minimum snow albedo in the near infra-red part of the spectrum' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%albedoDecayRate) = var_info('albedoDecayRate' , 'albedo decay rate' , 's' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%albedoSootLoad) = var_info('albedoSootLoad' , 'soot load factor' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%albedoRefresh) = var_info('albedoRefresh' , 'critical mass necessary for albedo refreshment' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! radiation transfer - mpar_meta(iLookPARAM%radExt_snow) = var_info('radExt_snow' , 'extinction coefficient for radiation penetration into snowpack' , 'm-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%directScale) = var_info('directScale' , 'scaling factor for fractional driect radiaion parameterization' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%Frad_direct) = var_info('Frad_direct' , 'fraction direct solar radiation' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%Frad_vis) = var_info('Frad_vis' , 'fraction radiation in visible part of spectrum' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! new snow density - mpar_meta(iLookPARAM%newSnowDenMin) = var_info('newSnowDenMin' , 'minimum new snow density' , 'kg m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%newSnowDenMult) = var_info('newSnowDenMult' , 'multiplier for new snow density' , 'kg m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%newSnowDenScal) = var_info('newSnowDenScal' , 'scaling factor for new snow density' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%constSnowDen) = var_info('constSnowDen' , 'Constant new snow density' , 'kg m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%newSnowDenAdd) = var_info('newSnowDenAdd' , 'Pahaut 1976, additive factor for new snow density' , 'kg m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%newSnowDenMultTemp) = var_info('newSnowDenMultTemp' , 'Pahaut 1976, multiplier for new snow density for air temperature' , 'kg m-3 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%newSnowDenMultWind) = var_info('newSnowDenMultWind' , 'Pahaut 1976, multiplier for new snow density for wind speed' , 'kg m-7/2 s-1/2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%newSnowDenMultAnd) = var_info('newSnowDenMultAnd' , 'Anderson 1976, multiplier for new snow density (Anderson func)' , 'K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%newSnowDenBase) = var_info('newSnowDenBase' , 'Anderson 1976, base value that is rasied to the (3/2) power' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! snow compaction - mpar_meta(iLookPARAM%densScalGrowth) = var_info('densScalGrowth' , 'density scaling factor for grain growth' , 'kg-1 m3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%tempScalGrowth) = var_info('tempScalGrowth' , 'temperature scaling factor for grain growth' , 'K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%grainGrowthRate) = var_info('grainGrowthRate' , 'rate of grain growth' , 's-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%densScalOvrbdn) = var_info('densScalOvrbdn' , 'density scaling factor for overburden pressure' , 'kg-1 m3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%tempScalOvrbdn) = var_info('tempScalOvrbdn' , 'temperature scaling factor for overburden pressure' , 'K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%baseViscosity ) = var_info('baseViscosity ' , 'viscosity coefficient at T=T_frz and snow density=0' , 'kg s m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! water flow through snow - mpar_meta(iLookPARAM%Fcapil) = var_info('Fcapil' , 'capillary retention (fraction of total pore volume)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%k_snow) = var_info('k_snow' , 'hydraulic conductivity of snow' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%mw_exp) = var_info('mw_exp' , 'exponent for meltwater flow' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! turbulent heat fluxes - mpar_meta(iLookPARAM%z0Snow) = var_info('z0Snow' , 'roughness length of snow' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%z0Soil) = var_info('z0Soil' , 'roughness length of bare soil below the canopy' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%z0Canopy) = var_info('z0Canopy' , 'roughness length of the canopy' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%zpdFraction) = var_info('zpdFraction' , 'zero plane displacement / canopy height' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%critRichNumber) = var_info('critRichNumber' , 'critical value for the bulk Richardson number' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%Louis79_bparam) = var_info('Louis79_bparam' , 'parameter in Louis (1979) stability function' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%Louis79_cStar) = var_info('Louis79_cStar' , 'parameter in Louis (1979) stability function' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%Mahrt87_eScale) = var_info('Mahrt87_eScale' , 'exponential scaling factor in the Mahrt (1987) stability function', '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%leafExchangeCoeff) = var_info('leafExchangeCoeff' , 'turbulent exchange coeff between canopy surface and canopy air' , 'm s-(1/2)' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%windReductionParam) = var_info('windReductionParam' , 'canopy wind reduction parameter' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! stomatal conductance - mpar_meta(iLookPARAM%Kc25) = var_info('Kc25' , 'Michaelis-Menten constant for CO2 at 25 degrees C' , 'umol mol-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%Ko25) = var_info('Ko25' , 'Michaelis-Menten constant for O2 at 25 degrees C' , 'mol mol-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%Kc_qFac) = var_info('Kc_qFac' , 'factor in the q10 function defining temperature controls on Kc' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%Ko_qFac) = var_info('Ko_qFac' , 'factor in the q10 function defining temperature controls on Ko' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%kc_Ha) = var_info('kc_Ha' , 'activation energy for the Michaelis-Menten constant for CO2' , 'J mol-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%ko_Ha) = var_info('ko_Ha' , 'activation energy for the Michaelis-Menten constant for O2' , 'J mol-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%vcmax25_canopyTop) = var_info('vcmax25_canopyTop' , 'potential carboxylation rate at 25 degrees C at the canopy top' , 'umol co2 m-2 s-1', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%vcmax_qFac) = var_info('vcmax_qFac' , 'factor in the q10 function defining temperature controls on vcmax', '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%vcmax_Ha) = var_info('vcmax_Ha' , 'activation energy in the vcmax function' , 'J mol-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%vcmax_Hd) = var_info('vcmax_Hd' , 'deactivation energy in the vcmax function' , 'J mol-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%vcmax_Sv) = var_info('vcmax_Sv' , 'entropy term in the vcmax function' , 'J mol-1 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%vcmax_Kn) = var_info('vcmax_Kn' , 'foliage nitrogen decay coefficient' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%jmax25_scale) = var_info('jmax25_scale' , 'scaling factor to relate jmax25 to vcmax25' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%jmax_Ha) = var_info('jmax_Ha' , 'activation energy in the jmax function' , 'J mol-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%jmax_Hd) = var_info('jmax_Hd' , 'deactivation energy in the jmax function' , 'J mol-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%jmax_Sv) = var_info('jmax_Sv' , 'entropy term in the jmax function' , 'J mol-1 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%fractionJ) = var_info('fractionJ' , 'fraction of light lost by other than the chloroplast lamellae' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%quantamYield) = var_info('quantamYield' , 'quantam yield' , 'mol e mol-1 q' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%vpScaleFactor) = var_info('vpScaleFactor' , 'vapor pressure scaling factor in stomatal conductance function' , 'Pa' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%cond2photo_slope) = var_info('cond2photo_slope' , 'slope of conductance-photosynthesis relationship' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%minStomatalConductance)= var_info('minStomatalConductance', 'minimum stomatal conductance' , 'umol H2O m-2 s-1', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! vegetation properties - mpar_meta(iLookPARAM%winterSAI) = var_info('winterSAI' , 'stem area index prior to the start of the growing season' , 'm2 m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%summerLAI) = var_info('summerLAI' , 'maximum leaf area index at the peak of the growing season' , 'm2 m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%rootScaleFactor1) = var_info('rootScaleFactor1' , '1st scaling factor (a) in Y = 1 - 0.5*( exp(-aZ) + exp(-bZ) )' , 'm-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%rootScaleFactor2) = var_info('rootScaleFactor2' , '2nd scaling factor (b) in Y = 1 - 0.5*( exp(-aZ) + exp(-bZ) )' , 'm-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%rootingDepth) = var_info('rootingDepth' , 'rooting depth' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%rootDistExp) = var_info('rootDistExp' , 'exponent for the vertical distribution of root density' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%plantWiltPsi) = var_info('plantWiltPsi' , 'matric head at wilting point' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%soilStressParam) = var_info('soilStressParam' , 'parameter in the exponential soil stress function' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%critSoilWilting) = var_info('critSoilWilting' , 'critical vol. liq. water content when plants are wilting' , '-' , get_ixVarType('parSoil'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%critSoilTranspire) = var_info('critSoilTranspire' , 'critical vol. liq. water content when transpiration is limited' , '-' , get_ixVarType('parSoil'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%critAquiferTranspire) = var_info('critAquiferTranspire' , 'critical aquifer storage value when transpiration is limited' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%minStomatalResistance) = var_info('minStomatalResistance' , 'minimum stomatal resistance' , 's m-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%leafDimension) = var_info('leafDimension' , 'characteristic leaf dimension' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%heightCanopyTop) = var_info('heightCanopyTop' , 'height of top of the vegetation canopy above ground surface' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%heightCanopyBottom) = var_info('heightCanopyBottom' , 'height of bottom of the vegetation canopy above ground surface' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%specificHeatVeg) = var_info('specificHeatVeg' , 'specific heat of vegetation' , 'J kg-1 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%maxMassVegetation) = var_info('maxMassVegetation' , 'maximum mass of vegetation (full foliage)' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%throughfallScaleSnow) = var_info('throughfallScaleSnow' , 'scaling factor for throughfall (snow)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%throughfallScaleRain) = var_info('throughfallScaleRain' , 'scaling factor for throughfall (rain)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%refInterceptCapSnow) = var_info('refInterceptCapSnow' , 'reference canopy interception capacity per unit leaf area (snow)' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%refInterceptCapRain) = var_info('refInterceptCapRain' , 'canopy interception capacity per unit leaf area (rain)' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%snowUnloadingCoeff) = var_info('snowUnloadingCoeff' , 'time constant for unloading of snow from the forest canopy' , 's-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%canopyDrainageCoeff) = var_info('canopyDrainageCoeff' , 'time constant for drainage of liquid water from the forest canopy', 's-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%ratioDrip2Unloading) = var_info('ratioDrip2Unloading' , 'ratio of canopy drip to unloading of snow from the forest canopy' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%canopyWettingFactor) = var_info('canopyWettingFactor' , 'maximum wetted fraction of the canopy' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%canopyWettingExp) = var_info('canopyWettingExp' , 'exponent in canopy wetting function' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%minTempUnloading) = var_info('minTempUnloading' , 'min temp for unloading in windySnow' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%rateTempUnloading) = var_info('rateTempUnloading' , 'how quickly to unload due to temperature' , 'K s' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%minWindUnloading) = var_info('minWindUnloading' , 'min wind speed for unloading in windySnow' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%rateWindUnloading) = var_info('rateWindUnloading' , 'how quickly to unload due to wind' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! soil properties - mpar_meta(iLookPARAM%soil_dens_intr) = var_info('soil_dens_intr' , 'intrinsic soil density' , 'kg m-3' , get_ixVarType('parSoil'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%thCond_soil) = var_info('thCond_soil' , 'thermal conductivity of soil (includes quartz and other minerals)', 'W m-1 K-1' , get_ixVarType('parSoil'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%frac_sand) = var_info('frac_sand' , 'fraction of sand' , '-' , get_ixVarType('parSoil'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%frac_silt) = var_info('frac_silt' , 'fraction of silt' , '-' , get_ixVarType('parSoil'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%frac_clay) = var_info('frac_clay' , 'fraction of clay' , '-' , get_ixVarType('parSoil'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%theta_sat) = var_info('theta_sat' , 'soil porosity' , '-' , get_ixVarType('parSoil'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%theta_res) = var_info('theta_res' , 'volumetric residual water content' , '-' , get_ixVarType('parSoil'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%vGn_alpha) = var_info('vGn_alpha' , 'van Genuchten "alpha" parameter' , 'm-1' , get_ixVarType('parSoil'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%vGn_n) = var_info('vGn_n' , 'van Genuchten "n" parameter' , '-' , get_ixVarType('parSoil'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%k_soil) = var_info('k_soil' , 'saturated hydraulic conductivity' , 'm s-1' , get_ixVarType('parSoil'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%k_macropore) = var_info('k_macropore' , 'saturated hydraulic conductivity for macropores' , 'm s-1' , get_ixVarType('parSoil'), iMissVec, iMissVec, .false.) - ! scalar soil properties - mpar_meta(iLookPARAM%fieldCapacity) = var_info('fieldCapacity' , 'soil field capacity (vol liq water content when baseflow begins)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%wettingFrontSuction) = var_info('wettingFrontSuction' , 'Green-Ampt wetting front suction' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%theta_mp) = var_info('theta_mp' , 'volumetric liquid water content when macropore flow begins' , '-' , get_ixVarType('parSoil'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%mpExp) = var_info('mpExp' , 'empirical exponent in macropore flow equation' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%kAnisotropic) = var_info('kAnisotropic' , 'anisotropy factor for lateral hydraulic conductivity' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%zScale_TOPMODEL) = var_info('zScale_TOPMODEL' , 'TOPMODEL scaling factor used in lower boundary condition for soil', 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%compactedDepth) = var_info('compactedDepth' , 'depth where k_soil reaches the compacted value given by CH78' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%aquiferBaseflowRate) = var_info('aquiferBaseflowRate' , 'baseflow rate when aquifer storage = aquiferScaleFactor' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%aquiferScaleFactor) = var_info('aquiferScaleFactor' , 'scaling factor for aquifer storage in the big bucket' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%aquiferBaseflowExp) = var_info('aquiferBaseflowExp' , 'baseflow exponent' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%qSurfScale) = var_info('qSurfScale' , 'scaling factor in the surface runoff parameterization' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%specificYield) = var_info('specificYield' , 'specific yield' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%specificStorage) = var_info('specificStorage' , 'specific storage coefficient' , 'm-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%f_impede) = var_info('f_impede' , 'ice impedence factor' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%soilIceScale) = var_info('soilIceScale' , 'scaling factor for depth of soil ice, used to get frozen fraction', 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%soilIceCV) = var_info('soilIceCV' , 'CV of depth of soil ice, used to get frozen fraction' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! algorithmic control parameters - mpar_meta(iLookPARAM%minwind) = var_info('minwind' , 'minimum wind speed' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%minstep) = var_info('minstep' , 'minimum length of the time step' , 's' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%maxstep) = var_info('maxstep' , 'maximum length of the time step' , 's' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%wimplicit) = var_info('wimplicit' , 'weight assigned to the start-of-step fluxes (alpha)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%maxiter) = var_info('maxiter' , 'maximum number of iterations' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%relConvTol_liquid) = var_info('relConvTol_liquid' , 'relative convergence tolerance for vol frac liq water' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%absConvTol_liquid) = var_info('absConvTol_liquid' , 'absolute convergence tolerance for vol frac liq water' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%relConvTol_matric) = var_info('relConvTol_matric' , 'relative convergence tolerance for matric head' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%absConvTol_matric) = var_info('absConvTol_matric' , 'absolute convergence tolerance for matric head' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%relConvTol_energy) = var_info('relConvTol_energy' , 'relative convergence tolerance for energy' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%absConvTol_energy) = var_info('absConvTol_energy' , 'absolute convergence tolerance for energy' , 'J m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%relConvTol_aquifr) = var_info('relConvTol_aquifr' , 'relative convergence tolerance for aquifer storage' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%absConvTol_aquifr) = var_info('absConvTol_aquifr' , 'absolute convergence tolerance for aquifer storage' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%zmin) = var_info('zmin' , 'minimum layer depth' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%zmax) = var_info('zmax' , 'maximum layer depth' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%zminLayer1) = var_info('zminLayer1' , 'minimum layer depth for the 1st (top) layer' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%zminLayer2) = var_info('zminLayer2' , 'minimum layer depth for the 2nd layer' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%zminLayer3) = var_info('zminLayer3' , 'minimum layer depth for the 3rd layer' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%zminLayer4) = var_info('zminLayer4' , 'minimum layer depth for the 4th layer' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%zminLayer5) = var_info('zminLayer5' , 'minimum layer depth for the 5th (bottom) layer' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%zmaxLayer1_lower) = var_info('zmaxLayer1_lower' , 'maximum layer depth for the 1st (top) layer when only 1 layer' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%zmaxLayer2_lower) = var_info('zmaxLayer2_lower' , 'maximum layer depth for the 2nd layer when only 2 layers' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%zmaxLayer3_lower) = var_info('zmaxLayer3_lower' , 'maximum layer depth for the 3rd layer when only 3 layers' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%zmaxLayer4_lower) = var_info('zmaxLayer4_lower' , 'maximum layer depth for the 4th layer when only 4 layers' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%zmaxLayer1_upper) = var_info('zmaxLayer1_upper' , 'maximum layer depth for the 1st (top) layer when > 1 layer' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%zmaxLayer2_upper) = var_info('zmaxLayer2_upper' , 'maximum layer depth for the 2nd layer when > 2 layers' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%zmaxLayer3_upper) = var_info('zmaxLayer3_upper' , 'maximum layer depth for the 3rd layer when > 3 layers' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - mpar_meta(iLookPARAM%zmaxLayer4_upper) = var_info('zmaxLayer4_upper' , 'maximum layer depth for the 4th layer when > 4 layers' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - - ! ----- - ! * basin parameter data... - ! ------------------------- - bpar_meta(iLookBPAR%basin__aquiferHydCond) = var_info('basin__aquiferHydCond' , 'hydraulic conductivity of the aquifer' , 'm s-1', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - bpar_meta(iLookBPAR%basin__aquiferScaleFactor) = var_info('basin__aquiferScaleFactor', 'scaling factor for aquifer storage in the big bucket' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - bpar_meta(iLookBPAR%basin__aquiferBaseflowExp) = var_info('basin__aquiferBaseflowExp', 'baseflow exponent for the big bucket' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - bpar_meta(iLookBPAR%routingGammaShape) = var_info('routingGammaShape' , 'shape parameter in Gamma distribution used for sub-grid routing', '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - bpar_meta(iLookBPAR%routingGammaScale) = var_info('routingGammaScale' , 'scale parameter in Gamma distribution used for sub-grid routing', 's' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - - ! ----- - ! * local model prognostic (state) variables... - ! --------------------------------------------- - ! define variables for time stepping - prog_meta(iLookPROG%dt_init) = var_info('dt_init' , 'length of initial time step at start of next data interval' , 's' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! state variables for vegetation - prog_meta(iLookPROG%scalarCanopyIce) = var_info('scalarCanopyIce' , 'mass of ice on the vegetation canopy' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - prog_meta(iLookPROG%scalarCanopyLiq) = var_info('scalarCanopyLiq' , 'mass of liquid water on the vegetation canopy' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - prog_meta(iLookPROG%scalarCanopyWat) = var_info('scalarCanopyWat' , 'mass of total water on the vegetation canopy' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - prog_meta(iLookPROG%scalarCanairTemp) = var_info('scalarCanairTemp' , 'temperature of the canopy air space' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - prog_meta(iLookPROG%scalarCanopyTemp) = var_info('scalarCanopyTemp' , 'temperature of the vegetation canopy' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! state variables for snow - prog_meta(iLookPROG%spectralSnowAlbedoDiffuse) = var_info('spectralSnowAlbedoDiffuse' , 'diffuse snow albedo for individual spectral bands' , '-' , get_ixVarType('wLength'), iMissVec, iMissVec, .false.) - prog_meta(iLookPROG%scalarSnowAlbedo) = var_info('scalarSnowAlbedo' , 'snow albedo for the entire spectral band' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - prog_meta(iLookPROG%scalarSnowDepth) = var_info('scalarSnowDepth' , 'total snow depth' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - prog_meta(iLookPROG%scalarSWE) = var_info('scalarSWE' , 'snow water equivalent' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - prog_meta(iLookPROG%scalarSfcMeltPond) = var_info('scalarSfcMeltPond' , 'ponded water caused by melt of the "snow without a layer"' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! define state variables for the snow+soil domain - prog_meta(iLookPROG%mLayerTemp) = var_info('mLayerTemp' , 'temperature of each layer' , 'K' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) - prog_meta(iLookPROG%mLayerVolFracIce) = var_info('mLayerVolFracIce' , 'volumetric fraction of ice in each layer' , '-' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) - prog_meta(iLookPROG%mLayerVolFracLiq) = var_info('mLayerVolFracLiq' , 'volumetric fraction of liquid water in each layer' , '-' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) - prog_meta(iLookPROG%mLayerVolFracWat) = var_info('mLayerVolFracWat' , 'volumetric fraction of total water in each layer' , '-' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) - prog_meta(iLookPROG%mLayerMatricHead) = var_info('mLayerMatricHead' , 'matric head of water in the soil' , 'm' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) - ! other state variables - prog_meta(iLookPROG%scalarAquiferStorage) = var_info('scalarAquiferStorage' , 'water required to bring aquifer to the bottom of the soil profile', 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - prog_meta(iLookPROG%scalarSurfaceTemp) = var_info('scalarSurfaceTemp' , 'surface temperature (just a copy of the upper-layer temperature)' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! define coordinate variables - prog_meta(iLookPROG%mLayerDepth) = var_info('mLayerDepth' , 'depth of each layer' , 'm' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) - prog_meta(iLookPROG%mLayerHeight) = var_info('mLayerHeight' , 'height of the layer mid-point (top of soil = 0)' , 'm' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) - prog_meta(iLookPROG%iLayerHeight) = var_info('iLayerHeight' , 'height of the layer interface (top of soil = 0)' , 'm' , get_ixVarType('ifcToto'), iMissVec, iMissVec, .false.) - - ! ----- - ! * local model diagnostic variables... - ! ------------------------------------- - ! local properties - diag_meta(iLookDIAG%scalarCanopyDepth) = var_info('scalarCanopyDepth' , 'canopy depth' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarGreenVegFraction) = var_info('scalarGreenVegFraction' , 'green vegetation fraction (used to compute LAI)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarBulkVolHeatCapVeg) = var_info('scalarBulkVolHeatCapVeg' , 'bulk volumetric heat capacity of vegetation' , 'J m-3 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarCanopyEmissivity) = var_info('scalarCanopyEmissivity' , 'effective canopy emissivity' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarRootZoneTemp) = var_info('scalarRootZoneTemp' , 'average temperature of the root zone' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarLAI) = var_info('scalarLAI' , 'one-sided leaf area index' , 'm2 m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarSAI) = var_info('scalarSAI' , 'one-sided stem area index' , 'm2 m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarExposedLAI) = var_info('scalarExposedLAI' , 'exposed leaf area index (after burial by snow)' , 'm2 m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarExposedSAI) = var_info('scalarExposedSAI' , 'exposed stem area index (after burial by snow)' , 'm2 m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarAdjMeasHeight) = var_info('scalarAdjMeasHeight' , 'adjusted measurement height for cases snowDepth>mHeight' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarCanopyIceMax) = var_info('scalarCanopyIceMax' , 'maximum interception storage capacity for ice' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarCanopyLiqMax) = var_info('scalarCanopyLiqMax' , 'maximum interception storage capacity for liquid water' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarGrowingSeasonIndex) = var_info('scalarGrowingSeasonIndex' , 'growing season index (0=off, 1=on)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarVolHtCap_air) = var_info('scalarVolHtCap_air' , 'volumetric heat capacity air' , 'J m-3 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarVolHtCap_ice) = var_info('scalarVolHtCap_ice' , 'volumetric heat capacity ice' , 'J m-3 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarVolHtCap_soil) = var_info('scalarVolHtCap_soil' , 'volumetric heat capacity dry soil' , 'J m-3 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarVolHtCap_water) = var_info('scalarVolHtCap_water' , 'volumetric heat capacity liquid wat' , 'J m-3 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%mLayerVolHtCapBulk) = var_info('mLayerVolHtCapBulk' , 'volumetric heat capacity in each layer' , 'J m-3 K-1' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarLambda_drysoil) = var_info('scalarLambda_drysoil' , 'thermal conductivity of dry soil' , 'W m-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarLambda_wetsoil) = var_info('scalarLambda_wetsoil' , 'thermal conductivity of wet soil' , 'W m-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%mLayerThermalC) = var_info('mLayerThermalC' , 'thermal conductivity at the mid-point of each layer' , 'W m-1 K-1' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%iLayerThermalC) = var_info('iLayerThermalC' , 'thermal conductivity at the interface of each layer' , 'W m-1 K-1' , get_ixVarType('ifcToto'), iMissVec, iMissVec, .false.) - ! forcing - diag_meta(iLookDIAG%scalarVPair) = var_info('scalarVPair' , 'vapor pressure of the air above the vegetation canopy' , 'Pa' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarVP_CanopyAir) = var_info('scalarVP_CanopyAir' , 'vapor pressure of the canopy air space' , 'Pa' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarTwetbulb) = var_info('scalarTwetbulb' , 'wet bulb temperature' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarSnowfallTemp) = var_info('scalarSnowfallTemp' , 'temperature of fresh snow' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarNewSnowDensity) = var_info('scalarNewSnowDensity' , 'density of fresh snow' , 'kg m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarO2air) = var_info('scalarO2air' , 'atmospheric o2 concentration' , 'Pa' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarCO2air) = var_info('scalarCO2air' , 'atmospheric co2 concentration' , 'Pa' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! shortwave radiation - diag_meta(iLookDIAG%scalarCosZenith) = var_info('scalarCosZenith' , 'cosine of the solar zenith angle' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarFractionDirect) = var_info('scalarFractionDirect' , 'fraction of direct radiation (0-1)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarCanopySunlitFraction) = var_info('scalarCanopySunlitFraction' , 'sunlit fraction of canopy' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarCanopySunlitLAI) = var_info('scalarCanopySunlitLAI' , 'sunlit leaf area' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarCanopyShadedLAI) = var_info('scalarCanopyShadedLAI' , 'shaded leaf area' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%spectralAlbGndDirect) = var_info('spectralAlbGndDirect' , 'direct albedo of underlying surface for each spectral band' , '-' , get_ixVarType('wLength'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%spectralAlbGndDiffuse) = var_info('spectralAlbGndDiffuse' , 'diffuse albedo of underlying surface for each spectral band' , '-' , get_ixVarType('wLength'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarGroundAlbedo) = var_info('scalarGroundAlbedo' , 'albedo of the ground surface' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! turbulent heat transfer - diag_meta(iLookDIAG%scalarLatHeatSubVapCanopy) = var_info('scalarLatHeatSubVapCanopy' , 'latent heat of sublimation/vaporization used for veg canopy' , 'J kg-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarLatHeatSubVapGround) = var_info('scalarLatHeatSubVapGround' , 'latent heat of sublimation/vaporization used for ground surface' , 'J kg-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarSatVP_CanopyTemp) = var_info('scalarSatVP_CanopyTemp' , 'saturation vapor pressure at the temperature of vegetation canopy', 'Pa' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarSatVP_GroundTemp) = var_info('scalarSatVP_GroundTemp' , 'saturation vapor pressure at the temperature of the ground' , 'Pa' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarZ0Canopy) = var_info('scalarZ0Canopy' , 'roughness length of the canopy' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarWindReductionFactor) = var_info('scalarWindReductionFactor' , 'canopy wind reduction factor' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarZeroPlaneDisplacement) = var_info('scalarZeroPlaneDisplacement' , 'zero plane displacement' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarRiBulkCanopy) = var_info('scalarRiBulkCanopy' , 'bulk Richardson number for the canopy' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarRiBulkGround) = var_info('scalarRiBulkGround' , 'bulk Richardson number for the ground surface' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarCanopyStabilityCorrection) = var_info('scalarCanopyStabilityCorrection', 'stability correction for the canopy' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarGroundStabilityCorrection) = var_info('scalarGroundStabilityCorrection', 'stability correction for the ground surface' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! evapotranspiration - diag_meta(iLookDIAG%scalarIntercellularCO2Sunlit) = var_info('scalarIntercellularCO2Sunlit' , 'carbon dioxide partial pressure of leaf interior (sunlit leaves)' , 'Pa' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarIntercellularCO2Shaded) = var_info('scalarIntercellularCO2Shaded' , 'carbon dioxide partial pressure of leaf interior (shaded leaves)' , 'Pa' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarTranspireLim) = var_info('scalarTranspireLim' , 'aggregate soil moisture and aquifer control on transpiration' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarTranspireLimAqfr) = var_info('scalarTranspireLimAqfr' , 'aquifer storage control on transpiration' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarFoliageNitrogenFactor) = var_info('scalarFoliageNitrogenFactor' , 'foliage nitrogen concentration (1=saturated)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarSoilRelHumidity) = var_info('scalarSoilRelHumidity' , 'relative humidity in the soil pores in the upper-most soil layer' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%mLayerTranspireLim) = var_info('mLayerTranspireLim' , 'soil moist & veg limit on transpiration for each layer' , '-' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%mLayerRootDensity) = var_info('mLayerRootDensity' , 'fraction of roots in each soil layer' , '-' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarAquiferRootFrac) = var_info('scalarAquiferRootFrac' , 'fraction of roots below the soil profile (in the aquifer)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! canopy hydrology - diag_meta(iLookDIAG%scalarFracLiqVeg) = var_info('scalarFracLiqVeg' , 'fraction of liquid water on vegetation' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarCanopyWetFraction) = var_info('scalarCanopyWetFraction' , 'fraction canopy that is wet' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! snow hydrology - diag_meta(iLookDIAG%scalarSnowAge) = var_info('scalarSnowAge' , 'non-dimensional snow age' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarGroundSnowFraction) = var_info('scalarGroundSnowFraction' , 'fraction ground that is covered with snow' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%spectralSnowAlbedoDirect) = var_info('spectralSnowAlbedoDirect' , 'direct snow albedo for individual spectral bands' , '-' , get_ixVarType('wLength'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%mLayerFracLiqSnow) = var_info('mLayerFracLiqSnow' , 'fraction of liquid water in each snow layer' , '-' , get_ixVarType('midSnow'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%mLayerThetaResid) = var_info('mLayerThetaResid' , 'residual volumetric water content in each snow layer' , '-' , get_ixVarType('midSnow'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%mLayerPoreSpace) = var_info('mLayerPoreSpace' , 'total pore space in each snow layer' , '-' , get_ixVarType('midSnow'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%mLayerMeltFreeze) = var_info('mLayerMeltFreeze' , 'ice content change from melt/freeze in each layer' , 'kg m-3' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) - ! soil hydrology - diag_meta(iLookDIAG%scalarInfilArea) = var_info('scalarInfilArea' , 'fraction of unfrozen area where water can infiltrate' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarFrozenArea) = var_info('scalarFrozenArea' , 'fraction of area that is considered impermeable due to soil ice' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarSoilControl) = var_info('scalarSoilControl' , 'soil control on infiltration (1=controlling; 0=not)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%mLayerVolFracAir) = var_info('mLayerVolFracAir' , 'volumetric fraction of air in each layer' , '-' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%mLayerTcrit) = var_info('mLayerTcrit' , 'critical soil temperature above which all water is unfrozen' , 'K' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%mLayerCompress) = var_info('mLayerCompress' , 'change in volumetric water content due to compression of soil' , '-' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarSoilCompress) = var_info('scalarSoilCompress' , 'change in total soil storage due to compression of soil matrix' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%mLayerMatricHeadLiq) = var_info('mLayerMatricHeadLiq' , 'matric potential of liquid water' , 'm' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) - ! mass balance check - diag_meta(iLookDIAG%scalarSoilWatBalError) = var_info('scalarSoilWatBalError' , 'error in the total soil water balance' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarAquiferBalError) = var_info('scalarAquiferBalError' , 'error in the aquifer water balance' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarTotalSoilLiq) = var_info('scalarTotalSoilLiq' , 'total mass of liquid water in the soil' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarTotalSoilIce) = var_info('scalarTotalSoilIce' , 'total mass of ice in the soil' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarTotalSoilWat) = var_info('scalarTotalSoilWat' , 'total mass of water in the soil' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! variable shortcuts - diag_meta(iLookDIAG%scalarVGn_m) = var_info('scalarVGn_m' , 'van Genuchten "m" parameter' , '-' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarKappa) = var_info('scalarKappa' , 'constant in the freezing curve function' , 'm K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarVolLatHt_fus) = var_info('scalarVolLatHt_fus' , 'volumetric latent heat of fusion' , 'J m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! timing information - diag_meta(iLookDIAG%numFluxCalls) = var_info('numFluxCalls' , 'number of flux calls' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%wallClockTime) = var_info('wallClockTime' , 'wall clock time' , 's' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - - ! ----- - ! * local model fluxes... - ! ----------------------- - ! net energy and mass fluxes for the vegetation domain - flux_meta(iLookFLUX%scalarCanairNetNrgFlux) = var_info('scalarCanairNetNrgFlux' , 'net energy flux for the canopy air space' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarCanopyNetNrgFlux) = var_info('scalarCanopyNetNrgFlux' , 'net energy flux for the vegetation canopy' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarGroundNetNrgFlux) = var_info('scalarGroundNetNrgFlux' , 'net energy flux for the ground surface' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarCanopyNetLiqFlux) = var_info('scalarCanopyNetLiqFlux' , 'net liquid water flux for the vegetation canopy' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! forcing - flux_meta(iLookFLUX%scalarRainfall) = var_info('scalarRainfall' , 'computed rainfall rate' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarSnowfall) = var_info('scalarSnowfall' , 'computed snowfall rate' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! shortwave radiation - flux_meta(iLookFLUX%spectralIncomingDirect) = var_info('spectralIncomingDirect' , 'incoming direct solar radiation in each wave band' , 'W m-2' , get_ixVarType('wLength'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%spectralIncomingDiffuse) = var_info('spectralIncomingDiffuse' , 'incoming diffuse solar radiation in each wave band' , 'W m-2' , get_ixVarType('wLength'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarCanopySunlitPAR) = var_info('scalarCanopySunlitPAR' , 'average absorbed par for sunlit leaves' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarCanopyShadedPAR) = var_info('scalarCanopyShadedPAR' , 'average absorbed par for shaded leaves' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%spectralBelowCanopyDirect) = var_info('spectralBelowCanopyDirect' , 'downward direct flux below veg layer for each spectral band' , 'W m-2' , get_ixVarType('wLength'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%spectralBelowCanopyDiffuse) = var_info('spectralBelowCanopyDiffuse' , 'downward diffuse flux below veg layer for each spectral band' , 'W m-2' , get_ixVarType('wLength'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarBelowCanopySolar) = var_info('scalarBelowCanopySolar' , 'solar radiation transmitted below the canopy' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarCanopyAbsorbedSolar) = var_info('scalarCanopyAbsorbedSolar' , 'solar radiation absorbed by canopy' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarGroundAbsorbedSolar) = var_info('scalarGroundAbsorbedSolar' , 'solar radiation absorbed by ground' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! longwave radiation - flux_meta(iLookFLUX%scalarLWRadCanopy) = var_info('scalarLWRadCanopy' , 'longwave radiation emitted from the canopy' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarLWRadGround) = var_info('scalarLWRadGround' , 'longwave radiation emitted at the ground surface' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarLWRadUbound2Canopy) = var_info('scalarLWRadUbound2Canopy' , 'downward atmospheric longwave radiation absorbed by the canopy' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarLWRadUbound2Ground) = var_info('scalarLWRadUbound2Ground' , 'downward atmospheric longwave radiation absorbed by the ground' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarLWRadUbound2Ubound) = var_info('scalarLWRadUbound2Ubound' , 'atmospheric radiation refl by ground + lost thru upper boundary' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarLWRadCanopy2Ubound) = var_info('scalarLWRadCanopy2Ubound' , 'longwave radiation emitted from canopy lost thru upper boundary' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarLWRadCanopy2Ground) = var_info('scalarLWRadCanopy2Ground' , 'longwave radiation emitted from canopy absorbed by the ground' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarLWRadCanopy2Canopy) = var_info('scalarLWRadCanopy2Canopy' , 'canopy longwave reflected from ground and absorbed by the canopy' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarLWRadGround2Ubound) = var_info('scalarLWRadGround2Ubound' , 'longwave radiation emitted from ground lost thru upper boundary' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarLWRadGround2Canopy) = var_info('scalarLWRadGround2Canopy' , 'longwave radiation emitted from ground and absorbed by the canopy', 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarLWNetCanopy) = var_info('scalarLWNetCanopy' , 'net longwave radiation at the canopy' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarLWNetGround) = var_info('scalarLWNetGround' , 'net longwave radiation at the ground surface' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarLWNetUbound) = var_info('scalarLWNetUbound' , 'net longwave radiation at the upper atmospheric boundary' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! turbulent heat transfer - flux_meta(iLookFLUX%scalarEddyDiffusCanopyTop) = var_info('scalarEddyDiffusCanopyTop' , 'eddy diffusivity for heat at the top of the canopy' , 'm2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarFrictionVelocity) = var_info('scalarFrictionVelocity' , 'friction velocity (canopy momentum sink)' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarWindspdCanopyTop) = var_info('scalarWindspdCanopyTop' , 'windspeed at the top of the canopy' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarWindspdCanopyBottom) = var_info('scalarWindspdCanopyBottom' , 'windspeed at the height of the bottom of the canopy' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarGroundResistance) = var_info('scalarGroundResistance' , 'below canopy aerodynamic resistance' , 's m-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarCanopyResistance) = var_info('scalarCanopyResistance' , 'above canopy aerodynamic resistance' , 's m-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarLeafResistance) = var_info('scalarLeafResistance' , 'mean leaf boundary layer resistance per unit leaf area' , 's m-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarSoilResistance) = var_info('scalarSoilResistance' , 'soil surface resistance' , 's m-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarSenHeatTotal) = var_info('scalarSenHeatTotal' , 'sensible heat from the canopy air space to the atmosphere' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarSenHeatCanopy) = var_info('scalarSenHeatCanopy' , 'sensible heat from the canopy to the canopy air space' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarSenHeatGround) = var_info('scalarSenHeatGround' , 'sensible heat from the ground (below canopy or non-vegetated)' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarLatHeatTotal) = var_info('scalarLatHeatTotal' , 'latent heat from the canopy air space to the atmosphere' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarLatHeatCanopyEvap) = var_info('scalarLatHeatCanopyEvap' , 'evaporation latent heat from the canopy to the canopy air space' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarLatHeatCanopyTrans) = var_info('scalarLatHeatCanopyTrans' , 'transpiration latent heat from the canopy to the canopy air space', 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarLatHeatGround) = var_info('scalarLatHeatGround' , 'latent heat from the ground (below canopy or non-vegetated)' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarCanopyAdvectiveHeatFlux) = var_info('scalarCanopyAdvectiveHeatFlux' , 'heat advected to the canopy with precipitation (snow + rain)' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarGroundAdvectiveHeatFlux) = var_info('scalarGroundAdvectiveHeatFlux' , 'heat advected to the ground with throughfall + unloading/drainage', 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarCanopySublimation) = var_info('scalarCanopySublimation' , 'canopy sublimation/frost' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarSnowSublimation) = var_info('scalarSnowSublimation' , 'snow sublimation/frost (below canopy or non-vegetated)' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! liquid water fluxes associated with evapotranspiration - flux_meta(iLookFLUX%scalarStomResistSunlit) = var_info('scalarStomResistSunlit' , 'stomatal resistance for sunlit leaves' , 's m-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarStomResistShaded) = var_info('scalarStomResistShaded' , 'stomatal resistance for shaded leaves' , 's m-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarPhotosynthesisSunlit) = var_info('scalarPhotosynthesisSunlit' , 'sunlit photosynthesis' , 'umolco2 m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarPhotosynthesisShaded) = var_info('scalarPhotosynthesisShaded' , 'shaded photosynthesis' , 'umolco2 m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarCanopyTranspiration) = var_info('scalarCanopyTranspiration' , 'canopy transpiration' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarCanopyEvaporation) = var_info('scalarCanopyEvaporation' , 'canopy evaporation/condensation' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarGroundEvaporation) = var_info('scalarGroundEvaporation' , 'ground evaporation/condensation (below canopy or non-vegetated)' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%mLayerTranspire) = var_info('mLayerTranspire' , 'transpiration loss from each soil layer' , 'm s-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) - ! liquid and solid water fluxes through the canopy - flux_meta(iLookFLUX%scalarThroughfallSnow) = var_info('scalarThroughfallSnow' , 'snow that reaches the ground without ever touching the canopy' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarThroughfallRain) = var_info('scalarThroughfallRain' , 'rain that reaches the ground without ever touching the canopy' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarCanopySnowUnloading) = var_info('scalarCanopySnowUnloading' , 'unloading of snow from the vegetation canopy' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarCanopyLiqDrainage) = var_info('scalarCanopyLiqDrainage' , 'drainage of liquid water from the vegetation canopy' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarCanopyMeltFreeze) = var_info('scalarCanopyMeltFreeze' , 'melt/freeze of water stored in the canopy' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! energy fluxes and for the snow and soil domains - flux_meta(iLookFLUX%iLayerConductiveFlux) = var_info('iLayerConductiveFlux' , 'conductive energy flux at layer interfaces' , 'W m-2' , get_ixVarType('ifcToto'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%iLayerAdvectiveFlux) = var_info('iLayerAdvectiveFlux' , 'advective energy flux at layer interfaces' , 'W m-2' , get_ixVarType('ifcToto'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%iLayerNrgFlux) = var_info('iLayerNrgFlux' , 'energy flux at layer interfaces' , 'W m-2' , get_ixVarType('ifcToto'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%mLayerNrgFlux) = var_info('mLayerNrgFlux' , 'net energy flux for each layer within the snow+soil domain' , 'J m-3 s-1' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) - ! liquid water fluxes for the snow domain - flux_meta(iLookFLUX%scalarSnowDrainage) = var_info('scalarSnowDrainage' , 'drainage from the bottom of the snow profile' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%iLayerLiqFluxSnow) = var_info('iLayerLiqFluxSnow' , 'liquid flux at snow layer interfaces' , 'm s-1' , get_ixVarType('ifcSnow'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%mLayerLiqFluxSnow) = var_info('mLayerLiqFluxSnow' , 'net liquid water flux for each snow layer' , 's-1' , get_ixVarType('midSnow'), iMissVec, iMissVec, .false.) - ! liquid water fluxes for the soil domain - flux_meta(iLookFLUX%scalarRainPlusMelt) = var_info('scalarRainPlusMelt' , 'rain plus melt, used as input to soil before surface runoff' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarMaxInfilRate) = var_info('scalarMaxInfilRate' , 'maximum infiltration rate' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarInfiltration) = var_info('scalarInfiltration' , 'infiltration of water into the soil profile' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarExfiltration) = var_info('scalarExfiltration' , 'exfiltration of water from the top of the soil profile' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarSurfaceRunoff) = var_info('scalarSurfaceRunoff' , 'surface runoff' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%mLayerSatHydCondMP) = var_info('mLayerSatHydCondMP' , 'saturated hydraulic conductivity of macropores in each layer' , 'm s-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%mLayerSatHydCond) = var_info('mLayerSatHydCond' , 'saturated hydraulic conductivity in each layer' , 'm s-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%iLayerSatHydCond) = var_info('iLayerSatHydCond' , 'saturated hydraulic conductivity in each layer interface' , 'm s-1' , get_ixVarType('ifcSoil'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%mLayerHydCond) = var_info('mLayerHydCond' , 'hydraulic conductivity in each layer' , 'm s-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%iLayerLiqFluxSoil) = var_info('iLayerLiqFluxSoil' , 'liquid flux at soil layer interfaces' , 'm s-1' , get_ixVarType('ifcSoil'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%mLayerLiqFluxSoil) = var_info('mLayerLiqFluxSoil' , 'net liquid water flux for each soil layer' , 's-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%mLayerBaseflow) = var_info('mLayerBaseflow' , 'baseflow from each soil layer' , 'm s-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%mLayerColumnInflow) = var_info('mLayerColumnInflow' , 'total inflow to each layer in a given soil column' , 'm3 s-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%mLayerColumnOutflow) = var_info('mLayerColumnOutflow' , 'total outflow from each layer in a given soil column' , 'm3 s-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarSoilBaseflow) = var_info('scalarSoilBaseflow' , 'total baseflow from the soil profile' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarSoilDrainage) = var_info('scalarSoilDrainage' , 'drainage from the bottom of the soil profile' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarAquiferRecharge) = var_info('scalarAquiferRecharge' , 'recharge to the aquifer' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarAquiferTranspire) = var_info('scalarAquiferTranspire' , 'transpiration loss from the aquifer' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarAquiferBaseflow) = var_info('scalarAquiferBaseflow' , 'baseflow from the aquifer' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! derived variables - flux_meta(iLookFLUX%scalarTotalET) = var_info('scalarTotalET' , 'total ET' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarTotalRunoff) = var_info('scalarTotalRunoff' , 'total runoff' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarNetRadiation) = var_info('scalarNetRadiation' , 'net radiation' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - - ! ----- - ! * local flux derivatives... - ! --------------------------- - ! derivatives in net vegetation energy fluxes w.r.t. relevant state variables - deriv_meta(iLookDERIV%dCanairNetFlux_dCanairTemp) = var_info('dCanairNetFlux_dCanairTemp' , 'derivative in net canopy air space flux w.r.t. canopy air temperature', 'W m-2 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%dCanairNetFlux_dCanopyTemp) = var_info('dCanairNetFlux_dCanopyTemp' , 'derivative in net canopy air space flux w.r.t. canopy temperature' , 'W m-2 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%dCanairNetFlux_dGroundTemp) = var_info('dCanairNetFlux_dGroundTemp' , 'derivative in net canopy air space flux w.r.t. ground temperature' , 'W m-2 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%dCanopyNetFlux_dCanairTemp) = var_info('dCanopyNetFlux_dCanairTemp' , 'derivative in net canopy flux w.r.t. canopy air temperature' , 'W m-2 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%dCanopyNetFlux_dCanopyTemp) = var_info('dCanopyNetFlux_dCanopyTemp' , 'derivative in net canopy flux w.r.t. canopy temperature' , 'W m-2 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%dCanopyNetFlux_dGroundTemp) = var_info('dCanopyNetFlux_dGroundTemp' , 'derivative in net canopy flux w.r.t. ground temperature' , 'W m-2 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%dCanopyNetFlux_dCanLiq) = var_info('dCanopyNetFlux_dCanLiq' , 'derivative in net canopy fluxes w.r.t. canopy liquid water content' , 'J kg-1 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%dGroundNetFlux_dCanairTemp) = var_info('dGroundNetFlux_dCanairTemp' , 'derivative in net ground flux w.r.t. canopy air temperature' , 'W m-2 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%dGroundNetFlux_dCanopyTemp) = var_info('dGroundNetFlux_dCanopyTemp' , 'derivative in net ground flux w.r.t. canopy temperature' , 'W m-2 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%dGroundNetFlux_dGroundTemp) = var_info('dGroundNetFlux_dGroundTemp' , 'derivative in net ground flux w.r.t. ground temperature' , 'W m-2 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%dGroundNetFlux_dCanLiq) = var_info('dGroundNetFlux_dCanLiq' , 'derivative in net ground fluxes w.r.t. canopy liquid water content' , 'J kg-1 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! derivatives in evaporative fluxes w.r.t. relevant state variables - deriv_meta(iLookDERIV%dCanopyEvaporation_dTCanair) = var_info('dCanopyEvaporation_dTCanair' , 'derivative in canopy evaporation w.r.t. canopy air temperature' , 'kg m-2 s-1 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%dCanopyEvaporation_dTCanopy) = var_info('dCanopyEvaporation_dTCanopy' , 'derivative in canopy evaporation w.r.t. canopy temperature' , 'kg m-2 s-1 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%dCanopyEvaporation_dTGround) = var_info('dCanopyEvaporation_dTGround' , 'derivative in canopy evaporation w.r.t. ground temperature' , 'kg m-2 s-1 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%dCanopyEvaporation_dCanLiq) = var_info('dCanopyEvaporation_dCanLiq' , 'derivative in canopy evaporation w.r.t. canopy liquid water content' , 's-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%dGroundEvaporation_dTCanair) = var_info('dGroundEvaporation_dTCanair' , 'derivative in ground evaporation w.r.t. canopy air temperature' , 'kg m-2 s-1 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%dGroundEvaporation_dTCanopy) = var_info('dGroundEvaporation_dTCanopy' , 'derivative in ground evaporation w.r.t. canopy temperature' , 'kg m-2 s-1 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%dGroundEvaporation_dTGround) = var_info('dGroundEvaporation_dTGround' , 'derivative in ground evaporation w.r.t. ground temperature' , 'kg m-2 s-1 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%dGroundEvaporation_dCanLiq) = var_info('dGroundEvaporation_dCanLiq' , 'derivative in ground evaporation w.r.t. canopy liquid water content' , 's-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! derivatives in canopy water w.r.t canopy temperature - deriv_meta(iLookDERIV%dTheta_dTkCanopy) = var_info('dTheta_dTkCanopy' , 'derivative of volumetric liquid water content w.r.t. temperature' , 'K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%dCanLiq_dTcanopy) = var_info('dCanLiq_dTcanopy' , 'derivative of canopy liquid storage w.r.t. temperature' , 'kg m-2 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! derivatives in canopy liquid fluxes w.r.t. canopy water - deriv_meta(iLookDERIV%scalarCanopyLiqDeriv) = var_info('scalarCanopyLiqDeriv' , 'derivative in (throughfall + drainage) w.r.t. canopy liquid water' , 's-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%scalarThroughfallRainDeriv) = var_info('scalarThroughfallRainDeriv' , 'derivative in throughfall w.r.t. canopy liquid water' , 's-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%scalarCanopyLiqDrainageDeriv) = var_info('scalarCanopyLiqDrainageDeriv' , 'derivative in canopy drainage w.r.t. canopy liquid water' , 's-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! derivatives in energy fluxes at the interface of snow+soil layers w.r.t. temperature in layers above and below - deriv_meta(iLookDERIV%dNrgFlux_dTempAbove) = var_info('dNrgFlux_dTempAbove' , 'derivatives in the flux w.r.t. temperature in the layer above' , 'J m-2 s-1 K-1' , get_ixVarType('ifcToto'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%dNrgFlux_dTempBelow) = var_info('dNrgFlux_dTempBelow' , 'derivatives in the flux w.r.t. temperature in the layer below' , 'J m-2 s-1 K-1' , get_ixVarType('ifcToto'), iMissVec, iMissVec, .false.) - ! derivative in liquid water fluxes at the interface of snow layers w.r.t. volumetric liquid water content in the layer above - deriv_meta(iLookDERIV%iLayerLiqFluxSnowDeriv) = var_info('iLayerLiqFluxSnowDeriv' , 'derivative in vertical liquid water flux at layer interfaces' , 'm s-1' , get_ixVarType('ifcSnow'), iMissVec, iMissVec, .false.) - ! derivative in liquid water fluxes for the soil domain w.r.t hydrology state variables - deriv_meta(iLookDERIV%dVolTot_dPsi0) = var_info('dVolTot_dPsi0' , 'derivative in total water content w.r.t. total water matric potential', 'm-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%dCompress_dPsi) = var_info('dCompress_dPsi' , 'derivative in compressibility w.r.t matric head' , 'm-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%mLayerdTheta_dPsi) = var_info('mLayerdTheta_dPsi' , 'derivative in the soil water characteristic w.r.t. psi' , 'm-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%mLayerdPsi_dTheta) = var_info('mLayerdPsi_dTheta' , 'derivative in the soil water characteristic w.r.t. theta' , 'm' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%dq_dHydStateAbove) = var_info('dq_dHydStateAbove' , 'change in flux at layer interfaces w.r.t. states in the layer above' , 'unknown' , get_ixVarType('ifcSoil'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%dq_dHydStateBelow) = var_info('dq_dHydStateBelow' , 'change in flux at layer interfaces w.r.t. states in the layer below' , 'unknown' , get_ixVarType('ifcSoil'), iMissVec, iMissVec, .false.) - ! derivative in baseflow flux w.r.t. aquifer storage - deriv_meta(iLookDERIV%dBaseflow_dAquifer) = var_info('dBaseflow_dAquifer' , 'derivative in baseflow flux w.r.t. aquifer storage' , 's-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! derivative in liquid water fluxes for the soil domain w.r.t energy state variables - deriv_meta(iLookDERIV%dq_dNrgStateAbove) = var_info('dq_dNrgStateAbove' , 'change in flux at layer interfaces w.r.t. states in the layer above' , 'unknown' , get_ixVarType('ifcSoil'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%dq_dNrgStateBelow) = var_info('dq_dNrgStateBelow' , 'change in flux at layer interfaces w.r.t. states in the layer below' , 'unknown' , get_ixVarType('ifcSoil'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%mLayerdTheta_dTk) = var_info('mLayerdTheta_dTk' , 'derivative of volumetric liquid water content w.r.t. temperature' , 'K-1' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%dPsiLiq_dTemp) = var_info('dPsiLiq_dTemp' , 'derivative in the liquid water matric potential w.r.t. temperature' , 'm K-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) - deriv_meta(iLookDERIV%dPsiLiq_dPsi0) = var_info('dPsiLiq_dPsi0' , 'derivative in liquid matric potential w.r.t. total matric potential' , '-' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) - - ! ----- - ! * basin-wide runoff and aquifer fluxes... - ! ----------------------------------------- - bvar_meta(iLookBVAR%basin__TotalArea) = var_info('basin__TotalArea' , 'total basin area' , 'm2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - bvar_meta(iLookBVAR%basin__SurfaceRunoff) = var_info('basin__SurfaceRunoff' , 'surface runoff' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - bvar_meta(iLookBVAR%basin__ColumnOutflow) = var_info('basin__ColumnOutflow' , 'outflow from all "outlet" HRUs (with no downstream HRU)', 'm3 s-1', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - bvar_meta(iLookBVAR%basin__AquiferStorage) = var_info('basin__AquiferStorage' , 'aquifer storage' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - bvar_meta(iLookBVAR%basin__AquiferRecharge) = var_info('basin__AquiferRecharge' , 'recharge to the aquifer' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - bvar_meta(iLookBVAR%basin__AquiferBaseflow) = var_info('basin__AquiferBaseflow' , 'baseflow from the aquifer' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - bvar_meta(iLookBVAR%basin__AquiferTranspire) = var_info('basin__AquiferTranspire', 'transpiration loss from the aquifer' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - bvar_meta(iLookBVAR%basin__TotalRunoff) = var_info('basin__TotalRunoff' , 'total runoff to channel from all active components' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - bvar_meta(iLookBVAR%basin__SoilDrainage) = var_info('basin__SoilDrainage' , 'soil drainage' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - bvar_meta(iLookBVAR%routingRunoffFuture) = var_info('routingRunoffFuture' , 'runoff in future time steps' , 'm s-1' , get_ixVarType('routing'), iMissVec, iMissVec, .false.) - bvar_meta(iLookBVAR%routingFractionFuture) = var_info('routingFractionFuture' , 'fraction of runoff in future time steps' , '-' , get_ixVarType('routing'), iMissVec, iMissVec, .false.) - bvar_meta(iLookBVAR%averageInstantRunoff) = var_info('averageInstantRunoff' , 'instantaneous runoff' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - bvar_meta(iLookBVAR%averageRoutedRunoff) = var_info('averageRoutedRunoff' , 'routed runoff' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - - ! ----- - ! * model indices... - ! ------------------ - - ! number of model layers, and layer indices - indx_meta(iLookINDEX%nSnow) = var_info('nSnow' , 'number of snow layers' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%nSoil) = var_info('nSoil' , 'number of soil layers' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%nLayers) = var_info('nLayers' , 'total number of layers' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%layerType) = var_info('layerType' , 'index defining type of layer (snow or soil)' , '-', get_ixVarType('midToto'), iMissVec, iMissVec, .false.) - ! number of state variables of different type - indx_meta(iLookINDEX%nCasNrg) = var_info('nCasNrg' , 'number of energy state variables for the canopy air space' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%nVegNrg) = var_info('nVegNrg' , 'number of energy state variables for the vegetation canopy' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%nVegMass) = var_info('nVegMass' , 'number of hydrology states for vegetation (mass of water)' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%nVegState) = var_info('nVegState' , 'number of vegetation state variables' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%nNrgState) = var_info('nNrgState' , 'number of energy state variables' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%nWatState) = var_info('nWatState' , 'number of "total water" states (vol. total water content)' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%nMatState) = var_info('nMatState' , 'number of matric head state variables' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%nMassState) = var_info('nMassState' , 'number of hydrology state variables (mass of water)' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%nState) = var_info('nState' , 'total number of model state variables' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! number of state variables within different domains in the snow+soil system - indx_meta(iLookINDEX%nSnowSoilNrg) = var_info('nSnowSoilNrg' , 'number of energy states in the snow+soil domain' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%nSnowOnlyNrg) = var_info('nSnowOnlyNrg' , 'number of energy states in the snow domain' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%nSoilOnlyNrg) = var_info('nSoilOnlyNrg' , 'number of energy states in the soil domain' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%nSnowSoilHyd) = var_info('nSnowSoilHyd' , 'number of hydrology states in the snow+soil domain' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%nSnowOnlyHyd) = var_info('nSnowOnlyHyd' , 'number of hydrology states in the snow domain' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%nSoilOnlyHyd) = var_info('nSoilOnlyHyd' , 'number of hydrology states in the soil domain' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! type of model state variables - indx_meta(iLookINDEX%ixControlVolume) = var_info('ixControlVolume' , 'index of the control volume for different domains (veg, snow, soil)' , '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%ixDomainType) = var_info('ixDomainType' , 'index of the type of domain (iname_veg, iname_snow, iname_soil)' , '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%ixStateType) = var_info('ixStateType' , 'index of the type of every state variable (iname_nrgCanair, ...)' , '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%ixHydType) = var_info('ixHydType' , 'index of the type of hydrology states in snow+soil domain' , '-', get_ixVarType('midToto'), iMissVec, iMissVec, .false.) - ! type of model state variables (state subset) - indx_meta(iLookINDEX%ixDomainType_subset) = var_info('ixDomainType_subset' , '[state subset] id of domain for desired model state variables' , '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%ixStateType_subset) = var_info('ixStateType_subset' , '[state subset] type of desired model state variables' , '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) - ! mapping between state subset and the full state vector - indx_meta(iLookINDEX%ixMapFull2Subset) = var_info('ixMapFull2Subset' , 'list of indices of the state subset in the full state vector' , '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%ixMapSubset2Full) = var_info('ixMapSubset2Full' , 'list of indices of the full state vector in the state subset' , '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) - ! indices of model specific state variables - indx_meta(iLookINDEX%ixCasNrg) = var_info('ixCasNrg' , 'index of canopy air space energy state variable' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%ixVegNrg) = var_info('ixVegNrg' , 'index of canopy energy state variable' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%ixVegHyd) = var_info('ixVegHyd' , 'index of canopy hydrology state variable (mass)' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%ixTopNrg) = var_info('ixTopNrg' , 'index of upper-most energy state in the snow+soil subdomain' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%ixTopHyd) = var_info('ixTopHyd' , 'index of upper-most hydrology state in the snow+soil subdomain' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%ixAqWat) = var_info('ixAqWat' , 'index of storage of water in the aquifer' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! vectors of indices for specific state types - indx_meta(iLookINDEX%ixNrgOnly) = var_info('ixNrgOnly' , 'indices IN THE STATE SUBSET for energy states' , '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%ixHydOnly) = var_info('ixHydOnly' , 'indices IN THE STATE SUBSET for hydrology states in the snow+soil domain', '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%ixMatOnly) = var_info('ixMatOnly' , 'indices IN THE STATE SUBSET for matric head state variables' , '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%ixMassOnly) = var_info('ixMassOnly' , 'indices IN THE STATE SUBSET for hydrology states (mass of water)' , '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) - ! vectors of indices for specific state types within specific sub-domains - indx_meta(iLookINDEX%ixSnowSoilNrg) = var_info('ixSnowSoilNrg' , 'indices IN THE STATE SUBSET for energy states in the snow+soil domain' , '-', get_ixVarType('midToto'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%ixSnowOnlyNrg) = var_info('ixSnowOnlyNrg' , 'indices IN THE STATE SUBSET for energy states in the snow domain' , '-', get_ixVarType('midSnow'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%ixSoilOnlyNrg) = var_info('ixSoilOnlyNrg' , 'indices IN THE STATE SUBSET for energy states in the soil domain' , '-', get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%ixSnowSoilHyd) = var_info('ixSnowSoilHyd' , 'indices IN THE STATE SUBSET for hydrology states in the snow+soil domain', '-', get_ixVarType('midToto'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%ixSnowOnlyHyd) = var_info('ixSnowOnlyHyd' , 'indices IN THE STATE SUBSET for hydrology states in the snow domain' , '-', get_ixVarType('midSnow'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%ixSoilOnlyHyd) = var_info('ixSoilOnlyHyd' , 'indices IN THE STATE SUBSET for hydrology states in the soil domain' , '-', get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) - ! vectors of indices for specfic state types within specific sub-domains - indx_meta(iLookINDEX%ixNrgCanair) = var_info('ixNrgCanair' , 'indices IN THE FULL VECTOR for energy states in canopy air space domain' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%ixNrgCanopy) = var_info('ixNrgCanopy' , 'indices IN THE FULL VECTOR for energy states in the canopy domain' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%ixHydCanopy) = var_info('ixHydCanopy' , 'indices IN THE FULL VECTOR for hydrology states in the canopy domain' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%ixNrgLayer) = var_info('ixNrgLayer' , 'indices IN THE FULL VECTOR for energy states in the snow+soil domain' , '-', get_ixVarType('midToto'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%ixHydLayer) = var_info('ixHydLayer' , 'indices IN THE FULL VECTOR for hydrology states in the snow+soil domain' , '-', get_ixVarType('midToto'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%ixWatAquifer) = var_info('ixWatAquifer' , 'indices IN THE FULL VECTOR for storage of water in the aquifer' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! vectors of indices for specific state types IN SPECIFIC SUB-DOMAINS - indx_meta(iLookINDEX%ixVolFracWat) = var_info('ixVolFracWat' , 'indices IN THE SNOW+SOIL VECTOR for hyd states' , '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%ixMatricHead) = var_info('ixMatricHead' , 'indices IN THE SOIL VECTOR for hyd states' , '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) - ! indices within state vectors - indx_meta(iLookINDEX%ixAllState) = var_info('ixAllState' , 'list of indices for all model state variables' , '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%ixSoilState) = var_info('ixSoilState' , 'list of indices for all soil layers' , '-', get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%ixLayerState) = var_info('ixLayerState' , 'list of indices for all model layers' , '-', get_ixVarType('midToto'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%ixLayerActive) = var_info('ixLayerActive' , 'list of indices for active model layers (inactive=integerMissing)' , '-', get_ixVarType('midToto'), iMissVec, iMissVec, .false.) - ! number of trials - indx_meta(iLookINDEX%numberFluxCalc) = var_info('numberFluxCalc' , 'number of flux calculations' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%numberStateSplit) = var_info('numberStateSplit' , 'number of state splitting solutions' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%numberDomainSplitNrg) = var_info('numberDomainSplitNrg' , 'number of domain splitting solutions for energy' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%numberDomainSplitMass) = var_info('numberDomainSplitMass', 'number of domain splitting solutions for mass' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - indx_meta(iLookINDEX%numberScalarSolutions) = var_info('numberScalarSolutions', 'number of scalar solutions' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - - ! read file to define model output (modifies metadata structures) - call read_output_file(err,cmessage) - if (err.ne.0) message=trim(message)//trim(cmessage) - - end subroutine popMetadat - - ! ------------------------------------------------ - ! subroutine to populate write commands from file input - ! ------------------------------------------------ - subroutine read_output_file(err,message) - USE netcdf - ! to get name of output control file from user - USE summaFileManager,only:SETTINGS_PATH ! path for metadata files - USE summaFileManager,only:OUTPUT_CONTROL ! file with output controls - - ! some dimensional parameters - USE globalData, only:outFreq ! output frequencies - USE var_lookup, only:maxvarFreq ! maximum # of output files - USE var_lookup, only:maxvarStat ! maximum # of statistics - - ! metadata structures - USE globalData, only: time_meta ! data structure for time metadata - USE globalData, only: forc_meta ! data structure for forcing metadata - USE globalData, only: type_meta ! data structure for categorical metadata - USE globalData, only: attr_meta ! data structure for attribute metadata - USE globalData, only: mpar_meta ! data structure for local parameter metadata - USE globalData, only: bpar_meta ! data structure for basin parameter metadata - USE globalData, only: bvar_meta ! data structure for basin model variable metadata - USE globalData, only: indx_meta ! data structure for index metadata - USE globalData, only: prog_meta ! data structure for local prognostic (state) variables - USE globalData, only: diag_meta ! data structure for local diagnostic variables - USE globalData, only: flux_meta ! data structure for local flux variables - USE globalData, only: deriv_meta ! data structure for local flux derivatives - USE globalData, only: outputPrecision ! data structure for output precision - USE globalData, only: outputCompressionLevel ! data structure for output netcdf deflate level - - ! structures of named variables - USE var_lookup, only: iLookTYPE ! named variables for categorical data - USE var_lookup, only: iLookID ! named variables for hru and gru ID metadata - USE var_lookup, only: iLookFORCE ! named variables for forcing data structure - USE var_lookup, only: iLookINDEX ! named variables for index variable data structure - USE var_lookup, only: iLookSTAT ! named variables for statitics variable data structure - USE var_lookup, only: iLookFREQ ! named variables for model output frequencies - - ! identify indices within structures - USE get_ixName_module,only:get_ixUnknown ! identify index in any structure - USE get_ixname_module,only:get_ixFreq ! identify index of model output frequency - USE get_ixname_module,only:get_ixStat ! identify index in ststistics structure - USE get_ixname_module,only:get_statName ! identify statistics name from the index - - ! modules to read ASCII data - USE ascii_util_module,only:file_open ! open file - USE ascii_util_module,only:linewidth ! match character number for one line - USE ascii_util_module,only:get_vlines ! get a vector of non-comment lines - USE ascii_util_module,only:split_line ! split a line into words - implicit none - - ! dummy variables - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - - ! define file format - integer(i4b),parameter :: noStatsDesired=1001 ! no statistic desired (temporally constant variables) - integer(i4b),parameter :: provideStatName=1002 ! provide the name of the desired statistic - integer(i4b),parameter :: provideStatFlags=1003 ! provide flags defining the desired statistic - integer(i4b) :: fileFormat ! the file format - - ! define statistics flags - logical(lgt),dimension(maxvarStat) :: statFlag ! vector of statistics flags - character(len=32) :: statName ! name of desired statistic - integer(i4b) :: iStat ! index of statistics vector - - ! define frequency of model output - character(len=64) :: freqName ! name of desired output frequency - integer(i4b) :: iFreq ! index of frequency vector - - ! general local variables - character(LEN=256) :: cmessage ! error message of downwind routine - character(LEN=256) :: outfile ! full path of model output file - integer(i4b) :: unt ! file unit - character(LEN=linewidth),allocatable :: charlines(:) ! vector of character strings - character(LEN=64),allocatable :: lineWords(:) ! vector to parse textline - integer(i4b) :: nWords ! number of words in line - character(LEN=128) :: varName ! variable name - character(LEN=5) :: structName ! name of structure - integer(i4b) :: vLine ! index for loop through variables - integer(i4b) :: vDex ! index into type lists - - ! initialize error control - err=0; message='read_output_file/' - - ! ********************************************************************************************** - ! (1) open file and read variable data - ! ********************************************************************************************** - outfile = trim(SETTINGS_PATH)//trim(OUTPUT_CONTROL) ! build filename - call file_open(trim(outfile),unt,err,cmessage) ! open file - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if - - ! ********************************************************************************************** - ! (2) read variable data (continue reading from previous point in the file) - ! ********************************************************************************************** - ! read the rest of the lines - call get_vlines(unt,charLines,err,cmessage) ! get a list of character strings from non-comment lines - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if - close(unt) ! close the file - - ! ********************************************************************************************** - ! (3) loop to parse individual file lines - ! ********************************************************************************************** - - ! initialize output frequency - outFreq(:) = .false. - - ! loop through the lines in the file - do vLine = 1,size(charLines) - - ! parse the current line - call split_line(charLines(vLine),lineWords,err,cmessage) +subroutine popMetadat(err,message) + ! data structures + USE data_types, only: var_info ! data type for metadata structure + USE globalData, only: time_meta ! data structure for time metadata + USE globalData, only: forc_meta ! data structure for forcing metadata + USE globalData, only: type_meta ! data structure for categorical metadata + USE globalData, only: id_meta ! data structure for hru and gru ID metadata + USE globalData, only: attr_meta ! data structure for attribute metadata + USE globalData, only: mpar_meta ! data structure for local parameter metadata + USE globalData, only: bpar_meta ! data structure for basin parameter metadata + USE globalData, only: bvar_meta ! data structure for basin model variable metadata + USE globalData, only: indx_meta ! data structure for index metadata + USE globalData, only: prog_meta ! data structure for local prognostic (state) variables + USE globalData, only: diag_meta ! data structure for local diagnostic variables + USE globalData, only: flux_meta ! data structure for local flux variables + USE globalData, only: deriv_meta ! data structure for local flux derivatives + USE globalData, only: lookup_meta ! data structure for lookup tables + ! structures of named variables + USE var_lookup, only: iLookTIME ! named variables for time data structure + USE var_lookup, only: iLookFORCE ! named variables for forcing data structure + USE var_lookup, only: iLookTYPE ! named variables for categorical attribute data structure + USE var_lookup, only: iLookID ! named variables for hru and gru ID metadata + USE var_lookup, only: iLookATTR ! named variables for real valued attribute data structure + USE var_lookup, only: iLookPARAM ! named variables for local parameter data structure + USE var_lookup, only: iLookBPAR ! named variables for basin parameter data structure + USE var_lookup, only: iLookBVAR ! named variables for basin model variable data structure + USE var_lookup, only: iLookINDEX ! named variables for index variable data structure + USE var_lookup, only: iLookPROG ! named variables for local state variables + USE var_lookup, only: iLookDIAG ! named variables for local diagnostic variables + USE var_lookup, only: iLookFLUX ! named variables for local flux variables + USE var_lookup, only: iLookDERIV ! named variables for local flux derivatives + USE var_lookup, only: iLookLOOKUP ! named variables for lookup tables + USE var_lookup, only: maxvarFreq ! number of output frequencies + USE var_lookup, only: maxvarStat ! number of statistics + USE get_ixName_module,only:get_ixVarType ! to turn vartype strings to integers + implicit none + ! dummy variables + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! internals + character(256) :: cmessage ! error message + integer,dimension(maxVarFreq) :: iMissVec ! vector of missing integers + ! initialize error control + err=0; message='popMetadat/' + + ! init arrays for structure constructors + iMissVec(:) = integerMissing + ! ----- + ! * model time structures... + ! -------------------------- + time_meta(iLookTIME%iyyy) = var_info('iyyy' , 'year' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + time_meta(iLookTIME%im) = var_info('im' , 'month' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + time_meta(iLookTIME%id) = var_info('id' , 'day' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + time_meta(iLookTIME%ih) = var_info('ih' , 'hour' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + time_meta(iLookTIME%imin) = var_info('imin' , 'minute' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + time_meta(iLookTIME%ih_tz) = var_info('ih_tz' , 'hour for time zone offset' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + time_meta(iLookTIME%imin_tz) = var_info('imin_tz' , 'minute for time zone offset' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! ----- + ! * model forcing data... + ! ----------------------- + forc_meta(iLookFORCE%time) = var_info('time' , 'time since time reference' , 'seconds since 1990-1-1 0:0:0.0 -0:00', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + forc_meta(iLookFORCE%pptrate) = var_info('pptrate' , 'precipitation rate' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + forc_meta(iLookFORCE%SWRadAtm) = var_info('SWRadAtm' , 'downward shortwave radiation at the upper boundary' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + forc_meta(iLookFORCE%LWRadAtm) = var_info('LWRadAtm' , 'downward longwave radiation at the upper boundary' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + forc_meta(iLookFORCE%airtemp) = var_info('airtemp' , 'air temperature at the measurement height' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + forc_meta(iLookFORCE%windspd) = var_info('windspd' , 'wind speed at the measurement height' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + forc_meta(iLookFORCE%airpres) = var_info('airpres' , 'air pressure at the the measurement height' , 'Pa' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + forc_meta(iLookFORCE%spechum) = var_info('spechum' , 'specific humidity at the measurement height' , 'g g-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! ----- + ! * categorical data... + ! --------------------- + type_meta(iLookTYPE%vegTypeIndex) = var_info('vegTypeIndex' , 'index defining vegetation type' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + type_meta(iLookTYPE%soilTypeIndex) = var_info('soilTypeIndex' , 'index defining soil type' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + type_meta(iLookTYPE%slopeTypeIndex) = var_info('slopeTypeIndex' , 'index defining slope' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + type_meta(iLookTYPE%downHRUindex) = var_info('downHRUindex' , 'index of downslope HRU (0 = basin outlet)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! ----- + ! * hru and gru ID data... + ! --------------------- + id_meta(iLookID%hruId) = var_info('hruId' , 'ID defining the hydrologic response unit' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + id_meta(iLookID%gruId) = var_info('gruId' , 'ID defining the grouped response unit' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + id_meta(iLookID%hru2gruId) = var_info('hru2gruId' , 'ID defining the GRU to which the HRU belongs' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! ----- + ! * site characteristics... + ! ------------------------- + attr_meta(iLookATTR%latitude) = var_info('latitude' , 'latitude' , 'degrees north' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + attr_meta(iLookATTR%longitude) = var_info('longitude' , 'longitude' , 'degrees east' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + attr_meta(iLookATTR%elevation) = var_info('elevation' , 'elevation' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + attr_meta(iLookATTR%tan_slope) = var_info('tan_slope' , 'tan water table slope (tan local ground surface slope)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + attr_meta(iLookATTR%contourLength) = var_info('contourLength' , 'length of contour at downslope edge of HRU' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + attr_meta(iLookATTR%HRUarea) = var_info('HRUarea' , 'area of each HRU' , 'm2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + attr_meta(iLookATTR%mHeight) = var_info('mHeight' , 'measurement height above bare ground' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + attr_meta(iLookATTR%aspect) = var_info('aspect' , 'mean azimuth of HRU in degrees East of North (0)' , 'degrees' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! ----- + ! * local parameter data... + ! ------------------------- + ! boundary conditions + mpar_meta(iLookPARAM%upperBoundHead) = var_info('upperBoundHead' , 'matric head at the upper boundary' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%lowerBoundHead) = var_info('lowerBoundHead' , 'matric head at the lower boundary' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%upperBoundTheta) = var_info('upperBoundTheta' , 'volumetric liquid water content at the upper boundary' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%lowerBoundTheta) = var_info('lowerBoundTheta' , 'volumetric liquid water content at the lower boundary' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%upperBoundTemp) = var_info('upperBoundTemp' , 'temperature of the upper boundary' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%lowerBoundTemp) = var_info('lowerBoundTemp' , 'temperature of the lower boundary' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! precipitation partitioning + mpar_meta(iLookPARAM%tempCritRain) = var_info('tempCritRain' , 'critical temperature where precipitation is rain' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%tempRangeTimestep) = var_info('tempRangeTimestep' , 'temperature range over the time step' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%frozenPrecipMultip) = var_info('frozenPrecipMultip' , 'frozen precipitation multiplier' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! snow properties + mpar_meta(iLookPARAM%snowfrz_scale) = var_info('snowfrz_scale' , 'scaling parameter for the freezing curve for snow' , 'K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%fixedThermalCond_snow) = var_info('fixedThermalCond_snow' , 'temporally constant thermal conductivity for snow' , 'W m-1 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! snow albedo + mpar_meta(iLookPARAM%albedoMax) = var_info('albedoMax' , 'maximum snow albedo (single spectral band)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%albedoMinWinter) = var_info('albedoMinWinter' , 'minimum snow albedo during winter (single spectral band)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%albedoMinSpring) = var_info('albedoMinSpring' , 'minimum snow albedo during spring (single spectral band)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%albedoMaxVisible) = var_info('albedoMaxVisible' , 'maximum snow albedo in the visible part of the spectrum' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%albedoMinVisible) = var_info('albedoMinVisible' , 'minimum snow albedo in the visible part of the spectrum' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%albedoMaxNearIR) = var_info('albedoMaxNearIR' , 'maximum snow albedo in the near infra-red part of the spectrum' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%albedoMinNearIR) = var_info('albedoMinNearIR' , 'minimum snow albedo in the near infra-red part of the spectrum' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%albedoDecayRate) = var_info('albedoDecayRate' , 'albedo decay rate' , 's' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%albedoSootLoad) = var_info('albedoSootLoad' , 'soot load factor' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%albedoRefresh) = var_info('albedoRefresh' , 'critical mass necessary for albedo refreshment' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! radiation transfer + mpar_meta(iLookPARAM%radExt_snow) = var_info('radExt_snow' , 'extinction coefficient for radiation penetration into snowpack' , 'm-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%directScale) = var_info('directScale' , 'scaling factor for fractional driect radiaion parameterization' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%Frad_direct) = var_info('Frad_direct' , 'fraction direct solar radiation' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%Frad_vis) = var_info('Frad_vis' , 'fraction radiation in visible part of spectrum' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! new snow density + mpar_meta(iLookPARAM%newSnowDenMin) = var_info('newSnowDenMin' , 'minimum new snow density' , 'kg m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%newSnowDenMult) = var_info('newSnowDenMult' , 'multiplier for new snow density' , 'kg m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%newSnowDenScal) = var_info('newSnowDenScal' , 'scaling factor for new snow density' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%constSnowDen) = var_info('constSnowDen' , 'Constant new snow density' , 'kg m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%newSnowDenAdd) = var_info('newSnowDenAdd' , 'Pahaut 1976, additive factor for new snow density' , 'kg m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%newSnowDenMultTemp) = var_info('newSnowDenMultTemp' , 'Pahaut 1976, multiplier for new snow density for air temperature' , 'kg m-3 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%newSnowDenMultWind) = var_info('newSnowDenMultWind' , 'Pahaut 1976, multiplier for new snow density for wind speed' , 'kg m-7/2 s-1/2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%newSnowDenMultAnd) = var_info('newSnowDenMultAnd' , 'Anderson 1976, multiplier for new snow density (Anderson func)' , 'K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%newSnowDenBase) = var_info('newSnowDenBase' , 'Anderson 1976, base value that is rasied to the (3/2) power' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! snow compaction + mpar_meta(iLookPARAM%densScalGrowth) = var_info('densScalGrowth' , 'density scaling factor for grain growth' , 'kg-1 m3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%tempScalGrowth) = var_info('tempScalGrowth' , 'temperature scaling factor for grain growth' , 'K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%grainGrowthRate) = var_info('grainGrowthRate' , 'rate of grain growth' , 's-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%densScalOvrbdn) = var_info('densScalOvrbdn' , 'density scaling factor for overburden pressure' , 'kg-1 m3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%tempScalOvrbdn) = var_info('tempScalOvrbdn' , 'temperature scaling factor for overburden pressure' , 'K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%baseViscosity ) = var_info('baseViscosity ' , 'viscosity coefficient at T=T_frz and snow density=0' , 'kg s m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! water flow through snow + mpar_meta(iLookPARAM%Fcapil) = var_info('Fcapil' , 'capillary retention (fraction of total pore volume)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%k_snow) = var_info('k_snow' , 'hydraulic conductivity of snow' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%mw_exp) = var_info('mw_exp' , 'exponent for meltwater flow' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! turbulent heat fluxes + mpar_meta(iLookPARAM%z0Snow) = var_info('z0Snow' , 'roughness length of snow' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%z0Soil) = var_info('z0Soil' , 'roughness length of bare soil below the canopy' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%z0Canopy) = var_info('z0Canopy' , 'roughness length of the canopy, only used if decision veg_traits==vegTypeTable', 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%zpdFraction) = var_info('zpdFraction' , 'zero plane displacement / canopy height' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%critRichNumber) = var_info('critRichNumber' , 'critical value for the bulk Richardson number' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%Louis79_bparam) = var_info('Louis79_bparam' , 'parameter in Louis (1979) stability function' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%Louis79_cStar) = var_info('Louis79_cStar' , 'parameter in Louis (1979) stability function' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%Mahrt87_eScale) = var_info('Mahrt87_eScale' , 'exponential scaling factor in the Mahrt (1987) stability function', '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%leafExchangeCoeff) = var_info('leafExchangeCoeff' , 'turbulent exchange coeff between canopy surface and canopy air' , 'm s-(1/2)' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%windReductionParam) = var_info('windReductionParam' , 'canopy wind reduction parameter' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! stomatal conductance + mpar_meta(iLookPARAM%Kc25) = var_info('Kc25' , 'Michaelis-Menten constant for CO2 at 25 degrees C' , 'umol mol-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%Ko25) = var_info('Ko25' , 'Michaelis-Menten constant for O2 at 25 degrees C' , 'mol mol-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%Kc_qFac) = var_info('Kc_qFac' , 'factor in the q10 function defining temperature controls on Kc' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%Ko_qFac) = var_info('Ko_qFac' , 'factor in the q10 function defining temperature controls on Ko' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%kc_Ha) = var_info('kc_Ha' , 'activation energy for the Michaelis-Menten constant for CO2' , 'J mol-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%ko_Ha) = var_info('ko_Ha' , 'activation energy for the Michaelis-Menten constant for O2' , 'J mol-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%vcmax25_canopyTop) = var_info('vcmax25_canopyTop' , 'potential carboxylation rate at 25 degrees C at the canopy top' , 'umol co2 m-2 s-1', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%vcmax_qFac) = var_info('vcmax_qFac' , 'factor in the q10 function defining temperature controls on vcmax', '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%vcmax_Ha) = var_info('vcmax_Ha' , 'activation energy in the vcmax function' , 'J mol-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%vcmax_Hd) = var_info('vcmax_Hd' , 'deactivation energy in the vcmax function' , 'J mol-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%vcmax_Sv) = var_info('vcmax_Sv' , 'entropy term in the vcmax function' , 'J mol-1 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%vcmax_Kn) = var_info('vcmax_Kn' , 'foliage nitrogen decay coefficient' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%jmax25_scale) = var_info('jmax25_scale' , 'scaling factor to relate jmax25 to vcmax25' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%jmax_Ha) = var_info('jmax_Ha' , 'activation energy in the jmax function' , 'J mol-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%jmax_Hd) = var_info('jmax_Hd' , 'deactivation energy in the jmax function' , 'J mol-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%jmax_Sv) = var_info('jmax_Sv' , 'entropy term in the jmax function' , 'J mol-1 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%fractionJ) = var_info('fractionJ' , 'fraction of light lost by other than the chloroplast lamellae' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%quantamYield) = var_info('quantamYield' , 'quantam yield' , 'mol e mol-1 q' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%vpScaleFactor) = var_info('vpScaleFactor' , 'vapor pressure scaling factor in stomatal conductance function' , 'Pa' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%cond2photo_slope) = var_info('cond2photo_slope' , 'slope of conductance-photosynthesis relationship' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%minStomatalConductance) = var_info('minStomatalConductance' , 'minimum stomatal conductance' , 'umol H2O m-2 s-1', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! vegetation properties + mpar_meta(iLookPARAM%winterSAI) = var_info('winterSAI' , 'stem area index prior to the start of the growing season' , 'm2 m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%summerLAI) = var_info('summerLAI' , 'maximum leaf area index at the peak of the growing season' , 'm2 m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%rootScaleFactor1) = var_info('rootScaleFactor1' , '1st scaling factor (a) in Y = 1 - 0.5*( exp(-aZ) + exp(-bZ) )' , 'm-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%rootScaleFactor2) = var_info('rootScaleFactor2' , '2nd scaling factor (b) in Y = 1 - 0.5*( exp(-aZ) + exp(-bZ) )' , 'm-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%rootingDepth) = var_info('rootingDepth' , 'rooting depth' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%rootDistExp) = var_info('rootDistExp' , 'exponent for the vertical distribution of root density' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%plantWiltPsi) = var_info('plantWiltPsi' , 'matric head at wilting point' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%soilStressParam) = var_info('soilStressParam' , 'parameter in the exponential soil stress function' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%critSoilWilting) = var_info('critSoilWilting' , 'critical vol. liq. water content when plants are wilting' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%critSoilTranspire) = var_info('critSoilTranspire' , 'critical vol. liq. water content when transpiration is limited' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%critAquiferTranspire) = var_info('critAquiferTranspire' , 'critical aquifer storage value when transpiration is limited' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%minStomatalResistance) = var_info('minStomatalResistance' , 'minimum stomatal resistance' , 's m-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%leafDimension) = var_info('leafDimension' , 'characteristic leaf dimension' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%heightCanopyTop) = var_info('heightCanopyTop' , 'height of top of the vegetation canopy above ground surface' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%heightCanopyBottom) = var_info('heightCanopyBottom' , 'height of bottom of the vegetation canopy above ground surface' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%specificHeatVeg) = var_info('specificHeatVeg' , 'specific heat of vegetation' , 'J kg-1 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%maxMassVegetation) = var_info('maxMassVegetation' , 'maximum mass of vegetation (full foliage)' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%throughfallScaleSnow) = var_info('throughfallScaleSnow' , 'scaling factor for throughfall (snow)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%throughfallScaleRain) = var_info('throughfallScaleRain' , 'scaling factor for throughfall (rain)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%refInterceptCapSnow) = var_info('refInterceptCapSnow' , 'reference canopy interception capacity per unit leaf area (snow)' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%refInterceptCapRain) = var_info('refInterceptCapRain' , 'canopy interception capacity per unit leaf area (rain)' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%snowUnloadingCoeff) = var_info('snowUnloadingCoeff' , 'time constant for unloading of snow from the forest canopy' , 's-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%canopyDrainageCoeff) = var_info('canopyDrainageCoeff' , 'time constant for drainage of liquid water from the forest canopy', 's-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%ratioDrip2Unloading) = var_info('ratioDrip2Unloading' , 'ratio of canopy drip to unloading of snow from the forest canopy' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%canopyWettingFactor) = var_info('canopyWettingFactor' , 'maximum wetted fraction of the canopy' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%canopyWettingExp) = var_info('canopyWettingExp' , 'exponent in canopy wetting function' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%minTempUnloading) = var_info('minTempUnloading' , 'min temp for unloading in windySnow' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%rateTempUnloading) = var_info('rateTempUnloading' , 'how quickly to unload due to temperature' , 'K s' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%minWindUnloading) = var_info('minWindUnloading' , 'min wind speed for unloading in windySnow' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%rateWindUnloading) = var_info('rateWindUnloading' , 'how quickly to unload due to wind' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! soil properties + mpar_meta(iLookPARAM%soil_dens_intr) = var_info('soil_dens_intr' , 'intrinsic soil density' , 'kg m-3' , get_ixVarType('parSoil'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%thCond_soil) = var_info('thCond_soil' , 'thermal conductivity of soil (includes quartz and other minerals)', 'W m-1 K-1' , get_ixVarType('parSoil'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%frac_sand) = var_info('frac_sand' , 'fraction of sand' , '-' , get_ixVarType('parSoil'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%frac_silt) = var_info('frac_silt' , 'fraction of silt' , '-' , get_ixVarType('parSoil'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%frac_clay) = var_info('frac_clay' , 'fraction of clay' , '-' , get_ixVarType('parSoil'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%theta_sat) = var_info('theta_sat' , 'soil porosity' , '-' , get_ixVarType('parSoil'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%theta_res) = var_info('theta_res' , 'volumetric residual water content' , '-' , get_ixVarType('parSoil'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%vGn_alpha) = var_info('vGn_alpha' , 'van Genuchten "alpha" parameter' , 'm-1' , get_ixVarType('parSoil'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%vGn_n) = var_info('vGn_n' , 'van Genuchten "n" parameter' , '-' , get_ixVarType('parSoil'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%k_soil) = var_info('k_soil' , 'saturated hydraulic conductivity' , 'm s-1' , get_ixVarType('parSoil'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%k_macropore) = var_info('k_macropore' , 'saturated hydraulic conductivity for macropores' , 'm s-1' , get_ixVarType('parSoil'), iMissVec, iMissVec, .false.) + ! scalar soil properties + mpar_meta(iLookPARAM%fieldCapacity) = var_info('fieldCapacity' , 'soil field capacity (vol liq water content when baseflow begins)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%wettingFrontSuction) = var_info('wettingFrontSuction' , 'Green-Ampt wetting front suction' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%theta_mp) = var_info('theta_mp' , 'volumetric liquid water content when macropore flow begins' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%mpExp) = var_info('mpExp' , 'empirical exponent in macropore flow equation' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%kAnisotropic) = var_info('kAnisotropic' , 'anisotropy factor for lateral hydraulic conductivity' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%zScale_TOPMODEL) = var_info('zScale_TOPMODEL' , 'TOPMODEL scaling factor used in lower boundary condition for soil', 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%compactedDepth) = var_info('compactedDepth' , 'depth where k_soil reaches the compacted value given by CH78' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%aquiferBaseflowRate) = var_info('aquiferBaseflowRate' , 'baseflow rate when aquifer storage = aquiferScaleFactor' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%aquiferScaleFactor) = var_info('aquiferScaleFactor' , 'scaling factor for aquifer storage in the big bucket' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%aquiferBaseflowExp) = var_info('aquiferBaseflowExp' , 'baseflow exponent' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%qSurfScale) = var_info('qSurfScale' , 'scaling factor in the surface runoff parameterization' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%specificYield) = var_info('specificYield' , 'specific yield' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%specificStorage) = var_info('specificStorage' , 'specific storage coefficient' , 'm-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%f_impede) = var_info('f_impede' , 'ice impedence factor' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%soilIceScale) = var_info('soilIceScale' , 'scaling factor for depth of soil ice, used to get frozen fraction', 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%soilIceCV) = var_info('soilIceCV' , 'CV of depth of soil ice, used to get frozen fraction' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! conceptual parameters for surface runoff + mpar_meta(iLookPARAM%FUSE_Ac_max) = var_info('FUSE_Ac_max' , 'FUSE PRMS max saturated area' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%FUSE_phi_tens) = var_info('FUSE_phi_tens' , 'FUSE PRMS tension storage fraction' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%FUSE_b) = var_info('FUSE_b' , 'FUSE ARNO/VIC exponent' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%FUSE_lambda) = var_info('FUSE_lambda' , 'FUSE TOPMODEL gamma distribution lambda parameter' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%FUSE_chi) = var_info('FUSE_chi' , 'FUSE TOPMODEL gamma distribution chi parameter' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%FUSE_mu) = var_info('FUSE_mu' , 'FUSE TOPMODEL gamma distribution mu parameter' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%FUSE_n) = var_info('FUSE_n' , 'FUSE TOPMODEL exponent' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! algorithmic control parameters + mpar_meta(iLookPARAM%minwind) = var_info('minwind' , 'minimum wind speed' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%minstep) = var_info('minstep' , 'minimum length of the time step homegrown' , 's' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%maxstep) = var_info('maxstep' , 'maximum length of the time step (data window)' , 's' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%be_steps) = var_info('be_steps' , 'number of equal substeps to dividing the data window for BE' ,'-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%wimplicit) = var_info('wimplicit' , 'weight assigned to the start-of-step fluxes ,homegrown, not currently used', '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%maxiter) = var_info('maxiter' , 'maximum number of iterations homegrown and kinsol' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%relConvTol_liquid) = var_info('relConvTol_liquid' , 'BE relative convergence tolerance for vol frac liq water homegrown', '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%absConvTol_liquid) = var_info('absConvTol_liquid' , 'BE absolute convergence tolerance for vol frac liq water homegrown', '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%relConvTol_matric) = var_info('relConvTol_matric' , 'BE relative convergence tolerance for matric head homegrown' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%absConvTol_matric) = var_info('absConvTol_matric' , 'BE absolute convergence tolerance for matric head homegrown' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%relConvTol_energy) = var_info('relConvTol_energy' , 'BE relative convergence tolerance for energy homegrown' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%absConvTol_energy) = var_info('absConvTol_energy' , 'BE absolute convergence tolerance for energy homegrown' , 'J m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%relConvTol_aquifr) = var_info('relConvTol_aquifr' , 'BE relative convergence tolerance for aquifer storage homegrown' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%absConvTol_aquifr) = var_info('absConvTol_aquifr' , 'BE absolute convergence tolerance for aquifer storage homegrown' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%relTolTempCas) = var_info('relTolTempCas' , 'IDA relative error tolerance for canopy temperature state variable', '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%absTolTempCas) = var_info('absTolTempCas' , 'IDA absolute error tolerance for canopy temperature state variable', '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%relTolTempVeg) = var_info('relTolTempVeg' , 'IDA relative error tolerance for vegitation temp state var' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%absTolTempVeg) = var_info('absTolTempVeg' , 'IDA absolute error tolerance for vegitation temp state var' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%relTolWatVeg) = var_info('relTolWatVeg' , 'IDA relative error tolerance for vegitation hydrology' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%absTolWatVeg) = var_info('absTolWatVeg' , 'IDA absolute error tolerance for vegitation hydrology' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%relTolTempSoilSnow) = var_info('relTolTempSoilSnow' , 'IDA relative error tolerance for snow+soil energy' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%absTolTempSoilSnow) = var_info('absTolTempSoilSnow' , 'IDA absolute error tolerance for snow+soil energy' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%relTolWatSnow) = var_info('relTolWatSnow' , 'IDA relative error tolerance for snow hydrology' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%absTolWatSnow) = var_info('absTolWatSnow' , 'IDA absolute error tolerance for snow hydrology' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%relTolMatric) = var_info('relTolMatric' , 'IDA relative error tolerance for matric head' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%absTolMatric) = var_info('absTolMatric' , 'IDA absolute error tolerance for matric head' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%relTolAquifr) = var_info('relTolAquifr' , 'IDA relative error tolerance for aquifer hydrology' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%absTolAquifr) = var_info('absTolAquifr' , 'IDA absolute error tolerance for aquifer hydrology' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%idaMaxOrder) = var_info('idaMaxOrder' , 'maximum order for IDA' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%idaMaxInternalSteps) = var_info('idaMaxInternalSteps' , 'maximum number of internal steps for IDA before tout' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%idaInitStepSize) = var_info('idaInitStepSize' , 'initial step size for IDA' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%idaMinStepSize) = var_info('idaMinStepSize' , 'minimum step size for IDA' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%idaMaxStepSize) = var_info('idaMaxStepSize' , 'maximum step size for IDA' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%idaMaxErrTestFail) = var_info('idaMaxErrTestFail' , 'maximum number of error test failures for IDA' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%idaMaxDataWindowSteps) = var_info('idaMaxDataWindowSteps' , 'maximum number of steps with event detection for IDA per data window', '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%idaDetectEvents) = var_info('idaDetectEvents' , 'flag to turn on event detection in IDA, 0=off, 1=on' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%zmin) = var_info('zmin' , 'minimum layer depth' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%zmax) = var_info('zmax' , 'maximum layer depth' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%zminLayer1) = var_info('zminLayer1' , 'minimum layer depth for the 1st (top) layer' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%zminLayer2) = var_info('zminLayer2' , 'minimum layer depth for the 2nd layer' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%zminLayer3) = var_info('zminLayer3' , 'minimum layer depth for the 3rd layer' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%zminLayer4) = var_info('zminLayer4' , 'minimum layer depth for the 4th layer' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%zminLayer5) = var_info('zminLayer5' , 'minimum layer depth for the 5th (bottom) layer' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%zmaxLayer1_lower) = var_info('zmaxLayer1_lower' , 'maximum layer depth for the 1st (top) layer when only 1 layer' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%zmaxLayer2_lower) = var_info('zmaxLayer2_lower' , 'maximum layer depth for the 2nd layer when only 2 layers' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%zmaxLayer3_lower) = var_info('zmaxLayer3_lower' , 'maximum layer depth for the 3rd layer when only 3 layers' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%zmaxLayer4_lower) = var_info('zmaxLayer4_lower' , 'maximum layer depth for the 4th layer when only 4 layers' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%zmaxLayer1_upper) = var_info('zmaxLayer1_upper' , 'maximum layer depth for the 1st (top) layer when > 1 layer' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%zmaxLayer2_upper) = var_info('zmaxLayer2_upper' , 'maximum layer depth for the 2nd layer when > 2 layers' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%zmaxLayer3_upper) = var_info('zmaxLayer3_upper' , 'maximum layer depth for the 3rd layer when > 3 layers' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + mpar_meta(iLookPARAM%zmaxLayer4_upper) = var_info('zmaxLayer4_upper' , 'maximum layer depth for the 4th layer when > 4 layers' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! ----- + ! * basin parameter data... + ! ------------------------- + bpar_meta(iLookBPAR%basin__aquiferHydCond) = var_info('basin__aquiferHydCond' , 'hydraulic conductivity of the aquifer' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bpar_meta(iLookBPAR%basin__aquiferScaleFactor) = var_info('basin__aquiferScaleFactor' , 'scaling factor for aquifer storage in the big bucket' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bpar_meta(iLookBPAR%basin__aquiferBaseflowExp) = var_info('basin__aquiferBaseflowExp' , 'baseflow exponent for the big bucket' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bpar_meta(iLookBPAR%routingGammaShape) = var_info('routingGammaShape' , 'shape parameter in Gamma distribution used for sub-grid routing' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bpar_meta(iLookBPAR%routingGammaScale) = var_info('routingGammaScale' , 'scale parameter in Gamma distribution used for sub-grid routing' , 's' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! ----- + ! * local model prognostic (state) variables... + ! --------------------------------------------- + ! define variables for time stepping + prog_meta(iLookPROG%dt_init) = var_info('dt_init' , 'length of initial time step at start of next data interval' , 's' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! state variables for vegetation + prog_meta(iLookPROG%scalarCanopyIce) = var_info('scalarCanopyIce' , 'mass of ice on the vegetation canopy' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + prog_meta(iLookPROG%scalarCanopyLiq) = var_info('scalarCanopyLiq' , 'mass of liquid water on the vegetation canopy' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + prog_meta(iLookPROG%scalarCanopyWat) = var_info('scalarCanopyWat' , 'mass of total water on the vegetation canopy' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + prog_meta(iLookPROG%scalarCanairTemp) = var_info('scalarCanairTemp' , 'temperature of the canopy air space' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + prog_meta(iLookPROG%scalarCanopyTemp) = var_info('scalarCanopyTemp' , 'temperature of the vegetation canopy' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! state variables for snow + prog_meta(iLookPROG%spectralSnowAlbedoDiffuse) = var_info('spectralSnowAlbedoDiffuse' , 'diffuse snow albedo for individual spectral bands' , '-' , get_ixVarType('wLength'), iMissVec, iMissVec, .false.) + prog_meta(iLookPROG%scalarSnowAlbedo) = var_info('scalarSnowAlbedo' , 'snow albedo for the entire spectral band' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + prog_meta(iLookPROG%scalarSnowDepth) = var_info('scalarSnowDepth' , 'total snow depth' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + prog_meta(iLookPROG%scalarSWE) = var_info('scalarSWE' , 'snow water equivalent' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + prog_meta(iLookPROG%scalarSfcMeltPond) = var_info('scalarSfcMeltPond' , 'ponded water caused by melt of the "snow without a layer"' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! define state variables for the snow+soil domain + prog_meta(iLookPROG%mLayerTemp) = var_info('mLayerTemp' , 'temperature of each layer' , 'K' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + prog_meta(iLookPROG%mLayerVolFracIce) = var_info('mLayerVolFracIce' , 'volumetric fraction of ice in each layer' , '-' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + prog_meta(iLookPROG%mLayerVolFracLiq) = var_info('mLayerVolFracLiq' , 'volumetric fraction of liquid water in each layer' , '-' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + prog_meta(iLookPROG%mLayerVolFracWat) = var_info('mLayerVolFracWat' , 'volumetric fraction of total water in each layer' , '-' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + prog_meta(iLookPROG%mLayerMatricHead) = var_info('mLayerMatricHead' , 'matric head of water in the soil' , 'm' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + ! enthalpy + prog_meta(iLookPROG%scalarCanairEnthalpy) = var_info('scalarCanairEnthalpy' , 'enthalpy of the canopy air space' , 'J m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + prog_meta(iLookPROG%scalarCanopyEnthalpy) = var_info('scalarCanopyEnthalpy' , 'enthalpy of the vegetation canopy' , 'J m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + prog_meta(iLookPROG%mLayerEnthalpy) = var_info('mLayerEnthalpy' , 'enthalpy of the snow+soil layers' , 'J m-3' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + ! other state variables + prog_meta(iLookPROG%scalarAquiferStorage) = var_info('scalarAquiferStorage' , 'water required to bring aquifer to the bottom of the soil profile', 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + prog_meta(iLookPROG%scalarSurfaceTemp) = var_info('scalarSurfaceTemp' , 'surface temperature (just a copy of the upper-layer temperature)' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! define coordinate variables + prog_meta(iLookPROG%mLayerDepth) = var_info('mLayerDepth' , 'depth of each layer' , 'm' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + prog_meta(iLookPROG%mLayerHeight) = var_info('mLayerHeight' , 'height of the layer mid-point (top of soil = 0)' , 'm' , get_ixVarType('ifcToto'), iMissVec, iMissVec, .false.) + prog_meta(iLookPROG%iLayerHeight) = var_info('iLayerHeight' , 'height of the layer interface (top of soil = 0)' , 'm' , get_ixVarType('ifcToto'), iMissVec, iMissVec, .false.) + ! ----- + ! * local model diagnostic variables... + ! ------------------------------------- + ! local properties + diag_meta(iLookDIAG%scalarCanopyDepth) = var_info('scalarCanopyDepth' , 'canopy depth' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarBulkVolHeatCapVeg) = var_info('scalarBulkVolHeatCapVeg' , 'bulk volumetric heat capacity of vegetation' , 'J m-3 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarCanopyCm) = var_info('scalarCanopyCm' , 'Cm for canopy vegetation' , 'J kg-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarCanopyEmissivity) = var_info('scalarCanopyEmissivity' , 'effective canopy emissivity' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarRootZoneTemp) = var_info('scalarRootZoneTemp' , 'average temperature of the root zone' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarLAI) = var_info('scalarLAI' , 'one-sided leaf area index' , 'm2 m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarSAI) = var_info('scalarSAI' , 'one-sided stem area index' , 'm2 m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarExposedLAI) = var_info('scalarExposedLAI' , 'exposed leaf area index (after burial by snow)' , 'm2 m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarExposedSAI) = var_info('scalarExposedSAI' , 'exposed stem area index (after burial by snow)' , 'm2 m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarAdjMeasHeight) = var_info('scalarAdjMeasHeight' , 'adjusted measurement height for cases snowDepth>mHeight' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarCanopyIceMax) = var_info('scalarCanopyIceMax' , 'maximum interception storage capacity for ice' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarCanopyLiqMax) = var_info('scalarCanopyLiqMax' , 'maximum interception storage capacity for liquid water' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarGrowingSeasonIndex) = var_info('scalarGrowingSeasonIndex' , 'growing season index (0=off, 1=on)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarVolHtCap_air) = var_info('scalarVolHtCap_air' , 'volumetric heat capacity air' , 'J m-3 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarVolHtCap_ice) = var_info('scalarVolHtCap_ice' , 'volumetric heat capacity ice' , 'J m-3 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarVolHtCap_soil) = var_info('scalarVolHtCap_soil' , 'volumetric heat capacity dry soil' , 'J m-3 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarVolHtCap_water) = var_info('scalarVolHtCap_water' , 'volumetric heat capacity liquid wat' , 'J m-3 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%mLayerVolHtCapBulk) = var_info('mLayerVolHtCapBulk' , 'volumetric heat capacity in each layer' , 'J m-3 K-1' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%mLayerCm) = var_info('mLayerCm' , 'Cm for each layer' , 'J m-3' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarLambda_drysoil) = var_info('scalarLambda_drysoil' , 'thermal conductivity of dry soil' , 'W m-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarLambda_wetsoil) = var_info('scalarLambda_wetsoil' , 'thermal conductivity of wet soil' , 'W m-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%mLayerThermalC) = var_info('mLayerThermalC' , 'thermal conductivity at the mid-point of each layer' , 'W m-1 K-1' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%iLayerThermalC) = var_info('iLayerThermalC' , 'thermal conductivity at the interface of each layer' , 'W m-1 K-1' , get_ixVarType('ifcToto'), iMissVec, iMissVec, .false.) + ! enthalpy + diag_meta(iLookDIAG%scalarCanopyEnthTemp) = var_info('scalarCanopyEnthTemp' , 'temperature component of enthalpy of the vegetation canopy' , 'J m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%mLayerEnthTemp) = var_info('mLayerEnthTemp' , 'temperature component of enthalpy of the snow+soil layers' , 'J m-3' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarTotalSoilEnthalpy) = var_info('scalarTotalSoilEnthalpy' , 'total enthalpy of the soil column' , 'J m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarTotalSnowEnthalpy) = var_info('scalarTotalSnowEnthalpy' , 'total enthalpy of the snow column' , 'J m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! forcing + diag_meta(iLookDIAG%scalarVPair) = var_info('scalarVPair' , 'vapor pressure of the air above the vegetation canopy' , 'Pa' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarVP_CanopyAir) = var_info('scalarVP_CanopyAir' , 'vapor pressure of the canopy air space' , 'Pa' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarTwetbulb) = var_info('scalarTwetbulb' , 'wet bulb temperature' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarSnowfallTemp) = var_info('scalarSnowfallTemp' , 'temperature of fresh snow' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarNewSnowDensity) = var_info('scalarNewSnowDensity' , 'density of fresh snow' , 'kg m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarO2air) = var_info('scalarO2air' , 'atmospheric o2 concentration' , 'Pa' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarCO2air) = var_info('scalarCO2air' , 'atmospheric co2 concentration' , 'Pa' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%windspd_x) = var_info('windspd_x' , 'wind speed at 10 meter height in x-direction' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%windspd_y) = var_info('windspd_y' , 'wind speed at 10 meter height in y-direction' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! shortwave radiation + diag_meta(iLookDIAG%scalarCosZenith) = var_info('scalarCosZenith' , 'cosine of the solar zenith angle' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarFractionDirect) = var_info('scalarFractionDirect' , 'fraction of direct radiation (0-1)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarCanopySunlitFraction) = var_info('scalarCanopySunlitFraction' , 'sunlit fraction of canopy' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarCanopySunlitLAI) = var_info('scalarCanopySunlitLAI' , 'sunlit leaf area' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarCanopyShadedLAI) = var_info('scalarCanopyShadedLAI' , 'shaded leaf area' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%spectralAlbGndDirect) = var_info('spectralAlbGndDirect' , 'direct albedo of underlying surface for each spectral band' , '-' , get_ixVarType('wLength'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%spectralAlbGndDiffuse) = var_info('spectralAlbGndDiffuse' , 'diffuse albedo of underlying surface for each spectral band' , '-' , get_ixVarType('wLength'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarGroundAlbedo) = var_info('scalarGroundAlbedo' , 'albedo of the ground surface' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! turbulent heat transfer + diag_meta(iLookDIAG%scalarLatHeatSubVapCanopy) = var_info('scalarLatHeatSubVapCanopy' , 'latent heat of sublimation/vaporization used for veg canopy' , 'J kg-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarLatHeatSubVapGround) = var_info('scalarLatHeatSubVapGround' , 'latent heat of sublimation/vaporization used for ground surface' , 'J kg-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarSatVP_CanopyTemp) = var_info('scalarSatVP_CanopyTemp' , 'saturation vapor pressure at the temperature of vegetation canopy', 'Pa' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarSatVP_GroundTemp) = var_info('scalarSatVP_GroundTemp' , 'saturation vapor pressure at the temperature of the ground' , 'Pa' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarZ0Canopy) = var_info('scalarZ0Canopy' , 'roughness length of the canopy' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarWindReductionFactor) = var_info('scalarWindReductionFactor' , 'canopy wind reduction factor' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarZeroPlaneDisplacement) = var_info('scalarZeroPlaneDisplacement' , 'zero plane displacement' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarRiBulkCanopy) = var_info('scalarRiBulkCanopy' , 'bulk Richardson number for the canopy' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarRiBulkGround) = var_info('scalarRiBulkGround' , 'bulk Richardson number for the ground surface' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarCanopyStabilityCorrection) = var_info('scalarCanopyStabilityCorrection', 'stability correction for the canopy' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarGroundStabilityCorrection) = var_info('scalarGroundStabilityCorrection', 'stability correction for the ground surface' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! evapotranspiration + diag_meta(iLookDIAG%scalarIntercellularCO2Sunlit) = var_info('scalarIntercellularCO2Sunlit' , 'carbon dioxide partial pressure of leaf interior (sunlit leaves)' , 'Pa' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarIntercellularCO2Shaded) = var_info('scalarIntercellularCO2Shaded' , 'carbon dioxide partial pressure of leaf interior (shaded leaves)' , 'Pa' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarTranspireLim) = var_info('scalarTranspireLim' , 'aggregate soil moisture and aquifer control on transpiration' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarTranspireLimAqfr) = var_info('scalarTranspireLimAqfr' , 'aquifer storage control on transpiration' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarFoliageNitrogenFactor) = var_info('scalarFoliageNitrogenFactor' , 'foliage nitrogen concentration (1=saturated)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarSoilRelHumidity) = var_info('scalarSoilRelHumidity' , 'relative humidity in the soil pores in the upper-most soil layer' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%mLayerTranspireLim) = var_info('mLayerTranspireLim' , 'soil moist & veg limit on transpiration for each layer' , '-' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%mLayerRootDensity) = var_info('mLayerRootDensity' , 'fraction of roots in each soil layer' , '-' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarAquiferRootFrac) = var_info('scalarAquiferRootFrac' , 'fraction of roots below the soil profile (in the aquifer)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! canopy hydrology + diag_meta(iLookDIAG%scalarFracLiqVeg) = var_info('scalarFracLiqVeg' , 'fraction of liquid water on vegetation' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarCanopyWetFraction) = var_info('scalarCanopyWetFraction' , 'fraction canopy that is wet' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! snow hydrology + diag_meta(iLookDIAG%scalarSnowAge) = var_info('scalarSnowAge' , 'non-dimensional snow age' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarGroundSnowFraction) = var_info('scalarGroundSnowFraction' , 'fraction ground that is covered with snow' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%spectralSnowAlbedoDirect) = var_info('spectralSnowAlbedoDirect' , 'direct snow albedo for individual spectral bands' , '-' , get_ixVarType('wLength'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%mLayerFracLiqSnow) = var_info('mLayerFracLiqSnow' , 'fraction of liquid water in each snow layer' , '-' , get_ixVarType('midSnow'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%mLayerThetaResid) = var_info('mLayerThetaResid' , 'residual volumetric water content in each snow layer' , '-' , get_ixVarType('midSnow'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%mLayerPoreSpace) = var_info('mLayerPoreSpace' , 'total pore space in each snow layer' , '-' , get_ixVarType('midSnow'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%mLayerMeltFreeze) = var_info('mLayerMeltFreeze' , 'ice content change from melt/freeze in each layer' , 'kg m-3' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + ! soil hydrology + diag_meta(iLookDIAG%scalarInfilArea) = var_info('scalarInfilArea' , 'fraction of unfrozen area where water can infiltrate' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarSaturatedArea) = var_info('scalarSaturatedArea' , 'fraction of area that is considered saturated' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarFrozenArea) = var_info('scalarFrozenArea' , 'fraction of area that is considered impermeable due to soil ice' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarSoilControl) = var_info('scalarSoilControl' , 'soil control on infiltration for derivative' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%mLayerVolFracAir) = var_info('mLayerVolFracAir' , 'volumetric fraction of air in each layer' , '-' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%mLayerTcrit) = var_info('mLayerTcrit' , 'critical soil temperature above which all water is unfrozen' , 'K' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%mLayerCompress) = var_info('mLayerCompress' , 'change in volumetric water content due to compression of soil' , 's-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarSoilCompress) = var_info('scalarSoilCompress' , 'change in total soil storage due to compression of soil matrix' , 'kg m-2 s-1 ' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%mLayerMatricHeadLiq) = var_info('mLayerMatricHeadLiq' , 'matric potential of liquid water' , 'm' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarTotalSoilLiq) = var_info('scalarTotalSoilLiq' , 'total mass of liquid water in the soil' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarTotalSoilIce) = var_info('scalarTotalSoilIce' , 'total mass of ice in the soil' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarTotalSoilWat) = var_info('scalarTotalSoilWat' , 'total mass of water in the soil' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! variable shortcuts + diag_meta(iLookDIAG%scalarVGn_m) = var_info('scalarVGn_m' , 'van Genuchten "m" parameter' , '-' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarKappa) = var_info('scalarKappa' , 'constant in the freezing curve function' , 'm K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarVolLatHt_fus) = var_info('scalarVolLatHt_fus' , 'volumetric latent heat of fusion' , 'J m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! timing information + diag_meta(iLookDIAG%numFluxCalls) = var_info('numFluxCalls' , 'number of flux calls' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%wallClockTime) = var_info('wallClockTime' , 'wall clock time for physics routines' , 's' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%meanStepSize) = var_info('meanStepSize' , 'mean time step size over data window' , 's' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! balances + diag_meta(iLookDIAG%balanceCasNrg) = var_info('balanceCasNrg' , 'balance of energy in the canopy air space on data window' , 'W m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%balanceVegNrg) = var_info('balanceVegNrg' , 'balance of energy in the vegetation on data window' , 'W m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%balanceLayerNrg) = var_info('balanceLayerNrg' , 'balance of energy in each snow+soil layer on substep' , 'W m-3' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%balanceSnowNrg) = var_info('balanceSnowNrg' , 'balance of energy in the snow on data window' , 'W m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%balanceSoilNrg) = var_info('balanceSoilNrg' , 'balance of energy in the soil on data window' , 'W m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%balanceVegMass) = var_info('balanceVegMass' , 'balance of water in the vegetation on data window' , 'kg m-3 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%balanceLayerMass) = var_info('balanceLayerMass' , 'balance of water in each snow+soil layer on substep' , 'kg m-3 s-1' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%balanceSnowMass) = var_info('balanceSnowMass' , 'balance of water in the snow on data window' , 'kg m-3 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%balanceSoilMass) = var_info('balanceSoilMass' , 'balance of water in the soil on data window' , 'kg m-3 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%balanceAqMass) = var_info('balanceAqMass' , 'balance of water in the aquifer on data window' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! sundials integrator stats + diag_meta(iLookDIAG%numSteps) = var_info('numSteps' , 'number of steps taken by the integrator' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%numResEvals) = var_info('numResEvals' , 'number of residual evaluations' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%numLinSolvSetups) = var_info('numLinSolvSetups' , 'number of linear solver setups' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%numErrTestFails) = var_info('numErrTestFails' , 'number of error test failures' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%kLast) = var_info('kLast' , 'method order used on the last internal step' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%kCur) = var_info('kCur' , 'method order to be used on the next internal step' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%hInitUsed) = var_info('hInitUsed' , 'step size used on the first internal step' , 's' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%hLast) = var_info('hLast' , 'step size used on the last internal step' , 's' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%hCur) = var_info('hCur' , 'step size to be used on the next internal step' , 's' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%tCur) = var_info('tCur' , 'current time reached by the integrator' , 's' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + + ! ----- + ! * local model fluxes... + ! ----------------------- + ! net energy and mass fluxes for the vegetation domain + flux_meta(iLookFLUX%scalarCanairNetNrgFlux) = var_info('scalarCanairNetNrgFlux' , 'net energy flux for the canopy air space' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarCanopyNetNrgFlux) = var_info('scalarCanopyNetNrgFlux' , 'net energy flux for the vegetation canopy' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarGroundNetNrgFlux) = var_info('scalarGroundNetNrgFlux' , 'net energy flux for the ground surface' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarCanopyNetLiqFlux) = var_info('scalarCanopyNetLiqFlux' , 'net liquid water flux for the vegetation canopy' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! forcing + flux_meta(iLookFLUX%scalarRainfall) = var_info('scalarRainfall' , 'computed rainfall rate' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarSnowfall) = var_info('scalarSnowfall' , 'computed snowfall rate' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! shortwave radiation + flux_meta(iLookFLUX%spectralIncomingDirect) = var_info('spectralIncomingDirect' , 'incoming direct solar radiation in each wave band' , 'W m-2' , get_ixVarType('wLength'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%spectralIncomingDiffuse) = var_info('spectralIncomingDiffuse' , 'incoming diffuse solar radiation in each wave band' , 'W m-2' , get_ixVarType('wLength'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarCanopySunlitPAR) = var_info('scalarCanopySunlitPAR' , 'average absorbed par for sunlit leaves' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarCanopyShadedPAR) = var_info('scalarCanopyShadedPAR' , 'average absorbed par for shaded leaves' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%spectralBelowCanopyDirect) = var_info('spectralBelowCanopyDirect' , 'downward direct flux below veg layer for each spectral band' , 'W m-2' , get_ixVarType('wLength'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%spectralBelowCanopyDiffuse) = var_info('spectralBelowCanopyDiffuse' , 'downward diffuse flux below veg layer for each spectral band' , 'W m-2' , get_ixVarType('wLength'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarBelowCanopySolar) = var_info('scalarBelowCanopySolar' , 'solar radiation transmitted below the canopy' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarCanopyAbsorbedSolar) = var_info('scalarCanopyAbsorbedSolar' , 'solar radiation absorbed by canopy' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarGroundAbsorbedSolar) = var_info('scalarGroundAbsorbedSolar' , 'solar radiation absorbed by ground' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! longwave radiation + flux_meta(iLookFLUX%scalarLWRadCanopy) = var_info('scalarLWRadCanopy' , 'longwave radiation emitted from the canopy' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarLWRadGround) = var_info('scalarLWRadGround' , 'longwave radiation emitted at the ground surface' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarLWRadUbound2Canopy) = var_info('scalarLWRadUbound2Canopy' , 'downward atmospheric longwave radiation absorbed by the canopy' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarLWRadUbound2Ground) = var_info('scalarLWRadUbound2Ground' , 'downward atmospheric longwave radiation absorbed by the ground' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarLWRadUbound2Ubound) = var_info('scalarLWRadUbound2Ubound' , 'atmospheric radiation refl by ground + lost thru upper boundary' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarLWRadCanopy2Ubound) = var_info('scalarLWRadCanopy2Ubound' , 'longwave radiation emitted from canopy lost thru upper boundary' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarLWRadCanopy2Ground) = var_info('scalarLWRadCanopy2Ground' , 'longwave radiation emitted from canopy absorbed by the ground' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarLWRadCanopy2Canopy) = var_info('scalarLWRadCanopy2Canopy' , 'canopy longwave reflected from ground and absorbed by the canopy' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarLWRadGround2Ubound) = var_info('scalarLWRadGround2Ubound' , 'longwave radiation emitted from ground lost thru upper boundary' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarLWRadGround2Canopy) = var_info('scalarLWRadGround2Canopy' , 'longwave radiation emitted from ground and absorbed by the canopy', 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarLWNetCanopy) = var_info('scalarLWNetCanopy' , 'net longwave radiation at the canopy' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarLWNetGround) = var_info('scalarLWNetGround' , 'net longwave radiation at the ground surface' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarLWNetUbound) = var_info('scalarLWNetUbound' , 'net longwave radiation at the upper atmospheric boundary' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! turbulent heat transfer + flux_meta(iLookFLUX%scalarEddyDiffusCanopyTop) = var_info('scalarEddyDiffusCanopyTop' , 'eddy diffusivity for heat at the top of the canopy' , 'm2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarFrictionVelocity) = var_info('scalarFrictionVelocity' , 'friction velocity (canopy momentum sink)' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarWindspdCanopyTop) = var_info('scalarWindspdCanopyTop' , 'windspeed at the top of the canopy' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarWindspdCanopyBottom) = var_info('scalarWindspdCanopyBottom' , 'windspeed at the height of the bottom of the canopy' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarGroundResistance) = var_info('scalarGroundResistance' , 'below canopy aerodynamic resistance' , 's m-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarCanopyResistance) = var_info('scalarCanopyResistance' , 'above canopy aerodynamic resistance' , 's m-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarLeafResistance) = var_info('scalarLeafResistance' , 'mean leaf boundary layer resistance per unit leaf area' , 's m-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarSoilResistance) = var_info('scalarSoilResistance' , 'soil surface resistance' , 's m-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarSenHeatTotal) = var_info('scalarSenHeatTotal' , 'sensible heat from the canopy air space to the atmosphere' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarSenHeatCanopy) = var_info('scalarSenHeatCanopy' , 'sensible heat from the canopy to the canopy air space' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarSenHeatGround) = var_info('scalarSenHeatGround' , 'sensible heat from the ground (below canopy or non-vegetated)' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarLatHeatTotal) = var_info('scalarLatHeatTotal' , 'latent heat from the canopy air space to the atmosphere' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarLatHeatCanopyEvap) = var_info('scalarLatHeatCanopyEvap' , 'evaporation latent heat from the canopy to the canopy air space' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarLatHeatCanopyTrans) = var_info('scalarLatHeatCanopyTrans' , 'transpiration latent heat from the canopy to the canopy air space', 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarLatHeatGround) = var_info('scalarLatHeatGround' , 'latent heat from the ground (below canopy or non-vegetated)' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarCanopyAdvectiveHeatFlux) = var_info('scalarCanopyAdvectiveHeatFlux' , 'heat advected to the canopy with precipitation (snow + rain)' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarGroundAdvectiveHeatFlux) = var_info('scalarGroundAdvectiveHeatFlux' , 'heat advected to the ground with throughfall + unloading/drainage', 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarCanopySublimation) = var_info('scalarCanopySublimation' , 'canopy sublimation/frost' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarSnowSublimation) = var_info('scalarSnowSublimation' , 'snow sublimation/frost (below canopy or non-vegetated)' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! liquid water fluxes associated with evapotranspiration + flux_meta(iLookFLUX%scalarStomResistSunlit) = var_info('scalarStomResistSunlit' , 'stomatal resistance for sunlit leaves' , 's m-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarStomResistShaded) = var_info('scalarStomResistShaded' , 'stomatal resistance for shaded leaves' , 's m-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarPhotosynthesisSunlit) = var_info('scalarPhotosynthesisSunlit' , 'sunlit photosynthesis' , 'umolco2 m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarPhotosynthesisShaded) = var_info('scalarPhotosynthesisShaded' , 'shaded photosynthesis' , 'umolco2 m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarCanopyTranspiration) = var_info('scalarCanopyTranspiration' , 'canopy transpiration' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarCanopyEvaporation) = var_info('scalarCanopyEvaporation' , 'canopy evaporation/condensation' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarGroundEvaporation) = var_info('scalarGroundEvaporation' , 'ground evaporation/condensation (below canopy or non-vegetated)' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%mLayerTranspire) = var_info('mLayerTranspire' , 'transpiration loss from each soil layer' , 'm s-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + ! liquid and solid water fluxes through the canopy + flux_meta(iLookFLUX%scalarThroughfallSnow) = var_info('scalarThroughfallSnow' , 'snow that reaches the ground without ever touching the canopy' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarThroughfallRain) = var_info('scalarThroughfallRain' , 'rain that reaches the ground without ever touching the canopy' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarCanopySnowUnloading) = var_info('scalarCanopySnowUnloading' , 'unloading of snow from the vegetation canopy' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarCanopyLiqDrainage) = var_info('scalarCanopyLiqDrainage' , 'drainage of liquid water from the vegetation canopy' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarCanopyMeltFreeze) = var_info('scalarCanopyMeltFreeze' , 'melt/freeze of water stored in the canopy' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! energy fluxes and for the snow and soil domains + flux_meta(iLookFLUX%iLayerConductiveFlux) = var_info('iLayerConductiveFlux' , 'conductive energy flux at layer interfaces' , 'W m-2' , get_ixVarType('ifcToto'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%iLayerAdvectiveFlux) = var_info('iLayerAdvectiveFlux' , 'advective energy flux at layer interfaces' , 'W m-2' , get_ixVarType('ifcToto'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%iLayerNrgFlux) = var_info('iLayerNrgFlux' , 'energy flux at layer interfaces' , 'W m-2' , get_ixVarType('ifcToto'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%mLayerNrgFlux) = var_info('mLayerNrgFlux' , 'net energy flux for each layer within the snow+soil domain' , 'J m-3 s-1' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + ! liquid water fluxes for the snow domain + flux_meta(iLookFLUX%scalarSnowDrainage) = var_info('scalarSnowDrainage' , 'drainage from the bottom of the snow profile' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%iLayerLiqFluxSnow) = var_info('iLayerLiqFluxSnow' , 'liquid flux at snow layer interfaces' , 'm s-1' , get_ixVarType('ifcSnow'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%mLayerLiqFluxSnow) = var_info('mLayerLiqFluxSnow' , 'net liquid water flux for each snow layer' , 's-1' , get_ixVarType('midSnow'), iMissVec, iMissVec, .false.) + ! liquid water fluxes for the soil domain + flux_meta(iLookFLUX%scalarRainPlusMelt) = var_info('scalarRainPlusMelt' , 'rain plus melt, used as input to soil before surface runoff' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarMaxInfilRate) = var_info('scalarMaxInfilRate' , 'maximum infiltration rate' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarInfiltration) = var_info('scalarInfiltration' , 'infiltration of water into the soil profile' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarExfiltration) = var_info('scalarExfiltration' , 'exfiltration of water from the top of the soil profile' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarSurfaceRunoff) = var_info('scalarSurfaceRunoff' , 'surface runoff' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarSurfaceRunoff_IE) = var_info('scalarSurfaceRunoff_IE' , 'infiltration excess surface runoff' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarSurfaceRunoff_SE) = var_info('scalarSurfaceRunoff_SE' , 'saturation excess surface runoff' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%mLayerSatHydCondMP) = var_info('mLayerSatHydCondMP' , 'saturated hydraulic conductivity of macropores in each layer' , 'm s-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%mLayerSatHydCond) = var_info('mLayerSatHydCond' , 'saturated hydraulic conductivity in each layer' , 'm s-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%iLayerSatHydCond) = var_info('iLayerSatHydCond' , 'saturated hydraulic conductivity in each layer interface' , 'm s-1' , get_ixVarType('ifcSoil'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%mLayerHydCond) = var_info('mLayerHydCond' , 'hydraulic conductivity in each layer' , 'm s-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%iLayerLiqFluxSoil) = var_info('iLayerLiqFluxSoil' , 'liquid flux at soil layer interfaces' , 'm s-1' , get_ixVarType('ifcSoil'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%mLayerLiqFluxSoil) = var_info('mLayerLiqFluxSoil' , 'net liquid water flux for each soil layer' , 's-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%mLayerBaseflow) = var_info('mLayerBaseflow' , 'baseflow from each soil layer' , 'm s-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%mLayerColumnInflow) = var_info('mLayerColumnInflow' , 'total inflow to each layer in a given soil column' , 'm3 s-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%mLayerColumnOutflow) = var_info('mLayerColumnOutflow' , 'total outflow from each layer in a given soil column' , 'm3 s-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarSoilBaseflow) = var_info('scalarSoilBaseflow' , 'total baseflow from the soil profile' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarSoilDrainage) = var_info('scalarSoilDrainage' , 'drainage from the bottom of the soil profile' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarAquiferRecharge) = var_info('scalarAquiferRecharge' , 'recharge to the aquifer' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarAquiferTranspire) = var_info('scalarAquiferTranspire' , 'transpiration loss from the aquifer' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarAquiferBaseflow) = var_info('scalarAquiferBaseflow' , 'baseflow from the aquifer' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! derived variables + flux_meta(iLookFLUX%scalarTotalET) = var_info('scalarTotalET' , 'total ET' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarTotalRunoff) = var_info('scalarTotalRunoff' , 'total runoff' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + flux_meta(iLookFLUX%scalarNetRadiation) = var_info('scalarNetRadiation' , 'net radiation' , 'W m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! ----- + ! * local flux derivatives... + ! --------------------------- + ! derivatives in net vegetation energy fluxes w.r.t. relevant state variables + deriv_meta(iLookDERIV%dCanairNetFlux_dCanairTemp) = var_info('dCanairNetFlux_dCanairTemp' , 'derivative in net canopy air space flux w.r.t. canopy air temperature', 'W m-2 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dCanairNetFlux_dCanopyTemp) = var_info('dCanairNetFlux_dCanopyTemp' , 'derivative in net canopy air space flux w.r.t. canopy temperature' , 'W m-2 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dCanairNetFlux_dGroundTemp) = var_info('dCanairNetFlux_dGroundTemp' , 'derivative in net canopy air space flux w.r.t. ground temperature' , 'W m-2 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dCanopyNetFlux_dCanairTemp) = var_info('dCanopyNetFlux_dCanairTemp' , 'derivative in net canopy flux w.r.t. canopy air temperature' , 'W m-2 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dCanopyNetFlux_dCanopyTemp) = var_info('dCanopyNetFlux_dCanopyTemp' , 'derivative in net canopy flux w.r.t. canopy temperature' , 'W m-2 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dCanopyNetFlux_dGroundTemp) = var_info('dCanopyNetFlux_dGroundTemp' , 'derivative in net canopy flux w.r.t. ground temperature' , 'W m-2 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dCanopyNetFlux_dCanWat) = var_info('dCanopyNetFlux_dCanWat' , 'derivative in net canopy fluxes w.r.t. canopy total water content' , 'J kg-1 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dGroundNetFlux_dCanairTemp) = var_info('dGroundNetFlux_dCanairTemp' , 'derivative in net ground flux w.r.t. canopy air temperature' , 'W m-2 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dGroundNetFlux_dCanopyTemp) = var_info('dGroundNetFlux_dCanopyTemp' , 'derivative in net ground flux w.r.t. canopy temperature' , 'W m-2 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dGroundNetFlux_dGroundTemp) = var_info('dGroundNetFlux_dGroundTemp' , 'derivative in net ground flux w.r.t. ground temperature' , 'W m-2 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dGroundNetFlux_dCanWat) = var_info('dGroundNetFlux_dCanWat' , 'derivative in net ground fluxes w.r.t. canopy total water content' , 'J kg-1 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! derivatives in evaporative fluxes w.r.t. relevant state variables + deriv_meta(iLookDERIV%dCanopyEvaporation_dTCanair) = var_info('dCanopyEvaporation_dTCanair' , 'derivative in canopy evaporation w.r.t. canopy air temperature' , 'kg m-2 s-1 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dCanopyEvaporation_dTCanopy) = var_info('dCanopyEvaporation_dTCanopy' , 'derivative in canopy evaporation w.r.t. canopy temperature' , 'kg m-2 s-1 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dCanopyEvaporation_dTGround) = var_info('dCanopyEvaporation_dTGround' , 'derivative in canopy evaporation w.r.t. ground temperature' , 'kg m-2 s-1 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dCanopyEvaporation_dCanWat) = var_info('dCanopyEvaporation_dCanWat' , 'derivative in canopy evaporation w.r.t. canopy total water content' , 's-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dGroundEvaporation_dTCanair) = var_info('dGroundEvaporation_dTCanair' , 'derivative in ground evaporation w.r.t. canopy air temperature' , 'kg m-2 s-1 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dGroundEvaporation_dTCanopy) = var_info('dGroundEvaporation_dTCanopy' , 'derivative in ground evaporation w.r.t. canopy temperature' , 'kg m-2 s-1 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dGroundEvaporation_dTGround) = var_info('dGroundEvaporation_dTGround' , 'derivative in ground evaporation w.r.t. ground temperature' , 'kg m-2 s-1 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dGroundEvaporation_dCanWat) = var_info('dGroundEvaporation_dCanWat' , 'derivative in ground evaporation w.r.t. canopy total water content' , 's-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! derivatives in transpiration + deriv_meta(iLookDERIV%dCanopyTrans_dTCanair) = var_info('dCanopyTrans_dTCanair' , 'derivative in canopy transpiration w.r.t. canopy air temperature' , 'kg m-2 s-1 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dCanopyTrans_dTCanopy) = var_info('dCanopyTrans_dTCanopy' , 'derivative in canopy transpiration w.r.t. canopy temperature' , 'kg m-2 s-1 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dCanopyTrans_dTGround) = var_info('dCanopyTrans_dTGround' , 'derivative in canopy transpiration w.r.t. ground temperature' , 'kg m-2 s-1 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dCanopyTrans_dCanWat) = var_info('dCanopyTrans_dCanWat' , 'derivative in canopy transpiration w.r.t. canopy total water content' , 's-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! derivatives in canopy water w.r.t canopy temperature + deriv_meta(iLookDERIV%dTheta_dTkCanopy) = var_info('dTheta_dTkCanopy' , 'derivative of volumetric liquid water content w.r.t. temperature' , 'K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%d2Theta_dTkCanopy2) = var_info('d2Theta_dTkCanopy2' , 'second derivative of volumetric liquid water content w.r.t. temperature', 'K-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dCanLiq_dTcanopy) = var_info('dCanLiq_dTcanopy' , 'derivative of canopy liquid storage w.r.t. temperature' , 'kg m-2 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dFracLiqVeg_dTkCanopy) = var_info('dFracLiqVeg_dTkCanopy' , 'derivative in fraction of (throughfall + drainage) w.r.t. temperature', 'K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! derivatives in canopy liquid fluxes w.r.t. canopy water + deriv_meta(iLookDERIV%scalarCanopyLiqDeriv) = var_info('scalarCanopyLiqDeriv' , 'derivative in (throughfall + drainage) w.r.t. canopy liquid water' , 's-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%scalarThroughfallRainDeriv) = var_info('scalarThroughfallRainDeriv' , 'derivative in throughfall w.r.t. canopy liquid water' , 's-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%scalarCanopyLiqDrainageDeriv) = var_info('scalarCanopyLiqDrainageDeriv' , 'derivative in canopy drainage w.r.t. canopy liquid water' , 's-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! energy derivatives that might be treated as constant if heat capacity and thermal conductivity not updated + deriv_meta(iLookDERIV%dVolHtCapBulk_dPsi0) = var_info('dVolHtCapBulk_dPsi0' , 'derivative in bulk heat capacity w.r.t. matric potential' , 'J m-4 K-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dVolHtCapBulk_dTheta) = var_info('dVolHtCapBulk_dTheta' , 'derivative in bulk heat capacity w.r.t. volumetric water content' , 'J m-3 K-1' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dVolHtCapBulk_dCanWat) = var_info('dVolHtCapBulk_dCanWat' , 'derivative in bulk heat capacity w.r.t. canopy volumetric water content', 'J m-3 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dVolHtCapBulk_dTk) = var_info('dVolHtCapBulk_dTk' , 'derivative in bulk heat capacity w.r.t. temperature' , 'J m-3 K-2' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dVolHtCapBulk_dTkCanopy) = var_info('dVolHtCapBulk_dTkCanopy' , 'derivative in bulk heat capacity w.r.t. canopy temperature' , 'J m-3 K-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dThermalC_dTempAbove) = var_info('dThermalC_dTempAbove' , 'derivative in the thermal conductivity w.r.t. energy in the layer above','J m-2 s-1 K-1' , get_ixVarType('ifcToto'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dThermalC_dTempBelow) = var_info('dThermalC_dTempBelow' , 'derivative in the thermal conductivity w.r.t. energy in the layer above','J m-2 s-1 K-1' , get_ixVarType('ifcToto'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dThermalC_dWatAbove) = var_info('dThermalC_dWatAbove' , 'derivative in the thermal conductivity w.r.t. water in the layer above', 'unknown' , get_ixVarType('ifcToto'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dThermalC_dWatBelow) = var_info('dThermalC_dWatBelow' , 'derivative in the thermal conductivity w.r.t. water in the layer above', 'unknown' , get_ixVarType('ifcToto'), iMissVec, iMissVec, .false.) + ! energy derivatives that might be treated as constant if Cm not updated + deriv_meta(iLookDERIV%dCm_dPsi0) = var_info('dCm_dPsi0' , 'derivative in Cm w.r.t. matric potential' , 'J kg K-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dCm_dTk) = var_info('dCm_dTk' , 'derivative in Cm w.r.t. temperature' , 'J kg K-2' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dCm_dTkCanopy) = var_info('dCm_dTkCanopy' , 'derivative in Cm w.r.t. canopy temperature' , 'J kg K-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! derivatives in energy fluxes at the interface of snow+soil layers w.r.t. temperature in layers above and below + deriv_meta(iLookDERIV%dNrgFlux_dTempAbove) = var_info('dNrgFlux_dTempAbove' , 'derivatives in the flux w.r.t. temperature in the layer above' , 'J m-2 s-1 K-1' , get_ixVarType('ifcToto'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dNrgFlux_dTempBelow) = var_info('dNrgFlux_dTempBelow' , 'derivatives in the flux w.r.t. temperature in the layer below' , 'J m-2 s-1 K-1' , get_ixVarType('ifcToto'), iMissVec, iMissVec, .false.) + ! derivatives in energy fluxes at the interface of snow+soil layers w.r.t. water state in layers above and below + deriv_meta(iLookDERIV%dNrgFlux_dWatAbove) = var_info('dNrgFlux_dWatAbove' , 'derivatives in the flux w.r.t. water state in the layer above' , 'unknown' , get_ixVarType('ifcToto'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dNrgFlux_dWatBelow) = var_info('dNrgFlux_dWatBelow' , 'derivatives in the flux w.r.t. water state in the layer below' , 'unknown' , get_ixVarType('ifcToto'), iMissVec, iMissVec, .false.) + ! derivative in liquid water fluxes at the interface of snow layers w.r.t. volumetric liquid water content in the layer above + deriv_meta(iLookDERIV%iLayerLiqFluxSnowDeriv) = var_info('iLayerLiqFluxSnowDeriv' , 'derivative in vertical liquid water flux at layer interfaces' , 'm s-1' , get_ixVarType('ifcSnow'), iMissVec, iMissVec, .false.) + ! derivative in liquid water fluxes for the soil domain w.r.t hydrology state variables + deriv_meta(iLookDERIV%dVolTot_dPsi0) = var_info('dVolTot_dPsi0' , 'derivative in total water content w.r.t. total water matric potential', 'm-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%d2VolTot_dPsi02) = var_info('d2VolTot_dPsi02' , 'second derivative in total water content w.r.t. total water matric potential', 'm-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dCompress_dPsi) = var_info('dCompress_dPsi' , 'derivative in compressibility w.r.t matric head' , 'm-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%mLayerdTheta_dPsi) = var_info('mLayerdTheta_dPsi' , 'derivative in the soil water characteristic w.r.t. psi' , 'm-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%mLayerdPsi_dTheta) = var_info('mLayerdPsi_dTheta' , 'derivative in the soil water characteristic w.r.t. theta' , 'm' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dq_dHydStateAbove) = var_info('dq_dHydStateAbove' , 'change in flux at layer interfaces w.r.t. states in the layer above' , 'unknown' , get_ixVarType('ifcSoil'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dq_dHydStateBelow) = var_info('dq_dHydStateBelow' , 'change in flux at layer interfaces w.r.t. states in the layer below' , 'unknown' , get_ixVarType('ifcSoil'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dq_dHydStateLayerSurfVec) = var_info('dq_dHydStateLayerSurfVec' , 'change in the flux in soil surface interface w.r.t. state variables in layers','unknown' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + ! derivative in baseflow flux w.r.t. aquifer storage + deriv_meta(iLookDERIV%dBaseflow_dAquifer) = var_info('dBaseflow_dAquifer' , 'derivative in baseflow flux w.r.t. aquifer storage' , 's-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! derivative in liquid water fluxes for the soil domain w.r.t energy state variables + deriv_meta(iLookDERIV%dq_dNrgStateAbove) = var_info('dq_dNrgStateAbove' , 'change in flux at layer interfaces w.r.t. states in the layer above' , 'unknown' , get_ixVarType('ifcSoil'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dq_dNrgStateBelow) = var_info('dq_dNrgStateBelow' , 'change in flux at layer interfaces w.r.t. states in the layer below' , 'unknown' , get_ixVarType('ifcSoil'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dq_dNrgStateLayerSurfVec) = var_info('dq_dNrgStateLayerSurfVec' , 'change in the flux in soil surface interface w.r.t. state variables in layers','unknown' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dPsiLiq_dTemp) = var_info('dPsiLiq_dTemp' , 'derivative in the liquid water matric potential w.r.t. temperature' , 'm K-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dPsiLiq_dPsi0) = var_info('dPsiLiq_dPsi0' , 'derivative in liquid matric potential w.r.t. total matric potential' , '-' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + ! derivatives in soil transpiration w.r.t. canopy state variables + deriv_meta(iLookDERIV%mLayerdTrans_dTCanair) = var_info('mLayerdTrans_dTCanair' , 'derivatives in the soil layer transpiration flux w.r.t. canopy air temperature','m s-1 K-1',get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%mLayerdTrans_dTCanopy) = var_info('mLayerdTrans_dTCanopy' , 'derivatives in the soil layer transpiration flux w.r.t. canopy temperature', 'm s-1 K-1' ,get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%mLayerdTrans_dTGround) = var_info('mLayerdTrans_dTGround' , 'derivatives in the soil layer transpiration flux w.r.t. ground temperature', 'm s-1 K-1' ,get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%mLayerdTrans_dCanWat) = var_info('mLayerdTrans_dCanWat' , 'derivatives in the soil layer transpiration flux w.r.t. canopy total water','m-1 s-1 kg-1' ,get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + ! derivatives in aquifer transpiration w.r.t. canopy state variables + deriv_meta(iLookDERIV%dAquiferTrans_dTCanair) = var_info('dAquiferTrans_dTCanair' , 'derivative in the aquifer transpiration flux w.r.t. canopy air temperature','m s-1 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dAquiferTrans_dTCanopy) = var_info('dAquiferTrans_dTCanopy' , 'derivative in the aquifer transpiration flux w.r.t. canopy temperature', 'm s-1 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dAquiferTrans_dTGround) = var_info('dAquiferTrans_dTGround' , 'derivative in the aquifer transpiration flux w.r.t. ground temperature', 'm s-1 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dAquiferTrans_dCanWat) = var_info('dAquiferTrans_dCanWat' , 'derivative in the aquifer transpiration flux w.r.t. canopy total water', 'm-1 s-1 kg-1', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! derivative in liquid water fluxes for the soil and snow domain w.rt temperature + deriv_meta(iLookDERIV%dFracLiqWat_dTk) = var_info('dFracLiqWat_dTk' , 'derivative in fraction of liquid water w.r.t. temperature' , 'K-1' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%mLayerdTheta_dTk) = var_info('mLayerdTheta_dTk' , 'derivative of volumetric liquid water content w.r.t. temperature' , 'K-1' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%mLayerd2Theta_dTk2) = var_info('mLayerd2Theta_dTk2' , 'second derivative of volumetric liquid water content w.r.t. temperature','K-2' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + ! derivatives in time + deriv_meta(iLookDERIV%mLayerdTemp_dt) = var_info('mLayerdTemp_dt' , 'timestep change in layer temperature' , 'K s-1' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%scalarCanopydTemp_dt) = var_info('scalarCanopydTemp_dt' , 'timestep change in canopy temperature' , 'K s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%mLayerdWat_dt) = var_info('mLayerdWat_dt' , 'timestep change in layer volumetric fraction of total water' , 's-1' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%scalarCanopydWat_dt) = var_info('scalarCanopydWat_dt' , 'timestep change in canopy water content' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! derivatives of temperature if enthalpy is the state variable + deriv_meta(iLookDERIV%dCanairTemp_dEnthalpy) = var_info('dCanairTemp_dEnthalpy' , 'derivative of canopy air temperature w.r.t. enthalpy' , 'K J-1 m3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dCanopyTemp_dEnthalpy) = var_info('dCanopyTemp_dEnthalpy' , 'derivative of canopy temperature w.r.t. enthalpy' , 'K J-1 m3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dTemp_dEnthalpy) = var_info('dTemp_dEnthalpy' , 'derivative of temperature w.r.t. enthalpy' , 'K J-1 m3' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dCanopyTemp_dCanWat) = var_info('dCanopyTemp_dCanWat' , 'derivative of canopy temperature w.r.t. volumetric water content' , 'K' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dTemp_dTheta) = var_info('dTemp_dTheta' , 'derivative of temperature w.r.t. volumetric water content' , 'K' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + deriv_meta(iLookDERIV%dTemp_dPsi0) = var_info('dTemp_dPsi0' , 'derivative of temperature w.r.t. total water matric potential' , 'K m-1' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + + + ! ----- + ! * basin-wide runoff and aquifer fluxes... + ! ----------------------------------------- + bvar_meta(iLookBVAR%basin__TotalArea) = var_info('basin__TotalArea' , 'total basin area' , 'm2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%basin__SurfaceRunoff) = var_info('basin__SurfaceRunoff' , 'surface runoff' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%basin__ColumnOutflow) = var_info('basin__ColumnOutflow' , 'outflow from all "outlet" HRUs (with no downstream HRU)', 'm3 s-1', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%basin__AquiferStorage) = var_info('basin__AquiferStorage' , 'aquifer storage' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%basin__AquiferRecharge) = var_info('basin__AquiferRecharge' , 'recharge to the aquifer' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%basin__AquiferBaseflow) = var_info('basin__AquiferBaseflow' , 'baseflow from the aquifer' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%basin__AquiferTranspire) = var_info('basin__AquiferTranspire', 'transpiration loss from the aquifer' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%basin__TotalRunoff) = var_info('basin__TotalRunoff' , 'total runoff to channel from all active components' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%basin__SoilDrainage) = var_info('basin__SoilDrainage' , 'soil drainage' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%routingRunoffFuture) = var_info('routingRunoffFuture' , 'runoff in future time steps' , 'm s-1' , get_ixVarType('routing'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%routingFractionFuture) = var_info('routingFractionFuture' , 'fraction of runoff in future time steps' , '-' , get_ixVarType('routing'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%averageInstantRunoff) = var_info('averageInstantRunoff' , 'instantaneous runoff' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%averageRoutedRunoff) = var_info('averageRoutedRunoff' , 'routed runoff' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! ----- + ! * temperature and enthalpy lookup tables... + ! ------------------------------------------- + lookup_meta(iLookLOOKUP%temperature) = var_info('temperature' , 'value of temperature in the lookup table' , 'K' , get_ixVarType('unknown'), iMissVec, iMissVec, .false.) + lookup_meta(iLookLOOKUP%psiLiq_int) = var_info('psiLiq_int' , 'value of integral of mLayerPsiLiq in the lookup table' , 'K' , get_ixVarType('unknown'), iMissVec, iMissVec, .false.) + lookup_meta(iLookLOOKUP%deriv2) = var_info('deriv2' , 'second derivatives of the interpolating function' , 'mixed' , get_ixVarType('unknown'), iMissVec, iMissVec, .false.) + ! ----- + ! * model indices... + ! ------------------ + ! number of model layers, and layer indices + indx_meta(iLookINDEX%nSnow) = var_info('nSnow' , 'number of snow layers' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%nSoil) = var_info('nSoil' , 'number of soil layers' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%nLayers) = var_info('nLayers' , 'total number of layers' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%layerType) = var_info('layerType' , 'index defining type of layer (snow or soil)' , '-', get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + ! number of state variables of different type + indx_meta(iLookINDEX%nCasNrg) = var_info('nCasNrg' , 'number of energy state variables for the canopy air space' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%nVegNrg) = var_info('nVegNrg' , 'number of energy state variables for the vegetation canopy' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%nVegMass) = var_info('nVegMass' , 'number of hydrology states for vegetation (mass of water)' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%nVegState) = var_info('nVegState' , 'number of vegetation state variables' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%nNrgState) = var_info('nNrgState' , 'number of energy state variables' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%nWatState) = var_info('nWatState' , 'number of "total water" states (vol. total water content)' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%nMatState) = var_info('nMatState' , 'number of matric head state variables' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%nMassState) = var_info('nMassState' , 'number of hydrology state variables (mass of water)' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%nState) = var_info('nState' , 'total number of model state variables' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! number of state variables within different domains in the snow+soil system + indx_meta(iLookINDEX%nSnowSoilNrg) = var_info('nSnowSoilNrg' , 'number of energy states in the snow+soil domain' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%nSnowOnlyNrg) = var_info('nSnowOnlyNrg' , 'number of energy states in the snow domain' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%nSoilOnlyNrg) = var_info('nSoilOnlyNrg' , 'number of energy states in the soil domain' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%nSnowSoilHyd) = var_info('nSnowSoilHyd' , 'number of hydrology states in the snow+soil domain' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%nSnowOnlyHyd) = var_info('nSnowOnlyHyd' , 'number of hydrology states in the snow domain' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%nSoilOnlyHyd) = var_info('nSoilOnlyHyd' , 'number of hydrology states in the soil domain' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! type of model state variables + indx_meta(iLookINDEX%ixControlVolume) = var_info('ixControlVolume' , 'index of the control volume for different domains (veg, snow, soil)' , '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%ixDomainType) = var_info('ixDomainType' , 'index of the type of domain (iname_veg, iname_snow, iname_soil)' , '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%ixStateType) = var_info('ixStateType' , 'index of the type of every state variable (iname_nrgCanair, ...)' , '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%ixHydType) = var_info('ixHydType' , 'index of the type of hydrology states in snow+soil domain' , '-', get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + ! type of model state variables (state subset) + indx_meta(iLookINDEX%ixDomainType_subset) = var_info('ixDomainType_subset' , '[state subset] id of domain for desired model state variables' , '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%ixStateType_subset) = var_info('ixStateType_subset' , '[state subset] type of desired model state variables' , '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) + ! mapping between state subset and the full state vector + indx_meta(iLookINDEX%ixMapFull2Subset) = var_info('ixMapFull2Subset' , 'list of indices of the state subset in the full state vector' , '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%ixMapSubset2Full) = var_info('ixMapSubset2Full' , 'list of indices of the full state vector in the state subset' , '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) + ! indices of model specific state variables + indx_meta(iLookINDEX%ixCasNrg) = var_info('ixCasNrg' , 'index of canopy air space energy state variable' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%ixVegNrg) = var_info('ixVegNrg' , 'index of canopy energy state variable' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%ixVegHyd) = var_info('ixVegHyd' , 'index of canopy hydrology state variable (mass)' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%ixTopNrg) = var_info('ixTopNrg' , 'index of upper-most energy state in the snow+soil subdomain' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%ixTopHyd) = var_info('ixTopHyd' , 'index of upper-most hydrology state in the snow+soil subdomain' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%ixAqWat) = var_info('ixAqWat' , 'index of storage of water in the aquifer' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! vectors of indices for specific state types + indx_meta(iLookINDEX%ixNrgOnly) = var_info('ixNrgOnly' , 'indices IN THE STATE SUBSET for energy states' , '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%ixHydOnly) = var_info('ixHydOnly' , 'indices IN THE STATE SUBSET for hydrology states in the snow+soil domain', '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%ixMatOnly) = var_info('ixMatOnly' , 'indices IN THE STATE SUBSET for matric head state variables' , '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%ixMassOnly) = var_info('ixMassOnly' , 'indices IN THE STATE SUBSET for hydrology states (mass of water)' , '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) + ! vectors of indices for specific state types within specific sub-domains + indx_meta(iLookINDEX%ixSnowSoilNrg) = var_info('ixSnowSoilNrg' , 'indices IN THE STATE SUBSET for energy states in the snow+soil domain' , '-', get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%ixSnowOnlyNrg) = var_info('ixSnowOnlyNrg' , 'indices IN THE STATE SUBSET for energy states in the snow domain' , '-', get_ixVarType('midSnow'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%ixSoilOnlyNrg) = var_info('ixSoilOnlyNrg' , 'indices IN THE STATE SUBSET for energy states in the soil domain' , '-', get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%ixSnowSoilHyd) = var_info('ixSnowSoilHyd' , 'indices IN THE STATE SUBSET for hydrology states in the snow+soil domain', '-', get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%ixSnowOnlyHyd) = var_info('ixSnowOnlyHyd' , 'indices IN THE STATE SUBSET for hydrology states in the snow domain' , '-', get_ixVarType('midSnow'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%ixSoilOnlyHyd) = var_info('ixSoilOnlyHyd' , 'indices IN THE STATE SUBSET for hydrology states in the soil domain' , '-', get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + ! vectors of indices for specfic state types within specific sub-domains + indx_meta(iLookINDEX%ixNrgCanair) = var_info('ixNrgCanair' , 'indices IN THE FULL VECTOR for energy states in canopy air space domain' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%ixNrgCanopy) = var_info('ixNrgCanopy' , 'indices IN THE FULL VECTOR for energy states in the canopy domain' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%ixHydCanopy) = var_info('ixHydCanopy' , 'indices IN THE FULL VECTOR for hydrology states in the canopy domain' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%ixNrgLayer) = var_info('ixNrgLayer' , 'indices IN THE FULL VECTOR for energy states in the snow+soil domain' , '-', get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%ixHydLayer) = var_info('ixHydLayer' , 'indices IN THE FULL VECTOR for hydrology states in the snow+soil domain' , '-', get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%ixWatAquifer) = var_info('ixWatAquifer' , 'indices IN THE FULL VECTOR for storage of water in the aquifer' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + ! vectors of indices for specific state types IN SPECIFIC SUB-DOMAINS + indx_meta(iLookINDEX%ixVolFracWat) = var_info('ixVolFracWat' , 'indices IN THE SNOW+SOIL VECTOR for hyd states' , '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%ixMatricHead) = var_info('ixMatricHead' , 'indices IN THE SOIL VECTOR for hyd states' , '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) + ! indices within state vectors + indx_meta(iLookINDEX%ixAllState) = var_info('ixAllState' , 'list of indices for all model state variables' , '-', get_ixVarType('unknown'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%ixSoilState) = var_info('ixSoilState' , 'list of indices for all soil layers' , '-', get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%ixLayerState) = var_info('ixLayerState' , 'list of indices for all model layers' , '-', get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%ixLayerActive) = var_info('ixLayerActive' , 'list of indices for active model layers (inactive=integerMissing)' , '-', get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + ! number of trials + indx_meta(iLookINDEX%numberFluxCalc) = var_info('numberFluxCalc' , 'number of flux calculations' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%numberStateSplit) = var_info('numberStateSplit' , 'number of state splitting solutions' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%numberDomainSplitNrg) = var_info('numberDomainSplitNrg' , 'number of domain splitting solutions for energy' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%numberDomainSplitMass) = var_info('numberDomainSplitMass', 'number of domain splitting solutions for mass' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + indx_meta(iLookINDEX%numberScalarSolutions) = var_info('numberScalarSolutions', 'number of scalar solutions' , '-', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + + ! read file to define model output (modifies metadata structures) + call read_output_file(err,cmessage) + if (err.ne.0) message=trim(message)//trim(cmessage) + +end subroutine popMetadat + +! ------------------------------------------------ +! subroutine to populate write commands from file input +! ------------------------------------------------ +subroutine read_output_file(err,message) + USE netcdf + ! to get name of output control file from user + USE summaFileManager,only:SETTINGS_PATH ! path for metadata files + USE summaFileManager,only:OUTPUT_CONTROL ! file with output controls + ! some dimensional parameters + USE globalData, only:outFreq ! output frequencies + USE var_lookup, only:maxvarFreq ! maximum # of output files + USE var_lookup, only:maxvarStat ! maximum # of statistics + ! metadata structures + USE globalData, only: time_meta ! data structure for time metadata + USE globalData, only: forc_meta ! data structure for forcing metadata + USE globalData, only: type_meta ! data structure for categorical metadata + USE globalData, only: attr_meta ! data structure for attribute metadata + USE globalData, only: mpar_meta ! data structure for local parameter metadata + USE globalData, only: bpar_meta ! data structure for basin parameter metadata + USE globalData, only: bvar_meta ! data structure for basin model variable metadata + USE globalData, only: indx_meta ! data structure for index metadata + USE globalData, only: prog_meta ! data structure for local prognostic (state) variables + USE globalData, only: diag_meta ! data structure for local diagnostic variables + USE globalData, only: flux_meta ! data structure for local flux variables + USE globalData, only: deriv_meta ! data structure for local flux derivatives + USE globalData, only: outputPrecision ! data structure for output precision + USE globalData, only: outputCompressionLevel ! data structure for output netcdf deflate level + ! structures of named variables + USE var_lookup, only: iLookTYPE ! named variables for categorical data + USE var_lookup, only: iLookID ! named variables for hru and gru ID metadata + USE var_lookup, only: iLookFORCE ! named variables for forcing data structure + USE var_lookup, only: iLookINDEX ! named variables for index variable data structure + USE var_lookup, only: iLookSTAT ! named variables for statitics variable data structure + USE var_lookup, only: iLookFREQ ! named variables for model output frequencies + ! identify indices within structures + USE get_ixName_module,only:get_ixUnknown ! identify index in any structure + USE get_ixname_module,only:get_ixFreq ! identify index of model output frequency + USE get_ixname_module,only:get_ixStat ! identify index in ststistics structure + USE get_ixname_module,only:get_statName ! identify statistics name from the index + ! modules to read ASCII data + USE ascii_util_module,only:file_open ! open file + USE ascii_util_module,only:linewidth ! match character number for one line + USE ascii_util_module,only:get_vlines ! get a vector of non-comment lines + USE ascii_util_module,only:split_line ! split a line into words + implicit none + + ! dummy variables + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! define file format + integer(i4b),parameter :: noStatsDesired=1001 ! no statistic desired (temporally constant variables) + integer(i4b),parameter :: provideStatName=1002 ! provide the name of the desired statistic + integer(i4b),parameter :: provideStatFlags=1003 ! provide flags defining the desired statistic + integer(i4b) :: fileFormat ! the file format + ! define statistics flags + logical(lgt),dimension(maxvarStat) :: statFlag ! vector of statistics flags + character(len=32) :: statName ! name of desired statistic + integer(i4b) :: iStat ! index of statistics vector + ! define frequency of model output + character(len=64) :: freqName ! name of desired output frequency + integer(i4b) :: iFreq ! index of frequency vector + ! general local variables + character(LEN=256) :: cmessage ! error message of downwind routine + character(LEN=256) :: outfile ! full path of model output file + integer(i4b) :: unt ! file unit + character(LEN=linewidth),allocatable :: charlines(:) ! vector of character strings + character(LEN=64),allocatable :: lineWords(:) ! vector to parse textline + integer(i4b) :: nWords ! number of words in line + character(LEN=128) :: varName ! variable name + character(LEN=5) :: structName ! name of structure + integer(i4b) :: vLine ! index for loop through variables + integer(i4b) :: vDex ! index into type lists + + ! initialize error control + err=0; message='read_output_file/' + + ! ********************************************************************************************** + ! (1) open file and read variable data + ! ********************************************************************************************** + outfile = trim(SETTINGS_PATH)//trim(OUTPUT_CONTROL) ! build filename + call file_open(trim(outfile),unt,err,cmessage) ! open file if(err/=0)then; message=trim(message)//trim(cmessage); return; end if - nWords = size(lineWords) - - ! define variable name - varName = trim(lineWords(nameIndex)) - ! user cannot control time output - if (trim(varName)=='time') cycle - ! set precision if it is given - if (trim(varName)=='outputPrecision') then - statName = trim(lineWords(nWords)) - if (statName=='single' .or. statName=='float') then - outputPrecision = nf90_float - else if (statName=='double') then - outputPrecision = nf90_double - else - err=20 - cmessage='outputPrecision must be single, float, or double' - message=trim(message)//trim(cmessage)//trim(varName); - return - end if - cycle - end if - - ! set output netcdf file compression level if given. default is level 4. - if (trim(varName)=='outputCompressionLevel') then - statName = trim(lineWords(nWords)) - read(statName, *) outputCompressionLevel - if ((outputCompressionLevel .LT. 0) .or. (outputCompressionLevel .GT. 9)) then - err=20 - cmessage='outputCompressionLevel must be between 0 and 9.' - message=trim(message)//trim(cmessage)//trim(varName); - return + ! ********************************************************************************************** + ! (2) read variable data (continue reading from previous point in the file) + ! ********************************************************************************************** + ! read the rest of the lines + call get_vlines(unt,charLines,err,cmessage) ! get a list of character strings from non-comment lines + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + close(unt) ! close the file + + ! ********************************************************************************************** + ! (3) loop to parse individual file lines + ! ********************************************************************************************** + + ! initialize output frequency + outFreq(:) = .false. + + ! loop through the lines in the file + do vLine = 1,size(charLines) + + ! parse the current line + call split_line(charLines(vLine),lineWords,err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + nWords = size(lineWords) + + ! define variable name + varName = trim(lineWords(nameIndex)) + + ! user cannot control time output + if (trim(varName)=='time') cycle + ! set precision if it is given + if (trim(varName)=='outputPrecision') then + statName = trim(lineWords(nWords)) + if (statName=='single' .or. statName=='float') then + outputPrecision = nf90_float + else if (statName=='double') then + outputPrecision = nf90_double + else + err=20 + cmessage='outputPrecision must be single, float, or double' + message=trim(message)//trim(cmessage)//trim(varName); + return + end if + cycle end if - cycle - end if - ! --- variables with multiple statistics options -------------------------- - - ! identify the data structure for the given variable (structName) and the variable index (vDex) - call get_ixUnknown(trim(varName),structName,vDex,err,cmessage) - if (err/=0) then; message=trim(message)//trim(cmessage)//trim(varName); return; end if; + ! set output netcdf file compression level if given. default is level 4. + if (trim(varName)=='outputCompressionLevel') then + statName = trim(lineWords(nWords)) + read(statName, *) outputCompressionLevel + if ((outputCompressionLevel .LT. 0) .or. (outputCompressionLevel .GT. 9)) then + err=20 + cmessage='outputCompressionLevel must be between 0 and 9.' + message=trim(message)//trim(cmessage)//trim(varName); + return + end if + cycle + end if - ! id variables should not be specified in output control file - if (trim(structName)=='id')then - print*,'id variable requested in outputControl, will be skipped: variable='//trim(varName) - cycle - end if + ! --- variables with multiple statistics options -------------------------- - ! --- identify the desired frequency in the metadata structure ----------- + ! identify the data structure for the given variable (structName) and the variable index (vDex) + call get_ixUnknown(trim(varName),structName,vDex,err,cmessage) + if (err/=0) then; message=trim(message)//trim(cmessage)// ': deprecated variable name, remove from output file'; return; end if; - ! process time-varying variables - select case(trim(structName)) - case('indx','forc','prog','diag','flux','bvar','deriv') + ! id variables should not be specified in output control file + if (trim(structName)=='id')then + print*,'id variable requested in outputControl, will be skipped: variable='//trim(varName) + cycle + end if - ! * ensure that the frequency index exists for time varying variables - if(nWordsmaxvarFreq)then + message=trim(message)//'unable to identify desired output frequency for variable '//trim(varName)& + //' [entered "'//trim(freqName)//'"]' + err=20; return + endif + + ! time and temporally constant variables always outputted at timestep level (no aggregation) + case('bpar','attr','type','mpar','time') + if(nWords included for backwards compatibility + case(provideStatFlags) + ! get statistic name + statFlag(:) = .false. + do iStat = 1,maxVarStat + if (lineWords(freqIndex + 2*iStat)=='1') then + statFlag(iStat)=.true. + statName = get_statName(istat) + end if + end do + ! check actually defined the statistic (and only defined one statistic) + if(count(statFlag)/=1)then + message=trim(message)//'expect only one statistic is defined when using flags to define statistics'& + //': entered "'//trim(charLines(vLine))//'"' + err=20; return + endif + + ! check: should not get here since checked above + case default; err=20; message=trim(message)//'unexpected file format'; return end select - ! * check that we could find the index - if(iFreq<0 .or. iFreq>maxvarFreq)then - message=trim(message)//'unable to identify desired output frequency for variable '//trim(varName)& - //' [entered "'//trim(freqName)//'"]' - err=20; return + ! * get the statistics index + iStat = get_ixStat(trim(statName)) + if(iStat<0 .or. iStat>maxvarStat)then + message=trim(message)//'unable to identify desired statistic for variable '//trim(varName)& + //' [evaluating '//trim(statName)//']' + err=20; return endif - ! temporally constant variables use timestep-level output (no aggregation) - case default - message=trim(message)//'unable to identify desired output frequency for variable '//trim(varName)& - //' [entered "'//trim(freqName)//'"];'& - //' outputting variable in timestep file' - iFreq = iLookFREQ%timestep - freqName = 'timestep' - end select - - ! --- identify the desired statistic in the metadata structure ----------- - - ! * check the definition of statistics - ! there are three options to define the statistic: - ! option 0: file format = varName - ! option 0: file format = varName | outFreq - ! option 1: file format = varName | outFreq | statisticName - ! option 2: file format = varName | outFreq | inst | sum | mean | var | min | max | mode - select case(nWords) - case(nameIndex + 2, nameIndex); fileFormat=noStatsDesired ! no statistic desired (temporally constant variables) - case(freqIndex + 2 ); fileFormat=provideStatName ! provide the name of the desired statistic - case(freqIndex + 2*maxVarStat); fileFormat=provideStatFlags ! provide flags defining the desired statistic - case default - message=trim(message)//'unexpected format for variable '//trim(varName)& - //' (format = "'//trim(charLines(vLine))//'")' + ! --- populate the metadata that controls the model output --------------- + + ! identify data structure + select case (trim(structName)) + + ! temporally constant structures -- request instantaneous timestep-level output (no aggregation) + case('time' ); time_meta(vDex)%statIndex(iLookFREQ%timestep) = iLookSTAT%inst; time_meta(vDex)%varDesire=.true. ! timing data + case('bpar' ); bpar_meta(vDex)%statIndex(iLookFREQ%timestep) = iLookSTAT%inst; bpar_meta(vDex)%varDesire=.true. ! basin parameters + case('attr' ); attr_meta(vDex)%statIndex(iLookFREQ%timestep) = iLookSTAT%inst; attr_meta(vDex)%varDesire=.true. ! local attributes + case('type' ); type_meta(vDex)%statIndex(iLookFREQ%timestep) = iLookSTAT%inst; type_meta(vDex)%varDesire=.true. ! local classification + case('mpar' ); mpar_meta(vDex)%statIndex(iLookFREQ%timestep) = iLookSTAT%inst; mpar_meta(vDex)%varDesire=.true. ! model parameters + + ! index structures -- can only be output at the model time step + case('indx' ); indx_meta(vDex)%statIndex(iLookFREQ%timestep) = iLookSTAT%inst; indx_meta(vDex)%varDesire=.true. + if(iFreq/=iLookFREQ%timestep)then + message=trim(message)//'index variables can only be output at model timestep'& + //' [evaluating variable "'//trim(varName)//'" for output frequency "'//trim(freqName)//'"]' + err=20; return + endif + + ! temporally varying structures + case('forc' ); call popStat(forc_meta(vDex) , iFreq, iStat, err, cmessage) ! model forcing data + case('prog' ); call popStat(prog_meta(vDex) , iFreq, iStat, err, cmessage) ! model prognostics + case('diag' ); call popStat(diag_meta(vDex) , iFreq, iStat, err, cmessage) ! model diagnostics + case('flux' ); call popStat(flux_meta(vDex) , iFreq, iStat, err, cmessage) ! model fluxes + case('bvar' ); call popStat(bvar_meta(vDex) , iFreq, iStat, err, cmessage) ! basin variables + case('deriv'); call popStat(deriv_meta(vDex), iFreq, iStat, err, cmessage) ! model derivs + + ! error control + case default; err=20;message=trim(message)//'unable to identify lookup structure';return + + end select ! select data structure + + ! error control from popStat + if (err/=0) then; message=trim(message)//trim(cmessage);return; end if + + ! ensure that time is turned on + forc_meta(iLookForce%time)%statIndex(iLookFREQ%timestep) = iLookSTAT%inst + + ! set desired output frequency + outFreq(iFreq) = .true. + + end do ! loop through file lines with vline + + ! ********************************************************************************************** + ! (4) include time variable + ! ********************************************************************************************** + + ! force time to be written in every file + forc_meta(iLookFORCE%time)%varDesire = .true. + forc_meta(iLookFORCE%time)%statIndex(:) = iLookSTAT%inst + +end subroutine read_output_file + +! ******************************************************************************************** +! Subroutine popStat for populating the meta_data structures with information read in from file. +! This routine is called by read_output_file +! ******************************************************************************************** +subroutine popStat(meta, iFreq, iStat, err, message) + USE data_types,only:var_info ! meta_data type declaration + USE get_ixname_module,only:get_freqName ! get name of frequency from frequency index (error control) + implicit none + ! dummy variables + class(var_info),intent(inout) :: meta ! dummy meta_data structure + integer(i4b),intent(in) :: iFreq ! index in output frequency vector + integer(i4b),intent(in) :: iStat ! index in output statistics vector + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! initiate error handling + err=0; message='popStat/' + + ! check that the variable is not already defined for a given frequency + if(meta%statIndex(iFreq)/=integerMissing)then + message=trim(message)//'variable "'//trim(meta%varName)//'" is already defined '& + //'for output frequency "'//trim(get_freqName(iFreq))//'"' err=20; return - end select - - ! * extract the statistic name - select case(fileFormat) - - ! no statistic desired (temporally constant variables) - case(noStatsDesired); statName = 'instant' ! use instantaneous values - - ! provide the name of the desired statistic - case(provideStatName); statName = trim(lineWords(freqIndex+2)) - - ! extract the statistic name from the flags - ! NOTE: cannot imagine why someone would want to do this now since the other option is easier - ! --> included for backwards compatibility - case(provideStatFlags) - ! get statistic name - statFlag(:) = .false. - do iStat = 1,maxVarStat - if (lineWords(freqIndex + 2*iStat)=='1') then - statFlag(iStat)=.true. - statName = get_statName(istat) - end if - end do - ! check actually defined the statistic (and only defined one statistic) - if(count(statFlag)/=1)then - message=trim(message)//'expect only one statistic is defined when using flags to define statistics'& - //': entered "'//trim(charLines(vLine))//'"' - err=20; return - endif - - ! check: should not get here since checked above - case default; err=20; message=trim(message)//'unexpected file format'; return - end select - - ! * get the statistics index - iStat = get_ixStat(trim(statName)) - if(iStat<0 .or. iStat>maxvarStat)then - message=trim(message)//'unable to identify desired statistic for variable '//trim(varName)& - //' [evaluating '//trim(statName)//']' - err=20; return endif - ! --- populate the metadata that controls the model output --------------- - - ! identify data structure - select case (trim(structName)) - - ! temporally constant structures -- request instantaneous timestep-level output (no aggregation) - case('time' ); time_meta(vDex)%statIndex(iLookFREQ%timestep) = iLookSTAT%inst; time_meta(vDex)%varDesire=.true. ! timing data - case('bpar' ); bpar_meta(vDex)%statIndex(iLookFREQ%timestep) = iLookSTAT%inst; bpar_meta(vDex)%varDesire=.true. ! basin parameters - case('attr' ); attr_meta(vDex)%statIndex(iLookFREQ%timestep) = iLookSTAT%inst; attr_meta(vDex)%varDesire=.true. ! local attributes - case('type' ); type_meta(vDex)%statIndex(iLookFREQ%timestep) = iLookSTAT%inst; type_meta(vDex)%varDesire=.true. ! local classification - case('mpar' ); mpar_meta(vDex)%statIndex(iLookFREQ%timestep) = iLookSTAT%inst; mpar_meta(vDex)%varDesire=.true. ! model parameters - - ! index structures -- can only be output at the model time step - case('indx' ); indx_meta(vDex)%statIndex(iLookFREQ%timestep) = iLookSTAT%inst; indx_meta(vDex)%varDesire=.true. - if(iFreq/=iLookFREQ%timestep)then - message=trim(message)//'index variables can only be output at model timestep'& - //' [evaluating variable "'//trim(varName)//'" for output frequency "'//trim(freqName)//'"]' - err=20; return - endif - - ! temporally varying structures - case('forc' ); call popStat(forc_meta(vDex) , iFreq, iStat, err, cmessage) ! model forcing data - case('prog' ); call popStat(prog_meta(vDex) , iFreq, iStat, err, cmessage) ! model prognostics - case('diag' ); call popStat(diag_meta(vDex) , iFreq, iStat, err, cmessage) ! model diagnostics - case('flux' ); call popStat(flux_meta(vDex) , iFreq, iStat, err, cmessage) ! model fluxes - case('bvar' ); call popStat(bvar_meta(vDex) , iFreq, iStat, err, cmessage) ! basin variables - case('deriv'); call popStat(deriv_meta(vDex), iFreq, iStat, err, cmessage) ! model derivs - - ! error control - case default; err=20;message=trim(message)//'unable to identify lookup structure';return - - end select ! select data structure - - ! error control from popStat - if (err/=0) then; message=trim(message)//trim(cmessage);return; end if - - ! ensure that time is turned on - forc_meta(iLookForce%time)%statIndex(iLookFREQ%timestep) = iLookSTAT%inst - - ! set desired output frequency - outFreq(iFreq) = .true. - - ! print output (debugging) - !write(*,'(a)') 'freqName = '//trim(freqName)//'; statName = '//trim(statName)//'; charLines(vLine) = '//trim(charLines(vLine)) - - end do ! loop through file lines with vline - - ! ********************************************************************************************** - ! (4) include time variable - ! ********************************************************************************************** - - ! force time to be written in every file - forc_meta(iLookFORCE%time)%varDesire = .true. - forc_meta(iLookFORCE%time)%statIndex(:) = iLookSTAT%inst - - end subroutine read_output_file - - ! ******************************************************************************************** - ! Subroutine popStat for populating the meta_data structures with information read in from file. - ! This routine is called by read_output_file - ! ******************************************************************************************** - subroutine popStat(meta, iFreq, iStat, err, message) - USE data_types,only:var_info ! meta_data type declaration - USE get_ixname_module,only:get_freqName ! get name of frequency from frequency index (error control) - implicit none - ! dummy variables - class(var_info),intent(inout) :: meta ! dummy meta_data structure - integer(i4b),intent(in) :: iFreq ! index in output frequency vector - integer(i4b),intent(in) :: iStat ! index in output statistics vector - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! initiate error handling - err=0; message='popStat/' - - ! check that the variable is not already defined for a given frequency - if(meta%statIndex(iFreq)/=integerMissing)then - message=trim(message)//'variable "'//trim(meta%varName)//'" is already defined '& - //'for output frequency "'//trim(get_freqName(iFreq))//'"' - err=20; return - endif - - ! identify desired variabe - meta%varDesire = .true. + ! identify desired variabe + meta%varDesire = .true. - ! populate structure - meta%statIndex(iFreq) = iStat + ! populate structure + meta%statIndex(iFreq) = iStat - end subroutine popStat +end subroutine popStat end module popMetadat_module diff --git a/build/source/dshare/type4ida.f90 b/build/source/dshare/type4ida.f90 new file mode 100644 index 000000000..0341f0ef1 --- /dev/null +++ b/build/source/dshare/type4ida.f90 @@ -0,0 +1,75 @@ +module type4ida + +! data types +USE nrtype +USE, intrinsic :: iso_c_binding + +! provide access to the derived types to define the data structures +USE data_types,only:& + var_i, & ! data vector (i4b) + var_d, & ! data vector (rkind) + var_ilength, & ! data vector with variable length dimension (i4b) + var_dlength, & ! data vector with variable length dimension (rkind) + zLookup, & ! data vector with variable length dimension (rkind) + model_options ! defines the model decisions + +implicit none + +type data4ida + type(c_ptr) :: ida_mem ! IDA memory + real(rkind) :: dt ! data step + integer(i4b) :: nSnow ! number of snow layers + integer(i4b) :: nSoil ! number of soil layers + integer(i4b) :: nLayers ! total number of layers + integer(i4b) :: nState ! total number of state variables + integer(i4b) :: ixMatrix ! form of matrix (dense or banded) + logical(lgt) :: firstSubStep ! flag to indicate if we are processing the first sub-step + logical(lgt) :: firstFluxCall ! flag to indicate if we are processing the first flux call + logical(lgt) :: firstSplitOper ! flag to indicate if we are processing the first flux call in a splitting operation + logical(lgt) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation + logical(lgt) :: scalarSolution ! flag to denote if implementing the scalar solution + type(model_options),allocatable :: model_decisions(:) ! model decisions + type(zLookup) :: lookup_data ! lookup tables + type(var_i) :: type_data ! type of vegetation and soil + type(var_d) :: attr_data ! spatial attributes + type(var_dlength) :: mpar_data ! model parameters + type(var_d) :: forc_data ! model forcing data + type(var_dlength) :: bvar_data ! model variables for the local basin + type(var_dlength) :: prog_data ! prognostic variables for a local HRU + type(var_ilength) :: indx_data ! indices defining model states and layers + type(var_dlength) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength) :: flux_data ! model fluxes for a local HRU + type(var_dlength) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + real(qp), allocatable :: sMul(:) ! state vector multiplier (used in the residual calculations) + real(rkind), allocatable :: dMat(:) ! diagonal of the Jacobian matrix + real(rkind), allocatable :: fluxVec(:) ! flux vector + real(qp), allocatable :: resVec(:) ! residual vector + real(qp), allocatable :: resSink(:) ! additional (sink) terms on the RHS of the state equation + real(rkind), allocatable :: atol(:) ! vector of absolute tolerances + real(rkind), allocatable :: rtol(:) ! vector of relative tolerances + integer(i4b) :: ixSaturation ! index of the lowest saturated layer + real(rkind), allocatable :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + integer(i4b) :: err ! error code + character(len=256) :: message ! error message + real(rkind) :: scalarCanopyTempPrev ! previous value for temperature of the vegetation canopy (K) + real(rkind), allocatable :: mLayerTempPrev(:) ! previous vector of layer temperature (K) + real(rkind), allocatable :: mLayerMatricHeadPrev(:) ! previous value for total water matric potential (m) + real(rkind) :: scalarCanopyEnthalpyTrial ! trial value for enthalpy of the vegetation canopy (J m-2) + real(rkind) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) + real(rkind) :: scalarCanopyWatTrial ! trial value for mass of total water on the vegetation canopy (kg m-2) + real(rkind), allocatable :: mLayerTempTrial(:) ! trial vector of layer temperature (K) + real(rkind), allocatable :: mLayerMatricHeadTrial(:) ! trial value for total water matric potential (m) + real(rkind) :: scalarCanopyTempPrime ! prime value for temperature of the vegetation canopy (K s-1) + real(rkind) :: scalarCanopyWatPrime ! prime value for mass of total water on the vegetation canopy (kg m-2 s-1) + real(rkind), allocatable :: mLayerTempPrime(:) ! prime vector of temperature of each snow and soil layer (K s-1) + real(rkind), allocatable :: mLayerMatricHeadPrime(:) ! prime vector of matric head of each snow and soil layer (m s-1) + real(rkind), allocatable :: mLayerVolFracWatPrime(:) ! prime vector of volumetric total water content of each snow and soil layer (s-1) + end type data4ida + + +end module type4ida + + + + + diff --git a/build/source/dshare/type4kinsol.f90 b/build/source/dshare/type4kinsol.f90 new file mode 100644 index 000000000..906451831 --- /dev/null +++ b/build/source/dshare/type4kinsol.f90 @@ -0,0 +1,58 @@ +module type4kinsol + +! data types +USE nrtype +USE, intrinsic :: iso_c_binding + +USE data_types,only:& + var_i, & ! data vector (i4b) + var_d, & ! data vector (rkind) + var_ilength, & ! data vector with variable length dimension (i4b) + var_dlength, & ! data vector with variable length dimension (dp) + zLookup, & ! data vector with variable length dimension (rkind) + model_options ! defines the model decisions +implicit none + +type data4kinsol + type(c_ptr) :: kinsol_mem ! KINSOL memory + real(rkind) :: dt_cur ! current stepsize + real(rkind) :: dt ! data step + integer(i4b) :: nSnow ! number of snow layers + integer(i4b) :: nSoil ! number of soil layers + integer(i4b) :: nLayers ! total number of layers + integer(i4b) :: nState ! total number of state variables + integer(i4b) :: ixMatrix ! form of matrix (dense or banded) + logical(lgt) :: firstSubStep ! flag to indicate if we are processing the first sub-step + logical(lgt) :: firstFluxCall ! flag to indicate if we are processing the first flux call + logical(lgt) :: firstSplitOper ! flag to indicate if we are processing the first flux call in a splitting operation + logical(lgt) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation + logical(lgt) :: scalarSolution ! flag to denote if implementing the scalar solution + type(model_options),allocatable :: model_decisions(:) ! model decisions + type(zLookup) :: lookup_data ! lookup tables + type(var_i) :: type_data ! type of vegetation and soil + type(var_d) :: attr_data ! spatial attributes + type(var_dlength) :: mpar_data ! model parameters + type(var_d) :: forc_data ! model forcing data + type(var_dlength) :: bvar_data ! model variables for the local basin + type(var_dlength) :: prog_data ! prognostic variables for a local HRU + type(var_ilength) :: indx_data ! indices defining model states and layers + type(var_dlength) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength) :: flux_data ! model fluxes for a local HRU + type(var_dlength) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + real(qp), allocatable :: sMul(:) ! state vector multiplier (used in the residual calculations) + real(rkind), allocatable :: dMat(:) ! diagonal of the Jacobian matrix + real(rkind), allocatable :: fluxVec(:) ! flux vector + real(qp), allocatable :: resVec(:) ! residual vector + real(qp), allocatable :: resSink(:) ! additional (sink) terms on the RHS of the state equation + real(rkind),allocatable :: fScale(:) ! characteristic scale of the function evaluations + real(rkind),allocatable :: xScale(:) ! characteristic scale of the state vector + real(rkind), allocatable :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + integer(i4b) :: ixSaturation ! index of the lowest saturated layer + logical(lgt) :: firstStateIteration ! flag to denote if we computed an iteration so we know to save the state + integer(i4b) :: err ! error code + character(len=256) :: message ! error message + real(rkind), allocatable :: stateVecPrev(:) ! state vector from the previous iteration to help with infeasibility +end type data4kinsol + + +end module type4kinsol \ No newline at end of file diff --git a/build/source/dshare/var_lookup.f90 b/build/source/dshare/var_lookup.f90 old mode 100755 new mode 100644 index 73d7d93f7..659ea7d2b --- a/build/source/dshare/var_lookup.f90 +++ b/build/source/dshare/var_lookup.f90 @@ -20,12 +20,15 @@ MODULE var_lookup ! defines named variables used to index array elements +#ifdef ACTORS_ACTIVE + USE, intrinsic :: iso_c_binding +#endif USE nrtype, integerMissing=>nr_integerMissing implicit none private ! local variables integer(i4b),parameter :: ixVal =1 ! an example 4 byte integer - integer(8),parameter :: ix8Val=2 ! an example 8 byte integer + integer(i8b),parameter :: ix8Val=2 ! an example 8 byte integer integer(i4b),parameter :: iLength =storage_size(ixVal) ! size of the example 4 byte integer integer(i4b),parameter :: i8Length=storage_size(ix8Val) ! size of the example 8 byte integer @@ -33,7 +36,7 @@ MODULE var_lookup ! (0) define model decisions ! *************************************************************************************** type, public :: iLook_decision - integer(i4b) :: soilCatTbl = integerMissing ! soil-category dateset + integer(i4b) :: soilCatTbl = integerMissing ! soil-category dataset integer(i4b) :: vegeParTbl = integerMissing ! vegetation category dataset integer(i4b) :: soilStress = integerMissing ! choice of function for the soil moisture control on stomatal resistance integer(i4b) :: stomResist = integerMissing ! choice of function for stomatal resistance @@ -71,6 +74,11 @@ MODULE var_lookup integer(i4b) :: spatial_gw = integerMissing ! choice of method for spatial representation of groundwater integer(i4b) :: subRouting = integerMissing ! choice of method for sub-grid routing integer(i4b) :: snowDenNew = integerMissing ! choice of method for new snow density + integer(i4b) :: nrgConserv = integerMissing ! choice of variable in either energy backward Euler residual or IDA state variable + integer(i4b) :: aquiferIni = integerMissing ! choice of full or empty aquifer at start + integer(i4b) :: infRateMax = integerMissing ! choice of method to determine maximum infiltration rate + integer(i4b) :: surfRun_SE = integerMissing ! choice of parameterization for saturation excess surface runoff + endtype iLook_decision ! *********************************************************************************************************** @@ -125,7 +133,9 @@ MODULE var_lookup end type iLook_type type, public :: iLook_id - integer(8) :: hruId = integerMissing ! ID label defining hydrologic response unit (-) + integer(i8b) :: hruId = integerMissing ! ID label defining hydrologic response unit (-) + integer(i8b) :: gruId = integerMissing ! ID label defining grouped response unit (-) + integer(i8b) :: hru2gruId = integerMissing ! ID label defining GRU to which HRU belongs (-) end type iLook_id ! *********************************************************************************************************** @@ -186,7 +196,7 @@ MODULE var_lookup ! turbulent heat fluxes integer(i4b) :: z0Snow = integerMissing ! roughness length of snow (m) integer(i4b) :: z0Soil = integerMissing ! roughness length of bare soil below the canopy (m) - integer(i4b) :: z0Canopy = integerMissing ! roughness length of the canopy (m) + integer(i4b) :: z0Canopy = integerMissing ! roughness length of the canopy (m), only used if decision veg_traits==vegTypeTable integer(i4b) :: zpdFraction = integerMissing ! zero plane displacement / canopy height (-) integer(i4b) :: critRichNumber = integerMissing ! critical value for the bulk Richardson number (-) integer(i4b) :: Louis79_bparam = integerMissing ! parameter in Louis (1979) stability function (-) @@ -275,20 +285,51 @@ MODULE var_lookup integer(i4b) :: f_impede = integerMissing ! ice impedence factor (-) integer(i4b) :: soilIceScale = integerMissing ! scaling factor for depth of soil ice, used to get frozen fraction (m) integer(i4b) :: soilIceCV = integerMissing ! CV of depth of soil ice, used to get frozen fraction (-) + ! conceptual parameters for surface runoff + integer(i4b) :: FUSE_Ac_max = integerMissing ! FUSE PRMS max saturated area + integer(i4b) :: FUSE_phi_tens = integerMissing ! FUSE PRMS tension storage fraction + integer(i4b) :: FUSE_b = integerMissing ! FUSE ARNO/VIC exponent + integer(i4b) :: FUSE_lambda = integerMissing ! FUSE TOPMODEL gamma distribution lambda parameter + integer(i4b) :: FUSE_chi = integerMissing ! FUSE TOPMODEL gamma distribution chi parameter + integer(i4b) :: FUSE_mu = integerMissing ! FUSE TOPMODEL gamma distribution mu parameter + integer(i4b) :: FUSE_n = integerMissing ! FUSE TOPMODEL exponent ! algorithmic control parameters integer(i4b) :: minwind = integerMissing ! minimum wind speed (m s-1) integer(i4b) :: minstep = integerMissing ! minimum length of the time step - integer(i4b) :: maxstep = integerMissing ! maximum length of the time step + integer(i4b) :: maxstep = integerMissing ! maximum length of the time step (data window) + integer(i4b) :: be_steps = integerMissing ! number of equal substeps to dividing the data window for BE integer(i4b) :: wimplicit = integerMissing ! weight assigned to the start-of-step fluxes - integer(i4b) :: maxiter = integerMissing ! maximum number of iteration - integer(i4b) :: relConvTol_liquid = integerMissing ! relative convergence tolerance for vol frac liq water (-) - integer(i4b) :: absConvTol_liquid = integerMissing ! absolute convergence tolerance for vol frac liq water (-) - integer(i4b) :: relConvTol_matric = integerMissing ! relative convergence tolerance for matric head (-) - integer(i4b) :: absConvTol_matric = integerMissing ! absolute convergence tolerance for matric head (m) - integer(i4b) :: relConvTol_energy = integerMissing ! relative convergence tolerance for energy (-) - integer(i4b) :: absConvTol_energy = integerMissing ! absolute convergence tolerance for energy (J m-3) - integer(i4b) :: relConvTol_aquifr = integerMissing ! relative convergence tolerance for aquifer storage (-) - integer(i4b) :: absConvTol_aquifr = integerMissing ! absolute convergence tolerance for aquifer storage (J m-3) + integer(i4b) :: maxiter = integerMissing ! maximum number of iterations homegrown and kinsol + integer(i4b) :: relConvTol_liquid = integerMissing ! BE relative convergence tolerance for vol frac liq water homegrown (-) + integer(i4b) :: absConvTol_liquid = integerMissing ! BE absolute convergence tolerance for vol frac liq water homegrown (-) + integer(i4b) :: relConvTol_matric = integerMissing ! BE relative convergence tolerance for matric head homegrown (-) + integer(i4b) :: absConvTol_matric = integerMissing ! BE absolute convergence tolerance for matric head homegrown (m) + integer(i4b) :: relConvTol_energy = integerMissing ! BE relative convergence tolerance for energy homegrown (-) + integer(i4b) :: absConvTol_energy = integerMissing ! BE absolute convergence tolerance for energy homegrown (J m-3) + integer(i4b) :: relConvTol_aquifr = integerMissing ! BE relative convergence tolerance for aquifer storage homegrown (-) + integer(i4b) :: absConvTol_aquifr = integerMissing ! BE absolute convergence tolerance for aquifer storage homegrown (J m-3) + integer(i4b) :: relTolTempCas = integerMissing ! IDA relative error tolerance for canopy temperature state variable + integer(i4b) :: absTolTempCas = integerMissing ! IDA absolute error tolerance for canopy temperature state variable + integer(i4b) :: relTolTempVeg = integerMissing ! IDA relative error tolerance for vegitation temp state var + integer(i4b) :: absTolTempVeg = integerMissing ! IDA absolute error tolerance for vegitation temp state var + integer(i4b) :: relTolWatVeg = integerMissing ! IDA relative error tolerance for vegitation hydrology + integer(i4b) :: absTolWatVeg = integerMissing ! IDA absolute error tolerance for vegitation hydrology + integer(i4b) :: relTolTempSoilSnow = integerMissing ! IDA relative error tolerance for snow+soil energy + integer(i4b) :: absTolTempSoilSnow = integerMissing ! IDA absolute error tolerance for snow+soil energy + integer(i4b) :: relTolWatSnow = integerMissing ! IDA relative error tolerance for snow hydrology + integer(i4b) :: absTolWatSnow = integerMissing ! IDA absolute error tolerance for snow hydrology + integer(i4b) :: relTolMatric = integerMissing ! IDA relative error tolerance for matric head + integer(i4b) :: absTolMatric = integerMissing ! IDA absolute error tolerance for matric head + integer(i4b) :: relTolAquifr = integerMissing ! IDA relative error tolerance for aquifer hydrology + integer(i4b) :: absTolAquifr = integerMissing ! IDA absolute error tolerance for aquifer hydrology + integer(i4b) :: idaMaxOrder = integerMissing ! maximum order for IDA + integer(i4b) :: idaMaxInternalSteps = integerMissing ! maximum number of internal steps for IDA before tout + integer(i4b) :: idaInitStepSize = integerMissing ! initial step size for IDA + integer(i4b) :: idaMinStepSize = integerMissing ! minimum step size for IDA + integer(i4b) :: idaMaxStepSize = integerMissing ! maximum step size for IDA + integer(i4b) :: idaMaxErrTestFail = integerMissing ! maximum number of error test failures for IDA + integer(i4b) :: idaMaxDataWindowSteps = integerMissing ! maximum number of steps with event detection for IDA per data window + integer(i4b) :: idaDetectEvents = integerMissing ! flag to turn on event detection in IDA, 0=off, 1=on integer(i4b) :: zmin = integerMissing ! minimum layer depth (m) integer(i4b) :: zmax = integerMissing ! maximum layer depth (m) integer(i4b) :: zminLayer1 = integerMissing ! minimum layer depth for the 1st (top) layer (m) @@ -304,7 +345,7 @@ MODULE var_lookup integer(i4b) :: zmaxLayer2_upper = integerMissing ! maximum layer depth for the 2nd layer when > 2 layers (m) integer(i4b) :: zmaxLayer3_upper = integerMissing ! maximum layer depth for the 3rd layer when > 3 layers (m) integer(i4b) :: zmaxLayer4_upper = integerMissing ! maximum layer depth for the 4th layer when > 4 layers (m) - endtype ilook_param + endtype iLook_param ! *********************************************************************************************************** ! (6) define model prognostic (state) variables @@ -330,6 +371,10 @@ MODULE var_lookup integer(i4b) :: mLayerVolFracLiq = integerMissing ! volumetric fraction of liquid water in each layer (-) integer(i4b) :: mLayerVolFracWat = integerMissing ! volumetric fraction of total water in each layer (-) integer(i4b) :: mLayerMatricHead = integerMissing ! matric head of water in the soil (m) + ! enthalpy + integer(i4b) :: scalarCanairEnthalpy = integerMissing ! enthalpy of the canopy air space (J m-3) + integer(i4b) :: scalarCanopyEnthalpy = integerMissing ! enthalpy of the vegetation canopy (J m-3) + integer(i4b) :: mLayerEnthalpy = integerMissing ! enthalpy of the snow+soil layers (J m-3) ! other state variables integer(i4b) :: scalarAquiferStorage = integerMissing ! relative aquifer storage -- above bottom of the soil profile (m) integer(i4b) :: scalarSurfaceTemp = integerMissing ! surface temperature (K) @@ -345,8 +390,8 @@ MODULE var_lookup type, public :: iLook_diag ! local properties integer(i4b) :: scalarCanopyDepth = integerMissing ! canopy depth (m) - integer(i4b) :: scalarGreenVegFraction = integerMissing ! green vegetation fraction used to compute LAI (-) integer(i4b) :: scalarBulkVolHeatCapVeg = integerMissing ! bulk volumetric heat capacity of vegetation (J m-3 K-1) + integer(i4b) :: scalarCanopyCm = integerMissing ! Cm for vegetation canopy (J kg-1) integer(i4b) :: scalarCanopyEmissivity = integerMissing ! effective canopy emissivity (-) integer(i4b) :: scalarRootZoneTemp = integerMissing ! average temperature of the root zone (K) integer(i4b) :: scalarLAI = integerMissing ! one-sided leaf area index (m2 m-2) @@ -362,10 +407,16 @@ MODULE var_lookup integer(i4b) :: scalarVolHtCap_soil = integerMissing ! volumetric heat capacity dry soil (J m-3 K-1) integer(i4b) :: scalarVolHtCap_water = integerMissing ! volumetric heat capacity liquid wat (J m-3 K-1) integer(i4b) :: mLayerVolHtCapBulk = integerMissing ! volumetric heat capacity in each layer (J m-3 K-1) + integer(i4b) :: mLayerCm = integerMissing ! Cm for each layer (J m-3) integer(i4b) :: scalarLambda_drysoil = integerMissing ! thermal conductivity of dry soil (W m-1 K-1) integer(i4b) :: scalarLambda_wetsoil = integerMissing ! thermal conductivity of wet soil (W m-1 K-1) integer(i4b) :: mLayerThermalC = integerMissing ! thermal conductivity at the mid-point of each layer (W m-1 K-1) integer(i4b) :: iLayerThermalC = integerMissing ! thermal conductivity at the interface of each layer (W m-1 K-1) + ! enthalpy + integer(i4b) :: scalarCanopyEnthTemp = integerMissing ! temperature component of enthalpy of the vegetation canopy (J m-3) + integer(i4b) :: mLayerEnthTemp = integerMissing ! temperature component of enthalpy of the snow+soil layers (J m-3) + integer(i4b) :: scalarTotalSoilEnthalpy = integerMissing ! total enthalpy of the soil column (J m-3) + integer(i4b) :: scalarTotalSnowEnthalpy = integerMissing ! total enthalpy of the snow column (J m-3) ! forcing integer(i4b) :: scalarVPair = integerMissing ! vapor pressure of the air above the vegetation canopy (Pa) integer(i4b) :: scalarVP_CanopyAir = integerMissing ! vapor pressure of the canopy air space (Pa) @@ -374,6 +425,8 @@ MODULE var_lookup integer(i4b) :: scalarNewSnowDensity = integerMissing ! density of fresh snow (kg m-3) integer(i4b) :: scalarO2air = integerMissing ! atmospheric o2 concentration (Pa) integer(i4b) :: scalarCO2air = integerMissing ! atmospheric co2 concentration (Pa) + integer(i4b) :: windspd_x = integerMissing ! wind speed at 10 meter height in x-direction (m s-1) + integer(i4b) :: windspd_y = integerMissing ! wind speed at 10 meter height in y-direction (m s-1) ! shortwave radiation integer(i4b) :: scalarCosZenith = integerMissing ! cosine of the solar zenith angle (0-1) integer(i4b) :: scalarFractionDirect = integerMissing ! fraction of direct radiation (0-1) @@ -417,17 +470,16 @@ MODULE var_lookup integer(i4b) :: mLayerPoreSpace = integerMissing ! total pore space in each snow layer (-) integer(i4b) :: mLayerMeltFreeze = integerMissing ! change in ice content due to melt/freeze in each layer (kg m-3) ! soil hydrology - integer(i4b) :: scalarInfilArea = integerMissing ! fraction of unfrozen area where water can infiltrate (-) + integer(i4b) :: scalarInfilArea = integerMissing ! fraction of area where water can infiltrate, may be frozen (-) + integer(i4b) :: scalarSaturatedArea = integerMissing ! fraction of area that is considered saturated (-) integer(i4b) :: scalarFrozenArea = integerMissing ! fraction of area that is considered impermeable due to soil ice (-) - integer(i4b) :: scalarSoilControl = integerMissing ! soil control on infiltration: 1=controlling; 0=not (-) + integer(i4b) :: scalarSoilControl = integerMissing ! soil control on infiltration for derivative integer(i4b) :: mLayerVolFracAir = integerMissing ! volumetric fraction of air in each layer (-) integer(i4b) :: mLayerTcrit = integerMissing ! critical soil temperature above which all water is unfrozen (K) - integer(i4b) :: mLayerCompress = integerMissing ! change in volumetric water content due to compression of soil (-) - integer(i4b) :: scalarSoilCompress = integerMissing ! change in total soil storage due to compression of the soil matrix (kg m-2) + integer(i4b) :: mLayerCompress = integerMissing ! change in volumetric water content due to compression of soil (s-1) + integer(i4b) :: scalarSoilCompress = integerMissing ! change in total soil storage due to compression of the soil matrix (kg m-2 s-1) integer(i4b) :: mLayerMatricHeadLiq = integerMissing ! matric potential of liquid water (m) ! mass balance check - integer(i4b) :: scalarSoilWatBalError = integerMissing ! error in the total soil water balance (kg m-2) - integer(i4b) :: scalarAquiferBalError = integerMissing ! error in the aquifer water balance (kg m-2) integer(i4b) :: scalarTotalSoilLiq = integerMissing ! total mass of liquid water in the soil (kg m-2) integer(i4b) :: scalarTotalSoilIce = integerMissing ! total mass of ice in the soil (kg m-2) integer(i4b) :: scalarTotalSoilWat = integerMissing ! total mass of water in the soil (kg m-2) @@ -435,9 +487,32 @@ MODULE var_lookup integer(i4b) :: scalarVGn_m = integerMissing ! van Genuchten "m" parameter (-) integer(i4b) :: scalarKappa = integerMissing ! constant in the freezing curve function (m K-1) integer(i4b) :: scalarVolLatHt_fus = integerMissing ! volumetric latent heat of fusion (J m-3) - ! timing information + ! number of function evaluations integer(i4b) :: numFluxCalls = integerMissing ! number of flux calls (-) - integer(i4b) :: wallClockTime = integerMissing ! wall clock time (s) + integer(i4b) :: wallClockTime = integerMissing ! wall clock time for physics routines(s) + integer(i4b) :: meanStepSize = integerMissing ! mean time step size over data window (s) + ! balances + integer(i4b) :: balanceCasNrg = integerMissing ! balance of energy in the canopy air space (W m-3) + integer(i4b) :: balanceVegNrg = integerMissing ! balance of energy in the vegetation (W m-3) + integer(i4b) :: balanceLayerNrg = integerMissing ! balance of energy in each snow+soil layer (W m-3) + integer(i4b) :: balanceSnowNrg = integerMissing ! balance of energy in the snow (W m-3) + integer(i4b) :: balanceSoilNrg = integerMissing ! balance of energy in the soil (W m-3) + integer(i4b) :: balanceVegMass = integerMissing ! balance of water in the vegetation (kg m-3 s-1) + integer(i4b) :: balanceLayerMass = integerMissing ! balance of water in each snow+soil layer (kg m-3 s-1) + integer(i4b) :: balanceSnowMass = integerMissing ! balance of water in the snow (kg m-3 s-1) + integer(i4b) :: balanceSoilMass = integerMissing ! balance of water in the soil (kg m-3 s-1) + integer(i4b) :: balanceAqMass = integerMissing ! balance of water in the aquifer (kg m-2 s-1) (no depth to aquifer) + ! sundials integrator stats + integer(i4b) :: numSteps = integerMissing ! + integer(i4b) :: numResEvals = integerMissing ! + integer(i4b) :: numLinSolvSetups = integerMissing ! + integer(i4b) :: numErrTestFails = integerMissing ! + integer(i4b) :: kLast = integerMissing ! + integer(i4b) :: kCur = integerMissing ! + integer(i4b) :: hInitUsed = integerMissing ! + integer(i4b) :: hLast = integerMissing ! + integer(i4b) :: hCur = integerMissing ! + integer(i4b) :: tCur = integerMissing ! endtype iLook_diag ! *********************************************************************************************************** @@ -526,6 +601,8 @@ MODULE var_lookup integer(i4b) :: scalarInfiltration = integerMissing ! infiltration of water into the soil profile (m s-1) integer(i4b) :: scalarExfiltration = integerMissing ! exfiltration of water from the top of the soil profile (m s-1) integer(i4b) :: scalarSurfaceRunoff = integerMissing ! surface runoff (m s-1) + integer(i4b) :: scalarSurfaceRunoff_IE = integerMissing ! infiltration excess surface runoff (m s-1) + integer(i4b) :: scalarSurfaceRunoff_SE = integerMissing ! saturation excess surface runoff (m s-1) integer(i4b) :: mLayerSatHydCondMP = integerMissing ! saturated hydraulic conductivity of macropores in each layer (m s-1) integer(i4b) :: mLayerSatHydCond = integerMissing ! saturated hydraulic conductivity in each layer (m s-1) integer(i4b) :: iLayerSatHydCond = integerMissing ! saturated hydraulic conductivity at each layer interface (m s-1) @@ -557,36 +634,62 @@ MODULE var_lookup integer(i4b) :: dCanopyNetFlux_dCanairTemp = integerMissing ! derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) integer(i4b) :: dCanopyNetFlux_dCanopyTemp = integerMissing ! derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) integer(i4b) :: dCanopyNetFlux_dGroundTemp = integerMissing ! derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) - integer(i4b) :: dCanopyNetFlux_dCanLiq = integerMissing ! derivative in net canopy fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + integer(i4b) :: dCanopyNetFlux_dCanWat = integerMissing ! derivative in net canopy fluxes w.r.t. canopy total water content (J kg-1 s-1) integer(i4b) :: dGroundNetFlux_dCanairTemp = integerMissing ! derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) integer(i4b) :: dGroundNetFlux_dCanopyTemp = integerMissing ! derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) integer(i4b) :: dGroundNetFlux_dGroundTemp = integerMissing ! derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) - integer(i4b) :: dGroundNetFlux_dCanLiq = integerMissing ! derivative in net ground fluxes w.r.t. canopy liquid water content (J kg-1 s-1) + integer(i4b) :: dGroundNetFlux_dCanWat = integerMissing ! derivative in net ground fluxes w.r.t. canopy total water content (J kg-1 s-1) ! derivatives in evaporative fluxes w.r.t. relevant state variables integer(i4b) :: dCanopyEvaporation_dTCanair = integerMissing ! derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) integer(i4b) :: dCanopyEvaporation_dTCanopy = integerMissing ! derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) integer(i4b) :: dCanopyEvaporation_dTGround = integerMissing ! derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) - integer(i4b) :: dCanopyEvaporation_dCanLiq = integerMissing ! derivative in canopy evaporation w.r.t. canopy liquid water content (s-1) + integer(i4b) :: dCanopyEvaporation_dCanWat = integerMissing ! derivative in canopy evaporation w.r.t. canopy total water content (s-1) integer(i4b) :: dGroundEvaporation_dTCanair = integerMissing ! derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) integer(i4b) :: dGroundEvaporation_dTCanopy = integerMissing ! derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) integer(i4b) :: dGroundEvaporation_dTGround = integerMissing ! derivative in ground evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) - integer(i4b) :: dGroundEvaporation_dCanLiq = integerMissing ! derivative in ground evaporation w.r.t. canopy liquid water content (s-1) - ! derivatives in canopy water w.r.t canopy temperature + integer(i4b) :: dGroundEvaporation_dCanWat = integerMissing ! derivative in ground evaporation w.r.t. canopy total water content (s-1) + ! derivatives in transpiration + integer(i4b) :: dCanopyTrans_dTCanair = integerMissing ! derivative in canopy transpiration w.r.t. canopy air temperature (kg m-2 s-1 K-1) + integer(i4b) :: dCanopyTrans_dTCanopy = integerMissing ! derivative in canopy transpiration w.r.t. canopy temperature (kg m-2 s-1 K-1) + integer(i4b) :: dCanopyTrans_dTGround = integerMissing ! derivative in canopy transpiration w.r.t. ground temperature (kg m-2 s-1 K-1) + integer(i4b) :: dCanopyTrans_dCanWat = integerMissing ! derivative in canopy transpiration w.r.t. canopy total water content (s-1) + ! derivatives in canopy water w.r.t canopy temperature integer(i4b) :: dTheta_dTkCanopy = integerMissing ! derivative of volumetric liquid water content w.r.t. temperature (K-1) + integer(i4b) :: d2Theta_dTkCanopy2 = integerMissing ! second derivative of volumetric liquid water content w.r.t. temperature integer(i4b) :: dCanLiq_dTcanopy = integerMissing ! derivative of canopy liquid storage w.r.t. temperature (kg m-2 K-1) + integer(i4b) :: dFracLiqVeg_dTkCanopy = integerMissing ! derivative in fraction of (throughfall + drainage) w.r.t. temperature ! derivatives in canopy liquid fluxes w.r.t. canopy water integer(i4b) :: scalarCanopyLiqDeriv = integerMissing ! derivative in (throughfall + canopy drainage) w.r.t. canopy liquid water (s-1) integer(i4b) :: scalarThroughfallRainDeriv = integerMissing ! derivative in throughfall w.r.t. canopy liquid water (s-1) integer(i4b) :: scalarCanopyLiqDrainageDeriv = integerMissing ! derivative in canopy drainage w.r.t. canopy liquid water (s-1) + ! energy derivatives that might be treated as constant if heat capacity and thermal conductivity not updated + integer(i4b) :: dVolHtCapBulk_dPsi0 = integerMissing ! derivative in bulk heat capacity w.r.t. matric potential + integer(i4b) :: dVolHtCapBulk_dTheta = integerMissing ! derivative in bulk heat capacity w.r.t. volumetric water content + integer(i4b) :: dVolHtCapBulk_dCanWat = integerMissing ! derivative in bulk heat capacity w.r.t. canopy volumetric water content + integer(i4b) :: dVolHtCapBulk_dTk = integerMissing ! derivative in bulk heat capacity w.r.t. temperature + integer(i4b) :: dVolHtCapBulk_dTkCanopy = integerMissing ! derivative in bulk heat capacity w.r.t. canopy temperature + integer(i4b) :: dThermalC_dTempAbove = integerMissing ! derivative in the thermal conductivity w.r.t. energy state in the layer above + integer(i4b) :: dThermalC_dTempBelow = integerMissing ! derivative in the thermal conductivity w.r.t. energy state in the layer above + integer(i4b) :: dThermalC_dWatAbove = integerMissing ! derivative in the thermal conductivity w.r.t. water state in the layer above + integer(i4b) :: dThermalC_dWatBelow = integerMissing ! derivative in the thermal conductivity w.r.t. water state in the layer above + ! energy derivatives that might be treated as constant if Cm not updated + integer(i4b) :: dCm_dPsi0 = integerMissing ! derivative in heat capacity w.r.t. matric potential (J kg-1) + integer(i4b) :: dCm_dTk = integerMissing ! derivative in heat capacity w.r.t. temperature (J kg-1 K-2) + integer(i4b) :: dCm_dTkCanopy = integerMissing ! derivative in heat capacity w.r.t. canopy temperature (J kg-1 K-2) ! derivatives in energy fluxes at the interface of snow+soil layers w.r.t. temperature in layers above and below integer(i4b) :: dNrgFlux_dTempAbove = integerMissing ! derivatives in the flux w.r.t. temperature in the layer above (J m-2 s-1 K-1) integer(i4b) :: dNrgFlux_dTempBelow = integerMissing ! derivatives in the flux w.r.t. temperature in the layer below (J m-2 s-1 K-1) + ! derivatives in energy fluxes at the interface of snow+soil layers w.r.t. water state in layers above and below + integer(i4b) :: dNrgFlux_dWatAbove = integerMissing ! derivatives in the flux w.r.t. water state in the layer above + integer(i4b) :: dNrgFlux_dWatBelow = integerMissing ! derivatives in the flux w.r.t. water state in the layer below ! derivative in liquid water fluxes at the interface of snow layers w.r.t. volumetric liquid water content in the layer above integer(i4b) :: iLayerLiqFluxSnowDeriv = integerMissing ! derivative in vertical liquid water flux at layer interfaces (m s-1) ! derivative in liquid water fluxes for the soil domain w.r.t hydrology state variables integer(i4b) :: dVolTot_dPsi0 = integerMissing ! derivative in total water content w.r.t. total water matric potential (m-1) + integer(i4b) :: d2VolTot_dPsi02 = integerMissing ! second derivative in total water content w.r.t. total water matric potential integer(i4b) :: dq_dHydStateAbove = integerMissing ! change in the flux in layer interfaces w.r.t. state variables in the layer above integer(i4b) :: dq_dHydStateBelow = integerMissing ! change in the flux in layer interfaces w.r.t. state variables in the layer below + integer(i4b) :: dq_dHydStateLayerSurfVec = integerMissing ! change in the flux in soil surface interface w.r.t. state variables in layers integer(i4b) :: mLayerdTheta_dPsi = integerMissing ! derivative in the soil water characteristic w.r.t. psi (m-1) integer(i4b) :: mLayerdPsi_dTheta = integerMissing ! derivative in the soil water characteristic w.r.t. theta (m) integer(i4b) :: dCompress_dPsi = integerMissing ! derivative in compressibility w.r.t matric head (m-1) @@ -595,9 +698,36 @@ MODULE var_lookup ! derivative in liquid water fluxes for the soil domain w.r.t energy state variables integer(i4b) :: dq_dNrgStateAbove = integerMissing ! change in the flux in layer interfaces w.r.t. state variables in the layer above integer(i4b) :: dq_dNrgStateBelow = integerMissing ! change in the flux in layer interfaces w.r.t. state variables in the layer below - integer(i4b) :: mLayerdTheta_dTk = integerMissing ! derivative of volumetric liquid water content w.r.t. temperature (K-1) + integer(i4b) :: dq_dNrgStateLayerSurfVec = integerMissing ! change in the flux in soil surface interface w.r.t. state variables in layers integer(i4b) :: dPsiLiq_dTemp = integerMissing ! derivative in the liquid water matric potential w.r.t. temperature (m K-1) integer(i4b) :: dPsiLiq_dPsi0 = integerMissing ! derivative in liquid water matric potential w.r.t. the total water matric potential (-) + ! derivatives in soil transpiration w.r.t. canopy state variables + integer(i4b) :: mLayerdTrans_dTCanair = integerMissing ! derivatives in the soil layer transpiration flux w.r.t. canopy air temperature + integer(i4b) :: mLayerdTrans_dTCanopy = integerMissing ! derivatives in the soil layer transpiration flux w.r.t. canopy temperature + integer(i4b) :: mLayerdTrans_dTGround = integerMissing ! derivatives in the soil layer transpiration flux w.r.t. ground temperature + integer(i4b) :: mLayerdTrans_dCanWat = integerMissing ! derivatives in the soil layer transpiration flux w.r.t. canopy total water + ! derivatives in aquifer transpiration w.r.t. canopy state variables + integer(i4b) :: dAquiferTrans_dTCanair = integerMissing ! derivative in the aquifer transpiration flux w.r.t. canopy air temperature + integer(i4b) :: dAquiferTrans_dTCanopy = integerMissing ! derivative in the aquifer transpiration flux w.r.t. canopy temperature + integer(i4b) :: dAquiferTrans_dTGround = integerMissing ! derivative in the aquifer transpiration flux w.r.t. ground temperature + integer(i4b) :: dAquiferTrans_dCanWat = integerMissing ! derivative in the aquifer transpiration flux w.r.t. canopy total water + ! derivative in liquid water fluxes for the soil and snow domain w.r.t temperature + integer(i4b) :: dFracLiqWat_dTk = integerMissing ! derivative in fraction of liquid water w.r.t. temperature + integer(i4b) :: mLayerdTheta_dTk = integerMissing ! derivative of volumetric liquid water content w.r.t. temperature (K-1) + integer(i4b) :: mLayerd2Theta_dTk2 = integerMissing ! second derivative of volumetric liquid water content w.r.t. temperature + ! derivatives in time + integer(i4b) :: mLayerdTemp_dt = integerMissing ! timestep change in layer temperature + integer(i4b) :: scalarCanopydTemp_dt = integerMissing ! timestep change in canopy temperature + integer(i4b) :: mLayerdWat_dt = integerMissing ! timestep change in layer volumetric fraction of total water + integer(i4b) :: scalarCanopydWat_dt = integerMissing ! timestep change in canopy water content + ! derivatives of temperature if enthalpy is the state variable + integer(i4b) :: dCanairTemp_dEnthalpy = integerMissing ! derivative of canopy air temperature w.r.t. enthalpy + integer(i4b) :: dCanopyTemp_dEnthalpy = integerMissing ! derivative of canopy temperature w.r.t. enthalpy + integer(i4b) :: dTemp_dEnthalpy = integerMissing ! derivative of temperature w.r.t. enthalpy + integer(i4b) :: dCanopyTemp_dCanWat = integerMissing ! derivative of canopy temperature w.r.t. volumetric water content + integer(i4b) :: dTemp_dTheta = integerMissing ! derivative of temperature w.r.t. volumetric water content + integer(i4b) :: dTemp_dPsi0 = integerMissing ! derivative of temperature w.r.t. total water matric potential + endtype iLook_deriv ! *********************************************************************************************************** @@ -718,7 +848,11 @@ MODULE var_lookup ! (13) structure for looking up the type of a model variable (this is only needed for backward ! compatability, and should be removed eventually) ! *********************************************************************************************************** +#ifdef ACTORS_ACTIVE + type, public, bind(C) :: iLook_varType +#else type, public :: iLook_varType +#endif integer(i4b) :: scalarv = integerMissing ! scalar variables integer(i4b) :: wLength = integerMissing ! # spectral bands integer(i4b) :: midSnow = integerMissing ! mid-layer snow variables @@ -756,6 +890,15 @@ MODULE var_lookup integer(i4b) :: timestep = integerMissing ! timestep-level output (no temporal aggregation) endtype iLook_freq + ! *********************************************************************************************************** + ! (16) structure for looking up lookup tables + ! *********************************************************************************************************** + type, public :: iLook_vLookup + integer(i4b) :: temperature = integerMissing ! temperature (K) + integer(i4b) :: psiLiq_int = integerMissing ! integral of mLayerPsiLiq from Tfreeze to Tk (K) + integer(i4b) :: deriv2 = integerMissing ! second derivatives of the interpolating function + endtype iLook_vLookup + ! *********************************************************************************************************** ! (X) define data structures and maximum number of variables of each type ! *********************************************************************************************************** @@ -764,22 +907,18 @@ MODULE var_lookup type(iLook_decision),public,parameter :: iLookDECISIONS=iLook_decision( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,& 11, 12, 13, 14, 15, 16, 17, 18, 19, 20,& 21, 22, 23, 24, 25, 26, 27, 28, 29, 30,& - 31, 32, 33, 34, 35, 36, 37, 38) + 31, 32, 33, 34, 35, 36, 37, 38, 39, 40,& + 41, 42) ! named variables: model time type(iLook_time), public,parameter :: iLookTIME =iLook_time ( 1, 2, 3, 4, 5, 6, 7) - ! named variables: model forcing data type(iLook_force), public,parameter :: iLookFORCE =iLook_force ( 1, 2, 3, 4, 5, 6, 7, 8) - ! named variables: model attributes type(iLook_attr), public,parameter :: iLookATTR =iLook_attr ( 1, 2, 3, 4, 5, 6, 7, 8) - ! named variables: soil and vegetation types type(iLook_type), public,parameter :: iLookTYPE =iLook_type ( 1, 2, 3, 4) - ! named variables: hru and gru IDs and associated information - type(iLook_id), public,parameter :: iLookID =iLook_id ( 1) - + type(iLook_id), public,parameter :: iLookID =iLook_id ( 1, 2, 3) ! named variables: model parameters type(iLook_param), public,parameter :: iLookPARAM =iLook_param ( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,& 11, 12, 13, 14, 15, 16, 17, 18, 19, 20,& @@ -796,13 +935,14 @@ MODULE var_lookup 121,122,123,124,125,126,127,128,129,130,& 131,132,133,134,135,136,137,138,139,140,& 141,142,143,144,145,146,147,148,149,150,& - 151,152,153,154,155,156,157,158,159) - + 151,152,153,154,155,156,157,158,159,160,& + 161,162,163,164,165,166,167,168,169,170,& + 171,172,173,174,175,176,177,178,179,180,& + 181,182,183,184,185,186,187,188,189) ! named variables: model prognostic (state) variables type(iLook_prog), public,parameter :: iLookPROG =iLook_prog ( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,& 11, 12, 13, 14, 15, 16, 17, 18, 19, 20,& - 21) - + 21, 22, 23, 24) ! named variables: model diagnostic variables type(iLook_diag), public,parameter :: iLookDIAG =iLook_diag ( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,& 11, 12, 13, 14, 15, 16, 17, 18, 19, 20,& @@ -812,7 +952,10 @@ MODULE var_lookup 51, 52, 53, 54, 55, 56, 57, 58, 59, 60,& 61, 62, 63, 64, 65, 66, 67, 68, 69, 70,& 71, 72, 73, 74, 75, 76, 77, 78, 79, 80,& - 81, 82, 83, 84) + 81, 82, 83, 84, 85, 86, 87, 88, 89, 90,& + 91, 92, 93, 94, 95, 96, 97, 98, 99,100,& + 101,102,103,104,105,106,107,108,109,110,& + 111) ! named variables: model fluxes type(iLook_flux), public,parameter :: iLookFLUX =iLook_flux ( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,& 11, 12, 13, 14, 15, 16, 17, 18, 19, 20,& @@ -822,14 +965,18 @@ MODULE var_lookup 51, 52, 53, 54, 55, 56, 57, 58, 59, 60,& 61, 62, 63, 64, 65, 66, 67, 68, 69, 70,& 71, 72, 73, 74, 75, 76, 77, 78, 79, 80,& - 81, 82, 83, 84, 85, 86, 87, 88, 89) - + 81, 82, 83, 84, 85, 86, 87, 88, 89, 90,& + 91) ! named variables: derivatives in model fluxes w.r.t. relevant state variables type(iLook_deriv), public,parameter :: iLookDERIV =iLook_deriv ( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,& 11, 12, 13, 14, 15, 16, 17, 18, 19, 20,& 21, 22, 23, 24, 25, 26, 27, 28, 29, 30,& - 31, 32, 33, 34, 35, 36, 37, 38, 39) - + 31, 32, 33, 34, 35, 36, 37, 38, 39, 40,& + 41, 42, 43, 44, 45, 46, 47, 48, 49, 50,& + 51, 52, 53, 54, 55, 56, 57, 58, 59, 60,& + 61, 62, 63, 64, 65, 66, 67, 68, 69, 70,& + 71, 72, 73, 74, 75, 76, 77, 78, 79, 80,& + 81, 82) ! named variables: model indices type(iLook_index), public,parameter :: iLookINDEX =ilook_index ( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,& 11, 12, 13, 14, 15, 16, 17, 18, 19, 20,& @@ -837,24 +984,20 @@ MODULE var_lookup 31, 32, 33, 34, 35, 36, 37, 38, 39, 40,& 41, 42, 43, 44, 45, 46, 47, 48, 49, 50,& 51, 52, 53, 54, 55, 56, 57, 58, 59, 60) - ! named variables: basin-average parameters type(iLook_bpar), public,parameter :: iLookBPAR =ilook_bpar ( 1, 2, 3, 4, 5) - ! named variables: basin-average variables type(iLook_bvar), public,parameter :: iLookBVAR =ilook_bvar ( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,& 11, 12, 13) - ! named variables in varibale type structure type(iLook_varType), public,parameter :: iLookVarType =ilook_varType ( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,& 11, 12) - ! number of possible output statistics - type(iLook_stat), public,parameter :: iLookStat =ilook_stat ( 1, 2, 3, 4, 5, 6, 7) - + type(iLook_stat), public,parameter :: iLookSTAT =ilook_stat ( 1, 2, 3, 4, 5, 6, 7) ! number of possible output frequencies - type(iLook_freq), public,parameter :: iLookFreq =ilook_freq ( 1, 2, 3, 4) - + type(iLook_freq), public,parameter :: iLookFREQ =ilook_freq ( 1, 2, 3, 4) + ! named variables in the lookup table structure + type(iLook_vLookup), public,parameter :: iLookLOOKUP =ilook_vLookup ( 1, 2, 3) ! define maximum number of variables of each type integer(i4b),parameter,public :: maxvarDecisions = storage_size(iLookDECISIONS)/iLength integer(i4b),parameter,public :: maxvarTime = storage_size(iLookTIME)/iLength @@ -871,8 +1014,9 @@ MODULE var_lookup integer(i4b),parameter,public :: maxvarBpar = storage_size(iLookBPAR)/iLength integer(i4b),parameter,public :: maxvarBvar = storage_size(iLookBVAR)/iLength integer(i4b),parameter,public :: maxvarVarType = storage_size(iLookVarType)/iLength - integer(i4b),parameter,public :: maxvarStat = storage_size(iLookStat)/iLength - integer(i4b),parameter,public :: maxvarFreq = storage_size(iLookFreq)/iLength + integer(i4b),parameter,public :: maxvarStat = storage_size(iLookSTAT)/iLength + integer(i4b),parameter,public :: maxvarFreq = storage_size(iLookFREQ)/iLength + integer(i4b),parameter,public :: maxvarLookup = storage_size(iLookLOOKUP)/iLength ! *********************************************************************************************************** ! (Y) define ancillary look-up structures @@ -880,5 +1024,4 @@ MODULE var_lookup integer(i4b),allocatable,save,public :: childFLUX_MEAN(:) ! index of the child data structure: mean flux - END MODULE var_lookup diff --git a/build/source/engine/allocspace.f90 b/build/source/engine/allocspace.f90 old mode 100755 new mode 100644 index 720067187..dd77f4eb9 --- a/build/source/engine/allocspace.f90 +++ b/build/source/engine/allocspace.f90 @@ -30,33 +30,35 @@ module allocspace_module ilength, & ! var%dat ! no spatial dimension var_i, & ! x%var(:) (i4b) - var_i8, & ! x%var(:) integer(8) - var_d, & ! x%var(:) (dp) + var_i8, & ! x%var(:) (i8b) + var_d, & ! x%var(:) (rkind) var_flagVec, & ! x%var(:)%dat (logical) var_ilength, & ! x%var(:)%dat (i4b) - var_dlength, & ! x%var(:)%dat (dp) + var_dlength, & ! x%var(:)%dat (rkind) ! gru dimension gru_int, & ! x%gru(:)%var(:) (i4b) - gru_int8, & ! x%gru(:)%var(:) integer(8) - gru_double, & ! x%gru(:)%var(:) (dp) + gru_int8, & ! x%gru(:)%var(:) (i8b) + gru_double, & ! x%gru(:)%var(:) (rkind) gru_intVec, & ! x%gru(:)%var(:)%dat (i4b) - gru_doubleVec, & ! x%gru(:)%var(:)%dat (dp) + gru_doubleVec, & ! x%gru(:)%var(:)%dat (rkind) ! gru+hru dimension gru_hru_int, & ! x%gru(:)%hru(:)%var(:) (i4b) - gru_hru_int8, & ! x%gru(:)%hru(:)%var(:) integer(8) - gru_hru_double, & ! x%gru(:)%hru(:)%var(:) (dp) + gru_hru_int8, & ! x%gru(:)%hru(:)%var(:) (i8b) + gru_hru_double, & ! x%gru(:)%hru(:)%var(:) (rkind) gru_hru_intVec, & ! x%gru(:)%hru(:)%var(:)%dat (i4b) - gru_hru_doubleVec ! x%gru(:)%hru(:)%var(:)%dat (dp) + gru_hru_doubleVec, & ! x%gru(:)%hru(:)%var(:)%dat (rkind) + ! gru+hru+z dimension + gru_hru_z_vLookup ! x%gru(:)%hru(:)%z(:)%var(:)%lookup (rkind) ! metadata structure USE data_types,only:var_info ! data type for metadata ! access missing values USE globalData,only:integerMissing ! missing integer -USE globalData,only:realMissing ! missing double precision number +USE globalData,only:realMissing ! missing real number USE globalData,only: nTimeDelay ! number of timesteps in the time delay histogram -USE globalData,only: nBand ! number of spectral bands +USE globalData,only: nSpecBand ! number of spectral bands ! access variable types USE var_lookup,only:iLookVarType ! look up structure for variable typed @@ -115,6 +117,8 @@ subroutine allocGlobal(metaStruct,dataStruct,err,message) class is (gru_hru_intVec); if(allocated(dataStruct%gru))then; check=.true.; else; allocate(dataStruct%gru(nGRU),stat=err); end if class is (gru_hru_double); if(allocated(dataStruct%gru))then; check=.true.; else; allocate(dataStruct%gru(nGRU),stat=err); end if class is (gru_hru_doubleVec); if(allocated(dataStruct%gru))then; check=.true.; else; allocate(dataStruct%gru(nGRU),stat=err); end if + ! gru+hru+z dimensions + class is (gru_hru_z_vLookup); if(allocated(dataStruct%gru))then; check=.true.; else; allocate(dataStruct%gru(nGRU),stat=err); end if end select ! check errors @@ -130,6 +134,7 @@ subroutine allocGlobal(metaStruct,dataStruct,err,message) class is (gru_hru_intVec); if(allocated(dataStruct%gru(iGRU)%hru))then; check=.true.; else; allocate(dataStruct%gru(iGRU)%hru(gru_struc(iGRU)%hruCount),stat=err); end if class is (gru_hru_double); if(allocated(dataStruct%gru(iGRU)%hru))then; check=.true.; else; allocate(dataStruct%gru(iGRU)%hru(gru_struc(iGRU)%hruCount),stat=err); end if class is (gru_hru_doubleVec); if(allocated(dataStruct%gru(iGRU)%hru))then; check=.true.; else; allocate(dataStruct%gru(iGRU)%hru(gru_struc(iGRU)%hruCount),stat=err); end if + class is (gru_hru_z_vLookup); if(allocated(dataStruct%gru(iGRU)%hru))then; check=.true.; else; allocate(dataStruct%gru(iGRU)%hru(gru_struc(iGRU)%hruCount),stat=err); end if class default ! do nothing: It is acceptable to not be any of these specified cases end select ! check errors @@ -158,6 +163,7 @@ subroutine allocGlobal(metaStruct,dataStruct,err,message) class is (gru_hru_intVec); call allocLocal(metaStruct,dataStruct%gru(iGRU)%hru(iHRU),nSnow,nSoil,err,cmessage); spatial=.true. class is (gru_hru_double); call allocLocal(metaStruct,dataStruct%gru(iGRU)%hru(iHRU),nSnow,nSoil,err,cmessage); spatial=.true. class is (gru_hru_doubleVec); call allocLocal(metaStruct,dataStruct%gru(iGRU)%hru(iHRU),nSnow,nSoil,err,cmessage); spatial=.true. + class is (gru_hru_z_vLookup); spatial=.true. ! (special case, allocate space separately later) class default; exit hruLoop end select @@ -566,7 +572,7 @@ subroutine allocateDat_rkind(metadata,nSnow,nSoil,nLayers, & ! input else select case(metadata(iVar)%vartype) case(iLookVarType%scalarv); allocate(varData%var(iVar)%dat(1),stat=err) - case(iLookVarType%wLength); allocate(varData%var(iVar)%dat(nBand),stat=err) + case(iLookVarType%wLength); allocate(varData%var(iVar)%dat(nSpecBand),stat=err) case(iLookVarType%midSnow); allocate(varData%var(iVar)%dat(nSnow),stat=err) case(iLookVarType%midSoil); allocate(varData%var(iVar)%dat(nSoil),stat=err) case(iLookVarType%midToto); allocate(varData%var(iVar)%dat(nLayers),stat=err) @@ -632,7 +638,7 @@ subroutine allocateDat_int(metadata,nSnow,nSoil,nLayers, & ! input else select case(metadata(iVar)%vartype) case(iLookVarType%scalarv); allocate(varData%var(iVar)%dat(1),stat=err) - case(iLookVarType%wLength); allocate(varData%var(iVar)%dat(nBand),stat=err) + case(iLookVarType%wLength); allocate(varData%var(iVar)%dat(nSpecBand),stat=err) case(iLookVarType%midSnow); allocate(varData%var(iVar)%dat(nSnow),stat=err) case(iLookVarType%midSoil); allocate(varData%var(iVar)%dat(nSoil),stat=err) case(iLookVarType%midToto); allocate(varData%var(iVar)%dat(nLayers),stat=err) @@ -695,7 +701,7 @@ subroutine allocateDat_flag(metadata,nSnow,nSoil,nLayers, & ! input else select case(metadata(iVar)%vartype) case(iLookVarType%scalarv); allocate(varData%var(iVar)%dat(1),stat=err) - case(iLookVarType%wLength); allocate(varData%var(iVar)%dat(nBand),stat=err) + case(iLookVarType%wLength); allocate(varData%var(iVar)%dat(nSpecBand),stat=err) case(iLookVarType%midSnow); allocate(varData%var(iVar)%dat(nSnow),stat=err) case(iLookVarType%midSoil); allocate(varData%var(iVar)%dat(nSoil),stat=err) case(iLookVarType%midToto); allocate(varData%var(iVar)%dat(nLayers),stat=err) diff --git a/build/source/engine/bigAquifer.f90 b/build/source/engine/bigAquifer.f90 old mode 100755 new mode 100644 index 5b5ed0190..19ea9093b --- a/build/source/engine/bigAquifer.f90 +++ b/build/source/engine/bigAquifer.f90 @@ -20,8 +20,7 @@ module bigAquifer_module ! ----------------------------------------------------------------------------------------------------------- - -! numerical recipes data types +! homegrown solver data types USE nrtype ! access missing values @@ -30,98 +29,107 @@ module bigAquifer_module ! physical constants USE multiconst,only:& - LH_vap, & ! latent heat of vaporization (J kg-1) - iden_water ! intrinsic density of water (kg m-3) - + LH_vap, & ! latent heat of vaporization (J kg-1) + iden_water ! intrinsic density of water (kg m-3) ! ----------------------------------------------------------------------------------------------------------- implicit none private -public::bigAquifer +public :: bigAquifer contains - - - ! *************************************************************************************************************** - ! public subroutine soilLiqFlx: compute liquid water fluxes and their derivatives - ! *************************************************************************************************************** - subroutine bigAquifer(& - ! input: state variables and fluxes - scalarAquiferStorageTrial, & ! intent(in): trial value of aquifer storage (m) - scalarCanopyTranspiration, & ! intent(in): canopy transpiration (kg m-2 s-1) - scalarSoilDrainage, & ! intent(in): soil drainage (m s-1) - ! input: diagnostic variables and parameters - mpar_data, & ! intent(in): model parameter structure - diag_data, & ! intent(in): diagnostic variable structure - ! output: fluxes - scalarAquiferTranspire, & ! intent(out): transpiration loss from the aquifer (m s-1) - scalarAquiferRecharge, & ! intent(out): recharge to the aquifer (m s-1) - scalarAquiferBaseflow, & ! intent(out): total baseflow from the aquifer (m s-1) - dBaseflow_dAquifer, & ! intent(out): change in baseflow flux w.r.t. aquifer storage (s-1) - ! output: error control - err,message) ! intent(out): error control - ! named variables - USE var_lookup,only:iLookDIAG ! named variables for structure elements - USE var_lookup,only:iLookPARAM ! named variables for structure elements - ! data types - USE data_types,only:var_dlength ! x%var(:)%dat (dp) - ! ------------------------------------------------------------------------------------------------------------------------------------------------- - implicit none - ! input: state variables, fluxes, and parameters - real(rkind),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) - real(rkind),intent(in) :: scalarCanopyTranspiration ! canopy transpiration (kg m-2 s-1) - real(rkind),intent(in) :: scalarSoilDrainage ! soil drainage (m s-1) - ! input: diagnostic variables and parameters - type(var_dlength),intent(in) :: mpar_data ! model parameters - type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU - ! output: fluxes - real(rkind),intent(out) :: scalarAquiferTranspire ! transpiration loss from the aquifer (m s-1) - real(rkind),intent(out) :: scalarAquiferRecharge ! recharge to the aquifer (m s-1) - real(rkind),intent(out) :: scalarAquiferBaseflow ! total baseflow from the aquifer (m s-1) - real(rkind),intent(out) :: dBaseflow_dAquifer ! change in baseflow flux w.r.t. aquifer storage (s-1) - ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! ----------------------------------------------------------------------------------------------------------------------------------------------------- - ! local variables - real(rkind) :: aquiferTranspireFrac ! fraction of total transpiration that comes from the aquifer (-) - real(rkind) :: xTemp ! temporary variable (-) - ! ------------------------------------------------------------------------------------------------------------------------------------------------- - ! initialize error control - err=0; message='bigAquifer/' - - ! make association between local variables and the information in the data structures - associate(& - ! model diagnostic variables: contribution of the aquifer to transpiration - scalarTranspireLim => diag_data%var(iLookDIAG%scalarTranspireLim)%dat(1), & ! intent(in): [dp] weighted average of the transpiration limiting factor (-) - scalarAquiferRootFrac => diag_data%var(iLookDIAG%scalarAquiferRootFrac)%dat(1), & ! intent(in): [dp] fraction of roots below the lowest soil layer (-) - scalarTranspireLimAqfr => diag_data%var(iLookDIAG%scalarTranspireLimAqfr)%dat(1), & ! intent(in): [dp] transpiration limiting factor for the aquifer (-) - ! model parameters: baseflow flux - aquiferBaseflowRate => mpar_data%var(iLookPARAM%aquiferBaseflowRate)%dat(1), & ! intent(in): [dp] tbaseflow rate when aquiferStorage = aquiferScaleFactor (m s-1) - aquiferScaleFactor => mpar_data%var(iLookPARAM%aquiferScaleFactor)%dat(1), & ! intent(in): [dp] scaling factor for aquifer storage in the big bucket (m) - aquiferBaseflowExp => mpar_data%var(iLookPARAM%aquiferBaseflowExp)%dat(1) & ! intent(in): [dp] baseflow exponent (-) - ) ! associating local variables with the information in the data structures - - ! compute aquifer transpiration (m s-1) - aquiferTranspireFrac = scalarAquiferRootFrac*scalarTranspireLimAqfr/scalarTranspireLim ! fraction of total transpiration that comes from the aquifer (-) - scalarAquiferTranspire = aquiferTranspireFrac*scalarCanopyTranspiration/iden_water ! aquifer transpiration (kg m-2 s-1 --> m s-1) - - ! compute aquifer recharge (transfer variables -- included for generality for basin-wide aquifer) - scalarAquiferRecharge = scalarSoilDrainage ! m s-1 - - ! compute the aquifer baseflow (m s-1) - xTemp = scalarAquiferStorageTrial/aquiferScaleFactor - scalarAquiferBaseflow = aquiferBaseflowRate*(xTemp**aquiferBaseflowExp) - - ! compute the derivative in the net aquifer flux - dBaseflow_dAquifer = -(aquiferBaseflowExp*aquiferBaseflowRate*(xTemp**(aquiferBaseflowExp - 1._rkind)))/aquiferScaleFactor - - ! end association to data in structures - end associate - - end subroutine bigAquifer - - - ! ******************************************************************************************************************************************************************************* - ! ******************************************************************************************************************************************************************************* - +! *************************************************************************************************************** +! public subroutine bigAquifer: compute aquifer water fluxes and their derivatives +! *************************************************************************************************************** +subroutine bigAquifer(& + ! input: state variables, fluxes, and pre-computed derivatives + in_bigAquifer, & ! intent(in): state variables, fluxes, and pre-computed derivatives + ! input: diagnostic variables and parameters + mpar_data, & ! intent(in): model parameter structure + diag_data, & ! intent(in): diagnostic variable structure + ! input-output: derivatives in transpiration w.r.t. canopy state variables + io_bigAquifer, & ! intent(inout): derivatives in transpiration w.r.t. canopy state variables + ! output: fluxes and error control + out_bigAquifer) ! intent(out): fluxes and error control + ! named variables + USE var_lookup,only:iLookDIAG ! named variables for structure elements + USE var_lookup,only:iLookPARAM ! named variables for structure elements + ! data types + USE data_types,only:var_dlength ! x%var(:)%dat [rkind] + USE data_types,only:in_type_bigAquifer ! derived typ for intent(in) arguments + USE data_types,only:io_type_bigAquifer ! derived typ for intent(inout) arguments + USE data_types,only:out_type_bigAquifer ! derived typ for intent(out) arguments + ! ------------------------------------------------------------------------------------------------------------------------------------------------- + implicit none + ! input: state variables, fluxes, and pre-computed derivatives + type(in_type_bigAquifer),intent(in) :: in_bigAquifer ! state variables, fluxes, and pre-computed derivatives + ! input: diagnostic variables and parameters + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU + ! input-output: derivatives in transpiration w.r.t. canopy state variables + type(io_type_bigAquifer),intent(inout) :: io_bigAquifer ! derivatives in transpiration w.r.t. canopy state variables + ! output: fluxes and error control + type(out_type_bigAquifer),intent(out) :: out_bigAquifer ! fluxes and error control + ! ----------------------------------------------------------------------------------------------------------------------------------------------------- + ! local variables + real(rkind) :: aquiferTranspireFrac ! fraction of total transpiration that comes from the aquifer (-) + real(rkind) :: xTemp ! temporary variable (-) + ! ------------------------------------------------------------------------------------------------------------------------------------------------- + ! make association between local variables and the information in the data structures + associate(& + ! input: state variables, fluxes, and parameters + scalarAquiferStorageTrial => in_bigAquifer % scalarAquiferStorageTrial, & ! intent(in): [dp] trial value of aquifer storage (m) + scalarCanopyTranspiration => in_bigAquifer % scalarCanopyTranspiration, & ! intent(in): [dp] canopy transpiration (kg m-2 s-1) + scalarSoilDrainage => in_bigAquifer % scalarSoilDrainage, & ! intent(in): [dp] soil drainage (m s-1) + ! input: pre-computed derivatves + dCanopyTrans_dCanWat => in_bigAquifer % dCanopyTrans_dCanWat, & ! intent(in): [dp] derivative in canopy transpiration w.r.t. canopy total water content (s-1) + dCanopyTrans_dTCanair => in_bigAquifer % dCanopyTrans_dTCanair, & ! intent(in): [dp] derivative in canopy transpiration w.r.t. canopy air temperature (kg m-2 s-1 K-1) + dCanopyTrans_dTCanopy => in_bigAquifer % dCanopyTrans_dTCanopy, & ! intent(in): [dp] derivative in canopy transpiration w.r.t. canopy temperature (kg m-2 s-1 K-1) + dCanopyTrans_dTGround => in_bigAquifer % dCanopyTrans_dTGround, & ! intent(in): [dp] derivative in canopy transpiration w.r.t. ground temperature (kg m-2 s-1 K-1) + ! input: model diagnostic variables: contribution of the aquifer to transpiration + scalarTranspireLim => diag_data%var(iLookDIAG%scalarTranspireLim)%dat(1), & ! intent(in): [dp] weighted average of the transpiration limiting factor (-) + scalarAquiferRootFrac => diag_data%var(iLookDIAG%scalarAquiferRootFrac)%dat(1), & ! intent(in): [dp] fraction of roots below the lowest soil layer (-) + scalarTranspireLimAqfr => diag_data%var(iLookDIAG%scalarTranspireLimAqfr)%dat(1), & ! intent(in): [dp] transpiration limiting factor for the aquifer (-) + ! input: model parameters: baseflow flux + aquiferBaseflowRate => mpar_data%var(iLookPARAM%aquiferBaseflowRate)%dat(1), & ! intent(in): [dp] tbaseflow rate when aquiferStorage = aquiferScaleFactor (m s-1) + aquiferScaleFactor => mpar_data%var(iLookPARAM%aquiferScaleFactor)%dat(1), & ! intent(in): [dp] scaling factor for aquifer storage in the big bucket (m) + aquiferBaseflowExp => mpar_data%var(iLookPARAM%aquiferBaseflowExp)%dat(1), & ! intent(in): [dp] baseflow exponent (-) + ! input-output: derivatives in transpiration w.r.t. canopy state variables + dAquiferTrans_dTCanair => io_bigAquifer % dAquiferTrans_dTCanair, & ! intent(inout): derivatives in the aquifer transpiration flux w.r.t. canopy air temperature + dAquiferTrans_dTCanopy => io_bigAquifer % dAquiferTrans_dTCanopy, & ! intent(inout): derivatives in the aquifer transpiration flux w.r.t. canopy temperature + dAquiferTrans_dTGround => io_bigAquifer % dAquiferTrans_dTGround, & ! intent(inout): derivatives in the aquifer transpiration flux w.r.t. ground temperature + dAquiferTrans_dCanWat => io_bigAquifer % dAquiferTrans_dCanWat, & ! intent(inout): derivatives in the aquifer transpiration flux w.r.t. canopy total water + ! output: fluxes + scalarAquiferTranspire => out_bigAquifer % scalarAquiferTranspire,& ! intent(out): transpiration loss from the aquifer (m s-1) + scalarAquiferRecharge => out_bigAquifer % scalarAquiferRecharge, & ! intent(out): recharge to the aquifer (m s-1) + scalarAquiferBaseflow => out_bigAquifer % scalarAquiferBaseflow, & ! intent(out): total baseflow from the aquifer (m s-1) + dBaseflow_dAquifer => out_bigAquifer % dBaseflow_dAquifer, & ! intent(out): change in baseflow flux w.r.t. aquifer storage (s-1) + ! output: error control + err => out_bigAquifer % err, & ! intent(out): error code + message => out_bigAquifer % cmessage & ! intent(out): error message + ) ! end associating local variables with the information in the data structures + err=0; message='bigAquifer/' ! initialize error control + + ! compute aquifer transpiration (m s-1) + aquiferTranspireFrac = scalarAquiferRootFrac*scalarTranspireLimAqfr/scalarTranspireLim ! fraction of total transpiration that comes from the aquifer (-) + scalarAquiferTranspire = aquiferTranspireFrac*scalarCanopyTranspiration/iden_water ! aquifer transpiration (kg m-2 s-1 --> m s-1) + ! derivatives in transpiration w.r.t. canopy state variables + dAquiferTrans_dCanWat = aquiferTranspireFrac*dCanopyTrans_dCanWat /iden_water + dAquiferTrans_dTCanair = aquiferTranspireFrac*dCanopyTrans_dTCanair/iden_water + dAquiferTrans_dTCanopy = aquiferTranspireFrac*dCanopyTrans_dTCanopy/iden_water + dAquiferTrans_dTGround = aquiferTranspireFrac*dCanopyTrans_dTGround/iden_water + + ! compute aquifer recharge (transfer variables -- included for generality for basin-wide aquifer) + scalarAquiferRecharge = scalarSoilDrainage ! m s-1 + + ! compute the aquifer baseflow (m s-1) + xTemp = scalarAquiferStorageTrial/aquiferScaleFactor + if (xTemp<0._rkind) xTemp = 0._rkind ! otherwise will give NaN in next line + scalarAquiferBaseflow = aquiferBaseflowRate*(xTemp**aquiferBaseflowExp) + + ! compute the derivative in the net aquifer flux + dBaseflow_dAquifer = -(aquiferBaseflowExp*aquiferBaseflowRate*(xTemp**(aquiferBaseflowExp - 1._rkind)))/aquiferScaleFactor + + end associate ! end association to data in structure + +end subroutine bigAquifer end module bigAquifer_module diff --git a/build/source/engine/canopySnow.f90 b/build/source/engine/canopySnow.f90 old mode 100755 new mode 100644 index 930227c9c..ebb5ab79b --- a/build/source/engine/canopySnow.f90 +++ b/build/source/engine/canopySnow.f90 @@ -22,12 +22,13 @@ module canopySnow_module ! data types USE nrtype +USE globalData,only:realMissing ! missing real number ! derived types to define the data structures USE data_types,only:& var_i, & ! data vector (i4b) - var_d, & ! data vector (dp) - var_dlength, & ! data vector with variable length dimension (dp) + var_d, & ! data vector (rkind) + var_dlength, & ! data vector with variable length dimension (rkind) model_options ! defines the model decisions ! physical constants @@ -70,78 +71,70 @@ subroutine canopySnow(& ! output: error control err,message) ! intent(out): error control ! ------------------------------------------------------------------------------------------------ - implicit none + implicit none ! ------------------------------------------------------------------------------------------------ ! input: model control - real(rkind),intent(in) :: dt ! time step (seconds) - real(rkind),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf + stem -- after burial by snow (m2 m-2) - logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) + real(rkind),intent(in) :: dt ! time step (seconds) + real(rkind),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf + stem -- after burial by snow (m2 m-2) + logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) ! input/output: data structures - type(model_options),intent(in) :: model_decisions(:) ! model decisions - type(var_d),intent(in) :: forc_data ! model forcing data - type(var_dlength),intent(in) :: mpar_data ! model parameters - type(var_dlength),intent(in) :: diag_data ! model diagnostic variables for a local HRU - type(var_dlength),intent(inout) :: prog_data ! model prognostic variables for a local HRU - type(var_dlength),intent(inout) :: flux_data ! model flux variables + type(model_options),intent(in) :: model_decisions(:) ! model decisions + type(var_d),intent(in) :: forc_data ! model forcing data + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_dlength),intent(in) :: diag_data ! model diagnostic variables for a local HRU + type(var_dlength),intent(inout) :: prog_data ! model prognostic variables for a local HRU + type(var_dlength),intent(inout) :: flux_data ! model flux variables ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message ! local variables - real(rkind),parameter :: valueMissing=-9999._rkind ! missing value - integer(i4b) :: iter ! iteration index - integer(i4b),parameter :: maxiter=50 ! maximum number of iterations - real(rkind) :: unloading_melt ! unloading associated with canopy drip (kg m-2 s-1) - real(rkind) :: airtemp_degC ! value of air temperature in degrees Celcius - real(rkind) :: leafScaleFactor ! scaling factor for interception based on temperature (-) - real(rkind) :: leafInterceptCapSnow ! storage capacity for snow per unit leaf area (kg m-2) - real(rkind) :: canopyIceScaleFactor ! capacity scaling factor for throughfall (kg m-2) - real(rkind) :: throughfallDeriv ! derivative in throughfall flux w.r.t. canopy storage (s-1) - real(rkind) :: unloadingDeriv ! derivative in unloading flux w.r.t. canopy storage (s-1) - real(rkind) :: scalarCanopyIceIter ! trial value for mass of ice on the vegetation canopy (kg m-2) (kg m-2) - real(rkind) :: flux ! net flux (kg m-2 s-1) - real(rkind) :: delS ! change in storage (kg m-2) - real(rkind) :: resMass ! residual in mass equation (kg m-2) - real(rkind) :: tempUnloadingFun ! temperature unloading functions, Eq. 14 in Roesch et al. 2001 - real(rkind) :: windUnloadingFun ! temperature unloading functions, Eq. 15 in Roesch et al. 2001 - real(rkind),parameter :: convTolerMass=0.0001_rkind ! convergence tolerance for mass (kg m-2) + integer(i4b) :: iter ! iteration index + integer(i4b),parameter :: maxiter=50 ! maximum number of iterations + real(rkind) :: unloading_melt ! unloading associated with canopy drip (kg m-2 s-1) + real(rkind) :: airtemp_degC ! value of air temperature in degrees Celcius + real(rkind) :: leafScaleFactor ! scaling factor for interception based on temperature (-) + real(rkind) :: leafInterceptCapSnow ! storage capacity for snow per unit leaf area (kg m-2) + real(rkind) :: canopyIceScaleFactor ! capacity scaling factor for throughfall (kg m-2) + real(rkind) :: throughfallDeriv ! derivative in throughfall flux w.r.t. canopy storage (s-1) + real(rkind) :: unloadingDeriv ! derivative in unloading flux w.r.t. canopy storage (s-1) + real(rkind) :: scalarCanopyIceIter ! trial value for mass of ice on the vegetation canopy (kg m-2) (kg m-2) + real(rkind) :: flux ! net flux (kg m-2 s-1) + real(rkind) :: delS ! change in storage (kg m-2) + real(rkind) :: resMass ! residual in mass equation (kg m-2) + real(rkind) :: tempUnloadingFun ! temperature unloading functions, Eq. 14 in Roesch et al. 2001 + real(rkind) :: windUnloadingFun ! temperature unloading functions, Eq. 15 in Roesch et al. 2001 + real(rkind),parameter :: convTolerMass=0.0001_rkind ! convergence tolerance for mass (kg m-2) ! ------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='canopySnow/' ! ------------------------------------------------------------------------------------------------ ! associate variables in the data structure associate(& - ! model decisions - ixSnowInterception => model_decisions(iLookDECISIONS%snowIncept)%iDecision, & ! intent(in): [i4b] choice of option to determine maximum snow interception capacity - ixSnowUnload => model_decisions(iLookDECISIONS%snowUnload)%iDecision, & ! intent(in): [i4b] choice of option to determing how snow unloads from canopy - + ixSnowInterception => model_decisions(iLookDECISIONS%snowIncept)%iDecision, & ! intent(in): [i4b] choice of option to determine maximum snow interception capacity + ixSnowUnload => model_decisions(iLookDECISIONS%snowUnload)%iDecision, & ! intent(in): [i4b] choice of option to determing how snow unloads from canopy ! model forcing data - scalarAirtemp => forc_data%var(iLookFORCE%airtemp), & ! intent(in): [dp] air temperature (K) - + scalarAirtemp => forc_data%var(iLookFORCE%airtemp), & ! intent(in): [dp] air temperature (K) ! model parameters - refInterceptCapSnow => mpar_data%var(iLookPARAM%refInterceptCapSnow)%dat(1), & ! intent(in): [dp] reference canopy interception capacity for snow per unit leaf area (kg m-2) - ratioDrip2Unloading => mpar_data%var(iLookPARAM%ratioDrip2Unloading)%dat(1), & ! intent(in): [dp] ratio of canopy drip to snow unloading (-) - snowUnloadingCoeff => mpar_data%var(iLookPARAM%snowUnloadingCoeff)%dat(1), & ! intent(in): [dp] time constant for unloading of snow from the forest canopy (s-1) - minTempUnloading => mpar_data%var(iLookPARAM%minTempUnloading)%dat(1), & ! constant describing the minimum temperature for snow unloading in windySnow parameterization (K) - minWindUnloading => mpar_data%var(iLookPARAM%minWindUnloading)%dat(1), & ! constant describing the minimum temperature for snow unloading in windySnow parameterization (K) - rateTempUnloading => mpar_data%var(iLookPARAM%rateTempUnloading)%dat(1), & ! constant describing how quickly snow will unload due to temperature in windySnow parameterization (K s) - rateWindUnloading => mpar_data%var(iLookPARAM%rateWindUnloading)%dat(1), & ! constant describing how quickly snow will unload due to wind in windySnow parameterization (K s) - + refInterceptCapSnow => mpar_data%var(iLookPARAM%refInterceptCapSnow)%dat(1), & ! intent(in): [dp] reference canopy interception capacity for snow per unit leaf area (kg m-2) + ratioDrip2Unloading => mpar_data%var(iLookPARAM%ratioDrip2Unloading)%dat(1), & ! intent(in): [dp] ratio of canopy drip to snow unloading (-) + snowUnloadingCoeff => mpar_data%var(iLookPARAM%snowUnloadingCoeff)%dat(1), & ! intent(in): [dp] time constant for unloading of snow from the forest canopy (s-1) + minTempUnloading => mpar_data%var(iLookPARAM%minTempUnloading)%dat(1), & ! intent(in): [dp] constant describing the minimum temperature for snow unloading in windySnow parameterization (K) + minWindUnloading => mpar_data%var(iLookPARAM%minWindUnloading)%dat(1), & ! intent(in): [dp] constant describing the minimum temperature for snow unloading in windySnow parameterization (K) + rateTempUnloading => mpar_data%var(iLookPARAM%rateTempUnloading)%dat(1), & ! intent(in): [dp] constant describing how quickly snow will unload due to temperature in windySnow parameterization (K s) + rateWindUnloading => mpar_data%var(iLookPARAM%rateWindUnloading)%dat(1), & ! intent(in): [dp] constant describing how quickly snow will unload due to wind in windySnow parameterization (K s) ! model diagnostic variables - scalarNewSnowDensity => diag_data%var(iLookDIAG%scalarNewSnowDensity)%dat(1), & ! intent(in): [dp] density of new snow (kg m-3) - + scalarNewSnowDensity => diag_data%var(iLookDIAG%scalarNewSnowDensity)%dat(1), & ! intent(in): [dp] density of new snow (kg m-3) ! model prognostic variables (input/output) scalarCanopyIce => prog_data%var(iLookPROG%scalarCanopyIce)%dat(1), & ! intent(inout): [dp] mass of ice on the vegetation canopy (kg m-2) - ! model fluxes (input) - scalarCanairTemp => prog_data%var(iLookPROG%scalarCanairTemp)%dat(1), & ! intent(in): [dp] temperature of the canopy air space (k) - scalarSnowfall => flux_data%var(iLookFLUX%scalarSnowfall)%dat(1), & ! intent(in): [dp] computed snowfall rate (kg m-2 s-1) - scalarCanopyLiqDrainage => flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1), & ! intent(in): [dp] liquid drainage from the vegetation canopy (kg m-2 s-1) - scalarWindspdCanopyTop => flux_data%var(iLookFLUX%scalarWindspdCanopyTop)%dat(1), & ! intent(in): [dp] windspeed at the top of the canopy (m s-1) + scalarCanairTemp => prog_data%var(iLookPROG%scalarCanairTemp)%dat(1), & ! intent(in): [dp] temperature of the canopy air space (k) + scalarSnowfall => flux_data%var(iLookFLUX%scalarSnowfall)%dat(1), & ! intent(in): [dp] computed snowfall rate (kg m-2 s-1) + scalarCanopyLiqDrainage => flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1), & ! intent(in): [dp] liquid drainage from the vegetation canopy (kg m-2 s-1) + scalarWindspdCanopyTop => flux_data%var(iLookFLUX%scalarWindspdCanopyTop)%dat(1), & ! intent(in): [dp] windspeed at the top of the canopy (m s-1) ! model variables (output) - scalarThroughfallSnow => flux_data%var(iLookFLUX%scalarThroughfallSnow)%dat(1), & ! intent(out): [dp] snow that reaches the ground without ever touching the canopy (kg m-2 s-1) - scalarCanopySnowUnloading => flux_data%var(iLookFLUX%scalarCanopySnowUnloading)%dat(1) & ! intent(out): [dp] unloading of snow from the vegetion canopy (kg m-2 s-1) - + scalarThroughfallSnow => flux_data%var(iLookFLUX%scalarThroughfallSnow)%dat(1), & ! intent(out): [dp] snow that reaches the ground without ever touching the canopy (kg m-2 s-1) + scalarCanopySnowUnloading => flux_data%var(iLookFLUX%scalarCanopySnowUnloading)%dat(1) & ! intent(out): [dp] unloading of snow from the vegetion canopy (kg m-2 s-1) ) ! associate variables in the data structures ! ----------------------------------------------------------------------------------------------------------------------------------------------------- @@ -149,92 +142,93 @@ subroutine canopySnow(& ! ************************************* if(computeVegFlux)then - unloading_melt = min(ratioDrip2Unloading*scalarCanopyLiqDrainage, scalarCanopyIce/dt) ! kg m-2 s-1 + unloading_melt = min(ratioDrip2Unloading*scalarCanopyLiqDrainage, scalarCanopyIce/dt) ! kg m-2 s-1 else - unloading_melt = 0._rkind + unloading_melt = 0._rkind end if scalarCanopyIce = scalarCanopyIce - unloading_melt*dt - ! ***** ! compute the ice balance due to snowfall and unloading... ! ******************************************************** ! check for early returns if(.not.computeVegFlux .or. (scalarSnowfall= minWindUnloading) then - windUnloadingFun = abs(scalarWindspdCanopyTop) / rateWindUnloading ! (s-1) + ! ** compute unloading + if(ixSnowUnload==meltDripUnload)then + scalarCanopySnowUnloading = snowUnloadingCoeff*scalarCanopyIceIter + unloadingDeriv = snowUnloadingCoeff + else if (ixSnowUnload==windUnload) then + tempUnloadingFun = max(scalarCanairTemp - minTempUnloading, 0._rkind) / rateTempUnloading ! (s-1) + if(scalarWindspdCanopyTop >= minWindUnloading)then + windUnloadingFun = abs(scalarWindspdCanopyTop) / rateWindUnloading ! (s-1) + else + windUnloadingFun = 0._rkind ! (s-1) + end if + ! implement the "windySnow" Roesch et al. 2001 parameterization, Eq. 13 in Roesch et al. 2001 + scalarCanopySnowUnloading = scalarCanopyIceIter * (tempUnloadingFun + windUnloadingFun) + unloadingDeriv = tempUnloadingFun + windUnloadingFun + end if + ! no snowfall + if(scalarSnowfall -1._rkind)then + leafScaleFactor = 4.0_rkind + elseif(airtemp_degC > -3._rkind)then + leafScaleFactor = 1.5_rkind*airtemp_degC + 5.5_rkind else - windUnloadingFun = 0._rkind ! (s-1) + leafScaleFactor = 1.0_rkind end if - ! implement the "windySnow" Roesch et al. 2001 parameterization, Eq. 13 in Roesch et al. 2001 - scalarCanopySnowUnloading = scalarCanopyIceIter * (tempUnloadingFun + windUnloadingFun) - unloadingDeriv = tempUnloadingFun + windUnloadingFun - end if - ! no snowfall - if(scalarSnowfall -1._rkind) then - leafScaleFactor = 4.0_rkind - elseif(airtemp_degC > -3._rkind) then - leafScaleFactor = 1.5_rkind*airtemp_degC + 5.5_rkind - else - leafScaleFactor = 1.0_rkind - end if - leafInterceptCapSnow = refInterceptCapSnow*leafScaleFactor - case default - message=trim(message)//'unable to identify option for maximum branch interception capacity' - err=20; return - end select - ! compute maximum interception capacity for the canopy - canopyIceScaleFactor = leafInterceptCapSnow*exposedVAI - ! (compute throughfall) - scalarThroughfallSnow = scalarSnowfall*(scalarCanopyIceIter/canopyIceScaleFactor) - throughfallDeriv = scalarSnowfall/canopyIceScaleFactor - end if ! (if snow is falling) - ! ** compute iteration increment - flux = scalarSnowfall - scalarThroughfallSnow - scalarCanopySnowUnloading ! net flux (kg m-2 s-1) - delS = (flux*dt - (scalarCanopyIceIter - scalarCanopyIce))/(1._rkind + (throughfallDeriv + unloadingDeriv)*dt) - ! ** check for convergence - resMass = scalarCanopyIceIter - (scalarCanopyIce + flux*dt) - if(abs(resMass) < convTolerMass)exit - ! ** check for non-convengence - if(iter==maxiter)then; err=20; message=trim(message)//'failed to converge [mass]'; return; end if - ! ** update value - scalarCanopyIceIter = scalarCanopyIceIter + delS + leafInterceptCapSnow = refInterceptCapSnow*leafScaleFactor + case default + message=trim(message)//'unable to identify option for maximum branch interception capacity' + err=20; return + end select + ! compute maximum interception capacity for the canopy + canopyIceScaleFactor = leafInterceptCapSnow*exposedVAI + ! compute throughfall + scalarThroughfallSnow = scalarSnowfall*(scalarCanopyIceIter/canopyIceScaleFactor) + throughfallDeriv = scalarSnowfall/canopyIceScaleFactor + end if ! (if snow is falling) + ! ** compute iteration increment + flux = scalarSnowfall - scalarThroughfallSnow - scalarCanopySnowUnloading ! net flux (kg m-2 s-1) + delS = (flux*dt - (scalarCanopyIceIter - scalarCanopyIce))/(1._rkind + (throughfallDeriv + unloadingDeriv)*dt) + + ! ** check for convergence + resMass = scalarCanopyIceIter - (scalarCanopyIce + flux*dt) + if(abs(resMass) < convTolerMass)exit + ! ** check for non-convengence + if(iter==maxiter)then; err=20; message=trim(message)//'failed to converge [mass]'; return; end if + ! ** update value + scalarCanopyIceIter = scalarCanopyIceIter + delS end do ! iterating ! add the unloading associated with melt drip (kg m-2 s-1) scalarCanopySnowUnloading = scalarCanopySnowUnloading + unloading_melt - ! ***** ! update mass of ice on the canopy (kg m-2) scalarCanopyIce = scalarCanopyIceIter + ! end association to variables in the data structure end associate diff --git a/build/source/engine/checkStruc.f90 b/build/source/engine/checkStruc.f90 old mode 100755 new mode 100644 index 7f8ddbd83..d40bbcb21 --- a/build/source/engine/checkStruc.f90 +++ b/build/source/engine/checkStruc.f90 @@ -40,11 +40,13 @@ subroutine checkStruc(err,message) USE globalData,only:prog_meta,diag_meta,flux_meta,deriv_meta ! metadata structures USE globalData,only:mpar_meta,indx_meta ! metadata structures USE globalData,only:bpar_meta,bvar_meta ! metadata structures - ! named variables defining strructure elements + USE globalData,only:lookup_meta ! metadata structures + ! named variables defining strructure elements USE var_lookup,only:iLookTIME,iLookFORCE,iLookATTR,iLookTYPE,iLookID ! named variables showing the elements of each data structure USE var_lookup,only:iLookPROG,iLookDIAG,iLookFLUX,iLookDERIV ! named variables showing the elements of each data structure USE var_lookup,only:iLookPARAM,iLookINDEX ! named variables showing the elements of each data structure USE var_lookup,only:iLookBPAR,iLookBVAR ! named variables showing the elements of each data structure + USE var_lookup,only:iLookLOOKUP ! named variables showing the elements of each data structure implicit none ! dummy variables integer(i4b),intent(out) :: err ! error code @@ -70,19 +72,20 @@ subroutine checkStruc(err,message) ! convert the lookup structures to a character string ! expect the lookup structures to be a vector (1,2,3,...,n) select case(trim(structInfo(iStruct)%structName)) - case('time'); write(longString,*) iLookTIME - case('forc'); write(longString,*) iLookFORCE - case('attr'); write(longString,*) iLookATTR - case('type'); write(longString,*) iLookTYPE - case('id'); write(longString,*) iLookID - case('mpar'); write(longString,*) iLookPARAM - case('bpar'); write(longString,*) iLookBPAR - case('bvar'); write(longString,*) iLookBVAR - case('indx'); write(longString,*) iLookINDEX - case('prog'); write(longString,*) iLookPROG - case('diag'); write(longString,*) iLookDIAG - case('flux'); write(longString,*) iLookFLUX - case('deriv'); write(longString,*) iLookDERIV + case('time'); write(longString,*) iLookTIME + case('forc'); write(longString,*) iLookFORCE + case('attr'); write(longString,*) iLookATTR + case('type'); write(longString,*) iLookTYPE + case('id'); write(longString,*) iLookID + case('mpar'); write(longString,*) iLookPARAM + case('bpar'); write(longString,*) iLookBPAR + case('bvar'); write(longString,*) iLookBVAR + case('indx'); write(longString,*) iLookINDEX + case('prog'); write(longString,*) iLookPROG + case('diag'); write(longString,*) iLookDIAG + case('flux'); write(longString,*) iLookFLUX + case('deriv'); write(longString,*) iLookDERIV + case('lookup'); write(longString,*) iLookLOOKUP case default; err=20; message=trim(message)//'unable to identify lookup structure'; return end select ! check that the length of the lookup structure matches the number of variables in the data structure @@ -107,19 +110,20 @@ subroutine checkStruc(err,message) do iStruct=1,nStruct ! check that the metadata is fully populated select case(trim(structInfo(iStruct)%structName)) - case('time'); call checkPopulated(iStruct,time_meta,err,cmessage) - case('forc'); call checkPopulated(iStruct,forc_meta,err,cmessage) - case('attr'); call checkPopulated(iStruct,attr_meta,err,cmessage) - case('type'); call checkPopulated(iStruct,type_meta,err,cmessage) - case('id'); call checkPopulated(iStruct,id_meta, err,cmessage) - case('mpar'); call checkPopulated(iStruct,mpar_meta,err,cmessage) - case('bpar'); call checkPopulated(iStruct,bpar_meta,err,cmessage) - case('bvar'); call checkPopulated(iStruct,bvar_meta,err,cmessage) - case('indx'); call checkPopulated(iStruct,indx_meta,err,cmessage) - case('prog'); call checkPopulated(iStruct,prog_meta,err,cmessage) - case('diag'); call checkPopulated(iStruct,diag_meta,err,cmessage) - case('flux'); call checkPopulated(iStruct,flux_meta,err,cmessage) - case('deriv'); call checkPopulated(iStruct,deriv_meta,err,cmessage) + case('time'); call checkPopulated(iStruct,time_meta,err,cmessage) + case('forc'); call checkPopulated(iStruct,forc_meta,err,cmessage) + case('attr'); call checkPopulated(iStruct,attr_meta,err,cmessage) + case('type'); call checkPopulated(iStruct,type_meta,err,cmessage) + case('id'); call checkPopulated(iStruct,id_meta, err,cmessage) + case('mpar'); call checkPopulated(iStruct,mpar_meta,err,cmessage) + case('bpar'); call checkPopulated(iStruct,bpar_meta,err,cmessage) + case('bvar'); call checkPopulated(iStruct,bvar_meta,err,cmessage) + case('indx'); call checkPopulated(iStruct,indx_meta,err,cmessage) + case('prog'); call checkPopulated(iStruct,prog_meta,err,cmessage) + case('diag'); call checkPopulated(iStruct,diag_meta,err,cmessage) + case('flux'); call checkPopulated(iStruct,flux_meta,err,cmessage) + case('deriv'); call checkPopulated(iStruct,deriv_meta,err,cmessage) + case('lookup'); call checkPopulated(iStruct,lookup_meta,err,cmessage) case default; err=20; message=trim(message)//'unable to identify lookup structure'; return end select if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) @@ -165,7 +169,8 @@ subroutine checkPopulated(iStruct,metadata,err,message) ! check that the variable was found at all if (jVar==integerMissing) then - message = trim(message)//'cannot find variable '//trim(metadata(iVar)%varname)//' in structure '//trim(structInfo(iStruct)%structName)//'_meta; you need to add variable to get_ix'//trim(structInfo(iStruct)%structName) + message = trim(message)//'cannot find variable '//trim(metadata(iVar)%varname)//' in structure '//trim(structInfo(iStruct)%structName)//'_meta; '// & + 'you need to add variable to get_ix'//trim(structInfo(iStruct)%structName) err=20; return end if @@ -178,7 +183,8 @@ subroutine checkPopulated(iStruct,metadata,err,message) ! check that the variable index is correct ! This can occur because (1) the code in popMetadat is corrupt (e.g., mis-match in look-up variable); or (2) var_lookup is corrupt. if (jVar/=iVar) then - write(message,'(a,i0,a,i0,a)') trim(message)//'variable '//trim(metadata(iVar)%varname)//' has index ', iVar, ' (expect index ', jVar, '); problem possible in popMetadat, get_ix'//trim(structInfo(iStruct)%structName)//', or var_lookup' + write(message,'(a,i0,a,i0,a)') trim(message)//'variable '//trim(metadata(iVar)%varname)//' has index ', iVar, & + ' (expect index ', jVar, '); problem possible in popMetadat, get_ix'//trim(structInfo(iStruct)%structName)//', or var_lookup' err=20; return end if diff --git a/build/source/engine/check_icond.f90 b/build/source/engine/check_icond.f90 old mode 100755 new mode 100644 index d8a506ef7..2449fa889 --- a/build/source/engine/check_icond.f90 +++ b/build/source/engine/check_icond.f90 @@ -22,13 +22,8 @@ module check_icond_module USE nrtype ! access missing values -USE globalData,only:integerMissing ! missing integer -USE globalData,only:realMissing ! missing double precision number - -! define modeling decisions -USE mDecisions_module,only: & - moisture, & ! moisture-based form of Richards' equation - mixdform ! mixed form of Richards' equation +USE globalData,only:integerMissing ! missing integer +USE globalData,only:realMissing ! missing real number implicit none private @@ -38,21 +33,28 @@ module check_icond_module ! ************************************************************************************************ ! public subroutine check_icond: read model initial conditions ! ************************************************************************************************ - subroutine check_icond(nGRU, & ! number of GRUs and HRUs - progData, & ! model prognostic (state) variables - mparData, & ! model parameters - indxData, & ! layer index data - err,message) ! error control + subroutine check_icond(nGRU, & ! intent(in): number of GRUs and HRUs + progData, & ! intent(inout): model prognostic (state) variables + diagData, & ! intent(inout): model diagnostic variables + mparData, & ! intent(in): model parameters + indxData, & ! intent(in): layer index data + lookupData, & ! intent(in): lookup table data + checkEnthalpy, & ! intent(in): flag if to check enthalpy for consistency + no_icond_enth, & ! intent(in): flag that enthalpy not in initial conditions + use_lookup, & ! intent(in): flag to use the lookup table for soil enthalpy + err,message) ! intent(out): error control ! -------------------------------------------------------------------------------------------------------- ! modules USE nrtype - USE var_lookup,only:iLookParam ! variable lookup structure - USE var_lookup,only:iLookProg ! variable lookup structure - USE var_lookup,only:iLookIndex ! variable lookup structure + USE var_lookup,only:iLookPARAM ! variable lookup structure + USE var_lookup,only:iLookPROG ! variable lookup structure + USE var_lookup,only:iLookDIAG ! variable lookup structure + USE var_lookup,only:iLookINDEX ! variable lookup structure USE globalData,only:gru_struc ! gru-hru mapping structures USE data_types,only:gru_hru_doubleVec ! actual data USE data_types,only:gru_hru_intVec ! actual data - USE globaldata,only:iname_soil,iname_snow ! named variables to describe the type of layer + USE data_types,only:gru_hru_z_vLookup ! actual data + USE globalData,only:iname_soil,iname_snow ! named variables to describe the type of layer USE multiconst,only:& LH_fus, & ! latent heat of fusion (J kg-1) iden_ice, & ! intrinsic density of ice (kg m-3) @@ -62,36 +64,43 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU USE snow_utils_module,only:fracliquid ! compute volumetric fraction of liquid water in snow based on temperature USE updatState_module,only:updateSnow ! update snow states USE updatState_module,only:updateSoil ! update soil states + USE enthalpyTemp_module,only:T2enthTemp_cas ! convert temperature to enthalpy for canopy air space + USE enthalpyTemp_module,only:T2enthTemp_veg ! convert temperature to enthalpy for vegetation + USE enthalpyTemp_module,only:T2enthTemp_snow ! convert temperature to enthalpy for snow + USE enthalpyTemp_module,only:T2enthTemp_soil ! convert temperature to enthalpy for soil + implicit none ! -------------------------------------------------------------------------------------------------------- ! variable declarations ! dummies - integer(i4b) ,intent(in) :: nGRU ! number of grouped response units - type(gru_hru_doubleVec),intent(inout) :: progData ! prognostic vars - type(gru_hru_doubleVec),intent(in) :: mparData ! parameters - type(gru_hru_intVec) ,intent(in) :: indxData ! layer indexes - integer(i4b) ,intent(out) :: err ! error code - character(*) ,intent(out) :: message ! returned error message - + integer(i4b),intent(in) :: nGRU ! number of grouped response units + type(gru_hru_doubleVec),intent(inout) :: diagData ! diagnostic vars + type(gru_hru_doubleVec),intent(inout) :: progData ! prognostic vars + type(gru_hru_doubleVec),intent(in) :: mparData ! parameters + type(gru_hru_intVec),intent(in) :: indxData ! layer indexes + type(gru_hru_z_vLookup),intent(in) :: lookupData ! lookup table data + logical(lgt),intent(in) :: checkEnthalpy ! if true either need enthTemp as starting residual value, or for state variable initialization + logical(lgt),intent(in) :: no_icond_enth ! if true, no enthalpy in icond file + logical(lgt),intent(in) :: use_lookup ! flag to use the lookup table for soil enthalpy, otherwise use hypergeometric function + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! returned error message ! locals - character(len=256) :: cmessage ! downstream error message - integer(i4b) :: iGRU ! loop index - integer(i4b) :: iHRU ! loop index - + character(len=256) :: cmessage ! downstream error message + integer(i4b) :: iGRU,iHRU ! loop index ! temporary variables for realism checks - integer(i4b) :: iLayer ! index of model layer - integer(i4b) :: iSoil ! index of soil layer - real(rkind) :: fLiq ! fraction of liquid water on the vegetation canopy (-) - real(rkind) :: vGn_m ! van Genutchen "m" parameter (-) - real(rkind) :: tWat ! total water on the vegetation canopy (kg m-2) - real(rkind) :: scalarTheta ! liquid water equivalent of total water [liquid water + ice] (-) - real(rkind) :: h1,h2 ! used to check depth and height are consistent - integer(i4b) :: nLayers ! total number of layers - real(rkind) :: kappa ! constant in the freezing curve function (m K-1) - integer(i4b) :: nSnow ! number of snow layers - real(rkind),parameter :: xTol=1.e-10_rkind ! small tolerance to address precision issues - real(rkind),parameter :: canIceTol=1.e-3_rkind ! small tolerance to allow existence of canopy ice for above-freezing temperatures (kg m-2) + integer(i4b) :: iLayer ! index of model layer + integer(i4b) :: iSoil ! index of soil layer + real(rkind) :: fLiq ! fraction of liquid water on the vegetation canopy (-) + real(rkind) :: vGn_m ! van Genutchen "m" parameter (-) + real(rkind) :: scalarTheta ! liquid water equivalent of total water [liquid water + ice] (-) + real(rkind) :: h1,h2 ! used to check depth and height are consistent + real(rkind) :: kappa ! constant in the freezing curve function (m K-1) + integer(i4b) :: nSoil ! number of soil layers + integer(i4b) :: nSnow ! number of snow layers + integer(i4b) :: nLayers ! total number of layers + real(rkind),parameter :: xTol=1.e-10_rkind ! small tolerance to address precision issues + real(rkind),parameter :: canIceTol=1.e-3_rkind ! small tolerance to allow existence of canopy ice for above-freezing temperatures (kg m-2) ! -------------------------------------------------------------------------------------------------------- ! Start procedure here @@ -126,24 +135,36 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU ! associate local variables with variables in the data structures associate(& + ! state variables in the canopy air space + scalarCanairTemp => progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarCanairTemp)%dat(1) ,& ! canopy air temperature (K) + scalarCanairEnthalpy => progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarCanairEnthalpy)%dat(1) ,& ! canopy air enthalpy (J m-3) ! state variables in the vegetation canopy - scalarCanopyTemp => progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarCanopyTemp)%dat(1) , & ! canopy temperature - scalarCanopyIce => progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarCanopyIce)%dat(1) , & ! mass of ice on the vegetation canopy (kg m-2) - scalarCanopyLiq => progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarCanopyLiq)%dat(1) , & ! mass of liquid water on the vegetation canopy (kg m-2) + scalarCanopyTemp => progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarCanopyTemp)%dat(1) ,& ! canopy temperature (K) + scalarCanopyEnthTemp => diagData%gru(iGRU)%hru(iHRU)%var(iLookDIAG%scalarCanopyEnthTemp)%dat(1) ,& ! canopy temperature component of enthalpy (J m-3) + scalarCanopyEnthalpy => progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarCanopyEnthalpy)%dat(1) ,& ! canopy enthalpy (J m-3) + scalarCanopyLiq => progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarCanopyLiq)%dat(1) ,& ! mass of liquid water on the vegetation canopy (kg m-2) + scalarCanopyIce => progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarCanopyIce)%dat(1) ,& ! mass of ice on the vegetation canopy (kg m-2) + heightCanopyTop => mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%heightCanopyTop)%dat(1) ,& ! height of the top of the canopy layer (m) + heightCanopyBottom => mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%heightCanopyBottom)%dat(1) ,& ! height of the bottom of the canopy layer (m) + specificHeatVeg => mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%specificHeatVeg)%dat(1) ,& ! specific heat of vegetation (J kg-1 K-1) + maxMassVegetation => mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%maxMassVegetation)%dat(1) ,& ! maximum mass of vegetation (kg m-2) ! state variables in the snow+soil domain - mLayerTemp => progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerTemp)%dat , & ! temperature (K) - mLayerVolFracLiq => progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerVolFracLiq)%dat , & ! volumetric fraction of liquid water in each snow layer (-) - mLayerVolFracIce => progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerVolFracIce)%dat , & ! volumetric fraction of ice in each snow layer (-) - mLayerMatricHead => progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerMatricHead)%dat , & ! matric head (m) - mLayerLayerType => indxData%gru(iGRU)%hru(iHRU)%var(iLookINDEX%layerType)%dat , & ! type of layer (ix_soil or ix_snow) + mLayerTemp => progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerTemp)%dat ,& ! temperature (K) + mLayerEnthTemp => diagData%gru(iGRU)%hru(iHRU)%var(iLookDIAG%mLayerEnthTemp)%dat ,& ! temperature component of enthalpy (J m-3) + mLayerEnthalpy => progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerEnthalpy)%dat ,& ! enthalpy (J m-3) + mLayerVolFracLiq => progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerVolFracLiq)%dat ,& ! volumetric fraction of liquid water in each snow layer (-) + mLayerVolFracIce => progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerVolFracIce)%dat ,& ! volumetric fraction of ice in each snow layer (-) + mLayerMatricHead => progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerMatricHead)%dat ,& ! matric head (m) + layerType => indxData%gru(iGRU)%hru(iHRU)%var(iLookINDEX%layerType)%dat ,& ! type of layer (ix_soil or ix_snow) ! depth varying soil properties - vGn_alpha => mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%vGn_alpha)%dat , & ! van Genutchen "alpha" parameter (m-1) - vGn_n => mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%vGn_n)%dat , & ! van Genutchen "n" parameter (-) - theta_sat => mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%theta_sat)%dat , & ! soil porosity (-) - theta_res => mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%theta_res)%dat , & ! soil residual volumetric water content (-) + soil_dens_intr => mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%soil_dens_intr)%dat ,& ! intrinsic soil density (kg m-3) + vGn_alpha => mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%vGn_alpha)%dat ,& ! van Genutchen "alpha" parameter (m-1) + vGn_n => mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%vGn_n)%dat ,& ! van Genutchen "n" parameter (-) + theta_sat => mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%theta_sat)%dat ,& ! soil porosity (-) + theta_res => mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%theta_res)%dat ,& ! soil residual volumetric water content (-) ! snow parameters - snowfrz_scale => mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%snowfrz_scale)%dat(1) , & ! scaling parameter for the snow freezing curve (K-1) - FCapil => mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%FCapil)%dat(1) & ! fraction of pore space in tension storage (-) + snowfrz_scale => mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%snowfrz_scale)%dat(1) ,& ! scaling parameter for the snow freezing curve (K-1) + FCapil => mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%FCapil)%dat(1) & ! fraction of pore space in tension storage (-) ) ! (associate local variables with model parameters) ! compute the constant in the freezing curve function (m K-1) @@ -156,34 +177,46 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU err=20; return else if(scalarCanopyIce > 0._rkind .and. scalarCanopyTemp > Tfreeze)then ! if here, ice content < threshold. Could be sublimation on previous timestep or simply wrong input. Print a warning - write(*,'(A,E22.16,A,F7.3,A,F7.3,A)') 'Warning: canopy ice content in restart file (=',scalarCanopyIce,') > 0 when canopy temperature (=',scalarCanopyTemp,') > Tfreeze (=',Tfreeze,'). Continuing.',NEW_LINE('a') + write(*,'(A,E22.16,A,F7.3,A,F7.3,A)') 'Warning: canopy ice content in restart file (=',scalarCanopyIce,') > 0 when canopy temperature (=',scalarCanopyTemp,') > Tfreeze (=',Tfreeze,'). Continuing.',NEW_LINE('a') + end if + scalarTheta = scalarCanopyIce + scalarCanopyLiq + + if(checkEnthalpy)then ! enthalpy as state variable or in residual + if(no_icond_enth)then ! no enthalpy in icond file + call T2enthTemp_cas(& + scalarCanairTemp, & ! intent(in): canopy air temperature (K) + scalarCanairEnthalpy) ! intent(out): enthalpy of the canopy air space (J m-3) + + call T2enthTemp_veg(& + (heightCanopyTop-heightCanopyBottom), & ! intent(in): canopy depth (m) + specificHeatVeg, & ! intent(in): specific heat of vegetation (J kg-1 K-1) + maxMassVegetation, & ! intent(in): maximum mass of vegetation (kg m-2) + snowfrz_scale, & ! intent(in): scaling parameter for the snow freezing curve (K-1) + scalarCanopyTemp, & ! intent(in): canopy temperature (K) + scalarTheta, & ! intent(in): canopy water content (kg m-2) + scalarCanopyEnthTemp) ! intent(out): temperature component of enthalpy of the vegetation canopy (J m-3) + scalarCanopyEnthalpy = scalarCanopyEnthTemp - LH_fus * scalarCanopyIce/ (heightCanopyTop-heightCanopyBottom) + else ! enthalpy is in the icond file + scalarCanopyEnthTemp = scalarCanopyEnthalpy + LH_fus * scalarCanopyIce/ (heightCanopyTop-heightCanopyBottom) + end if end if ! number of layers - nLayers = gru_struc(iGRU)%hruInfo(iHRU)%nSnow + gru_struc(iGRU)%hruInfo(iHRU)%nSoil + nSoil = gru_struc(iGRU)%hruInfo(iHRU)%nSoil nSnow = gru_struc(iGRU)%hruInfo(iHRU)%nSnow + nLayers = nSoil + nSnow ! loop through all layers do iLayer=1,nLayers - ! compute liquid water equivalent of total water (liquid plus ice) - if (iLayer>nSnow) then ! soil layer = no volume expansion - iSoil = iLayer - nSnow - vGn_m = 1._rkind - 1._rkind/vGn_n(iSoil) - scalarTheta = mLayerVolFracIce(iLayer) + mLayerVolFracLiq(iLayer) - else ! snow layer = volume expansion allowed - iSoil = integerMissing - vGn_m = realMissing - scalarTheta = mLayerVolFracIce(iLayer)*(iden_ice/iden_water) + mLayerVolFracLiq(iLayer) - end if - ! ***** ! * check that the initial volumetric fraction of liquid water and ice is reasonable... ! ************************************************************************************* - select case(mlayerLayerType(iLayer)) + select case(layerType(iLayer)) - ! ***** snow + ! ***** snow, volume expansion allowed case(iname_snow) + scalarTheta = mLayerVolFracIce(iLayer)*(iden_ice/iden_water) + mLayerVolFracLiq(iLayer) ! (check liquid water) if(mLayerVolFracLiq(iLayer) < 0._rkind)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water < 0: layer = ',iLayer; err=20; return; end if if(mLayerVolFracLiq(iLayer) > 1._rkind)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water > 1: layer = ',iLayer; err=20; return; end if @@ -194,28 +227,32 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU if(scalarTheta > 0.80_rkind)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with total water fraction [liquid + ice] > 0.80: layer = ',iLayer; err=20; return; end if if(scalarTheta < 0.05_rkind)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with total water fraction [liquid + ice] < 0.05: layer = ',iLayer; err=20; return; end if - ! ***** soil + ! ***** soil, no volume expansion case(iname_soil) - + iSoil = iLayer - nSnow + if(vGn_n(iSoil) <= 1._rkind)then; write(message,'(a,1x,i0)') trim(message)//'cannot have van Genutchen n <= 1: soil layer = ',iSoil; err=20; return; end if + if(vGn_alpha(iSoil) >= 0._rkind)then; write(message,'(a,1x,i0)') trim(message)//'cannot have van Genutchen alpha >= 0: soil layer = ',iSoil; err=20; return; end if + vGn_m = 1._rkind - 1._rkind/vGn_n(iSoil) + scalarTheta = mLayerVolFracIce(iLayer) + mLayerVolFracLiq(iLayer) ! (check liquid water) if(mLayerVolFracLiq(iLayer) < theta_res(iSoil)-xTol)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water < theta_res: layer = ',iLayer; err=20; return; end if if(mLayerVolFracLiq(iLayer) > theta_sat(iSoil)+xTol)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water > theta_sat: layer = ',iLayer; err=20; return; end if ! (check ice) - if(mLayerVolFracIce(iLayer) < 0._rkind )then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice < 0: layer = ' ,iLayer; err=20; return; end if + if(mLayerVolFracIce(iLayer) < 0._rkind )then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice < 0: layer = ' ,iLayer; err=20; return; end if if(mLayerVolFracIce(iLayer) > theta_sat(iSoil)+xTol)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice > theta_sat: layer = ',iLayer; err=20; return; end if ! check total water if(scalarTheta < theta_res(iSoil)-xTol)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with total water fraction [liquid + ice] < theta_res: layer = ',iLayer; err=20; return; end if if(scalarTheta > theta_sat(iSoil)+xTol)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with total water fraction [liquid + ice] > theta_sat: layer = ',iLayer; err=20; return; end if case default - write(*,*) 'Cannot recognize case in initial vol water/ice check: type=', mlayerLayerType(iLayer) + write(*,*) 'Cannot recognize case in initial vol water/ice check: type=', layerType(iLayer) err=20; message=trim(message)//'cannot identify layer type'; return end select ! ***** ! * check that the initial conditions are consistent with the constitutive functions... ! ************************************************************************************* - select case(mLayerLayerType(iLayer)) + select case(layerType(iLayer)) ! ** snow case(iname_snow) @@ -228,46 +265,75 @@ subroutine check_icond(nGRU, & ! number of GRUs and HRU ! ensure consistency among state variables call updateSnow(& - ! input - mLayerTemp(iLayer), & ! intent(in): temperature (K) - scalarTheta, & ! intent(in): mass fraction of total water (-) - snowfrz_scale, & ! intent(in): scaling parameter for the snow freezing curve (K-1) - ! output - mLayerVolFracLiq(iLayer), & ! intent(out): volumetric fraction of liquid water (-) - mLayerVolFracIce(iLayer), & ! intent(out): volumetric fraction of ice (-) - fLiq, & ! intent(out): fraction of liquid water (-) - err,cmessage) ! intent(out): error control + mLayerTemp(iLayer), & ! intent(in): temperature (K) + scalarTheta, & ! intent(in): volumetric fraction of total water (-) + snowfrz_scale, & ! intent(in): scaling parameter for the snow freezing curve (K-1) + mLayerVolFracLiq(iLayer), & ! intent(out): volumetric fraction of liquid water (-) + mLayerVolFracIce(iLayer), & ! intent(out): volumetric fraction of ice (-) + fLiq, & ! intent(out): fraction of liquid water (-) + err,cmessage) ! intent(out): error control if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) + if(checkEnthalpy)then ! enthalpy as state variable or in residual + if(no_icond_enth)then ! no enthalpy in icond file + call T2enthTemp_snow(& + snowfrz_scale, & ! intent(in): scaling parameter for the snow freezing curve (K-1) + mLayerTemp(iLayer), & ! intent(in): layer temperature (K) + scalarTheta, & ! intent(in): volumetric total water content (-) + mLayerEnthTemp(iLayer)) ! intent(out): temperature component of enthalpy of each snow layer (J m-3) + mLayerEnthalpy(iLayer) = mLayerEnthTemp(iLayer) - iden_ice * LH_fus * mLayerVolFracIce(iLayer) + else + mLayerEnthTemp(iLayer) = mLayerEnthalpy(iLayer) + iden_ice * LH_fus * mLayerVolFracIce(iLayer) + end if + endif + ! ** soil case(iname_soil) ! ensure consistency among state variables call updateSoil(& - ! input - mLayerTemp(iLayer), & ! intent(in): layer temperature (K) - mLayerMatricHead(iLayer-nSnow), & ! intent(in): matric head (m) + mLayerTemp(iLayer), & ! intent(in): layer temperature (K) + mLayerMatricHead(iLayer-nSnow), & ! intent(in): matric head (m) vGn_alpha(iSoil),vGn_n(iSoil),theta_sat(iSoil),theta_res(iSoil),vGn_m, & ! intent(in): van Genutchen soil parameters - ! output - scalarTheta, & ! intent(out): volumetric fraction of total water (-) - mLayerVolFracLiq(iLayer), & ! intent(out): volumetric fraction of liquid water (-) - mLayerVolFracIce(iLayer), & ! intent(out): volumetric fraction of ice (-) - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) + scalarTheta, & ! intent(out): volumetric fraction of total water (-) + mLayerVolFracLiq(iLayer), & ! intent(out): volumetric fraction of liquid water (-) + mLayerVolFracIce(iLayer), & ! intent(out): volumetric fraction of ice (-) + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + + if(checkEnthalpy)then ! enthalpy as state variable or in residual + if(no_icond_enth)then ! no enthalpy in icond file + call T2enthTemp_soil(& + use_lookup, & ! intent(in): flag to use the lookup table for soil enthalpy + soil_dens_intr(iSoil), & ! intent(in): intrinsic soil density (kg m-3) + vGn_alpha(iSoil),vGn_n(iSoil),theta_sat(iSoil),theta_res(iSoil),vGn_m, & ! intent(in): van Genutchen soil parameters + iSoil, & ! intent(in): index of the control volume within the domain + lookupData%gru(iGRU)%hru(iHRU), & ! intent(in): lookup table data structure + realMissing, & ! intent(in): lower value of integral (not computed) + mLayerTemp(iLayer), & ! intent(in): layer temperature (K) + mLayerMatricHead(iLayer-nSnow), & ! intent(in): matric head (m) + mLayerEnthTemp(iLayer), & ! intent(out): temperature component of enthalpy soil layer (J m-3) + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + mLayerEnthalpy(iLayer) = mLayerEnthTemp(iLayer) - iden_water * LH_fus * mLayerVolFracIce(iLayer) + else + mLayerEnthTemp(iLayer) = mLayerEnthalpy(iLayer) + iden_water * LH_fus * mLayerVolFracIce(iLayer) + end if + endif case default; err=10; message=trim(message)//'unknown case for model layer'; return end select end do ! (looping through layers) - + ! end association to variables in the data structures end associate ! if snow layers exist, compute snow depth and SWE if(nSnow > 0)then - progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarSWE)%dat(1) = sum( (progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerVolFracLiq)%dat(1:nSnow)*iden_water + & - progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerVolFracIce)%dat(1:nSnow)*iden_ice) * & - progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerDepth)%dat(1:nSnow) ) + progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarSWE)%dat(1) = sum( (progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerVolFracLiq)%dat(1:nSnow)*iden_water + & + progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerVolFracIce)%dat(1:nSnow)*iden_ice) * & + progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerDepth)%dat(1:nSnow) ) end if ! if snow layers exist ! check that the layering is consistent diff --git a/build/source/engine/childStruc.f90 b/build/source/engine/childStruc.f90 old mode 100755 new mode 100644 diff --git a/build/source/engine/computFlux.f90 b/build/source/engine/computFlux.f90 old mode 100755 new mode 100644 index ce72bea5b..c33645d6b --- a/build/source/engine/computFlux.f90 +++ b/build/source/engine/computFlux.f90 @@ -23,13 +23,20 @@ module computFlux_module ! data types USE nrtype -! provide access to the derived types to define the data structures +! provide access to the derived types and classes used to define data structures and class objects USE data_types,only:& - var_i, & ! data vector (i4b) - var_d, & ! data vector (dp) - var_ilength, & ! data vector with variable length dimension (i4b) - var_dlength, & ! data vector with variable length dimension (dp) - model_options ! defines the model decisions + var_i, & ! data vector (i4b) + var_d, & ! data vector (rkind) + var_ilength, & ! data vector with variable length dimension (i4b) + var_dlength, & ! data vector with variable length dimension (rkind) + model_options, & ! defines the model decisions + in_type_vegNrgFlux,out_type_vegNrgFlux, & ! classes for vegNrgFlux call + in_type_ssdNrgFlux,io_type_ssdNrgFlux,out_type_ssdNrgFlux,& ! classes for ssdNrgFlux call + in_type_vegLiqFlux,out_type_vegLiqFlux, & ! classes for vegLiqFlux call + in_type_snowLiqFlx,io_type_snowLiqFlx,out_type_snowLiqFlx,& ! classes for snowLiqFlx call + in_type_soilLiqFlx,io_type_soilLiqFlx,out_type_soilLiqFlx,& ! classes for soilLiqFlx call + in_type_groundwatr,io_type_groundwatr,out_type_groundwatr,& ! classes for groundwatr call + in_type_bigAquifer,io_type_bigAquifer,out_type_bigAquifer ! classes for bigAquifer call ! indices that define elements of the data structures USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure @@ -49,25 +56,8 @@ module computFlux_module USE globalData,only:iname_snow ! named variables for snow USE globalData,only:iname_soil ! named variables for soil -! access the global print flag -USE globalData,only:globalPrintFlag - -! control parameters -USE globalData,only:verySmall ! a very small number -USE globalData,only:veryBig ! a very big number -USE globalData,only:dx ! finite difference increment - ! constants -USE multiconst,only:& - gravity, & ! acceleration of gravity (m s-2) - Tfreeze, & ! temperature at freezing (K) - LH_fus, & ! latent heat of fusion (J kg-1) - LH_vap, & ! latent heat of vaporization (J kg-1) - LH_sub, & ! latent heat of sublimation (J kg-1) - Cp_air, & ! specific heat of air (J kg-1 K-1) - iden_air, & ! intrinsic density of air (kg m-3) - iden_ice, & ! intrinsic density of ice (kg m-3) - iden_water ! intrinsic density of liquid water (kg m-3) +USE multiconst,only:iden_water ! intrinsic density of liquid water (kg m-3) ! look-up values for the choice of groundwater representation (local-column, or single-basin) USE mDecisions_module,only: & @@ -97,811 +87,644 @@ module computFlux_module private public::computFlux public::soilCmpres +public::soilCmpresPrime + contains +! ********************************************************************************************************* +! public subroutine computFlux: compute model fluxes +! ********************************************************************************************************* +subroutine computFlux(& + ! input-output: model control + nSnow, & ! intent(in): number of snow layers + nSoil, & ! intent(in): number of soil layers + nLayers, & ! intent(in): total number of layers + firstSubStep, & ! intent(in): flag to indicate if we are processing the first sub-step + firstFluxCall, & ! intent(inout): flag to denote the first flux call + firstSplitOper, & ! intent(in): flag to indicate if we are processing the first flux call in a splitting operation + computeVegFlux, & ! intent(in): flag to indicate if we need to compute fluxes over vegetation + scalarSolution, & ! intent(in): flag to indicate the scalar solution + checkLWBalance, & ! intent(in): flag to check longwave balance + drainageMeltPond, & ! intent(in): drainage from the surface melt pond (kg m-2 s-1) + ! input: state variables + scalarCanairTempTrial, & ! intent(in): trial value for the temperature of the canopy air space (K) + scalarCanopyTempTrial, & ! intent(in): trial value for the temperature of the vegetation canopy (K) + mLayerTempTrial, & ! intent(in): trial value for the temperature of each snow and soil layer (K) + mLayerMatricHeadLiqTrial, & ! intent(in): trial value for the liquid water matric potential in each soil layer (m) + mLayerMatricHeadTrial, & ! intent(in): trial vector of total water matric potential (m) + scalarAquiferStorageTrial,& ! intent(in): trial value of storage of water in the aquifer (m) + ! input: diagnostic variables defining the liquid water and ice content + scalarCanopyLiqTrial, & ! intent(in): trial value for the liquid water on the vegetation canopy (kg m-2) + scalarCanopyIceTrial, & ! intent(in): trial value for the ice on the vegetation canopy (kg m-2) + mLayerVolFracLiqTrial, & ! intent(in): trial value for the volumetric liquid water content in each snow and soil layer (-) + mLayerVolFracIceTrial, & ! intent(in): trial value for the volumetric ice in each snow and soil layer (-) + ! input: data structures + model_decisions, & ! intent(in): model decisions + type_data, & ! intent(in): type of vegetation and soil + attr_data, & ! intent(in): spatial attributes + mpar_data, & ! intent(in): model parameters + forc_data, & ! intent(in): model forcing data + bvar_data, & ! intent(in): average model variables for the entire basin + prog_data, & ! intent(in): model prognostic variables for a local HRU + indx_data, & ! intent(in): index data + ! input-output: data structures + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + flux_data, & ! intent(inout): model fluxes for a local HRU + deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables + ! input-output: flux vector and baseflow derivatives + ixSaturation, & ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) + dBaseflow_dMatric, & ! intent(out): derivative in baseflow w.r.t. matric head (s-1) + fluxVec, & ! intent(out): flux vector (mixed units) + ! output: error control + err,message) ! intent(out): error code and error message + ! provide access to flux subroutines + USE vegNrgFlux_module,only:vegNrgFlux ! compute energy fluxes over vegetation + USE ssdNrgFlux_module,only:ssdNrgFlux ! compute energy fluxes throughout the snow and soil subdomains + USE vegLiqFlux_module,only:vegLiqFlux ! compute liquid water fluxes through vegetation + USE snowLiqFlx_module,only:snowLiqflx ! compute liquid water fluxes through snow + USE soilLiqFlx_module,only:soilLiqflx ! compute liquid water fluxes through soil + USE groundwatr_module,only:groundwatr ! compute the baseflow flux + USE bigAquifer_module,only:bigAquifer ! compute fluxes for the big aquifer + implicit none + ! ------------------------------------------------------------------------------------------------------------------------- + ! * dummy variables + ! ------------------------------------------------------------------------------------------------------------------------- + ! input-output: control + integer(i4b),intent(in) :: nSnow ! number of snow layers + integer(i4b),intent(in) :: nSoil ! number of soil layers + integer(i4b),intent(in) :: nLayers ! total number of layers + logical(lgt),intent(in) :: firstSubStep ! flag to indicate if we are processing the first sub-step + logical(lgt),intent(inout) :: firstFluxCall ! flag to indicate if we are processing the first flux call + logical(lgt),intent(in) :: firstSplitOper ! flag to indicate if we are processing the first flux call in a splitting operation + logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation + logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution + logical(lgt),intent(in) :: checkLWBalance ! flag to check longwave balance + real(rkind),intent(in) :: drainageMeltPond ! drainage from the surface melt pond (kg m-2 s-1) + ! input: state variables + real(rkind),intent(in) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) + real(rkind),intent(in) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) + real(rkind),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) + real(rkind),intent(in) :: mLayerMatricHeadLiqTrial(:) ! trial value for the liquid water matric potential (m) + real(rkind),intent(in) :: mLayerMatricHeadTrial(:) ! trial value for the total water matric potential (m) + real(rkind),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) + ! input: diagnostic variables + real(rkind),intent(in) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) + real(rkind),intent(in) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) + real(rkind),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) + real(rkind),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) + ! input: data structures + type(model_options),intent(in) :: model_decisions(:) ! model decisions + type(var_i), intent(in) :: type_data ! type of vegetation and soil + type(var_d), intent(in) :: attr_data ! spatial attributes + type(var_dlength), intent(in) :: mpar_data ! model parameters + type(var_d), intent(in) :: forc_data ! model forcing data + type(var_dlength), intent(in) :: bvar_data ! model variables for the local basin + type(var_dlength), intent(in) :: prog_data ! prognostic variables for a local HRU + type(var_ilength), intent(in) :: indx_data ! indices defining model states and layers + ! input-output: data structures + type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + ! input-output: flux vector and baseflow derivatives + integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) + real(rkind),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + real(rkind),intent(out) :: fluxVec(:) ! model flux vector (mixed units) + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! ------------------------------------------------------------------------------------------------------------------------- + ! * local variables + ! ------------------------------------------------------------------------------------------------------------------------- + integer(i4b) :: local_ixGroundwater ! local index for groundwater representation + integer(i4b) :: iLayer ! index of model layers + logical(lgt) :: doVegNrgFlux ! flag to compute the energy flux over vegetation + real(rkind),dimension(nSoil) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t matric head (s-1) + character(LEN=256) :: cmessage ! error message of downwind routine + ! ---------------------- classes for flux subroutine arguments (classes defined in data_types module) ---------------------- + ! ** intent(in) arguments ** || ** intent(inout) arguments ** || ** intent(out) arguments ** + type(in_type_vegNrgFlux) :: in_vegNrgFlux; type(out_type_vegNrgFlux) :: out_vegNrgFlux ! vegNrgFlux arguments + type(in_type_ssdNrgFlux) :: in_ssdNrgFlux; type(io_type_ssdNrgFlux) :: io_ssdNrgFlux; type(out_type_ssdNrgFlux) :: out_ssdNrgFlux ! ssdNrgFlux arguments + type(in_type_vegLiqFlux) :: in_vegLiqFlux; type(out_type_vegLiqFlux) :: out_vegLiqFlux ! vegLiqFlux arguments + type(in_type_snowLiqFlx) :: in_snowLiqFlx; type(io_type_snowLiqFlx) :: io_snowLiqFlx; type(out_type_snowLiqFlx) :: out_snowLiqFlx ! snowLiqFlx arguments + type(in_type_soilLiqFlx) :: in_soilLiqFlx; type(io_type_soilLiqFlx) :: io_soilLiqFlx; type(out_type_soilLiqFlx) :: out_soilLiqFlx ! soilLiqFlx arguments + type(in_type_groundwatr) :: in_groundwatr; type(io_type_groundwatr) :: io_groundwatr; type(out_type_groundwatr) :: out_groundwatr ! groundwatr arguments + type(in_type_bigAquifer) :: in_bigAquifer; type(io_type_bigAquifer) :: io_bigAquifer; type(out_type_bigAquifer) :: out_bigAquifer ! bigAquifer arguments + ! ------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message='computFlux/' + + call initialize_computFlux; if(err/=0)then; return; endif ! Preliminary operations to start routine + + ! *** CALCULATE ENERGY FLUXES OVER VEGETATION *** + associate(& + ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1), & ! intent(in): [i4b] index of canopy air space energy state variable + ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1), & ! intent(in): [i4b] index of canopy energy state variable + ixTopNrg => indx_data%var(iLookINDEX%ixTopNrg)%dat(1) ) ! intent(in): [i4b] index of upper-most energy state in the snow+soil subdomain + ! identify the need to calculate the energy flux over vegetation + doVegNrgFlux = (ixCasNrg/=integerMissing .or. ixVegNrg/=integerMissing .or. ixTopNrg/=integerMissing) + if (doVegNrgFlux) then ! if necessary, calculate the energy fluxes over vegetation + call initialize_vegNrgFlux + call vegNrgFlux(in_vegNrgFlux,type_data,forc_data,mpar_data,indx_data,prog_data,diag_data,flux_data,bvar_data,model_decisions,out_vegNrgFlux) + call finalize_vegNrgFlux; if(err/=0)then; return; endif + end if + end associate + + ! *** CALCULATE ENERGY FLUXES THROUGH THE SNOW-SOIL DOMAIN *** + associate(nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg)%dat(1)) ! intent(in): [i4b] number of energy state variables in the snow+soil domain + if (nSnowSoilNrg>0) then ! if necessary, calculate energy fluxes at layer interfaces through the snow and soil domain + call initialize_ssdNrgFlux + call ssdNrgFlux(in_ssdNrgFlux,mpar_data,indx_data,prog_data,diag_data,flux_data,io_ssdNrgFlux,out_ssdNrgFlux) + call finalize_ssdNrgFlux; if(err/=0)then; return; endif + end if + end associate + + ! *** CALCULATE THE LIQUID FLUX THROUGH VEGETATION *** + associate(ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1)) ! intent(in): [i4b] index of canopy hydrology state variable (mass) + if (ixVegHyd/=integerMissing) then ! if necessary, calculate liquid water fluxes through vegetation + call initialize_vegLiqFlux + call vegLiqFlux(in_vegLiqFlux,mpar_data,diag_data,out_vegLiqFlux) + call finalize_vegLiqFlux; if(err/=0)then; return; endif + end if + end associate + + ! *** CALCULATE THE LIQUID FLUX THROUGH SNOW *** + associate(nSnowOnlyHyd => indx_data%var(iLookINDEX%nSnowOnlyHyd)%dat(1)) ! intent(in): [i4b] number of hydrology variables in the snow domain + if (nSnowOnlyHyd>0) then ! if necessary, compute liquid fluxes through snow + call initialize_snowLiqFlx + call snowLiqFlx(in_snowLiqFlx,indx_data,mpar_data,prog_data,diag_data,io_snowLiqFlx,out_snowLiqFlx) + call finalize_snowLiqFlx; if(err/=0)then; return; endif + else + call soilForcingNoSnow ! define forcing for the soil domain for the case of no snow layers + end if + end associate + + ! *** CALCULATE THE LIQUID FLUX THROUGH SOIL *** + associate(nSoilOnlyHyd => indx_data%var(iLookINDEX%nSoilOnlyHyd)%dat(1)) ! intent(in): [i4b] number of hydrology variables in the soil domain + if (nSoilOnlyHyd>0) then ! if necessary, calculate the liquid flux through soil + call initialize_soilLiqFlx + call soilLiqFlx(in_soilLiqFlx,mpar_data,indx_data,prog_data,diag_data,flux_data,io_soilLiqFlx,out_soilLiqFlx) + call finalize_soilLiqFlx; if(err/=0)then; return; endif + end if + end associate + + ! *** CALCULATE THE GROUNDWATER FLOW *** + associate(nSoilOnlyHyd => indx_data%var(iLookINDEX%nSoilOnlyHyd)%dat(1)) ! intent(in): [i4b] number of hydrology variables in the soil domain + if (nSoilOnlyHyd>0) then ! check if computing soil hydrology + if (local_ixGroundwater/=qbaseTopmodel) then ! set baseflow fluxes to zero if the topmodel baseflow routine is not used + call zeroBaseflowFluxes + else ! compute the baseflow flux for topmodel-ish shallow groundwater + call initialize_groundwatr; if(err/=0)then; return; endif + call groundwatr(in_groundwatr,attr_data,mpar_data,prog_data,flux_data,io_groundwatr,out_groundwatr) + call finalize_groundwatr; if(err/=0)then; return; endif + end if + call computeBaseflowRunoff ! compute total baseflow from soil and runoff + end if + end associate + + ! *** CALCULATE FLUXES FOR THE DEEP AQUIFER *** + associate(ixAqWat => indx_data%var(iLookINDEX%ixAqWat)%dat(1)) ! intent(in): [i4b] index of water storage in the aquifer + if (ixAqWat/=integerMissing) then ! check if computing aquifer fluxes + if (local_ixGroundwater==bigBucket) then ! compute fluxes for the big bucket + call initialize_bigAquifer + call bigAquifer(in_bigAquifer,mpar_data,diag_data,io_bigAquifer,out_bigAquifer) + call finalize_bigAquifer; if(err/=0)then; return; endif + else ! if no aquifer, then fluxes are zero + call zeroAquiferFluxes + end if ! end check aquifer model decision + end if ! if computing aquifer fluxes + end associate + + call finalize_computFlux; if(err/=0)then; return; endif ! final operations to prep for end of routine - ! ********************************************************************************************************* - ! public subroutine computFlux: compute model fluxes - ! ********************************************************************************************************* - subroutine computFlux(& - ! input-output: model control - nSnow, & ! intent(in): number of snow layers - nSoil, & ! intent(in): number of soil layers - nLayers, & ! intent(in): total number of layers - firstSubStep, & ! intent(in): flag to indicate if we are processing the first sub-step - firstFluxCall, & ! intent(inout): flag to denote the first flux call - firstSplitOper, & ! intent(in): flag to indicate if we are processing the first flux call in a splitting operation - computeVegFlux, & ! intent(in): flag to indicate if we need to compute fluxes over vegetation - scalarSolution, & ! intent(in): flag to indicate the scalar solution - drainageMeltPond, & ! intent(in): drainage from the surface melt pond (kg m-2 s-1) - ! input: state variables - scalarCanairTempTrial, & ! intent(in): trial value for the temperature of the canopy air space (K) - scalarCanopyTempTrial, & ! intent(in): trial value for the temperature of the vegetation canopy (K) - mLayerTempTrial, & ! intent(in): trial value for the temperature of each snow and soil layer (K) - mLayerMatricHeadLiqTrial, & ! intent(in): trial value for the liquid water matric potential in each soil layer (m) - scalarAquiferStorageTrial,& ! intent(in): trial value of storage of water in the aquifer (m) - ! input: diagnostic variables defining the liquid water and ice content - scalarCanopyLiqTrial, & ! intent(in): trial value for the liquid water on the vegetation canopy (kg m-2) - scalarCanopyIceTrial, & ! intent(in): trial value for the ice on the vegetation canopy (kg m-2) - mLayerVolFracLiqTrial, & ! intent(in): trial value for the volumetric liquid water content in each snow and soil layer (-) - mLayerVolFracIceTrial, & ! intent(in): trial value for the volumetric ice in each snow and soil layer (-) - ! input: data structures - model_decisions, & ! intent(in): model decisions - type_data, & ! intent(in): type of vegetation and soil - attr_data, & ! intent(in): spatial attributes - mpar_data, & ! intent(in): model parameters - forc_data, & ! intent(in): model forcing data - bvar_data, & ! intent(in): average model variables for the entire basin - prog_data, & ! intent(in): model prognostic variables for a local HRU - indx_data, & ! intent(in): index data - ! input-output: data structures - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - flux_data, & ! intent(inout): model fluxes for a local HRU - deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables - ! input-output: flux vector and baseflow derivatives - ixSaturation, & ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) - dBaseflow_dMatric, & ! intent(out): derivative in baseflow w.r.t. matric head (s-1) - fluxVec, & ! intent(out): flux vector (mixed units) - ! output: error control - err,message) ! intent(out): error code and error message - ! provide access to flux subroutines - USE vegNrgFlux_module,only:vegNrgFlux ! compute energy fluxes over vegetation - USE ssdNrgFlux_module,only:ssdNrgFlux ! compute energy fluxes throughout the snow and soil subdomains - USE vegLiqFlux_module,only:vegLiqFlux ! compute liquid water fluxes through vegetation - USE snowLiqFlx_module,only:snowLiqflx ! compute liquid water fluxes through snow - USE soilLiqFlx_module,only:soilLiqflx ! compute liquid water fluxes through soil - USE groundwatr_module,only:groundwatr ! compute the baseflow flux - USE bigAquifer_module,only:bigAquifer ! compute fluxes for the big aquifer - implicit none - ! --------------------------------------------------------------------------------------- - ! * dummy variables - ! --------------------------------------------------------------------------------------- - ! input-output: control - integer(i4b),intent(in) :: nSnow ! number of snow layers - integer(i4b),intent(in) :: nSoil ! number of soil layers - integer(i4b),intent(in) :: nLayers ! total number of layers - logical(lgt),intent(in) :: firstSubStep ! flag to indicate if we are processing the first sub-step - logical(lgt),intent(inout) :: firstFluxCall ! flag to indicate if we are processing the first flux call - logical(lgt),intent(in) :: firstSplitOper ! flag to indicate if we are processing the first flux call in a splitting operation - logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation - logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution - real(rkind),intent(in) :: drainageMeltPond ! drainage from the surface melt pond (kg m-2 s-1) - ! input: state variables - real(rkind),intent(in) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) - real(rkind),intent(in) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) - real(rkind),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) - real(rkind),intent(in) :: mLayerMatricHeadLiqTrial(:) ! trial value for the liquid water matric potential (m) - real(rkind),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) - ! input: diagnostic variables - real(rkind),intent(in) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) - real(rkind),intent(in) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) - real(rkind),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) - real(rkind),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) - ! input: data structures - type(model_options),intent(in) :: model_decisions(:) ! model decisions - type(var_i), intent(in) :: type_data ! type of vegetation and soil - type(var_d), intent(in) :: attr_data ! spatial attributes - type(var_dlength), intent(in) :: mpar_data ! model parameters - type(var_d), intent(in) :: forc_data ! model forcing data - type(var_dlength), intent(in) :: bvar_data ! model variables for the local basin - type(var_dlength), intent(in) :: prog_data ! prognostic variables for a local HRU - type(var_ilength), intent(in) :: indx_data ! indices defining model states and layers - ! input-output: data structures - type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU - type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU - type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables - ! input-output: flux vector and baseflow derivatives - integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) - real(rkind),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) - real(rkind),intent(out) :: fluxVec(:) ! model flux vector (mixed units) - ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! --------------------------------------------------------------------------------------- - ! * local variables - ! --------------------------------------------------------------------------------------- - integer(i4b) :: local_ixGroundwater ! local index for groundwater representation - integer(i4b) :: iLayer ! index of model layers - logical(lgt) :: doVegNrgFlux ! flag to compute the energy flux over vegetation - real(rkind),dimension(nSoil) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t matric head (s-1) - character(LEN=256) :: cmessage ! error message of downwind routine - ! -------------------------------------------------------------- - ! initialize error control - err=0; message='computFlux/' - - ! ***** - ! (0) PRELIMINARIES... - ! ******************** - - ! get the necessary variables for the flux computations - associate(& - - ! model decisions - ixGroundwater => model_decisions(iLookDECISIONS%groundwatr)%iDecision ,& ! intent(in): [i4b] groundwater parameterization - ixSpatialGroundwater => model_decisions(iLookDECISIONS%spatial_gw)%iDecision ,& ! intent(in): [i4b] spatial representation of groundwater (local-column or single-basin) - - ! domain boundary conditions - upperBoundTemp => forc_data%var(iLookFORCE%airtemp) ,& ! intent(in): [dp] temperature of the upper boundary of the snow and soil domains (K) - scalarRainfall => flux_data%var(iLookFLUX%scalarRainfall)%dat(1) ,& ! intent(in): [dp] rainfall rate (kg m-2 s-1) - - ! canopy and layer depth - canopyDepth => diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1) ,& ! intent(in): [dp ] canopy depth (m) - mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat ,& ! intent(in): [dp(:)] depth of each layer in the snow-soil sub-domain (m) - - ! indices of model state variables for the vegetation subdomain - ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy air space energy state variable - ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable - ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) - ixTopNrg => indx_data%var(iLookINDEX%ixTopNrg)%dat(1) ,& ! intent(in): [i4b] index of upper-most energy state in the snow+soil subdomain - ixTopHyd => indx_data%var(iLookINDEX%ixTopHyd)%dat(1) ,& ! intent(in): [i4b] index of upper-most hydrology state in the snow+soil subdomain - ixAqWat => indx_data%var(iLookINDEX%ixAqWat)%dat(1) ,& ! intent(in): [i4b] index of water storage in the aquifer - - ! indices of model state variables for the snow+soil domain - ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in): [i4b(:)] indices for energy states in the snow+soil subdomain - ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in): [i4b(:)] indices for hydrology states in the snow+soil subdomain - layerType => indx_data%var(iLookINDEX%layerType)%dat ,& ! intent(in): [i4b(:)] type of layer (iname_soil or iname_snow) - - ! number of state variables of a specific type - nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg )%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow+soil domain - nSnowOnlyNrg => indx_data%var(iLookINDEX%nSnowOnlyNrg )%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow domain - nSoilOnlyNrg => indx_data%var(iLookINDEX%nSoilOnlyNrg )%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the soil domain - nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the snow+soil domain - nSnowOnlyHyd => indx_data%var(iLookINDEX%nSnowOnlyHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the snow domain - nSoilOnlyHyd => indx_data%var(iLookINDEX%nSoilOnlyHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the soil domain - - ! snow parameters - snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1) ,& ! intent(in): [dp] scaling parameter for the snow freezing curve (K-1) - - ! derivatives - dPsiLiq_dPsi0 => deriv_data%var(iLookDERIV%dPsiLiq_dPsi0 )%dat ,& ! intent(in): [dp(:)] derivative in liquid water matric pot w.r.t. the total water matric pot (-) - dPsiLiq_dTemp => deriv_data%var(iLookDERIV%dPsiLiq_dTemp )%dat ,& ! intent(in): [dp(:)] derivative in the liquid water matric potential w.r.t. temperature - mLayerdTheta_dTk => deriv_data%var(iLookDERIV%mLayerdTheta_dTk)%dat ,& ! intent(in): [dp(:)] derivative of volumetric liquid water content w.r.t. temperature - dTheta_dTkCanopy => deriv_data%var(iLookDERIV%dTheta_dTkCanopy)%dat(1) ,& ! intent(in): [dp] derivative of volumetric liquid water content w.r.t. temperature - - ! number of flux calls - numFluxCalls => diag_data%var(iLookDIAG%numFluxCalls)%dat(1) ,& ! intent(out): [dp] number of flux calls (-) - - ! net fluxes over the vegetation domain - scalarCanairNetNrgFlux => flux_data%var(iLookFLUX%scalarCanairNetNrgFlux)%dat(1) ,& ! intent(out): [dp] net energy flux for the canopy air space (W m-2) - scalarCanopyNetNrgFlux => flux_data%var(iLookFLUX%scalarCanopyNetNrgFlux)%dat(1) ,& ! intent(out): [dp] net energy flux for the vegetation canopy (W m-2) - scalarGroundNetNrgFlux => flux_data%var(iLookFLUX%scalarGroundNetNrgFlux)%dat(1) ,& ! intent(out): [dp] net energy flux for the ground surface (W m-2) - scalarCanopyNetLiqFlux => flux_data%var(iLookFLUX%scalarCanopyNetLiqFlux)%dat(1) ,& ! intent(out): [dp] net liquid water flux for the vegetation canopy (kg m-2 s-1) - - ! net fluxes over the snow+soil domain - mLayerNrgFlux => flux_data%var(iLookFLUX%mLayerNrgFlux)%dat ,& ! intent(out): [dp] net energy flux for each layer within the snow+soil domain (J m-3 s-1) - mLayerLiqFluxSnow => flux_data%var(iLookFLUX%mLayerLiqFluxSnow)%dat ,& ! intent(out): [dp] net liquid water flux for each snow layer (s-1) - mLayerLiqFluxSoil => flux_data%var(iLookFLUX%mLayerLiqFluxSoil)%dat ,& ! intent(out): [dp] net liquid water flux for each soil layer (s-1) - - ! evaporative fluxes - scalarCanopyTranspiration => flux_data%var(iLookFLUX%scalarCanopyTranspiration)%dat(1) ,& ! intent(out): [dp] canopy transpiration (kg m-2 s-1) - scalarCanopyEvaporation => flux_data%var(iLookFLUX%scalarCanopyEvaporation)%dat(1) ,& ! intent(out): [dp] canopy evaporation/condensation (kg m-2 s-1) - scalarGroundEvaporation => flux_data%var(iLookFLUX%scalarGroundEvaporation)%dat(1) ,& ! intent(out): [dp] ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) - mLayerTranspire => flux_data%var(iLookFLUX%mLayerTranspire)%dat ,& ! intent(out): [dp(:)] transpiration loss from each soil layer (m s-1) - - ! fluxes for the snow+soil domain - iLayerNrgFlux => flux_data%var(iLookFLUX%iLayerNrgFlux)%dat ,& ! intent(out): [dp(0:)] vertical energy flux at the interface of snow and soil layers - iLayerLiqFluxSnow => flux_data%var(iLookFLUX%iLayerLiqFluxSnow)%dat ,& ! intent(out): [dp(0:)] vertical liquid water flux at snow layer interfaces (-) - iLayerLiqFluxSoil => flux_data%var(iLookFLUX%iLayerLiqFluxSoil)%dat ,& ! intent(out): [dp(0:)] vertical liquid water flux at soil layer interfaces (-) - mLayerHydCond => flux_data%var(iLookFLUX%mLayerHydCond)%dat ,& ! intent(out): [dp(:)] hydraulic conductivity in each soil layer (m s-1) - mLayerBaseflow => flux_data%var(iLookFLUX%mLayerBaseflow)%dat ,& ! intent(out): [dp(:)] baseflow from each soil layer (m s-1) - scalarSnowDrainage => flux_data%var(iLookFLUX%scalarSnowDrainage)%dat(1) ,& ! intent(out): [dp] drainage from the snow profile (m s-1) - scalarSoilDrainage => flux_data%var(iLookFLUX%scalarSoilDrainage)%dat(1) ,& ! intent(out): [dp] drainage from the soil profile (m s-1) - scalarSoilBaseflow => flux_data%var(iLookFLUX%scalarSoilBaseflow)%dat(1) ,& ! intent(out): [dp] total baseflow from the soil profile (m s-1) - - ! infiltration - scalarInfilArea => diag_data%var(iLookDIAG%scalarInfilArea )%dat(1) ,& ! intent(out): [dp] fraction of unfrozen area where water can infiltrate (-) - scalarFrozenArea => diag_data%var(iLookDIAG%scalarFrozenArea )%dat(1) ,& ! intent(out): [dp] fraction of area that is considered impermeable due to soil ice (-) - scalarSoilControl => diag_data%var(iLookDIAG%scalarSoilControl )%dat(1) ,& ! intent(out): [dp] soil control on infiltration, zero or one - scalarMaxInfilRate => flux_data%var(iLookFLUX%scalarMaxInfilRate)%dat(1) ,& ! intent(out): [dp] maximum infiltration rate (m s-1) - scalarInfiltration => flux_data%var(iLookFLUX%scalarInfiltration)%dat(1) ,& ! intent(out): [dp] infiltration of water into the soil profile (m s-1) - - ! boundary fluxes in the soil domain - scalarThroughfallRain => flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1) ,& ! intent(out): [dp] rain that reaches the ground without ever touching the canopy (kg m-2 s-1) - scalarCanopyLiqDrainage => flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) ,& ! intent(out): [dp] drainage of liquid water from the vegetation canopy (kg m-2 s-1) - scalarRainPlusMelt => flux_data%var(iLookFLUX%scalarRainPlusMelt)%dat(1) ,& ! intent(out): [dp] rain plus melt (m s-1) - scalarSurfaceRunoff => flux_data%var(iLookFLUX%scalarSurfaceRunoff)%dat(1) ,& ! intent(out): [dp] surface runoff (m s-1) - scalarExfiltration => flux_data%var(iLookFLUX%scalarExfiltration)%dat(1) ,& ! intent(out): [dp] exfiltration from the soil profile (m s-1) - mLayerColumnOutflow => flux_data%var(iLookFLUX%mLayerColumnOutflow)%dat ,& ! intent(out): [dp(:)] column outflow from each soil layer (m3 s-1) - - ! fluxes for the aquifer - scalarAquiferTranspire => flux_data%var(iLookFLUX%scalarAquiferTranspire)%dat(1) ,& ! intent(out): [dp] transpiration loss from the aquifer (m s-1 - scalarAquiferRecharge => flux_data%var(iLookFLUX%scalarAquiferRecharge)%dat(1) ,& ! intent(out): [dp] recharge to the aquifer (m s-1) - scalarAquiferBaseflow => flux_data%var(iLookFLUX%scalarAquiferBaseflow)%dat(1) ,& ! intent(out): [dp] total baseflow from the aquifer (m s-1) - - ! total runoff - scalarTotalRunoff => flux_data%var(iLookFLUX%scalarTotalRunoff)%dat(1) ,& ! intent(out): [dp] total runoff (m s-1) - - ! derivatives in net vegetation energy fluxes w.r.t. relevant state variables - dCanairNetFlux_dCanairTemp => deriv_data%var(iLookDERIV%dCanairNetFlux_dCanairTemp )%dat(1) ,& ! intent(out): [dp] derivative in net canopy air space flux w.r.t. canopy air temperature - dCanairNetFlux_dCanopyTemp => deriv_data%var(iLookDERIV%dCanairNetFlux_dCanopyTemp )%dat(1) ,& ! intent(out): [dp] derivative in net canopy air space flux w.r.t. canopy temperature - dCanairNetFlux_dGroundTemp => deriv_data%var(iLookDERIV%dCanairNetFlux_dGroundTemp )%dat(1) ,& ! intent(out): [dp] derivative in net canopy air space flux w.r.t. ground temperature - dCanopyNetFlux_dCanairTemp => deriv_data%var(iLookDERIV%dCanopyNetFlux_dCanairTemp )%dat(1) ,& ! intent(out): [dp] derivative in net canopy flux w.r.t. canopy air temperature - dCanopyNetFlux_dCanopyTemp => deriv_data%var(iLookDERIV%dCanopyNetFlux_dCanopyTemp )%dat(1) ,& ! intent(out): [dp] derivative in net canopy flux w.r.t. canopy temperature - dCanopyNetFlux_dGroundTemp => deriv_data%var(iLookDERIV%dCanopyNetFlux_dGroundTemp )%dat(1) ,& ! intent(out): [dp] derivative in net canopy flux w.r.t. ground temperature - dCanopyNetFlux_dCanLiq => deriv_data%var(iLookDERIV%dCanopyNetFlux_dCanLiq )%dat(1) ,& ! intent(out): [dp] derivative in net canopy fluxes w.r.t. canopy liquid water content - dGroundNetFlux_dCanairTemp => deriv_data%var(iLookDERIV%dGroundNetFlux_dCanairTemp )%dat(1) ,& ! intent(out): [dp] derivative in net ground flux w.r.t. canopy air temperature - dGroundNetFlux_dCanopyTemp => deriv_data%var(iLookDERIV%dGroundNetFlux_dCanopyTemp )%dat(1) ,& ! intent(out): [dp] derivative in net ground flux w.r.t. canopy temperature - dGroundNetFlux_dGroundTemp => deriv_data%var(iLookDERIV%dGroundNetFlux_dGroundTemp )%dat(1) ,& ! intent(out): [dp] derivative in net ground flux w.r.t. ground temperature - dGroundNetFlux_dCanLiq => deriv_data%var(iLookDERIV%dGroundNetFlux_dCanLiq )%dat(1) ,& ! intent(out): [dp] derivative in net ground fluxes w.r.t. canopy liquid water content - - ! derivatives in evaporative fluxes w.r.t. relevant state variables - dCanopyEvaporation_dTCanair => deriv_data%var(iLookDERIV%dCanopyEvaporation_dTCanair )%dat(1) ,& ! intent(out): [dp] derivative in canopy evaporation w.r.t. canopy air temperature - dCanopyEvaporation_dTCanopy => deriv_data%var(iLookDERIV%dCanopyEvaporation_dTCanopy )%dat(1) ,& ! intent(out): [dp] derivative in canopy evaporation w.r.t. canopy temperature - dCanopyEvaporation_dTGround => deriv_data%var(iLookDERIV%dCanopyEvaporation_dTGround )%dat(1) ,& ! intent(out): [dp] derivative in canopy evaporation w.r.t. ground temperature - dCanopyEvaporation_dCanLiq => deriv_data%var(iLookDERIV%dCanopyEvaporation_dCanLiq )%dat(1) ,& ! intent(out): [dp] derivative in canopy evaporation w.r.t. canopy liquid water content - dGroundEvaporation_dTCanair => deriv_data%var(iLookDERIV%dGroundEvaporation_dTCanair )%dat(1) ,& ! intent(out): [dp] derivative in ground evaporation w.r.t. canopy air temperature - dGroundEvaporation_dTCanopy => deriv_data%var(iLookDERIV%dGroundEvaporation_dTCanopy )%dat(1) ,& ! intent(out): [dp] derivative in ground evaporation w.r.t. canopy temperature - dGroundEvaporation_dTGround => deriv_data%var(iLookDERIV%dGroundEvaporation_dTGround )%dat(1) ,& ! intent(out): [dp] derivative in ground evaporation w.r.t. ground temperature - dGroundEvaporation_dCanLiq => deriv_data%var(iLookDERIV%dGroundEvaporation_dCanLiq )%dat(1) ,& ! intent(out): [dp] derivative in ground evaporation w.r.t. canopy liquid water content - - ! derivatives in canopy water w.r.t canopy temperature - dCanLiq_dTcanopy => deriv_data%var(iLookDERIV%dCanLiq_dTcanopy )%dat(1) ,& ! intent(out): [dp] derivative of canopy liquid storage w.r.t. temperature - - ! derivatives in canopy liquid fluxes w.r.t. canopy water - scalarCanopyLiqDeriv => deriv_data%var(iLookDERIV%scalarCanopyLiqDeriv )%dat(1) ,& ! intent(out): [dp] derivative in (throughfall + drainage) w.r.t. canopy liquid water - scalarThroughfallRainDeriv => deriv_data%var(iLookDERIV%scalarThroughfallRainDeriv )%dat(1) ,& ! intent(out): [dp] derivative in throughfall w.r.t. canopy liquid water - scalarCanopyLiqDrainageDeriv => deriv_data%var(iLookDERIV%scalarCanopyLiqDrainageDeriv)%dat(1) ,& ! intent(out): [dp] derivative in canopy drainage w.r.t. canopy liquid water - - ! derivatives in energy fluxes at the interface of snow+soil layers w.r.t. temperature in layers above and below - dNrgFlux_dTempAbove => deriv_data%var(iLookDERIV%dNrgFlux_dTempAbove )%dat ,& ! intent(out): [dp(:)] derivatives in the flux w.r.t. temperature in the layer above - dNrgFlux_dTempBelow => deriv_data%var(iLookDERIV%dNrgFlux_dTempBelow )%dat ,& ! intent(out): [dp(:)] derivatives in the flux w.r.t. temperature in the layer below - - ! derivative in liquid water fluxes at the interface of snow layers w.r.t. volumetric liquid water content in the layer above - iLayerLiqFluxSnowDeriv => deriv_data%var(iLookDERIV%iLayerLiqFluxSnowDeriv )%dat ,& ! intent(out): [dp(:)] derivative in vertical liquid water flux at layer interfaces - - ! derivative in liquid water fluxes for the soil domain w.r.t hydrology state variables - dVolTot_dPsi0 => deriv_data%var(iLookDERIV%dVolTot_dPsi0 )%dat ,& ! intent(out): [dp(:)] derivative in total water content w.r.t. total water matric potential - dq_dHydStateAbove => deriv_data%var(iLookDERIV%dq_dHydStateAbove )%dat ,& ! intent(out): [dp(:)] change in flux at layer interfaces w.r.t. states in the layer above - dq_dHydStateBelow => deriv_data%var(iLookDERIV%dq_dHydStateBelow )%dat ,& ! intent(out): [dp(:)] change in flux at layer interfaces w.r.t. states in the layer below - mLayerdTheta_dPsi => deriv_data%var(iLookDERIV%mLayerdTheta_dPsi )%dat ,& ! intent(out): [dp(:)] derivative in the soil water characteristic w.r.t. psi - mLayerdPsi_dTheta => deriv_data%var(iLookDERIV%mLayerdPsi_dTheta )%dat ,& ! intent(out): [dp(:)] derivative in the soil water characteristic w.r.t. theta - dCompress_dPsi => deriv_data%var(iLookDERIV%dCompress_dPsi )%dat ,& ! intent(out): [dp(:)] derivative in compressibility w.r.t matric head - - ! derivative in baseflow flux w.r.t. aquifer storage - dBaseflow_dAquifer => deriv_data%var(iLookDERIV%dBaseflow_dAquifer )%dat(1) ,& ! intent(out): [dp(:)] erivative in baseflow flux w.r.t. aquifer storage (s-1) - - ! derivative in liquid water fluxes for the soil domain w.r.t energy state variables - dq_dNrgStateAbove => deriv_data%var(iLookDERIV%dq_dNrgStateAbove )%dat ,& ! intent(out): [dp(:)] change in flux at layer interfaces w.r.t. states in the layer above - dq_dNrgStateBelow => deriv_data%var(iLookDERIV%dq_dNrgStateBelow )%dat & ! intent(out): [dp(:)] change in flux at layer interfaces w.r.t. states in the layer below - - ) ! association to data in structures - - ! ***** - ! * PRELIMINARIES... - ! ****************** - - !print*, '***** nSnowSoilNrg, nSnowOnlyNrg, nSoilOnlyNrg, nSnowSoilHyd, nSnowOnlyHyd, nSoilOnlyHyd = ', & - ! nSnowSoilNrg, nSnowOnlyNrg, nSoilOnlyNrg, nSnowSoilHyd, nSnowOnlyHyd, nSoilOnlyHyd - - ! increment the number of flux calls - numFluxCalls = numFluxCalls+1 - - ! modify the groundwater representation for this single-column implementation - select case(ixSpatialGroundwater) - case(singleBasin); local_ixGroundwater = noExplicit ! force no explicit representation of groundwater at the local scale - case(localColumn); local_ixGroundwater = ixGroundwater ! go with the specified decision - case default; err=20; message=trim(message)//'unable to identify spatial representation of groundwater'; return - end select ! (modify the groundwater representation for this single-column implementation) - - ! initialize liquid water fluxes throughout the snow and soil domains - ! NOTE: used in the energy routines, which is called before the hydrology routines - if(firstFluxCall)then - if(nSnow > 0) iLayerLiqFluxSnow(0:nSnow) = 0._rkind - iLayerLiqFluxSoil(0:nSoil) = 0._rkind - end if - - ! ***** - ! * CALCULATE ENERGY FLUXES OVER VEGETATION... - ! ********************************************* - - ! identify the need to calculate the energy flux over vegetation - doVegNrgFlux = (ixCasNrg/=integerMissing .or. ixVegNrg/=integerMissing .or. ixTopNrg/=integerMissing) - - ! check if there is a need to calculate the energy fluxes over vegetation - if(doVegNrgFlux)then - - ! derivative in canopy liquid storage w.r.t. canopy temperature - dCanLiq_dTcanopy = dTheta_dTkCanopy*iden_water*canopyDepth ! kg m-2 K-1 - - ! calculate the energy fluxes over vegetation - call vegNrgFlux(& - ! input: model control - firstSubStep, & ! intent(in): flag to indicate if we are processing the first sub-step - firstFluxCall, & ! intent(in): flag to indicate if we are processing the first flux call - computeVegFlux, & ! intent(in): flag to indicate if we need to compute fluxes over vegetation - ! input: model state variables - upperBoundTemp, & ! intent(in): temperature of the upper boundary (K) --> NOTE: use air temperature - scalarCanairTempTrial, & ! intent(in): trial value of the canopy air space temperature (K) - scalarCanopyTempTrial, & ! intent(in): trial value of canopy temperature (K) - mLayerTempTrial(1), & ! intent(in): trial value of ground temperature (K) - scalarCanopyIceTrial, & ! intent(in): trial value of mass of ice on the vegetation canopy (kg m-2) - scalarCanopyLiqTrial, & ! intent(in): trial value of mass of liquid water on the vegetation canopy (kg m-2) - ! input: model derivatives - dCanLiq_dTcanopy, & ! intent(in): derivative in canopy liquid storage w.r.t. canopy temperature (kg m-2 K-1) - ! input/output: data structures - type_data, & ! intent(in): type of vegetation and soil - forc_data, & ! intent(in): model forcing data - mpar_data, & ! intent(in): model parameters - indx_data, & ! intent(in): index data - prog_data, & ! intent(in): model prognostic variables for a local HRU - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - flux_data, & ! intent(inout): model fluxes for a local HRU - bvar_data, & ! intent(in): model variables for the local basin - model_decisions, & ! intent(in): model decisions - ! output: liquid water fluxes associated with evaporation/transpiration - scalarCanopyTranspiration, & ! intent(out): canopy transpiration (kg m-2 s-1) - scalarCanopyEvaporation, & ! intent(out): canopy evaporation/condensation (kg m-2 s-1) - scalarGroundEvaporation, & ! intent(out): ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) - ! output: fluxes - scalarCanairNetNrgFlux, & ! intent(out): net energy flux for the canopy air space (W m-2) - scalarCanopyNetNrgFlux, & ! intent(out): net energy flux for the vegetation canopy (W m-2) - scalarGroundNetNrgFlux, & ! intent(out): net energy flux for the ground surface (W m-2) - ! output: flux derivatives - dCanairNetFlux_dCanairTemp, & ! intent(out): derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) - dCanairNetFlux_dCanopyTemp, & ! intent(out): derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) - dCanairNetFlux_dGroundTemp, & ! intent(out): derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) - dCanopyNetFlux_dCanairTemp, & ! intent(out): derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) - dCanopyNetFlux_dCanopyTemp, & ! intent(out): derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) - dCanopyNetFlux_dGroundTemp, & ! intent(out): derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) - dGroundNetFlux_dCanairTemp, & ! intent(out): derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) - dGroundNetFlux_dCanopyTemp, & ! intent(out): derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) - dGroundNetFlux_dGroundTemp, & ! intent(out): derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) - ! output: liquid water flux derivatives (canopy evap) - dCanopyEvaporation_dCanLiq, & ! intent(out): derivative in canopy evaporation w.r.t. canopy liquid water content (s-1) - dCanopyEvaporation_dTCanair, & ! intent(out): derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) - dCanopyEvaporation_dTCanopy, & ! intent(out): derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) - dCanopyEvaporation_dTGround, & ! intent(out): derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) - ! output: liquid water flux derivatives (ground evap) - dGroundEvaporation_dCanLiq, & ! intent(out): derivative in ground evaporation w.r.t. canopy liquid water content (s-1) - dGroundEvaporation_dTCanair, & ! intent(out): derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) - dGroundEvaporation_dTCanopy, & ! intent(out): derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) - dGroundEvaporation_dTGround, & ! intent(out): derivative in ground evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) - ! output: cross derivative terms - dCanopyNetFlux_dCanLiq, & ! intent(out): derivative in net canopy fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - dGroundNetFlux_dCanLiq, & ! intent(out): derivative in net ground fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - ! output: error control - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (check for errors) - - ! check fluxes - if(globalPrintFlag)then - print*, '**' - write(*,'(a,1x,10(f30.20))') 'canopyDepth = ', canopyDepth - write(*,'(a,1x,10(f30.20))') 'mLayerDepth(1:2) = ', mLayerDepth(1:2) - write(*,'(a,1x,10(f30.20))') 'scalarCanairTempTrial = ', scalarCanairTempTrial ! trial value of the canopy air space temperature (K) - write(*,'(a,1x,10(f30.20))') 'scalarCanopyTempTrial = ', scalarCanopyTempTrial ! trial value of canopy temperature (K) - write(*,'(a,1x,10(f30.20))') 'mLayerTempTrial(1:2) = ', mLayerTempTrial(1:2) ! trial value of ground temperature (K) - write(*,'(a,1x,10(f30.20))') 'scalarCanairNetNrgFlux = ', scalarCanairNetNrgFlux - write(*,'(a,1x,10(f30.20))') 'scalarCanopyNetNrgFlux = ', scalarCanopyNetNrgFlux - write(*,'(a,1x,10(f30.20))') 'scalarGroundNetNrgFlux = ', scalarGroundNetNrgFlux - write(*,'(a,1x,10(f30.20))') 'dGroundNetFlux_dGroundTemp = ', dGroundNetFlux_dGroundTemp - endif ! if checking fluxes - - endif ! if calculating the energy fluxes over vegetation - - ! ***** - ! * CALCULATE ENERGY FLUXES THROUGH THE SNOW-SOIL DOMAIN... - ! ********************************************************** - - ! check the need to compute energy fluxes throughout the snow+soil domain - if(nSnowSoilNrg>0)then - - ! calculate energy fluxes at layer interfaces through the snow and soil domain - call ssdNrgFlux(& - ! input: model control - (scalarSolution .and. .not.firstFluxCall), & ! intent(in): flag to indicate the scalar solution - ! input: fluxes and derivatives at the upper boundary - scalarGroundNetNrgFlux, & ! intent(in): total flux at the ground surface (W m-2) - dGroundNetFlux_dGroundTemp, & ! intent(in): derivative in total ground surface flux w.r.t. ground temperature (W m-2 K-1) - ! input: liquid water fluxes throughout the snow and soil domains - iLayerLiqFluxSnow, & ! intent(in): liquid flux at the interface of each snow layer (m s-1) - iLayerLiqFluxSoil, & ! intent(in): liquid flux at the interface of each soil layer (m s-1) - ! input: trial value of model state variabes - mLayerTempTrial, & ! intent(in): trial temperature at the current iteration (K) - ! input-output: data structures - mpar_data, & ! intent(in): model parameters - indx_data, & ! intent(in): model indices - prog_data, & ! intent(in): model prognostic variables for a local HRU - diag_data, & ! intent(in): model diagnostic variables for a local HRU - flux_data, & ! intent(inout): model fluxes for a local HRU - ! output: fluxes and derivatives at all layer interfaces - iLayerNrgFlux, & ! intent(out): energy flux at the layer interfaces (W m-2) - dNrgFlux_dTempAbove, & ! intent(out): derivatives in the flux w.r.t. temperature in the layer above (W m-2 K-1) - dNrgFlux_dTempBelow, & ! intent(out): derivatives in the flux w.r.t. temperature in the layer below (W m-2 K-1) - ! output: error control - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - - ! calculate net energy fluxes for each snow and soil layer (J m-3 s-1) - do iLayer=1,nLayers - mLayerNrgFlux(iLayer) = -(iLayerNrgFlux(iLayer) - iLayerNrgFlux(iLayer-1))/mLayerDepth(iLayer) - if(globalPrintFlag)then - if(iLayer < 10) write(*,'(a,1x,i4,1x,10(f25.15,1x))') 'iLayer, iLayerNrgFlux(iLayer-1:iLayer), mLayerNrgFlux(iLayer) = ', iLayer, iLayerNrgFlux(iLayer-1:iLayer), mLayerNrgFlux(iLayer) - endif - end do - - endif ! if computing energy fluxes throughout the snow+soil domain - - - ! ***** - ! * CALCULATE THE LIQUID FLUX THROUGH VEGETATION... - ! ************************************************** - - ! check the need to compute the liquid water fluxes through vegetation - if(ixVegHyd/=integerMissing)then - - ! calculate liquid water fluxes through vegetation - call vegLiqFlux(& - ! input - computeVegFlux, & ! intent(in): flag to denote if computing energy flux over vegetation - scalarCanopyLiqTrial, & ! intent(in): trial mass of liquid water on the vegetation canopy at the current iteration (kg m-2) - scalarRainfall, & ! intent(in): rainfall rate (kg m-2 s-1) - ! input-output: data structures - mpar_data, & ! intent(in): model parameters - diag_data, & ! intent(in): local HRU diagnostic model variables - ! output - scalarThroughfallRain, & ! intent(out): rain that reaches the ground without ever touching the canopy (kg m-2 s-1) - scalarCanopyLiqDrainage, & ! intent(out): drainage of liquid water from the vegetation canopy (kg m-2 s-1) - scalarThroughfallRainDeriv, & ! intent(out): derivative in throughfall w.r.t. canopy liquid water (s-1) - scalarCanopyLiqDrainageDeriv, & ! intent(out): derivative in canopy drainage w.r.t. canopy liquid water (s-1) - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - - ! calculate the net liquid water flux for the vegetation canopy - scalarCanopyNetLiqFlux = scalarRainfall + scalarCanopyEvaporation - scalarThroughfallRain - scalarCanopyLiqDrainage - - ! calculate the total derivative in the downward liquid flux - scalarCanopyLiqDeriv = scalarThroughfallRainDeriv + scalarCanopyLiqDrainageDeriv - - ! test - if(globalPrintFlag)then - print*, '**' - print*, 'scalarRainfall = ', scalarRainfall - print*, 'scalarThroughfallRain = ', scalarThroughfallRain - print*, 'scalarCanopyEvaporation = ', scalarCanopyEvaporation - print*, 'scalarCanopyLiqDrainage = ', scalarCanopyLiqDrainage - print*, 'scalarCanopyNetLiqFlux = ', scalarCanopyNetLiqFlux - print*, 'scalarCanopyLiqTrial = ', scalarCanopyLiqTrial - endif - - endif ! computing the liquid water fluxes through vegetation - - ! ***** - ! * CALCULATE THE LIQUID FLUX THROUGH SNOW... - ! ******************************************** - - ! check the need to compute liquid water fluxes through snow - if(nSnowOnlyHyd>0)then - - ! compute liquid fluxes through snow - call snowLiqFlx(& - ! input: model control - nSnow, & ! intent(in): number of snow layers - firstFluxCall, & ! intent(in): the first flux call (compute variables that are constant over the iterations) - (scalarSolution .and. .not.firstFluxCall), & ! intent(in): flag to indicate the scalar solution - ! input: forcing for the snow domain - scalarThroughfallRain, & ! intent(in): rain that reaches the snow surface without ever touching vegetation (kg m-2 s-1) - scalarCanopyLiqDrainage, & ! intent(in): liquid drainage from the vegetation canopy (kg m-2 s-1) - ! input: model state vector - mLayerVolFracLiqTrial(1:nSnow), & ! intent(in): trial value of volumetric fraction of liquid water at the current iteration (-) - ! input-output: data structures - indx_data, & ! intent(in): model indices - mpar_data, & ! intent(in): model parameters - prog_data, & ! intent(in): model prognostic variables for a local HRU - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - ! output: fluxes and derivatives - iLayerLiqFluxSnow(0:nSnow), & ! intent(inout): vertical liquid water flux at layer interfaces (m s-1) - iLayerLiqFluxSnowDeriv(0:nSnow), & ! intent(inout): derivative in vertical liquid water flux at layer interfaces (m s-1) - ! output: error control - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - - ! define forcing for the soil domain - scalarRainPlusMelt = iLayerLiqFluxSnow(nSnow) ! drainage from the base of the snowpack - - ! calculate net liquid water fluxes for each soil layer (s-1) - do iLayer=1,nSnow - mLayerLiqFluxSnow(iLayer) = -(iLayerLiqFluxSnow(iLayer) - iLayerLiqFluxSnow(iLayer-1))/mLayerDepth(iLayer) - !write(*,'(a,1x,i4,1x,2(f16.10,1x))') 'iLayer, mLayerLiqFluxSnow(iLayer), iLayerLiqFluxSnow(iLayer-1) = ', & - ! iLayer, mLayerLiqFluxSnow(iLayer), iLayerLiqFluxSnow(iLayer-1) - end do - - ! compute drainage from the soil zone (needed for mass balance checks) - scalarSnowDrainage = iLayerLiqFluxSnow(nSnow) - - else +contains + ! **** Subroutines that handle the absence of model features **** + subroutine soilForcingNoSnow ! define forcing for the soil domain for the case of no snow layers ! NOTE: in case where nSnowOnlyHyd==0 AND snow layers exist, then scalarRainPlusMelt is taken from the previous flux evaluation - if (nSnow==0) then - scalarSnowDrainage = drainageMeltPond/iden_water ! melt of the snow without a layer (m s-1) - scalarRainPlusMelt = (scalarThroughfallRain + scalarCanopyLiqDrainage)/iden_water & ! liquid flux from the canopy (m s-1) - + scalarSnowDrainage - end if ! if no snow layers - end if - - ! ***** - ! * CALCULATE THE LIQUID FLUX THROUGH SOIL... - ! ******************************************** - - ! check the need to calculate the liquid flux through soil - if(nSoilOnlyHyd>0)then - - ! calculate the liquid flux through soil - call soilLiqFlx(& - ! input: model control - nSoil, & ! intent(in): number of soil layers - firstSplitOper, & ! intent(in): flag indicating first flux call in a splitting operation - (scalarSolution .and. .not.firstFluxCall), & ! intent(in): flag to indicate the scalar solution - .true., & ! intent(in): flag indicating if derivatives are desired - ! input: trial state variables - mLayerTempTrial(nSnow+1:nLayers), & ! intent(in): trial temperature at the current iteration (K) - mLayerMatricHeadLiqTrial(1:nSoil), & ! intent(in): liquid water matric potential (m) - mLayerVolFracLiqTrial(nSnow+1:nLayers), & ! intent(in): volumetric fraction of liquid water (-) - mLayerVolFracIceTrial(nSnow+1:nLayers), & ! intent(in): volumetric fraction of ice (-) - ! input: pre-computed deriavatives - mLayerdTheta_dTk(nSnow+1:nLayers), & ! intent(in): derivative in volumetric liquid water content w.r.t. temperature (K-1) - dPsiLiq_dTemp(1:nSoil), & ! intent(in): derivative in liquid water matric potential w.r.t. temperature (m K-1) - ! input: fluxes - scalarCanopyTranspiration, & ! intent(in): canopy transpiration (kg m-2 s-1) - scalarGroundEvaporation, & ! intent(in): ground evaporation (kg m-2 s-1) - scalarRainPlusMelt, & ! intent(in): rain plus melt (m s-1) - ! input-output: data structures - mpar_data, & ! intent(in): model parameters - indx_data, & ! intent(in): model indices - prog_data, & ! intent(inout): model prognostic variables for a local HRU - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - flux_data, & ! intent(inout): model fluxes for a local HRU - ! output: diagnostic variables for surface runoff - scalarMaxInfilRate, & ! intent(inout): maximum infiltration rate (m s-1) - scalarInfilArea, & ! intent(inout): fraction of unfrozen area where water can infiltrate (-) - scalarFrozenArea, & ! intent(inout): fraction of area that is considered impermeable due to soil ice (-) - scalarSurfaceRunoff, & ! intent(inout): surface runoff (m s-1) - ! output: diagnostic variables for model layers - mLayerdTheta_dPsi, & ! intent(inout): derivative in the soil water characteristic w.r.t. psi (m-1) - mLayerdPsi_dTheta, & ! intent(inout): derivative in the soil water characteristic w.r.t. theta (m) - dHydCond_dMatric, & ! intent(inout): derivative in hydraulic conductivity w.r.t matric head (s-1) - ! output: fluxes - scalarInfiltration, & ! intent(inout): surface infiltration rate (m s-1) -- controls on infiltration only computed for iter==1 - iLayerLiqFluxSoil, & ! intent(inout): liquid fluxes at layer interfaces (m s-1) - mLayerTranspire, & ! intent(inout): transpiration loss from each soil layer (m s-1) - mLayerHydCond, & ! intent(inout): hydraulic conductivity in each layer (m s-1) - ! output: derivatives in fluxes w.r.t. state variables -- matric head or volumetric lquid water -- in the layer above and layer below (m s-1 or s-1) - dq_dHydStateAbove, & ! intent(inout): derivatives in the flux w.r.t. matric head in the layer above (s-1) - dq_dHydStateBelow, & ! intent(inout): derivatives in the flux w.r.t. matric head in the layer below (s-1) - ! output: derivatives in fluxes w.r.t. energy state variables -- now just temperature -- in the layer above and layer below (m s-1 K-1) - dq_dNrgStateAbove, & ! intent(inout): derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) - dq_dNrgStateBelow, & ! intent(inout): derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) - ! output: error control - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - - ! calculate net liquid water fluxes for each soil layer (s-1) - do iLayer=1,nSoil - mLayerLiqFluxSoil(iLayer) = -(iLayerLiqFluxSoil(iLayer) - iLayerLiqFluxSoil(iLayer-1))/mLayerDepth(iLayer+nSnow) - !if(iLayer<8) write(*,'(a,1x,2(i4,1x),3(e20.10),f12.7)') 'iLayerLiqFluxSoil(iLayer-1), iLayerLiqFluxSoil(iLayer), mLayerLiqFluxSoil(iLayer) = ', iLayer-1, iLayer, & - ! iLayerLiqFluxSoil(iLayer-1), iLayerLiqFluxSoil(iLayer), mLayerLiqFluxSoil(iLayer), mLayerDepth(iLayer+nSnow) - end do - - ! calculate the soil control on infiltration - if(nSnow==0) then - ! * case of infiltration into soil - if(scalarMaxInfilRate > scalarRainPlusMelt)then ! infiltration is not rate-limited - scalarSoilControl = (1._rkind - scalarFrozenArea)*scalarInfilArea - else - scalarSoilControl = 0._rkind ! (scalarRainPlusMelt exceeds maximum infiltration rate - endif - else - ! * case of infiltration into snow - scalarSoilControl = 1._rkind - endif - - ! compute drainage from the soil zone (needed for mass balance checks) - scalarSoilDrainage = iLayerLiqFluxSoil(nSoil) - - ! expand derivatives to the total water matric potential - ! NOTE: arrays are offset because computing derivatives in interface fluxes, at the top and bottom of the layer respectively - if(globalPrintFlag) print*, 'dPsiLiq_dPsi0(1:nSoil) = ', dPsiLiq_dPsi0(1:nSoil) - dq_dHydStateAbove(1:nSoil) = dq_dHydStateAbove(1:nSoil) *dPsiLiq_dPsi0(1:nSoil) - dq_dHydStateBelow(0:nSoil-1) = dq_dHydStateBelow(0:nSoil-1)*dPsiLiq_dPsi0(1:nSoil) - - endif ! if calculating the liquid flux through soil - - ! ***** - ! * CALCULATE THE GROUNDWATER FLOW... - ! ************************************ - - ! check if computing soil hydrology - if(nSoilOnlyHyd>0)then - + associate(& + scalarRainPlusMelt => flux_data%var(iLookFLUX%scalarRainPlusMelt)%dat(1), & ! intent(out): [dp] rain plus melt (m s-1) + scalarThroughfallRain => flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1), & ! intent(out): [dp] rain that reaches the ground without ever touching the canopy (kg m-2 s-1) + scalarCanopyLiqDrainage => flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) ) ! intent(out): [dp] drainage of liquid water from the vegetation canopy (kg m-2 s-1) + if (nSnow==0) then !no snow layers + scalarRainPlusMelt = (scalarThroughfallRain + scalarCanopyLiqDrainage)/iden_water & ! liquid flux from the canopy (m s-1) + + drainageMeltPond/iden_water ! melt of the snow without a layer (m s-1) + end if ! snow layers or not + end associate + end subroutine soilForcingNoSnow + + subroutine zeroBaseflowFluxes ! set baseflow fluxes to zero if the topmodel baseflow routine is not used - if(local_ixGroundwater/=qbaseTopmodel)then - ! (diagnostic variables in the data structures) + associate(& + scalarExfiltration => flux_data%var(iLookFLUX%scalarExfiltration)%dat(1), & ! intent(out): [dp] exfiltration from the soil profile (m s-1) + mLayerColumnOutflow => flux_data%var(iLookFLUX%mLayerColumnOutflow)%dat, & ! intent(out): [dp(:)] column outflow from each soil layer (m3 s-1) + mLayerBaseflow => flux_data%var(iLookFLUX%mLayerBaseflow)%dat ) ! intent(out): [dp(:)] baseflow from each soil layer (m s-1) + ! diagnostic variables in the data structures scalarExfiltration = 0._rkind ! exfiltration from the soil profile (m s-1) mLayerColumnOutflow(:) = 0._rkind ! column outflow from each soil layer (m3 s-1) - ! (variables needed for the numerical solution) + ! variables needed for the numerical solution mLayerBaseflow(:) = 0._rkind ! baseflow from each soil layer (m s-1) + end associate + end subroutine zeroBaseflowFluxes - ! topmodel-ish shallow groundwater - else ! local_ixGroundwater==qbaseTopmodel - - ! check the derivative matrix is sized appropriately - if(size(dBaseflow_dMatric,1)/=nSoil .or. size(dBaseflow_dMatric,2)/=nSoil)then - message=trim(message)//'expect dBaseflow_dMatric to be nSoil x nSoil' - err=20; return - endif - - ! compute the baseflow flux - call groundwatr(& - ! input: model control - nSnow, & ! intent(in): number of snow layers - nSoil, & ! intent(in): number of soil layers - nLayers, & ! intent(in): total number of layers - firstFluxCall, & ! intent(in): logical flag to compute index of the lowest saturated layer - ! input: state and diagnostic variables - mLayerdTheta_dPsi, & ! intent(in): derivative in the soil water characteristic w.r.t. matric head in each layer (m-1) - mLayerMatricHeadLiqTrial, & ! intent(in): liquid water matric potential (m) - mLayerVolFracLiqTrial(nSnow+1:nLayers), & ! intent(in): volumetric fraction of liquid water (-) - mLayerVolFracIceTrial(nSnow+1:nLayers), & ! intent(in): volumetric fraction of ice (-) - ! input: data structures - attr_data, & ! intent(in): model attributes - mpar_data, & ! intent(in): model parameters - prog_data, & ! intent(in): model prognostic variables for a local HRU - diag_data, & ! intent(in): model diagnostic variables for a local HRU - flux_data, & ! intent(inout): model fluxes for a local HRU - ! output - ixSaturation, & ! intent(inout) index of lowest saturated layer (NOTE: only computed on the first iteration) - mLayerBaseflow, & ! intent(out): baseflow from each soil layer (m s-1) - dBaseflow_dMatric, & ! intent(out): derivative in baseflow w.r.t. matric head (s-1) - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - endif ! computing baseflow flux - - ! compute total baseflow from the soil zone (needed for mass balance checks) - scalarSoilBaseflow = sum(mLayerBaseflow) - - ! compute total runoff + subroutine computeBaseflowRunoff + ! compute total baseflow from the soil zone (needed for mass balance checks) and total runoff ! (Note: scalarSoilBaseflow is zero if topmodel is not used) ! (Note: scalarSoilBaseflow may need to re-envisioned in topmodel formulation if parts of it flow into neighboring soil rather than exfiltrate) - scalarTotalRunoff = scalarSurfaceRunoff + scalarSoilDrainage + scalarSoilBaseflow - - endif ! if computing soil hydrology - - - ! ***** - ! (7) CALCULATE FLUXES FOR THE DEEP AQUIFER... - ! ******************************************** - - ! check if computing aquifer fluxes - if(ixAqWat/=integerMissing)then - - ! identify modeling decision - if(local_ixGroundwater==bigBucket)then - - ! compute fluxes for the big bucket - call bigAquifer(& - ! input: state variables and fluxes - scalarAquiferStorageTrial, & ! intent(in): trial value of aquifer storage (m) - scalarCanopyTranspiration, & ! intent(in): canopy transpiration (kg m-2 s-1) - scalarSoilDrainage, & ! intent(in): soil drainage (m s-1) - ! input: diagnostic variables and parameters - mpar_data, & ! intent(in): model parameter structure - diag_data, & ! intent(in): diagnostic variable structure - ! output: fluxes - scalarAquiferTranspire, & ! intent(out): transpiration loss from the aquifer (m s-1) - scalarAquiferRecharge, & ! intent(out): recharge to the aquifer (m s-1) - scalarAquiferBaseflow, & ! intent(out): total baseflow from the aquifer (m s-1) - dBaseflow_dAquifer, & ! intent(out): change in baseflow flux w.r.t. aquifer storage (s-1) - ! output: error control - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - - ! compute total runoff (overwrite previously calculated value before considering aquifer). - ! (Note: SoilDrainage goes into aquifer, not runoff) - scalarTotalRunoff = scalarSurfaceRunoff + scalarAquiferBaseflow - - ! if no aquifer, then fluxes are zero - else + associate(& + scalarSoilBaseflow => flux_data%var(iLookFLUX%scalarSoilBaseflow)%dat(1), & ! intent(out): [dp] total baseflow from the soil profile (m s-1) + mLayerBaseflow => flux_data%var(iLookFLUX%mLayerBaseflow)%dat, & ! intent(out): [dp(:)] baseflow from each soil layer (m s-1) + scalarTotalRunoff => flux_data%var(iLookFLUX%scalarTotalRunoff)%dat(1), & ! intent(out): [dp] total runoff (m s-1) + scalarSurfaceRunoff => flux_data%var(iLookFLUX%scalarSurfaceRunoff)%dat(1), & ! intent(out): [dp] surface runoff (m s-1) + scalarSoilDrainage => flux_data%var(iLookFLUX%scalarSoilDrainage)%dat(1) ) ! intent(out): [dp] drainage from the soil profile (m s-1) + scalarSoilBaseflow = sum(mLayerBaseflow) ! baseflow from the soil zone + scalarTotalRunoff = scalarSurfaceRunoff + scalarSoilDrainage + scalarSoilBaseflow ! total runoff + end associate + end subroutine computeBaseflowRunoff + + subroutine zeroAquiferFluxes + ! set aquifer fluxes to zero (if no aquifer exists) + associate(& + scalarAquiferTranspire => flux_data%var(iLookFLUX%scalarAquiferTranspire)%dat(1), & ! intent(out): [dp] transpiration loss from the aquifer (m s-1 + scalarAquiferRecharge => flux_data%var(iLookFLUX%scalarAquiferRecharge)%dat(1), & ! intent(out): [dp] recharge to the aquifer (m s-1) + scalarAquiferBaseflow => flux_data%var(iLookFLUX%scalarAquiferBaseflow)%dat(1), & ! intent(out): [dp] total baseflow from the aquifer (m s-1) + dBaseflow_dAquifer => deriv_data%var(iLookDERIV%dBaseflow_dAquifer)%dat(1) ) ! intent(out): [dp(:)] derivative in baseflow flux w.r.t. aquifer storage (s-1) scalarAquiferTranspire = 0._rkind ! transpiration loss from the aquifer (m s-1) scalarAquiferRecharge = 0._rkind ! recharge to the aquifer (m s-1) scalarAquiferBaseflow = 0._rkind ! total baseflow from the aquifer (m s-1) dBaseflow_dAquifer = 0._rkind ! change in baseflow flux w.r.t. aquifer storage (s-1) - end if ! no aquifer - - endif ! if computing aquifer fluxes - - ! ***** - ! (X) WRAP UP... - ! ************* - - ! define model flux vector for the vegetation sub-domain - if(ixCasNrg/=integerMissing) fluxVec(ixCasNrg) = scalarCanairNetNrgFlux/canopyDepth - if(ixVegNrg/=integerMissing) fluxVec(ixVegNrg) = scalarCanopyNetNrgFlux/canopyDepth - if(ixVegHyd/=integerMissing) fluxVec(ixVegHyd) = scalarCanopyNetLiqFlux ! NOTE: solid fluxes are handled separately - - ! populate the flux vector for energy - if(nSnowSoilNrg>0)then - do concurrent (iLayer=1:nLayers,ixSnowSoilNrg(iLayer)/=integerMissing) ! (loop through non-missing energy state variables in the snow+soil domain) - fluxVec( ixSnowSoilNrg(iLayer) ) = mLayerNrgFlux(iLayer) - end do ! looping through non-missing energy state variables in the snow+soil domain - endif - - ! populate the flux vector for hydrology - ! NOTE: ixVolFracWat and ixVolFracLiq can also include states in the soil domain, hence enable primary variable switching - if(nSnowSoilHyd>0)then ! check if any hydrology states exist - do iLayer=1,nLayers - if(ixSnowSoilHyd(iLayer)/=integerMissing)then ! check if a given hydrology state exists - select case( layerType(iLayer) ) - case(iname_snow); fluxVec( ixSnowSoilHyd(iLayer) ) = mLayerLiqFluxSnow(iLayer) - case(iname_soil); fluxVec( ixSnowSoilHyd(iLayer) ) = mLayerLiqFluxSoil(iLayer-nSnow) - case default; err=20; message=trim(message)//'expect layerType to be either iname_snow or iname_soil'; return - end select - endif ! if a given hydrology state exists - end do ! looping through non-missing energy state variables in the snow+soil domain - endif ! if any hydrology states exist - - ! compute the flux vector for the aquifer - if(ixAqWat/=integerMissing) fluxVec(ixAqWat) = scalarAquiferTranspire + scalarAquiferRecharge - scalarAquiferBaseflow - - ! set the first flux call to false - firstFluxCall=.false. - - ! end association to variables in the data structures - end associate - - end subroutine computFlux - - - ! ********************************************************************************************************** - ! public subroutine soilCmpres: compute soil compressibility (-) and its derivative w.r.t matric head (m-1) - ! ********************************************************************************************************** - subroutine soilCmpres(& - ! input: - ixRichards, & ! intent(in): choice of option for Richards' equation - ixBeg,ixEnd, & ! intent(in): start and end indices defining desired layers - mLayerMatricHead, & ! intent(in): matric head at the start of the time step (m) - mLayerMatricHeadTrial, & ! intent(in): trial value of matric head (m) - mLayerVolFracLiqTrial, & ! intent(in): trial value for the volumetric liquid water content in each soil layer (-) - mLayerVolFracIceTrial, & ! intent(in): trial value for the volumetric ice content in each soil layer (-) - specificStorage, & ! intent(in): specific storage coefficient (m-1) - theta_sat, & ! intent(in): soil porosity (-) - ! output: - compress, & ! intent(out): compressibility of the soil matrix (-) - dCompress_dPsi, & ! intent(out): derivative in compressibility w.r.t. matric head (m-1) - err,message) ! intent(out): error code and error message - implicit none - ! input: - integer(i4b),intent(in) :: ixRichards ! choice of option for Richards' equation - integer(i4b),intent(in) :: ixBeg,ixEnd ! start and end indices defining desired layers - real(rkind),intent(in) :: mLayerMatricHead(:) ! matric head at the start of the time step (m) - real(rkind),intent(in) :: mLayerMatricHeadTrial(:) ! trial value for matric head (m) - real(rkind),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) - real(rkind),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) - real(rkind),intent(in) :: specificStorage ! specific storage coefficient (m-1) - real(rkind),intent(in) :: theta_sat(:) ! soil porosity (-) - ! output: - real(rkind),intent(inout) :: compress(:) ! soil compressibility (-) - real(rkind),intent(inout) :: dCompress_dPsi(:) ! derivative in soil compressibility w.r.t. matric head (m-1) - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! local variables - integer(i4b) :: iLayer ! index of soil layer - ! -------------------------------------------------------------- - ! initialize error control - err=0; message='soilCmpres/' - ! (only compute for the mixed form of Richards' equation) - if(ixRichards==mixdform)then - do iLayer=1,size(mLayerMatricHead) - if(iLayer>=ixBeg .and. iLayer<=ixEnd)then - ! compute the derivative for the compressibility term (m-1) - dCompress_dPsi(iLayer) = specificStorage*(mLayerVolFracLiqTrial(iLayer) + mLayerVolFracIceTrial(iLayer))/theta_sat(iLayer) - ! compute the compressibility term (-) - compress(iLayer) = (mLayerMatricHeadTrial(iLayer) - mLayerMatricHead(iLayer))*dCompress_dPsi(iLayer) - endif - end do - else - compress(:) = 0._rkind - dCompress_dPsi(:) = 0._rkind - end if - end subroutine soilCmpres + end associate + end subroutine zeroAquiferFluxes + + ! **** Subroutines for starting/ending operations of computFlux **** + subroutine initialize_computFlux + ! operations to prep for the start of computFlux + associate(& + numFluxCalls => diag_data%var(iLookDIAG%numFluxCalls)%dat(1), & ! intent(out): [dp] number of flux calls (-) + ixSpatialGroundwater => model_decisions(iLookDECISIONS%spatial_gw)%iDecision, & ! intent(in): [i4b] spatial representation of groundwater (local-column or single-basin) + ixGroundwater => model_decisions(iLookDECISIONS%groundwatr)%iDecision, & ! intent(in): [i4b] groundwater parameterization + iLayerLiqFluxSnow => flux_data%var(iLookFLUX%iLayerLiqFluxSnow)%dat, & ! intent(out): [dp(0:)] vertical liquid water flux at snow layer interfaces (-) + iLayerLiqFluxSoil => flux_data%var(iLookFLUX%iLayerLiqFluxSoil)%dat ) ! intent(out): [dp(0:)] vertical liquid water flux at soil layer interfaces (-) + + numFluxCalls = numFluxCalls+1 ! increment the number of flux calls + + ! modify the groundwater representation for this single-column implementation + select case(ixSpatialGroundwater) + case(singleBasin); local_ixGroundwater = noExplicit ! force no explicit representation of groundwater at the local scale + case(localColumn); local_ixGroundwater = ixGroundwater ! go with the specified decision + case default; err=20; message=trim(message)//'unable to identify spatial representation of groundwater'; return + end select ! end modify the groundwater representation for this single-column implementation + + ! initialize liquid water fluxes throughout the snow and soil domains + ! NOTE: used in the energy routines, which is called before the hydrology routines + if (firstFluxCall) then + if (nSnow>0) iLayerLiqFluxSnow(0:nSnow) = 0._rkind + iLayerLiqFluxSoil(0:nSoil) = 0._rkind + end if + end associate + end subroutine initialize_computFlux + + subroutine finalize_computFlux + ! operations to prep for the end of computFlux + associate(& + ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1), & ! intent(in): [i4b] index of canopy air space energy state variable + ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1), & ! intent(in): [i4b] index of canopy energy state variable + ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1), & ! intent(in): [i4b] index of canopy hydrology state variable (mass) + scalarCanairNetNrgFlux => flux_data%var(iLookFLUX%scalarCanairNetNrgFlux)%dat(1), & ! intent(out): [dp] net energy flux for the canopy air space (W m-2) + scalarCanopyNetNrgFlux => flux_data%var(iLookFLUX%scalarCanopyNetNrgFlux)%dat(1), & ! intent(out): [dp] net energy flux for the vegetation canopy (W m-2) + scalarCanopyNetLiqFlux => flux_data%var(iLookFLUX%scalarCanopyNetLiqFlux)%dat(1), & ! intent(out): [dp] net liquid water flux for the vegetation canopy (kg m-2 s-1) + canopyDepth => diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1), & ! intent(in): [dp] canopy depth (m) + nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg)%dat(1), & ! intent(in): [i4b] number of energy state variables in the snow+soil domain + ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat, & ! intent(in): [i4b(:)] indices for energy states in the snow+soil subdomain + mLayerNrgFlux => flux_data%var(iLookFLUX%mLayerNrgFlux)%dat ) ! intent(out): [dp] net energy flux for each layer within the snow+soil domain (J m-3 s-1) + ! *** WRAP UP *** + ! define model flux vector for the vegetation sub-domain + if (ixCasNrg/=integerMissing) fluxVec(ixCasNrg) = scalarCanairNetNrgFlux/canopyDepth + if (ixVegNrg/=integerMissing) fluxVec(ixVegNrg) = scalarCanopyNetNrgFlux/canopyDepth + if (ixVegHyd/=integerMissing) fluxVec(ixVegHyd) = scalarCanopyNetLiqFlux ! NOTE: solid fluxes are handled separately + if (nSnowSoilNrg>0) then ! if necessary, populate the flux vector for energy + do concurrent (iLayer=1:nLayers,ixSnowSoilNrg(iLayer)/=integerMissing) ! loop through non-missing energy state variables in the snow+soil domain + fluxVec( ixSnowSoilNrg(iLayer) ) = mLayerNrgFlux(iLayer) + end do + end if + end associate + + associate(& + ixAqWat => indx_data%var(iLookINDEX%ixAqWat)%dat(1), & ! intent(in): [i4b] index of water storage in the aquifer + ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat, & ! intent(in): [i4b(:)] indices for hydrology states in the snow+soil subdomain + nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd)%dat(1), & ! intent(in): [i4b] number of hydrology variables in the snow+soil domain + layerType => indx_data%var(iLookINDEX%layerType)%dat, & ! intent(in): [i4b(:)] type of layer (iname_soil or iname_snow) + mLayerLiqFluxSnow => flux_data%var(iLookFLUX%mLayerLiqFluxSnow)%dat, & ! intent(out): [dp] net liquid water flux for each snow layer (s-1) + mLayerLiqFluxSoil => flux_data%var(iLookFLUX%mLayerLiqFluxSoil)%dat, & ! intent(out): [dp] net liquid water flux for each soil layer (s-1) + scalarAquiferTranspire => flux_data%var(iLookFLUX%scalarAquiferTranspire)%dat(1), & ! intent(out): [dp] transpiration loss from the aquifer (m s-1) + scalarAquiferRecharge => flux_data%var(iLookFLUX%scalarAquiferRecharge)%dat(1), & ! intent(out): [dp] recharge to the aquifer (m s-1) + scalarAquiferBaseflow => flux_data%var(iLookFLUX%scalarAquiferBaseflow)%dat(1) ) ! intent(out): [dp] total baseflow from the aquifer (m s-1) + ! populate the flux vector for hydrology + ! NOTE: ixVolFracWat and ixVolFracLiq can also include states in the soil domain, hence enable primary variable switching + if (nSnowSoilHyd>0) then ! check if any hydrology states exist + do iLayer=1,nLayers ! loop through non-missing energy state variables in the snow+soil domain + if (ixSnowSoilHyd(iLayer)/=integerMissing) then ! check if a given hydrology state exists + select case(layerType(iLayer)) + case(iname_snow); fluxVec(ixSnowSoilHyd(iLayer)) = mLayerLiqFluxSnow(iLayer) + case(iname_soil); fluxVec(ixSnowSoilHyd(iLayer)) = mLayerLiqFluxSoil(iLayer-nSnow) + case default; err=20; message=trim(message)//'expect layerType to be either iname_snow or iname_soil'; return + end select + end if ! end if a given hydrology state exists + end do + end if ! end if any hydrology states exist + ! compute the flux vector for the aquifer + if (ixAqWat/=integerMissing) fluxVec(ixAqWat) = scalarAquiferTranspire + scalarAquiferRecharge - scalarAquiferBaseflow + end associate + + firstFluxCall=.false. ! set the first flux call to false + end subroutine finalize_computFlux + + ! ----------------------- Initialize and Finalize procedures for the flux routines ----------------------- + ! **** vegNrgFlux **** + subroutine initialize_vegNrgFlux + associate(& + dCanLiq_dTcanopy => deriv_data%var(iLookDERIV%dCanLiq_dTcanopy)%dat(1), & ! intent(out): [dp] derivative of canopy liquid storage w.r.t. temperature + dTheta_dTkCanopy => deriv_data%var(iLookDERIV%dTheta_dTkCanopy)%dat(1), & ! intent(in): [dp] derivative of volumetric liquid water content w.r.t. temperature + canopyDepth => diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1) ) ! intent(in): [dp] canopy depth (m) + + dCanLiq_dTcanopy = dTheta_dTkCanopy*iden_water*canopyDepth ! derivative in canopy liquid storage w.r.t. canopy temperature (kg m-2 K-1) + end associate + call in_vegNrgFlux % initialize(firstSubStep,firstFluxCall,computeVegFlux,checkLWBalance,& + scalarCanairTempTrial,scalarCanopyTempTrial,mLayerTempTrial,scalarCanopyIceTrial,& + scalarCanopyLiqTrial,forc_data,deriv_data) + end subroutine initialize_vegNrgFlux + + subroutine finalize_vegNrgFlux + call out_vegNrgFlux%finalize(flux_data,deriv_data,err,cmessage) + ! error control + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if ! check for errors + end subroutine finalize_vegNrgFlux + ! **** end vegNrgFlux **** + + ! **** ssdNrgFlux **** + subroutine initialize_ssdNrgFlux + call in_ssdNrgFlux%initialize(scalarSolution,firstFluxCall,mLayerTempTrial,flux_data,deriv_data) + call io_ssdNrgFlux%initialize(deriv_data) + end subroutine initialize_ssdNrgFlux + + subroutine finalize_ssdNrgFlux + call io_ssdNrgFlux%finalize(deriv_data) + call out_ssdNrgFlux%finalize(flux_data,deriv_data,err,cmessage) + associate(& + mLayerNrgFlux => flux_data%var(iLookFLUX%mLayerNrgFlux)%dat, & ! intent(out): [dp] net energy flux for each layer within the snow+soil domain (J m-3 s-1) + iLayerNrgFlux => flux_data%var(iLookFLUX%iLayerNrgFlux)%dat, & ! intent(out): [dp(0:)] vertical energy flux at the interface of snow and soil layers + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat ) ! intent(in): [dp(:)] depth of each layer in the snow-soil sub-domain (m) + ! error control + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if + ! calculate net energy fluxes for each snow and soil layer (J m-3 s-1) + do iLayer=1,nLayers + mLayerNrgFlux(iLayer) = -(iLayerNrgFlux(iLayer) - iLayerNrgFlux(iLayer-1))/mLayerDepth(iLayer) + end do + end associate + end subroutine finalize_ssdNrgFlux + ! **** end ssdNrgFlux **** + + ! **** vegLiqFlux **** + subroutine initialize_vegLiqFlux + call in_vegLiqFlux%initialize(computeVegFlux,scalarCanopyLiqTrial,flux_data) + end subroutine initialize_vegLiqFlux + + subroutine finalize_vegLiqFlux + call out_vegLiqFlux%finalize(flux_data,deriv_data,err,cmessage) + associate( & + scalarThroughfallRain => flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1), & ! intent(out): [dp] rain that reaches the ground without ever touching the canopy (kg m-2 s-1) + scalarCanopyLiqDrainage => flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1), & ! intent(out): [dp] drainage of liquid water from the vegetation canopy (kg m-2 s-1) + scalarThroughfallRainDeriv => deriv_data%var(iLookDERIV%scalarThroughfallRainDeriv )%dat(1),& ! intent(out): [dp] derivative in throughfall w.r.t. canopy liquid water + scalarCanopyLiqDrainageDeriv => deriv_data%var(iLookDERIV%scalarCanopyLiqDrainageDeriv)%dat(1),& ! intent(out): [dp] derivative in canopy drainage w.r.t. canopy liquid water + scalarCanopyNetLiqFlux => flux_data%var(iLookFLUX%scalarCanopyNetLiqFlux)%dat(1), & ! intent(out): [dp] net liquid water flux for the vegetation canopy (kg m-2 s-1) + scalarRainfall => flux_data%var(iLookFLUX%scalarRainfall)%dat(1), & ! intent(in): [dp] rainfall rate (kg m-2 s-1) + scalarCanopyEvaporation => flux_data%var(iLookFLUX%scalarCanopyEvaporation)%dat(1), & ! intent(out): [dp] canopy evaporation/condensation (kg m-2 s-1) + scalarCanopyLiqDeriv => deriv_data%var(iLookDERIV%scalarCanopyLiqDeriv )%dat(1) ) ! intent(out): [dp] derivative in (throughfall + drainage) w.r.t. canopy liquid water + ! error control + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if + ! calculate the net liquid water flux for the vegetation canopy + scalarCanopyNetLiqFlux = scalarRainfall + scalarCanopyEvaporation - scalarThroughfallRain - scalarCanopyLiqDrainage + ! calculate the total derivative in the downward liquid flux + scalarCanopyLiqDeriv = scalarThroughfallRainDeriv + scalarCanopyLiqDrainageDeriv + end associate + end subroutine finalize_vegLiqFlux + ! **** end vegLiqFlux **** + + ! **** snowLiqFlx **** + subroutine initialize_snowLiqFlx + call in_snowLiqFlx%initialize(nSnow,firstFluxCall,scalarSolution,mLayerVolFracLiqTrial,flux_data) + call io_snowLiqFlx%initialize(flux_data,deriv_data) + end subroutine initialize_snowLiqFlx + + subroutine finalize_snowLiqFlx + call io_snowLiqFlx%finalize(flux_data,deriv_data) + call out_snowLiqFlx%finalize(err,cmessage) + ! error control + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if + associate(& + scalarRainPlusMelt => flux_data%var(iLookFLUX%scalarRainPlusMelt)%dat(1), & ! intent(out): [dp] rain plus melt (m s-1) + mLayerLiqFluxSnow => flux_data%var(iLookFLUX%mLayerLiqFluxSnow)%dat, & ! intent(out): [dp] net liquid water flux for each snow layer (s-1) + iLayerLiqFluxSnow => flux_data%var(iLookFLUX%iLayerLiqFluxSnow)%dat, & ! intent(out): [dp(0:)] vertical liquid water flux at snow layer interfaces (-) + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat, & ! intent(in): [dp(:)] depth of each layer in the snow-soil sub-domain (m) + scalarSnowDrainage => flux_data%var(iLookFLUX%scalarSnowDrainage)%dat(1) ) ! intent(out): [dp] drainage from the snow profile (m s-1) + ! define forcing for the soil domain + scalarRainPlusMelt = iLayerLiqFluxSnow(nSnow) ! drainage from the base of the snowpack + ! calculate net liquid water fluxes for each snow layer (s-1) + do iLayer=1,nSnow + mLayerLiqFluxSnow(iLayer) = -(iLayerLiqFluxSnow(iLayer) - iLayerLiqFluxSnow(iLayer-1))/mLayerDepth(iLayer) + end do + ! compute drainage from the soil zone (needed for mass balance checks) + scalarSnowDrainage = iLayerLiqFluxSnow(nSnow) + end associate + end subroutine finalize_snowLiqFlx + ! **** end snowLiqFlx **** + + ! **** soilLiqFlx **** + subroutine initialize_soilLiqFlx + call in_soilLiqFlx%initialize(nSnow,nSoil,nlayers,firstSplitOper,scalarSolution,firstFluxCall,scalarAquiferStorageTrial,& + mLayerTempTrial,mLayerMatricHeadTrial,mLayerMatricHeadLiqTrial,mLayerVolFracLiqTrial,mLayerVolFracIceTrial,& + flux_data,deriv_data) + call io_soilLiqFlx%initialize(nSoil,dHydCond_dMatric,flux_data,diag_data,deriv_data) + end subroutine initialize_soilLiqFlx + + subroutine finalize_soilLiqFlx + call io_soilLiqFlx%finalize(nSoil,dHydCond_dMatric,flux_data,diag_data,deriv_data) + call out_soilLiqFlx%finalize(err,cmessage) + ! error control + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if + associate(& + mLayerLiqFluxSoil => flux_data%var(iLookFLUX%mLayerLiqFluxSoil)%dat, & ! intent(out): [dp] net liquid water flux for each soil layer (s-1) + iLayerLiqFluxSoil => flux_data%var(iLookFLUX%iLayerLiqFluxSoil)%dat, & ! intent(out): [dp(0:)] vertical liquid water flux at soil layer interfaces (-) + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat, & ! intent(in): [dp(:)] depth of each layer in the snow-soil sub-domain (m) + scalarSoilDrainage => flux_data%var(iLookFLUX%scalarSoilDrainage)%dat(1) ) ! intent(out): [dp] drainage from the soil profile (m s-1) + ! calculate net liquid water fluxes for each soil layer (s-1) + do iLayer=1,nSoil + mLayerLiqFluxSoil(iLayer) = -(iLayerLiqFluxSoil(iLayer) - iLayerLiqFluxSoil(iLayer-1))/mLayerDepth(iLayer+nSnow) + end do + ! compute drainage from the soil zone (needed for mass balance checks and in aquifer recharge) + scalarSoilDrainage = iLayerLiqFluxSoil(nSoil) + end associate + + associate(& + dq_dHydStateAbove => deriv_data%var(iLookDERIV%dq_dHydStateAbove)%dat, & ! intent(out): [dp(:)] change in flux at layer interfaces w.r.t. states in the layer above + dq_dHydStateBelow => deriv_data%var(iLookDERIV%dq_dHydStateBelow)%dat, & ! intent(out): [dp(:)] change in flux at layer interfaces w.r.t. states in the layer below + dq_dHydStateLayerSurfVec => deriv_data%var(iLookDERIV%dq_dHydStateLayerSurfVec)%dat, & ! intent(out): [dp(:)] change in the flux in soil surface interface w.r.t. state variables in layers + dPsiLiq_dPsi0 => deriv_data%var(iLookDERIV%dPsiLiq_dPsi0 )%dat ) ! intent(in): [dp(:)] derivative in liquid water matric pot w.r.t. the total water matric pot (-) + ! expand derivatives to the total water matric potential + ! NOTE: arrays are offset because computing derivatives in interface fluxes, at the top and bottom of the layer respectively + dq_dHydStateAbove(1:nSoil) = dq_dHydStateAbove(1:nSoil) *dPsiLiq_dPsi0(1:nSoil) + dq_dHydStateBelow(0:nSoil-1) = dq_dHydStateBelow(0:nSoil-1)*dPsiLiq_dPsi0(1:nSoil) + if(all(dq_dHydStateLayerSurfVec/=realMissing)) dq_dHydStateLayerSurfVec(1:nSoil) = dq_dHydStateLayerSurfVec(1:nSoil)*dPsiLiq_dPsi0(1:nSoil) + end associate + end subroutine finalize_soilLiqFlx + ! **** end soilLiqFlx **** + + ! **** groundwatr **** + subroutine initialize_groundwatr + ! check the derivative matrix is sized appropriately + if (size(dBaseflow_dMatric,1)/=nSoil .or. size(dBaseflow_dMatric,2)/=nSoil) then + message=trim(message)//'expect dBaseflow_dMatric to be nSoil x nSoil' + err=20; return + end if + call in_groundwatr%initialize(nSnow,nSoil,nLayers,firstFluxCall,mLayerVolFracLiqTrial,mLayerVolFracIceTrial,deriv_data) + call io_groundwatr%initialize(ixSaturation) + end subroutine initialize_groundwatr + + subroutine finalize_groundwatr + call io_groundwatr%finalize(ixSaturation) + call out_groundwatr%finalize(dBaseflow_dMatric,flux_data,err,cmessage) + ! error control + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if + end subroutine finalize_groundwatr + ! **** end groundwatr **** + + ! **** bigAquifer **** + subroutine initialize_bigAquifer + call in_bigAquifer%initialize(scalarAquiferStorageTrial,flux_data,deriv_data) + call io_bigAquifer%initialize(deriv_data) + end subroutine initialize_bigAquifer + + subroutine finalize_bigAquifer + call io_bigAquifer%finalize(deriv_data) + call out_bigAquifer%finalize(flux_data,deriv_data,err,cmessage) + associate(& + scalarTotalRunoff => flux_data%var(iLookFLUX%scalarTotalRunoff)%dat(1) ,& ! intent(out): [dp] total runoff (m s-1) + scalarSurfaceRunoff => flux_data%var(iLookFLUX%scalarSurfaceRunoff)%dat(1) ,& ! intent(out): [dp] surface runoff (m s-1) + scalarAquiferBaseflow => flux_data%var(iLookFLUX%scalarAquiferBaseflow)%dat(1) ) ! intent(out): [dp] total baseflow from the aquifer (m s-1) + ! error control + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if + ! compute total runoff (overwrite previously calculated value before considering aquifer). + ! (Note: SoilDrainage goes into aquifer, not runoff) + scalarTotalRunoff = scalarSurfaceRunoff + scalarAquiferBaseflow + end associate + end subroutine finalize_bigAquifer + ! **** end bigAquifer **** + +end subroutine computFlux + +! ********************************************************************************************************** +! public subroutine soilCmpres: compute soil compressibility (-) and its derivative w.r.t matric head (m-1) +! ********************************************************************************************************** +subroutine soilCmpres(& + ! input: + dt, & ! intent(in): length of the time step (seconds) + ixRichards, & ! intent(in): choice of option for Richards' equation + ixBeg,ixEnd, & ! intent(in): start and end indices defining desired layers + mLayerMatricHead, & ! intent(in): matric head at the start of the time step (m) + mLayerMatricHeadTrial, & ! intent(in): trial value of matric head (m) + mLayerVolFracLiqTrial, & ! intent(in): trial value for the volumetric liquid water content in each soil layer (-) + mLayerVolFracIceTrial, & ! intent(in): trial value for the volumetric ice content in each soil layer (-) + specificStorage, & ! intent(in): specific storage coefficient (m-1) + theta_sat, & ! intent(in): soil porosity (-) + ! output: + compress, & ! intent(out): compressibility of the soil matrix (-), per second + dCompress_dPsi, & ! intent(out): derivative in compressibility w.r.t. matric head (m-1) + err,message) ! intent(out): error code and error message + implicit none + ! input: + real(rkind),intent(in) :: dt ! length of the time step (seconds) + integer(i4b),intent(in) :: ixRichards ! choice of option for Richards' equation + integer(i4b),intent(in) :: ixBeg,ixEnd ! start and end indices defining desired layers + real(rkind),intent(in) :: mLayerMatricHead(:) ! matric head at the start of the time step (m) + real(rkind),intent(in) :: mLayerMatricHeadTrial(:) ! trial value for matric head (m) + real(rkind),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) + real(rkind),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) + real(rkind),intent(in) :: specificStorage ! specific storage coefficient (m-1) + real(rkind),intent(in) :: theta_sat(:) ! soil porosity (-) + ! output: + real(rkind),intent(inout) :: compress(:) ! soil compressibility (-) + real(rkind),intent(inout) :: dCompress_dPsi(:) ! derivative in soil compressibility w.r.t. matric head (m-1) + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! local variables + integer(i4b) :: iLayer ! index of soil layer + ! -------------------------------------------------------------- + ! initialize error control + err=0; message='soilCmpres/' + ! (only compute for the mixed form of Richards' equation) + if (ixRichards==mixdform) then + do iLayer=1,size(mLayerMatricHead) + if (iLayer>=ixBeg .and. iLayer<=ixEnd) then + ! compute the derivative for the compressibility term (m-1), no volume expansion for total water + dCompress_dPsi(iLayer) = specificStorage*(mLayerVolFracLiqTrial(iLayer) + mLayerVolFracIceTrial(iLayer))/theta_sat(iLayer) + ! compute the compressibility term (-) per second + compress(iLayer) = (mLayerMatricHeadTrial(iLayer) - mLayerMatricHead(iLayer))*dCompress_dPsi(iLayer)/dt + end if + end do + else + compress(:) = 0._rkind + dCompress_dPsi(:) = 0._rkind + end if +end subroutine soilCmpres + +! ********************************************************************************************************** +! public subroutine soilCmpres: compute soil compressibility (-) and its derivative w.r.t matric head (m-1) +! ********************************************************************************************************** +subroutine soilCmpresPrime(& + ! input: + ixRichards, & ! intent(in): choice of option for Richards' equation + ixBeg,ixEnd, & ! intent(in): start and end indices defining desired layers + mLayerMatricHeadPrime, & ! intent(in): matric head at the start of the time step (m) + mLayerVolFracLiqTrial, & ! intent(in): trial value for the volumetric liquid water content in each soil layer (-) + mLayerVolFracIceTrial, & ! intent(in): trial value for the volumetric ice content in each soil layer (-) + specificStorage, & ! intent(in): specific storage coefficient (m-1) + theta_sat, & ! intent(in): soil porosity (-) + ! output: + compress, & ! intent(out): compressibility of the soil matrix (-) + dCompress_dPsi, & ! intent(out): derivative in compressibility w.r.t. matric head (m-1) + err,message) ! intent(out): error code and error message + implicit none + ! input: + integer(i4b),intent(in) :: ixRichards ! choice of option for Richards' equation + integer(i4b),intent(in) :: ixBeg,ixEnd ! start and end indices defining desired layers + real(rkind),intent(in) :: mLayerMatricHeadPrime(:) ! matric head at the start of the time step (m) + real(rkind),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) + real(rkind),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) + real(rkind),intent(in) :: specificStorage ! specific storage coefficient (m-1) + real(rkind),intent(in) :: theta_sat(:) ! soil porosity (-) + ! output: + real(rkind),intent(inout) :: compress(:) ! soil compressibility (-) + real(rkind),intent(inout) :: dCompress_dPsi(:) ! derivative in soil compressibility w.r.t. matric head (m-1) + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! local variables + integer(i4b) :: iLayer ! index of soil layer + ! -------------------------------------------------------------- + ! initialize error control + err=0; message='soilCmpresPrime/' + ! (only compute for the mixed form of Richards' equation) + if (ixRichards==mixdform) then + do iLayer=1,size(mLayerMatricHeadPrime) + if (iLayer>=ixBeg .and. iLayer<=ixEnd) then + ! compute the derivative for the compressibility term (m-1), no volume expansion for total water + dCompress_dPsi(iLayer) = specificStorage*(mLayerVolFracLiqTrial(iLayer) + mLayerVolFracIceTrial(iLayer))/theta_sat(iLayer) + ! compute the compressibility term (-) instantaneously + compress(iLayer) = mLayerMatricHeadPrime(iLayer) * dCompress_dPsi(iLayer) + end if + end do + else + compress(:) = 0._rkind + dCompress_dPsi(:) = 0._rkind + end if +end subroutine soilCmpresPrime end module computFlux_module diff --git a/build/source/engine/computHeatCap.f90 b/build/source/engine/computHeatCap.f90 new file mode 100644 index 000000000..aafdf62b4 --- /dev/null +++ b/build/source/engine/computHeatCap.f90 @@ -0,0 +1,494 @@ +! SUMMA - Structure for Unifying Multiple Modeling Alternatives +! Copyright (C) 2014-2015 NCAR/RAL +! +! This file is part of SUMMA +! +! For more information see: http://www.ral.ucar.edu/projects/summa +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see . + +module computHeatCap_module + +! data types +USE nrtype + +! derived types to define the data structures +USE data_types,only:& + var_d, & ! data vector (rkind) + var_ilength, & ! data vector with variable length dimension (i4b) + var_dlength ! data vector with variable length dimension (rkind) + +! named variables defining elements in the data structures +USE var_lookup,only:iLookPARAM,iLookDIAG,iLookINDEX ! named variables for structure elements + +! physical constants +USE multiconst,only: gravity, & ! gravitational acceleration (m s-1) + Tfreeze, & ! freezing point of water (K) + Cp_soil,Cp_water,Cp_ice,Cp_air,& ! specific heat of soil, water and ice (J kg-1 K-1) + iden_water,iden_ice,iden_air,& ! intrinsic density of water and ice (kg m-3) + LH_fus ! latent heat of fusion (J kg-1) + +! named variables to describe the state variable type +USE globalData,only:iname_nrgCanair ! named variable defining the energy of the canopy air space +USE globalData,only:iname_nrgCanopy ! named variable defining the energy of the vegetation canopy +USE globalData,only:iname_watCanopy ! named variable defining the mass of total water on the vegetation canopy +USE globalData,only:iname_liqCanopy ! named variable defining the mass of liquid water on the vegetation canopy +USE globalData,only:iname_nrgLayer ! named variable defining the energy state variable for snow+soil layers +USE globalData,only:iname_watLayer ! named variable defining the total water state variable for snow+soil layers +USE globalData,only:iname_liqLayer ! named variable defining the liquid water state variable for snow+soil layers +USE globalData,only:iname_matLayer ! named variable defining the matric head state variable for soil layers +USE globalData,only:iname_lmpLayer ! named variable defining the liquid matric potential state variable for soil layers +USE globalData,only:iname_watAquifer ! named variable defining the water storage in the aquifer + +! missing values +USE globalData,only:integerMissing ! missing integer +USE globalData,only:realMissing ! missing real + +! domain types +USE globalData,only:iname_cas ! named variables for canopy air space +USE globalData,only:iname_veg ! named variables for vegetation canopy +USE globalData,only:iname_snow ! named variables for snow +USE globalData,only:iname_soil ! named variables for soil +USE globalData,only:iname_aquifer ! named variables for the aquifer + +! privacy +implicit none +private +public::computStatMult +public::computHeatCapAnalytic +public::computCm + +contains + + +! ********************************************************************************************************** +! public subroutine computStatMult: get scale factors +! ********************************************************************************************************** +subroutine computStatMult(& + heatCapVeg, & ! intent(in): heat capacity for canopy + mLayerHeatCap, & ! intent(in): heat capacity for snow and soil + ! input: data structures + indx_data, & ! intent(in): indices defining model states and layers + ! output + sMul, & ! intent(out): multiplier for state vector (used in the residual calculations) + err,message) ! intent(out): error control +! -------------------------------------------------------------------------------------------------------------------------------- +USE nr_utility_module,only:arth ! get a sequence of numbers arth(start, incr, count) +USE f2008funcs_module,only:findIndex ! finds the index of the first value within a vector + ! -------------------------------------------------------------------------------------------------------------------------------- + ! input: data structures + real(qp),intent(in) :: heatCapVeg ! volumetric heat capacity of vegetation (J m-3 K-1) + real(qp),intent(in) :: mLayerHeatCap(:) ! volumetric heat capacity of snow and soil (J m-3 K-1) + type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers + ! output: state vectors + real(qp),intent(inout) :: sMul(:) ! NOTE: qp ! multiplier for state vector (used in the residual calculations) + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! -------------------------------------------------------------------------------------------------------------------------------- + ! local variables + ! -------------------------------------------------------------------------------------------------------------------------------- + ! state subsets + integer(i4b) :: iLayer ! index of layer within the snow+soil domain + integer(i4b) :: ixStateSubset ! index within the state subset + ! -------------------------------------------------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------------------------------------------------- + ! make association with variables in the data structures + associate(& + ! vector of energy and hydrology indices for the snow and soil domains + ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in) : [i4b(:)] index in the state subset for energy state variables in the snow+soil domain + ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in) : [i4b(:)] index in the state subset for hydrology state variables in the snow+soil domain + nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg )%dat(1) ,& ! intent(in) : [i4b] number of energy state variables in the snow+soil domain + nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd )%dat(1) ,& ! intent(in) : [i4b] number of hydrology state variables in the snow+soil domain + ! type of model state variabless + ixStateType_subset => indx_data%var(iLookINDEX%ixStateType_subset)%dat ,& ! intent(in) : [i4b(:)] [state subset] type of desired model state variables + ! number of layers + nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1) & ! intent(in) : [i4b] total number of layers + ) ! end association with variables in the data structures + ! -------------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message='computStatMult/' + + ! ----- + ! * define components of derivative matrices at start of time step (substep)... + ! ------------------------------------------------------------------------------------------ + + ! define the multiplier for the state vector for residual calculations (vegetation canopy) + ! NOTE: Use the "where" statement to generalize to multiple canopy layers (currently one canopy layer) + where(ixStateType_subset==iname_nrgCanair) sMul = Cp_air*iden_air ! volumetric heat capacity of air (J m-3 K-1) + where(ixStateType_subset==iname_nrgCanopy) sMul = heatCapVeg ! volumetric heat capacity of the vegetation (J m-3 K-1) + where(ixStateType_subset==iname_watCanopy) sMul = 1._rkind ! nothing else on the left hand side + where(ixStateType_subset==iname_liqCanopy) sMul = 1._rkind ! nothing else on the left hand side + + ! define the energy multiplier for the state vector for residual calculations (snow-soil domain) + if(nSnowSoilNrg>0)then + do concurrent (iLayer=1:nLayers,ixSnowSoilNrg(iLayer)/=integerMissing) ! (loop through non-missing energy state variables in the snow+soil domain) + ixStateSubset = ixSnowSoilNrg(iLayer) ! index within the state vector + sMul(ixStateSubset) = mLayerHeatCap(iLayer) ! transfer volumetric heat capacity to the state multiplier + end do ! looping through non-missing energy state variables in the snow+soil domain + endif + + ! define the hydrology multiplier and diagonal elements for the state vector for residual calculations (snow-soil domain) + if(nSnowSoilHyd>0)then + do concurrent (iLayer=1:nLayers,ixSnowSoilHyd(iLayer)/=integerMissing) ! (loop through non-missing energy state variables in the snow+soil domain) + ixStateSubset = ixSnowSoilHyd(iLayer) ! index within the state vector + sMul(ixStateSubset) = 1._rkind ! state multiplier = 1 (nothing else on the left-hand-side) + end do ! looping through non-missing energy state variables in the snow+soil domain + endif + + ! define the scaling factor and diagonal elements for the aquifer + where(ixStateType_subset==iname_watAquifer) sMul = 1._rkind + + ! ------------------------------------------------------------------------------------------ + ! ------------------------------------------------------------------------------------------ + + end associate +! end association to variables in the data structure where vector length does not change +end subroutine computStatMult + +! ********************************************************************************************************** +! public subroutine computHeatCapAnalytic: compute diagnostic energy variables (heat capacity) +! NOTE: computing on whole vector, could just compute on state subset +! ********************************************************************************************************** +subroutine computHeatCapAnalytic(& + ! input: state variables + canopyDepth, & ! intent(in): canopy depth (m) + scalarCanopyIce, & ! intent(in): trial value for mass of ice on the vegetation canopy (kg m-2) + scalarCanopyLiquid, & ! intent(in): trial value for the liquid water on the vegetation canopy (kg m-2) + scalarCanopyTemp, & ! intent(in): trial value of canopy temperature (K) + mLayerVolFracIce, & ! intent(in): volumetric fraction of ice at the start of the sub-step (-) + mLayerVolFracLiq, & ! intent(in): volumetric fraction of liquid water at the start of the sub-step (-) + mLayerTemp, & ! intent(in): trial value of layer temperature (K) + mLayerMatricHead, & ! intent(in): total water matric potential (m) + ! input: pre-computed derivatives + dTheta_dTkCanopy, & ! intent(in): derivative in canopy volumetric liquid water content w.r.t. temperature (K-1) + scalarFracLiqVeg, & ! intent(in): fraction of canopy liquid water (-) + mLayerdTheta_dTk, & ! intent(in): derivative of volumetric liquid water content w.r.t. temperature (K-1) + mLayerFracLiqSnow, & ! intent(in): fraction of liquid water (-) + dVolTot_dPsi0, & ! intent(in): derivative in total water content w.r.t. total water matric potential (m-1) + ! input output data structures + mpar_data, & ! intent(in): model parameters + indx_data, & ! intent(in): model layer indices + ! output + heatCapVeg, & ! intent(inout): heat capacity for canopy + mLayerHeatCap, & ! intent(inout): heat capacity for snow and soil + dVolHtCapBulk_dPsi0, & ! intent(inout): derivative in bulk heat capacity w.r.t. matric potential + dVolHtCapBulk_dTheta, & ! intent(inout): derivative in bulk heat capacity w.r.t. volumetric water content + dVolHtCapBulk_dCanWat, & ! intent(inout): derivative in bulk heat capacity w.r.t. volumetric water content + dVolHtCapBulk_dTk, & ! intent(inout): derivative in bulk heat capacity w.r.t. temperature + dVolHtCapBulk_dTkCanopy, & ! intent(inout): derivative in bulk heat capacity w.r.t. temperature + ! output: error control + err,message) ! intent(out): error control + ! -------------------------------------------------------------------------------------------------------------------------------------- + ! provide access to external subroutines + USE soil_utils_module,only:crit_soilT ! compute critical temperature below which ice exists + ! -------------------------------------------------------------------------------------------------------------------------------------- + ! input: model control + real(rkind),intent(in) :: canopyDepth ! depth of the vegetation canopy (m) + real(rkind),intent(in) :: scalarCanopyIce ! trial value of canopy ice content (kg m-2) + real(rkind),intent(in) :: scalarCanopyLiquid ! trial value of canopy liquid content (kg m-2) + real(rkind),intent(in) :: scalarCanopyTemp ! value of canopy temperature (kg m-2) + real(rkind),intent(in) :: mLayerVolFracLiq(:) ! trial vector of volumetric liquid water content (-) + real(rkind),intent(in) :: mLayerVolFracIce(:) ! trial vector of volumetric ice water content (-) + real(rkind),intent(in) :: mLayerTemp(:) ! vector of temperature (-) + real(rkind),intent(in) :: mLayerMatricHead(:) ! vector of total water matric potential (m) + ! input: pre-computed derivatives + real(rkind),intent(in) :: dTheta_dTkCanopy ! derivative in canopy volumetric liquid water content w.r.t. temperature (K-1) + real(rkind),intent(in) :: scalarFracLiqVeg ! fraction of canopy liquid water (-) + real(rkind),intent(in) :: mLayerdTheta_dTk(:) ! derivative of volumetric liquid water content w.r.t. temperature (K-1) + real(rkind),intent(in) :: mLayerFracLiqSnow(:) ! fraction of liquid water (-) + real(rkind),intent(in) :: dVolTot_dPsi0(:) ! derivative in total water content w.r.t. total water matric potential (m-1) + ! input/output: data structures + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_ilength),intent(in) :: indx_data ! model layer indices + ! output + real(qp),intent(inout) :: heatCapVeg ! heat capacity for canopy + real(qp),intent(inout) :: mLayerHeatCap(:) ! heat capacity for snow and soil + real(rkind),intent(inout) :: dVolHtCapBulk_dPsi0(:) ! derivative in bulk heat capacity w.r.t. matric potential + real(rkind),intent(inout) :: dVolHtCapBulk_dTheta(:) ! derivative in bulk heat capacity w.r.t. volumetric water content + real(rkind),intent(inout) :: dVolHtCapBulk_dCanWat ! derivative in bulk heat capacity w.r.t. volumetric water content + real(rkind),intent(inout) :: dVolHtCapBulk_dTk(:) ! derivative in bulk heat capacity w.r.t. temperature + real(rkind),intent(inout) :: dVolHtCapBulk_dTkCanopy ! derivative in bulk heat capacity w.r.t. temperature + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! -------------------------------------------------------- ------------------------------------------------------------------------ + ! local variables + integer(i4b) :: iState ! index of model state variable + integer(i4b) :: iLayer ! index of model layer + integer(i4b) :: ixFullVector ! index within full state vector + integer(i4b) :: ixDomainType ! name of a given model domain + integer(i4b) :: ixControlIndex ! index within a given model domain + real(rkind) :: fLiq ! fraction of liquid water + real(rkind) :: Tcrit ! temperature where all water is unfrozen (K) + ! -------------------------------------------------------------------------------------------------------------------------------- + ! associate variables in data structure + associate(& + ! input: coordinate variables + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in): number of snow layers + ! mapping between the full state vector and the state subset + ixMapFull2Subset => indx_data%var(iLookINDEX%ixMapFull2Subset)%dat ,& ! intent(in): [i4b(:)] list of indices in the state subset for each state in the full state vector + ixMapSubset2Full => indx_data%var(iLookINDEX%ixMapSubset2Full)%dat ,& ! intent(in): [i4b(:)] [state subset] list of indices of the full state vector in the state subset + ! type of domain, type of state variable, and index of control volume within domain + ixDomainType_subset => indx_data%var(iLookINDEX%ixDomainType_subset)%dat ,& ! intent(in): [i4b(:)] [state subset] id of domain for desired model state variables + ixControlVolume => indx_data%var(iLookINDEX%ixControlVolume)%dat ,& ! intent(in): [i4b(:)] index of the control volume for different domains (veg, snow, soil) + ixStateType => indx_data%var(iLookINDEX%ixStateType)%dat ,& ! intent(in): [i4b(:)] indices defining the type of the state (iname_nrgLayer...) + ! input: heat capacity and thermal conductivity + specificHeatVeg => mpar_data%var(iLookPARAM%specificHeatVeg)%dat(1) ,& ! intent(in): specific heat of vegetation (J kg-1 K-1) + maxMassVegetation => mpar_data%var(iLookPARAM%maxMassVegetation)%dat(1) ,& ! intent(in): maximum mass of vegetation (kg m-2) + ! input: depth varying soil parameters + iden_soil => mpar_data%var(iLookPARAM%soil_dens_intr)%dat ,& ! intent(in): intrinsic density of soil (kg m-3) + theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat & ! intent(in): soil porosity (-) + ) ! end associate statement + ! -------------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message="computHeatCapAnalytic/" + + ! loop through model state variables + do iState=1,size(ixMapSubset2Full) + + ! ----- + ! - compute indices... + ! -------------------- + + ! get domain type, and index of the control volume within the domain + ixFullVector = ixMapSubset2Full(iState) ! index within full state vector + ixDomainType = ixDomainType_subset(iState) ! named variables defining the domain (iname_cas, iname_veg, etc.) + ixControlIndex = ixControlVolume(ixFullVector) ! index within a given domain + + ! check an energy state, since only need for energy state equations + if(ixStateType(ixFullVector)==iname_nrgCanair .or. ixStateType(ixFullVector)==iname_nrgCanopy .or. ixStateType(ixFullVector)==iname_nrgLayer)then + + ! get the layer index + select case(ixDomainType) + case(iname_cas); cycle ! canopy air space, do nothing (no water stored in canopy air space) + case(iname_veg); iLayer = integerMissing + case(iname_snow); iLayer = ixControlIndex + case(iname_soil); iLayer = ixControlIndex + nSnow + case(iname_aquifer); cycle ! aquifer: do nothing (no thermodynamics in the aquifer) + case default; err=20; message=trim(message)//'expect case to be iname_cas, iname_veg, iname_snow, iname_soil, iname_aquifer'; return + end select + + ! identify domain + select case(ixDomainType) + + case(iname_veg) + heatCapVeg = specificHeatVeg*maxMassVegetation/canopyDepth + & ! vegetation component + Cp_water*scalarCanopyLiquid/canopyDepth + & ! liquid water component + Cp_ice*scalarCanopyIce/canopyDepth ! ice component + + ! derivatives + fLiq = scalarFracLiqVeg + dVolHtCapBulk_dCanWat = ( -Cp_ice*( fLiq-1._rkind ) + Cp_water*fLiq )/canopyDepth !this is iden_water/(iden_water*canopyDepth) + if(scalarCanopyTemp < Tfreeze)then + dVolHtCapBulk_dTkCanopy = iden_water * (-Cp_ice + Cp_water) * dTheta_dTkCanopy ! no derivative in air + else + dVolHtCapBulk_dTkCanopy = 0._rkind + endif + + case(iname_snow) + mLayerHeatCap(iLayer) = iden_ice * Cp_ice * mLayerVolFracIce(iLayer) + & ! ice component + iden_water * Cp_water * mLayerVolFracLiq(iLayer) + & ! liquid water component + iden_air * Cp_air * ( 1._rkind - (mLayerVolFracIce(iLayer) + mLayerVolFracLiq(iLayer)) ) ! air component + ! derivatives + fLiq = mLayerFracLiqSnow(iLayer) + dVolHtCapBulk_dTheta(iLayer) = iden_water * ( -Cp_ice*( fLiq-1._rkind ) + Cp_water*fLiq ) + iden_air * ( ( fLiq-1._rkind )*iden_water/iden_ice - fLiq ) * Cp_air + if( mLayerTemp(iLayer) < Tfreeze)then + dVolHtCapBulk_dTk(iLayer) = ( iden_water * (-Cp_ice + Cp_water) + iden_air * (iden_water/iden_ice - 1._rkind) * Cp_air ) * mLayerdTheta_dTk(iLayer) + else + dVolHtCapBulk_dTk(iLayer) = 0._rkind + endif + + case(iname_soil) + mLayerHeatCap(iLayer) = iden_soil(ixControlIndex) * Cp_soil * ( 1._rkind - theta_sat(ixControlIndex) ) + & ! soil component + iden_ice * Cp_ice * mLayerVolFracIce(iLayer) + & ! ice component + iden_water * Cp_water * mLayerVolFracLiq(iLayer) + & ! liquid water component + iden_air * Cp_air * ( theta_sat(ixControlIndex) - (mLayerVolFracIce(iLayer) + mLayerVolFracLiq(iLayer)) )! air component + ! derivatives + dVolHtCapBulk_dTheta(iLayer) = realMissing ! do not use + Tcrit = crit_soilT( mLayerMatricHead(ixControlIndex) ) + if( mLayerTemp(iLayer) < Tcrit)then + dVolHtCapBulk_dPsi0(ixControlIndex) = (iden_ice * Cp_ice - iden_air * Cp_air) * dVolTot_dPsi0(ixControlIndex) + dVolHtCapBulk_dTk(iLayer) = (-iden_ice * Cp_ice + iden_water * Cp_water) * mLayerdTheta_dTk(iLayer) + else + dVolHtCapBulk_dPsi0(ixControlIndex) = (iden_water*Cp_water - iden_air * Cp_air) * dVolTot_dPsi0(ixControlIndex) + dVolHtCapBulk_dTk(iLayer) = 0._rkind + endif + end select + + end if ! if an energy layer + end do ! looping through state variables + + end associate + +end subroutine computHeatCapAnalytic + +! ********************************************************************************************************** +! public subroutine computCm: compute diagnostic energy variables (change in enthTemp with water) +! NOTE: computing on whole vector, could just compute on state subset +! ********************************************************************************************************** +subroutine computCm(& + ! input: state variables + scalarCanopyTemp, & ! intent(in): value of canopy temperature (K) + mLayerTemp, & ! intent(in): vector of temperature (K) + mLayerMatricHead, & ! intent(in): vector of total water matric potential (-) + ! input data structures + mpar_data, & ! intent(in): model parameters + indx_data, & ! intent(in): model layer indices + ! output + scalarCanopyCm, & ! intent(inout): Cm for vegetation (J kg K-1) + mLayerCm, & ! intent(inout): Cm for snow and soil (J kg K-1) + dCm_dPsi0, & ! intent(inout): derivative in Cm w.r.t. matric potential (J kg) + dCm_dTk, & ! intent(inout): derivative in Cm w.r.t. temperature (J kg K-2) + dCm_dTkCanopy, & ! intent(inout): derivative in Cm w.r.t. temperature (J kg K-2) + ! output: error control + err,message) ! intent(out): error control + ! -------------------------------------------------------------------------------------------------------------------------------------- + ! provide access to external subroutines + USE snow_utils_module,only:fracliquid ! compute the fraction of liquid water (snow) + USE snow_utils_module,only:dFracLiq_dTk ! differentiate the freezing curve w.r.t. temperature (snow) + USE soil_utils_module,only:crit_soilT ! compute critical temperature below which ice exists (soil) + ! -------------------------------------------------------------------------------------------------------------------------------------- + ! input: state variables + real(rkind),intent(in) :: scalarCanopyTemp ! value of canopy temperature (K) + real(rkind),intent(in) :: mLayerTemp(:) ! vector of temperature (K) + real(rkind),intent(in) :: mLayerMatricHead(:) ! vector of total water matric potential (-) + ! input/output: data structures + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_ilength),intent(in) :: indx_data ! model layer indices + ! output: Cm and derivatives + real(rkind),intent(inout) :: scalarCanopyCm ! Cm for vegetation (J kg K-1) use for LHS + real(rkind),intent(inout) :: mLayerCm(:) ! Cm for snow and soil (J kg K-1) + real(rkind),intent(inout) :: dCm_dPsi0(:) ! derivative in Cm w.r.t. matric potential (J kg) + real(rkind),intent(inout) :: dCm_dTk(:) ! derivative in Cm w.r.t. temperature (J kg K-2) + real(rkind),intent(inout) :: dCm_dTkCanopy ! derivative in Cm w.r.t. temperature (J kg K-2) + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! -------------------------------------------------------------------------------------------------------------------------------- + ! local variables + integer(i4b) :: iState ! index of model state variable + integer(i4b) :: iLayer ! index of model layer + integer(i4b) :: ixFullVector ! index within full state vector + integer(i4b) :: ixDomainType ! name of a given model domain + integer(i4b) :: ixControlIndex ! index within a given model domain + real(rkind) :: diffT ! temperature difference from Tfreeze + real(rkind) :: diff0 ! temperature difference Tcrit from Tfreeze + real(rkind) :: integral ! integral of snow freezing curve + real(rkind) :: fLiq ! fraction of liquid water + real(rkind) :: dfLiq_dT ! derivative of fraction of liquid water with temperature + real(rkind) :: Tcrit ! temperature where all water is unfrozen (K) + real(rkind) :: dTcrit_dPsi0 ! derivative of critical temperature with matric potential + ! -------------------------------------------------------------------------------------------------------------------------------- + ! associate variables in data structure + associate(& + ! input: coordinate variables + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in): number of snow layers + snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1) ,& ! intent(in): [dp] scaling parameter for the snow freezing curve (K-1) + ! mapping between the full state vector and the state subset + ixMapFull2Subset => indx_data%var(iLookINDEX%ixMapFull2Subset)%dat ,& ! intent(in): [i4b(:)] list of indices in the state subset for each state in the full state vector + ixMapSubset2Full => indx_data%var(iLookINDEX%ixMapSubset2Full)%dat ,& ! intent(in): [i4b(:)] [state subset] list of indices of the full state vector in the state subset + ! type of domain, type of state variable, and index of control volume within domain + ixDomainType_subset => indx_data%var(iLookINDEX%ixDomainType_subset)%dat ,& ! intent(in): [i4b(:)] [state subset] id of domain for desired model state variables + ixControlVolume => indx_data%var(iLookINDEX%ixControlVolume)%dat ,& ! intent(in): [i4b(:)] index of the control volume for different domains (veg, snow, soil) + ixStateType => indx_data%var(iLookINDEX%ixStateType)%dat & ! intent(in): [i4b(:)] indices defining the type of the state (iname_nrgLayer...) + ) ! end associate statement + ! -------------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message="computCm/" + + ! loop through model state variables + do iState=1,size(ixMapSubset2Full) + + ! ----- + ! - compute indices... + ! -------------------- + + ! get domain type, and index of the control volume within the domain + ixFullVector = ixMapSubset2Full(iState) ! index within full state vector + ixDomainType = ixDomainType_subset(iState) ! named variables defining the domain (iname_cas, iname_veg, etc.) + ixControlIndex = ixControlVolume(ixFullVector) ! index within a given domain + + ! check an energy state, since only need for energy state equations + if(ixStateType(ixFullVector)==iname_nrgCanair .or. ixStateType(ixFullVector)==iname_nrgCanopy .or. ixStateType(ixFullVector)==iname_nrgLayer)then + + ! get the layer index + select case(ixDomainType) + case(iname_cas); cycle ! canopy air space, do nothing (no water stored in canopy air space) + case(iname_veg); iLayer = integerMissing + case(iname_snow); iLayer = ixControlIndex + case(iname_soil); iLayer = ixControlIndex + nSnow + case(iname_aquifer); cycle ! aquifer: do nothing (no thermodynamics in the aquifer) + case default; err=20; message=trim(message)//'expect case to be iname_cas, iname_veg, iname_snow, iname_soil, iname_aquifer'; return + end select + + ! identify domain + select case(ixDomainType) + + case(iname_veg) + ! Note that scalarCanopyCm/iden_water is computed + diffT = scalarCanopyTemp - Tfreeze + if(diffT>=0._rkind)then + scalarCanopyCm = Cp_water * diffT + ! derivatives + dCm_dTkCanopy = Cp_water + else + integral = (1._rkind/snowfrz_scale) * atan(snowfrz_scale * diffT) + fLiq = fracLiquid(scalarCanopyTemp,snowfrz_scale) + scalarCanopyCm = Cp_water * integral + Cp_ice * (diffT - integral) + ! derivatives + dfLiq_dT = dFracLiq_dTk(scalarCanopyTemp,snowfrz_scale) + dCm_dTkCanopy = Cp_water * fLiq + Cp_ice * (1._rkind - fLiq) + end if + + case(iname_snow) + diffT = mLayerTemp(iLayer) - Tfreeze + fLiq = fracLiquid(mLayerTemp(iLayer),snowfrz_scale) + integral = (1._rkind/snowfrz_scale) * atan(snowfrz_scale * diffT) + mLayerCm(iLayer) = (iden_water * Cp_ice - iden_air * Cp_air * iden_water/iden_ice) * ( diffT - integral ) & + + (iden_water * Cp_water - iden_air * Cp_air) * integral + ! derivatives + dfLiq_dT = dFracLiq_dTk(mLayerTemp(iLayer),snowfrz_scale) + dCm_dTk(iLayer) = (iden_water * Cp_ice - iden_air * Cp_air * iden_water/iden_ice) * ( 1._rkind -fLiq ) & + + (iden_water * Cp_water - iden_air * Cp_air) * fLiq + + case(iname_soil) + diffT = mLayerTemp(iLayer) - Tfreeze + Tcrit = crit_soilT( mLayerMatricHead(ixControlIndex) ) + diff0 = Tcrit - Tfreeze + if( mLayerTemp(iLayer)>=Tcrit)then + mLayerCm(iLayer) = (-iden_air * Cp_air + iden_water * Cp_water) * diffT + ! derivatives + dCm_dTk(iLayer) = -iden_air * Cp_air + iden_water * Cp_water + dCm_dPsi0(ixControlIndex) = 0._rkind + else + mLayerCm(iLayer) = -iden_air * Cp_air * diffT + iden_ice * Cp_ice * (mLayerTemp(iLayer)-Tcrit) & + + iden_water * Cp_water * diff0 + ! derivatives + dTcrit_dPsi0 = merge(gravity*Tfreeze/LH_fus,0._rkind,mLayerMatricHead(ixControlIndex)<=0._rkind) + dCm_dTk(iLayer) = -iden_air * Cp_air + iden_ice * Cp_ice + dCm_dPsi0(ixControlIndex) = (-iden_ice * Cp_ice + iden_water * Cp_water) * dTcrit_dPsi0 + endif + + end select + + end if ! if an energy layer + end do ! looping through state variables + + end associate + +end subroutine computCm + + +end module computHeatCap_module diff --git a/build/source/engine/computJacob.f90 b/build/source/engine/computJacob.f90 old mode 100755 new mode 100644 index 017a77a96..07974fcde --- a/build/source/engine/computJacob.f90 +++ b/build/source/engine/computJacob.f90 @@ -25,13 +25,17 @@ module computJacob_module ! derived types to define the data structures USE data_types,only:& - var_ilength, & ! data vector with variable length dimension (i4b) - var_dlength ! data vector with variable length dimension (dp) + var_ilength, & ! data vector with variable length dimension (i4b) + var_dlength, & ! data vector with variable length dimension (rkind) + model_options, & ! defines the model decisions + in_type_computJacob, & ! class for computJacob arguments + out_type_computJacob ! class for computJacob arguments ! named variables for structure elements +USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure USE var_lookup,only:iLookPROG ! named variables for structure elements -USE var_lookup,only:iLookDIAG ! named variables for structure elements USE var_lookup,only:iLookINDEX ! named variables for structure elements +USE var_lookup,only:iLookDIAG ! named variables for structure elements USE var_lookup,only:iLookDERIV ! named variables for structure elements ! access the global print flag @@ -41,24 +45,13 @@ module computJacob_module USE globalData,only:integerMissing ! missing integer USE globalData,only:realMissing ! missing real number -! domain types -USE globalData,only:iname_veg ! named variables for vegetation -USE globalData,only:iname_snow ! named variables for snow -USE globalData,only:iname_soil ! named variables for soil - ! named variables to describe the state variable type -USE globalData,only:iname_nrgCanair ! named variable defining the energy of the canopy air space -USE globalData,only:iname_nrgCanopy ! named variable defining the energy of the vegetation canopy -USE globalData,only:iname_watCanopy ! named variable defining the mass of water on the vegetation canopy -USE globalData,only:iname_nrgLayer ! named variable defining the energy state variable for snow+soil layers -USE globalData,only:iname_watLayer ! named variable defining the total water state variable for snow+soil layers -USE globalData,only:iname_liqLayer ! named variable defining the liquid water state variable for snow+soil layers -USE globalData,only:iname_matLayer ! named variable defining the matric head state variable for soil layers -USE globalData,only:iname_lmpLayer ! named variable defining the liquid matric potential state variable for soil layers +USE globalData,only:iname_watLayer ! named variable defining the total water state variable for snow+soil layers +USE globalData,only:maxVolIceContent ! snow maximum volumetric ice content to store water (-) ! access named variables to describe the form and structure of the matrices used in the numerical solver -USE globalData,only: ku ! number of super-diagonal bands -USE globalData,only: kl ! number of sub-diagonal bands +USE globalData,only: ku ! number of super-diagonal bands, assume ku>=3 +USE globalData,only: kl ! number of sub-diagonal bands, assume kl>=4 USE globalData,only: ixDiag ! index for the diagonal band USE globalData,only: nBands ! length of the leading dimension of the band diagonal matrix USE globalData,only: ixFullMatrix ! named variable for the full Jacobian matrix @@ -69,723 +62,900 @@ module computJacob_module ! constants USE multiconst,only:& LH_fus, & ! latent heat of fusion (J kg-1) - iden_ice, & ! intrinsic density of ice (kg m-3) iden_water ! intrinsic density of liquid water (kg m-3) -implicit none -! define constants -real(rkind),parameter :: verySmall=tiny(1.0_rkind) ! a very small number -integer(i4b),parameter :: ixBandOffset=kl+ku+1 ! offset in the band Jacobian matrix +! look-up values for the choice of groundwater parameterization +USE mDecisions_module,only: & + qbaseTopmodel, & ! TOPMODEL-ish baseflow parameterization + bigBucket, & ! a big bucket (lumped aquifer model) + noExplicit ! no explicit groundwater parameterization +implicit none private public::computJacob +public::fluxJacAdd +public::ixInd +#ifdef SUNDIALS_ACTIVE +public::computJacob4kinsol +#endif contains - ! ********************************************************************************************************** - ! public subroutine computJacob: compute the Jacobian matrix - ! ********************************************************************************************************** - subroutine computJacob(& - ! input: model control - dt, & ! intent(in): length of the time step (seconds) - nSnow, & ! intent(in): number of snow layers - nSoil, & ! intent(in): number of soil layers - nLayers, & ! intent(in): total number of layers - computeVegFlux, & ! intent(in): flag to indicate if we need to compute fluxes over vegetation - computeBaseflow, & ! intent(in): flag to indicate if we need to compute baseflow - ixMatrix, & ! intent(in): form of the Jacobian matrix - ! input: data structures - indx_data, & ! intent(in): index data - prog_data, & ! intent(in): model prognostic variables for a local HRU - diag_data, & ! intent(in): model diagnostic variables for a local HRU - deriv_data, & ! intent(in): derivatives in model fluxes w.r.t. relevant state variables - dBaseflow_dMatric, & ! intent(in): derivative in baseflow w.r.t. matric head (s-1) - ! input-output: Jacobian and its diagonal - dMat, & ! intent(inout): diagonal of the Jacobian matrix - aJac, & ! intent(out): Jacobian matrix - ! output: error control - err,message) ! intent(out): error code and error message - ! ----------------------------------------------------------------------------------------------------------------- - implicit none - ! input: model control - real(rkind),intent(in) :: dt ! length of the time step (seconds) - integer(i4b),intent(in) :: nSnow ! number of snow layers - integer(i4b),intent(in) :: nSoil ! number of soil layers - integer(i4b),intent(in) :: nLayers ! total number of layers in the snow+soil domain - logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation - logical(lgt),intent(in) :: computeBaseflow ! flag to indicate if computing baseflow - integer(i4b),intent(in) :: ixMatrix ! form of the Jacobian matrix - ! input: data structures - type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers - type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU - type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU - type(var_dlength),intent(in) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables - real(rkind),intent(in) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) - ! input-output: Jacobian and its diagonal - real(rkind),intent(inout) :: dMat(:) ! diagonal of the Jacobian matrix - real(rkind),intent(out) :: aJac(:,:) ! Jacobian matrix - ! output variables - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! -------------------------------------------------------------- - ! * local variables - ! -------------------------------------------------------------- - ! indices of model state variables - integer(i4b) :: jState ! index of state within the state subset - integer(i4b) :: qState ! index of cross-derivative state variable for baseflow - integer(i4b) :: nrgState ! energy state variable - integer(i4b) :: watState ! hydrology state variable - integer(i4b) :: nState ! number of state variables - ! indices of model layers - integer(i4b) :: iLayer ! index of model layer - integer(i4b) :: jLayer ! index of model layer within the full state vector (hydrology) - integer(i4b) :: pLayer ! indices of soil layers (used for the baseflow derivatives) - ! conversion factors - real(rkind) :: convLiq2tot ! factor to convert liquid water derivative to total water derivative - ! -------------------------------------------------------------- - ! associate variables from data structures - associate(& - ! indices of model state variables - ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy air space energy state variable - ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable - ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) - ixTopNrg => indx_data%var(iLookINDEX%ixTopNrg)%dat(1) ,& ! intent(in): [i4b] index of upper-most energy state in the snow+soil subdomain - ixTopHyd => indx_data%var(iLookINDEX%ixTopHyd)%dat(1) ,& ! intent(in): [i4b] index of upper-most hydrology state in the snow+soil subdomain - ixAqWat => indx_data%var(iLookINDEX%ixAqWat)%dat(1) ,& ! intent(in): [i4b] index of water storage in the aquifer - ! vectors of indices for specfic state types within specific sub-domains IN THE FULL STATE VECTOR - ixNrgLayer => indx_data%var(iLookINDEX%ixNrgLayer)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for energy states in the snow+soil domain - ixHydLayer => indx_data%var(iLookINDEX%ixHydLayer)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for hydrology states in the snow+soil domain - ! vector of energy indices for the snow and soil domains - ! NOTE: states not in the subset are equal to integerMissing - ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the snow+soil domain - ixSnowOnlyNrg => indx_data%var(iLookINDEX%ixSnowOnlyNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the snow domain - ixSoilOnlyNrg => indx_data%var(iLookINDEX%ixSoilOnlyNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the soil domain - ! vector of hydrology indices for the snow and soil domains - ! NOTE: states not in the subset are equal to integerMissing - ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the snow+soil domain - ixSnowOnlyHyd => indx_data%var(iLookINDEX%ixSnowOnlyHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the snow domain - ixSoilOnlyHyd => indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the soil domain - ! number of state variables of a specific type - nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg )%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow+soil domain - nSnowOnlyNrg => indx_data%var(iLookINDEX%nSnowOnlyNrg )%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow domain - nSoilOnlyNrg => indx_data%var(iLookINDEX%nSoilOnlyNrg )%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the soil domain - nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the snow+soil domain - nSnowOnlyHyd => indx_data%var(iLookINDEX%nSnowOnlyHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the snow domain - nSoilOnlyHyd => indx_data%var(iLookINDEX%nSoilOnlyHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the soil domain - ! type and index of model control volume - ixHydType => indx_data%var(iLookINDEX%ixHydType)%dat ,& ! intent(in): [i4b(:)] index of the type of hydrology states in snow+soil domain - ixDomainType => indx_data%var(iLookINDEX%ixDomainType)%dat ,& ! intent(in): [i4b(:)] indices defining the type of the domain (iname_veg, iname_snow, iname_soil) - ixControlVolume => indx_data%var(iLookINDEX%ixControlVolume)%dat ,& ! intent(in): [i4b(:)] index of the control volume for specific model domains - ! mapping between states and model layers - ixMapSubset2Full => indx_data%var(iLookINDEX%ixMapSubset2Full)%dat ,& ! intent(in): [i4b(:)] list of indices in the full state vector that are in the state subset - ixMapFull2Subset => indx_data%var(iLookINDEX%ixMapFull2Subset)%dat ,& ! intent(in): [i4b(:)] list of indices in the state subset in each element of the full state vector - ! derivatives in net vegetation energy fluxes w.r.t. relevant state variables - dCanairNetFlux_dCanairTemp => deriv_data%var(iLookDERIV%dCanairNetFlux_dCanairTemp )%dat(1) ,& ! intent(in): [dp] derivative in net canopy air space flux w.r.t. canopy air temperature - dCanairNetFlux_dCanopyTemp => deriv_data%var(iLookDERIV%dCanairNetFlux_dCanopyTemp )%dat(1) ,& ! intent(in): [dp] derivative in net canopy air space flux w.r.t. canopy temperature - dCanairNetFlux_dGroundTemp => deriv_data%var(iLookDERIV%dCanairNetFlux_dGroundTemp )%dat(1) ,& ! intent(in): [dp] derivative in net canopy air space flux w.r.t. ground temperature - dCanopyNetFlux_dCanairTemp => deriv_data%var(iLookDERIV%dCanopyNetFlux_dCanairTemp )%dat(1) ,& ! intent(in): [dp] derivative in net canopy flux w.r.t. canopy air temperature - dCanopyNetFlux_dCanopyTemp => deriv_data%var(iLookDERIV%dCanopyNetFlux_dCanopyTemp )%dat(1) ,& ! intent(in): [dp] derivative in net canopy flux w.r.t. canopy temperature - dCanopyNetFlux_dGroundTemp => deriv_data%var(iLookDERIV%dCanopyNetFlux_dGroundTemp )%dat(1) ,& ! intent(in): [dp] derivative in net canopy flux w.r.t. ground temperature - dCanopyNetFlux_dCanLiq => deriv_data%var(iLookDERIV%dCanopyNetFlux_dCanLiq )%dat(1) ,& ! intent(in): [dp] derivative in net canopy fluxes w.r.t. canopy liquid water content - dGroundNetFlux_dCanairTemp => deriv_data%var(iLookDERIV%dGroundNetFlux_dCanairTemp )%dat(1) ,& ! intent(in): [dp] derivative in net ground flux w.r.t. canopy air temperature - dGroundNetFlux_dCanopyTemp => deriv_data%var(iLookDERIV%dGroundNetFlux_dCanopyTemp )%dat(1) ,& ! intent(in): [dp] derivative in net ground flux w.r.t. canopy temperature - dGroundNetFlux_dCanLiq => deriv_data%var(iLookDERIV%dGroundNetFlux_dCanLiq )%dat(1) ,& ! intent(in): [dp] derivative in net ground fluxes w.r.t. canopy liquid water content - ! derivatives in evaporative fluxes w.r.t. relevant state variables - dCanopyEvaporation_dTCanair => deriv_data%var(iLookDERIV%dCanopyEvaporation_dTCanair )%dat(1) ,& ! intent(in): [dp] derivative in canopy evaporation w.r.t. canopy air temperature - dCanopyEvaporation_dTCanopy => deriv_data%var(iLookDERIV%dCanopyEvaporation_dTCanopy )%dat(1) ,& ! intent(in): [dp] derivative in canopy evaporation w.r.t. canopy temperature - dCanopyEvaporation_dTGround => deriv_data%var(iLookDERIV%dCanopyEvaporation_dTGround )%dat(1) ,& ! intent(in): [dp] derivative in canopy evaporation w.r.t. ground temperature - dCanopyEvaporation_dCanLiq => deriv_data%var(iLookDERIV%dCanopyEvaporation_dCanLiq )%dat(1) ,& ! intent(in): [dp] derivative in canopy evaporation w.r.t. canopy liquid water content - dGroundEvaporation_dTCanair => deriv_data%var(iLookDERIV%dGroundEvaporation_dTCanair )%dat(1) ,& ! intent(in): [dp] derivative in ground evaporation w.r.t. canopy air temperature - dGroundEvaporation_dTCanopy => deriv_data%var(iLookDERIV%dGroundEvaporation_dTCanopy )%dat(1) ,& ! intent(in): [dp] derivative in ground evaporation w.r.t. canopy temperature - dGroundEvaporation_dTGround => deriv_data%var(iLookDERIV%dGroundEvaporation_dTGround )%dat(1) ,& ! intent(in): [dp] derivative in ground evaporation w.r.t. ground temperature - dGroundEvaporation_dCanLiq => deriv_data%var(iLookDERIV%dGroundEvaporation_dCanLiq )%dat(1) ,& ! intent(in): [dp] derivative in ground evaporation w.r.t. canopy liquid water content - ! derivatives in canopy water w.r.t canopy temperature - dCanLiq_dTcanopy => deriv_data%var(iLookDERIV%dCanLiq_dTcanopy )%dat(1) ,& ! intent(in): [dp] derivative of canopy liquid storage w.r.t. temperature - dTheta_dTkCanopy => deriv_data%var(iLookDERIV%dTheta_dTkCanopy )%dat(1) ,& ! intent(in): [dp] derivative of volumetric liquid water content w.r.t. temperature - ! derivatives in canopy liquid fluxes w.r.t. canopy water - scalarCanopyLiqDeriv => deriv_data%var(iLookDERIV%scalarCanopyLiqDeriv )%dat(1) ,& ! intent(in): [dp] derivative in (throughfall + drainage) w.r.t. canopy liquid water - ! derivatives in energy fluxes at the interface of snow+soil layers w.r.t. temperature in layers above and below - dNrgFlux_dTempAbove => deriv_data%var(iLookDERIV%dNrgFlux_dTempAbove )%dat ,& ! intent(in): [dp(:)] derivatives in the flux w.r.t. temperature in the layer above - dNrgFlux_dTempBelow => deriv_data%var(iLookDERIV%dNrgFlux_dTempBelow )%dat ,& ! intent(in): [dp(:)] derivatives in the flux w.r.t. temperature in the layer below - ! derivative in liquid water fluxes at the interface of snow layers w.r.t. volumetric liquid water content in the layer above - iLayerLiqFluxSnowDeriv => deriv_data%var(iLookDERIV%iLayerLiqFluxSnowDeriv )%dat ,& ! intent(in): [dp(:)] derivative in vertical liquid water flux at layer interfaces - ! derivative in liquid water fluxes for the soil domain w.r.t hydrology state variables - dVolTot_dPsi0 => deriv_data%var(iLookDERIV%dVolTot_dPsi0 )%dat ,& ! intent(in): [dp(:)] derivative in total water content w.r.t. total water matric potential - dq_dHydStateAbove => deriv_data%var(iLookDERIV%dq_dHydStateAbove )%dat ,& ! intent(in): [dp(:)] change in flux at layer interfaces w.r.t. states in the layer above - dq_dHydStateBelow => deriv_data%var(iLookDERIV%dq_dHydStateBelow )%dat ,& ! intent(in): [dp(:)] change in flux at layer interfaces w.r.t. states in the layer below - dCompress_dPsi => deriv_data%var(iLookDERIV%dCompress_dPsi )%dat ,& ! intent(in): [dp(:)] derivative in compressibility w.r.t matric head - ! derivative in baseflow flux w.r.t. aquifer storage - dBaseflow_dAquifer => deriv_data%var(iLookDERIV%dBaseflow_dAquifer )%dat(1) ,& ! intent(out): [dp(:)] erivative in baseflow flux w.r.t. aquifer storage (s-1) - ! derivative in liquid water fluxes for the soil domain w.r.t energy state variables - dq_dNrgStateAbove => deriv_data%var(iLookDERIV%dq_dNrgStateAbove )%dat ,& ! intent(in): [dp(:)] change in flux at layer interfaces w.r.t. states in the layer above - dq_dNrgStateBelow => deriv_data%var(iLookDERIV%dq_dNrgStateBelow )%dat ,& ! intent(in): [dp(:)] change in flux at layer interfaces w.r.t. states in the layer below - mLayerdTheta_dTk => deriv_data%var(iLookDERIV%mLayerdTheta_dTk )%dat ,& ! intent(in): [dp(:)] derivative of volumetric liquid water content w.r.t. temperature - ! diagnostic variables - scalarFracLiqVeg => diag_data%var(iLookDIAG%scalarFracLiqVeg)%dat(1) ,& ! intent(in): [dp] fraction of liquid water on vegetation (-) - scalarBulkVolHeatCapVeg => diag_data%var(iLookDIAG%scalarBulkVolHeatCapVeg)%dat(1) ,& ! intent(in): [dp] bulk volumetric heat capacity of vegetation (J m-3 K-1) - mLayerFracLiqSnow => diag_data%var(iLookDIAG%mLayerFracLiqSnow)%dat ,& ! intent(in): [dp(:)] fraction of liquid water in each snow layer (-) - mLayerVolHtCapBulk => diag_data%var(iLookDIAG%mLayerVolHtCapBulk)%dat ,& ! intent(in): [dp(:)] bulk volumetric heat capacity in each snow and soil layer (J m-3 K-1) - scalarSoilControl => diag_data%var(iLookDIAG%scalarSoilControl)%dat(1) ,& ! intent(in): [dp] soil control on infiltration, zero or one - ! canopy and layer depth - canopyDepth => diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1) ,& ! intent(in): [dp ] canopy depth (m) - mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat & ! intent(in): [dp(:)] depth of each layer in the snow-soil sub-domain (m) - ) ! making association with data in structures - ! -------------------------------------------------------------- - ! initialize error control - err=0; message='computJacob/' - - ! ********************************************************************************************************************************************************* - ! ********************************************************************************************************************************************************* - ! * PART 0: PRELIMINARIES (INITIALIZE JACOBIAN AND COMPUTE TIME-VARIABLE DIAGONAL TERMS) - ! ********************************************************************************************************************************************************* - ! ********************************************************************************************************************************************************* - - ! get the number of state variables - nState = size(dMat) - - ! initialize the Jacobian - ! NOTE: this needs to be done every time, since Jacobian matrix is modified in the solver - aJac(:,:) = 0._rkind ! analytical Jacobian matrix - - ! compute terms in the Jacobian for vegetation (excluding fluxes) - ! NOTE: energy for vegetation is computed *within* the iteration loop as it includes phase change - if(ixVegNrg/=integerMissing) dMat(ixVegNrg) = scalarBulkVolHeatCapVeg + LH_fus*iden_water*dTheta_dTkCanopy ! volumetric heat capacity of the vegetation (J m-3 K-1) - - ! compute additional terms for the Jacobian for the snow-soil domain (excluding fluxes) - ! NOTE: energy for snow+soil is computed *within* the iteration loop as it includes phase change - do iLayer=1,nLayers - if(ixSnowSoilNrg(iLayer)/=integerMissing) dMat(ixSnowSoilNrg(iLayer)) = mLayerVolHtCapBulk(iLayer) + LH_fus*iden_water*mLayerdTheta_dTk(iLayer) - end do - - ! compute additional terms for the Jacobian for the soil domain (excluding fluxes) - do iLayer=1,nSoil - if(ixSoilOnlyHyd(iLayer)/=integerMissing) dMat(ixSoilOnlyHyd(iLayer)) = dVolTot_dPsi0(iLayer) + dCompress_dPsi(iLayer) - end do - - ! define the form of the matrix - select case(ixMatrix) - - ! ********************************************************************************************************************************************************* - ! ********************************************************************************************************************************************************* - ! * PART 1: BAND MATRIX - ! ********************************************************************************************************************************************************* - ! ********************************************************************************************************************************************************* - case(ixBandMatrix) - - ! check - if(size(aJac,1)/=nBands .or. size(aJac,2)/=size(dMat))then - message=trim(message)//'unexpected shape of the Jacobian matrix: expect aJac(nBands,nState)' - err=20; return - end if - - ! ----- - ! * energy and liquid fluxes over vegetation... - ! --------------------------------------------- - if(computeVegFlux)then ! (derivatives only defined when vegetation protrudes over the surface) - - ! * diagonal elements for the vegetation canopy (-) - if(ixCasNrg/=integerMissing) aJac(ixDiag,ixCasNrg) = (dt/canopyDepth)*(-dCanairNetFlux_dCanairTemp) + dMat(ixCasNrg) - if(ixVegNrg/=integerMissing) aJac(ixDiag,ixVegNrg) = (dt/canopyDepth)*(-dCanopyNetFlux_dCanopyTemp) + dMat(ixVegNrg) - if(ixVegHyd/=integerMissing) aJac(ixDiag,ixVegHyd) = -scalarFracLiqVeg*(dCanopyEvaporation_dCanLiq - scalarCanopyLiqDeriv)*dt + 1._rkind ! ixVegHyd: CORRECT - - ! * cross-derivative terms w.r.t. canopy water - if(ixVegHyd/=integerMissing)then - ! cross-derivative terms w.r.t. system temperatures (kg m-2 K-1) - if(ixCasNrg/=integerMissing) aJac(ixOffDiag(ixVegHyd,ixCasNrg),ixCasNrg) = -dCanopyEvaporation_dTCanair*dt ! ixCasNrg: CORRECT - if(ixVegNrg/=integerMissing) aJac(ixOffDiag(ixVegHyd,ixVegNrg),ixVegNrg) = -dCanopyEvaporation_dTCanopy*dt + dt*scalarCanopyLiqDeriv*dCanLiq_dTcanopy ! ixVegNrg: CORRECT - if(ixTopNrg/=integerMissing) aJac(ixOffDiag(ixVegHyd,ixTopNrg),ixTopNrg) = -dCanopyEvaporation_dTGround*dt ! ixTopNrg: CORRECT - ! cross-derivative terms w.r.t. canopy water (kg-1 m2) - if(ixTopHyd/=integerMissing) aJac(ixOffDiag(ixTopHyd,ixVegHyd),ixVegHyd) = (dt/mLayerDepth(1))*(-scalarSoilControl*scalarFracLiqVeg*scalarCanopyLiqDeriv)/iden_water - ! cross-derivative terms w.r.t. canopy liquid water (J m-1 kg-1) - ! NOTE: dIce/dLiq = (1 - scalarFracLiqVeg); dIce*LH_fus/canopyDepth = J m-3; dLiq = kg m-2 - if(ixVegNrg/=integerMissing) aJac(ixOffDiag(ixVegNrg,ixVegHyd),ixVegHyd) = (dt/canopyDepth) *(-dCanopyNetFlux_dCanLiq) - (1._rkind - scalarFracLiqVeg)*LH_fus/canopyDepth ! dF/dLiq - if(ixTopNrg/=integerMissing) aJac(ixOffDiag(ixTopNrg,ixVegHyd),ixVegHyd) = (dt/mLayerDepth(1))*(-dGroundNetFlux_dCanLiq) - endif - - ! cross-derivative terms between surface hydrology and the temperature of the vegetation canopy (K-1) - if(ixVegNrg/=integerMissing)then - if(ixTopHyd/=integerMissing) aJac(ixOffDiag(ixTopHyd,ixVegNrg),ixVegNrg) = (dt/mLayerDepth(1))*(-scalarSoilControl*scalarCanopyLiqDeriv*dCanLiq_dTcanopy)/iden_water - endif - ! cross-derivative terms w.r.t. the temperature of the canopy air space (J m-3 K-1) - if(ixCasNrg/=integerMissing)then - if(ixVegNrg/=integerMissing) aJac(ixOffDiag(ixCasNrg,ixVegNrg),ixVegNrg) = (dt/canopyDepth)*(-dCanairNetFlux_dCanopyTemp) - if(ixTopNrg/=integerMissing) aJac(ixOffDiag(ixCasNrg,ixTopNrg),ixTopNrg) = (dt/canopyDepth)*(-dCanairNetFlux_dGroundTemp) +! ********************************************************************************************************** +! public subroutine computJacob: compute the Jacobian matrix +! ********************************************************************************************************** +subroutine computJacob(& + ! input: model control + in_computJacob, & ! intent(in): model control + ! input: data structures + indx_data, & ! intent(in): index data + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(in): model diagnostic variables for a local HRU + deriv_data, & ! intent(in): derivatives in model fluxes w.r.t. relevant state variables + dBaseflow_dMatric, & ! intent(in): derivative in baseflow w.r.t. matric head (s-1) + ! input-output: Jacobian and its diagonal + dMat0, & ! intent(in): diagonal of the Jacobian matrix excluding fluxes, not depending on the state vector + aJac, & ! intent(out): Jacobian matrix + ! output: error control + out_computJacob) ! intent(out): error code and error message + ! ----------------------------------------------------------------------------------------------------------------- + implicit none + ! input: model control + type(in_type_computJacob),intent(in) :: in_computJacob ! model control + ! input: data structures + type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers + type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU + type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(in) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + real(rkind),intent(in) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + ! input-output: Jacobian and its diagonal + real(rkind),intent(in) :: dMat0(:) ! diagonal of the Jacobian matrix excluding fluxes, not depending on the state vector + real(rkind),intent(out) :: aJac(:,:) ! Jacobian matrix + ! output variables + type(out_type_computJacob),intent(out) :: out_computJacob ! error control + ! -------------------------------------------------------------- + ! * local variables + ! -------------------------------------------------------------- + real(rkind),allocatable :: dMat(:) ! diagonal of the Jacobian matrix excluding fluxes, depending on the state vector + ! indices of model state variables + integer(i4b) :: nrgState ! energy state variable + integer(i4b) :: watState ! hydrology state variable + integer(i4b) :: nState ! number of state variables + ! indices of model layers + integer(i4b) :: iLayer ! index of model layer + integer(i4b) :: jLayer ! index of model layer within the full state vector (hydrology) + character(LEN=256) :: cmessage ! error message of downwind routine + logical(lgt) :: full ! flag to indicate if the matrix is full (true) or banded (false) + ! -------------------------------------------------------------- + ! associate variables from data structures + associate(& + ! model control + dt => in_computJacob % dt ,& ! intent(in): length of the time step (seconds) + nSnow => in_computJacob % nSnow ,& ! intent(in): number of snow layers + nSoil => in_computJacob % nSoil ,& ! intent(in): number of soil layers + nLayers => in_computJacob % nLayers ,& ! intent(in): total number of layers in the snow and soil domains + computeVegFlux => in_computJacob % computeVegFlux ,& ! intent(in): flag to indicate if computing fluxes over vegetation + computeBaseflow => in_computJacob % computeBaseflow ,& ! intent(in): flag to indicate if computing baseflow + ixMatrix => in_computJacob % ixMatrix ,& ! intent(in): form of the Jacobian matrix + ! indices of model state variables + ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy air space energy state variable + ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable + ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) + ! vector of energy indices for the snow and soil domains + ! NOTE: states not in the subset are equal to integerMissing + ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the snow and soil domains + ixSnowOnlyNrg => indx_data%var(iLookINDEX%ixSnowOnlyNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the snow domain + ixSoilOnlyNrg => indx_data%var(iLookINDEX%ixSoilOnlyNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the soil domain + ! vector of hydrology indices for the snow and soil domains + ! NOTE: states not in the subset are equal to integerMissing + ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the snow and soil domains + ixSnowOnlyHyd => indx_data%var(iLookINDEX%ixSnowOnlyHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the snow domain + ixSoilOnlyHyd => indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the soil domain + ! number of state variables of a specific type + nSnowOnlyNrg => indx_data%var(iLookINDEX%nSnowOnlyNrg)%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow domain + nSoilOnlyNrg => indx_data%var(iLookINDEX%nSoilOnlyNrg)%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the soil domain + nSnowOnlyHyd => indx_data%var(iLookINDEX%nSnowOnlyHyd)%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the snow domain + nSoilOnlyHyd => indx_data%var(iLookINDEX%nSoilOnlyHyd)%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the soil domain + ! derivatives in net vegetation energy fluxes w.r.t. relevant state variables + dCanopyNetFlux_dCanWat => deriv_data%var(iLookDERIV%dCanopyNetFlux_dCanWat)%dat(1) ,& ! intent(in): [dp] derivative in net canopy fluxes w.r.t. canopy total water content + ! derivatives in canopy water w.r.t canopy temperature + dTheta_dTkCanopy => deriv_data%var(iLookDERIV%dTheta_dTkCanopy)%dat(1) ,& ! intent(in): [dp] derivative in volumetric liquid water content w.r.t. temperature + dFracLiqVeg_dTkCanopy => deriv_data%var(iLookDERIV%dFracLiqVeg_dTkCanopy)%dat(1) ,& ! intent(in): [dp] derivative in fraction of (throughfall + drainage) w.r.t. temperature + ! derivatives in energy fluxes at the interface of snow+soil layers w.r.t. water state in layers above and below + dNrgFlux_dWatAbove => deriv_data%var(iLookDERIV%dNrgFlux_dWatAbove)%dat ,& ! intent(in): [dp(:)] derivatives in the flux w.r.t. water state in the layer above + dNrgFlux_dWatBelow => deriv_data%var(iLookDERIV%dNrgFlux_dWatBelow)%dat ,& ! intent(in): [dp(:)] derivatives in the flux w.r.t. water state in the layer below + ! derivative in liquid water fluxes for the soil domain w.r.t hydrology state variables + dVolTot_dPsi0 => deriv_data%var(iLookDERIV%dVolTot_dPsi0)%dat ,& ! intent(in): [dp(:)] derivatives in total water content w.r.t. total water matric potential + dCompress_dPsi => deriv_data%var(iLookDERIV%dCompress_dPsi)%dat ,& ! intent(in): [dp(:)] derivatives in compressibility w.r.t matric head + ! derivative in liquid water fluxes for the soil and snow domain w.r.t temperature + dFracLiqWat_dTk => deriv_data%var(iLookDERIV%dFracLiqWat_dTk)%dat ,& ! intent(in): [dp(:)] derivatives in fraction of liquid w.r.t. temperature + mLayerdTheta_dTk => deriv_data%var(iLookDERIV%mLayerdTheta_dTk)%dat ,& ! intent(in): [dp(:)] derivatives in volumetric liquid water content w.r.t. temperature + ! derivative in bulk heat capacity w.r.t. relevant state variables + dVolHtCapBulk_dPsi0 => deriv_data%var(iLookDERIV%dVolHtCapBulk_dPsi0)%dat ,& ! intent(in): [dp(:)] derivatives in bulk heat capacity w.r.t. matric potential + dVolHtCapBulk_dTheta => deriv_data%var(iLookDERIV%dVolHtCapBulk_dTheta)%dat ,& ! intent(in): [dp(:)] derivatives in bulk heat capacity w.r.t. volumetric water content + dVolHtCapBulk_dCanWat => deriv_data%var(iLookDERIV%dVolHtCapBulk_dCanWat)%dat(1) ,& ! intent(in): [dp ] derivative in bulk heat capacity w.r.t. volumetric water content + dVolHtCapBulk_dTk => deriv_data%var(iLookDERIV%dVolHtCapBulk_dTk)%dat ,& ! intent(in): [dp(:)] derivatives in bulk heat capacity w.r.t. temperature + dVolHtCapBulk_dTkCanopy => deriv_data%var(iLookDERIV%dVolHtCapBulk_dTkCanopy)%dat(1) ,& ! intent(in): [dp ] derivative in bulk heat capacity w.r.t. temperature + ! derivative in Cm w.r.t. relevant state variables + dCm_dPsi0 => deriv_data%var(iLookDERIV%dCm_dPsi0)%dat ,& ! intent(in): [dp(:)] derivatives in heat capacity w.r.t. matric potential (J kg-1) + dCm_dTk => deriv_data%var(iLookDERIV%dCm_dTk)%dat ,& ! intent(in): [dp(:)] derivatives in heat capacity w.r.t. temperature (J kg-1 K-2) + dCm_dTkCanopy => deriv_data%var(iLookDERIV%dCm_dTkCanopy)%dat(1) ,& ! intent(in): [dp ] derivative in heat capacity w.r.t. canopy temperature (J kg-1 K-2) + ! derivatives in time + mLayerdTemp_dt => deriv_data%var(iLookDERIV%mLayerdTemp_dt)%dat ,& ! intent(in): [dp(:)] timestep change in layer temperature + scalarCanopydTemp_dt => deriv_data%var(iLookDERIV%scalarCanopydTemp_dt)%dat(1) ,& ! intent(in): [dp ] timestep change in canopy temperature + mLayerdWat_dt => deriv_data%var(iLookDERIV%mLayerdWat_dt)%dat ,& ! intent(in): [dp(:)] timestep change in layer volumetric fraction of total water + scalarCanopydWat_dt => deriv_data%var(iLookDERIV%scalarCanopydWat_dt)%dat(1) ,& ! intent(in): [dp ] timestep change in canopy total water + ! diagnostic variables + scalarFracLiqVeg => diag_data%var(iLookDIAG%scalarFracLiqVeg)%dat(1) ,& ! intent(in): [dp] fraction of liquid water on vegetation (-) + scalarBulkVolHeatCapVeg => diag_data%var(iLookDIAG%scalarBulkVolHeatCapVeg)%dat(1) ,& ! intent(in): [dp] bulk volumetric heat capacity of vegetation (J m-3 K-1) + scalarCanopyCm => diag_data%var(iLookDIAG%scalarCanopyCm)%dat(1) ,& ! intent(in): [dp] Cm for canopy vegetation (J kg-1) + mLayerFracLiqSnow => diag_data%var(iLookDIAG%mLayerFracLiqSnow)%dat ,& ! intent(in): [dp(:)] fraction of liquid water in each snow layer (-) + mLayerVolHtCapBulk => diag_data%var(iLookDIAG%mLayerVolHtCapBulk)%dat ,& ! intent(in): [dp(:)] bulk volumetric heat capacity in each snow+soil layer (J m-3 K-1) + mLayerCm => diag_data%var(iLookDIAG%mLayerCm)%dat ,& ! intent(in): [dp(:)] Cm for each snow+soil layer (J m-3) + ! canopy and layer depth + canopyDepth => diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1) ,& ! intent(in): [dp ] canopy depth (m) + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat ,& ! intent(in): [dp(:)] depth of each layer in the snow+soil sub-domain (m) + ! output variables + err => out_computJacob % err ,& ! error code + message => out_computJacob % cmessage & ! error message + ) ! making association with data in structures + ! -------------------------------------------------------------- + ! initialize error control + err=0; message='computJacob/' + + ! ********************************************************************************************************************************************************* + ! * PART 0: PRELIMINARIES (INITIALIZE JACOBIAN AND COMPUTE TIME-VARIABLE DIAGONAL TERMS) + ! ********************************************************************************************************************************************************* + ! get the number of state variables + nState = size(dMat0) + + ! initialize the Jacobian and diagonal + ! NOTE: this needs to be done every time, since Jacobian matrix is modified in the solver and dMat is modified below + aJac(:,:) = 0._rkind ! analytical Jacobian matrix + allocate(dMat(nState)) + dMat = dMat0 ! dMat0(ixCasNrg) = Cp_air*iden_air and dMat0(Wat states) = 1.0 + + if(computeVegFlux)then + ! compute terms in the Jacobian for vegetation (excluding fluxes) + if(ixVegNrg/=integerMissing)& + dMat(ixVegNrg) = scalarBulkVolHeatCapVeg + LH_fus*iden_water*dTheta_dTkCanopy & + + dVolHtCapBulk_dTkCanopy * scalarCanopydTemp_dt & + + dCm_dTkCanopy * scalarCanopydWat_dt/canopyDepth & + + LH_fus * dFracLiqVeg_dTkCanopy * scalarCanopydWat_dt/canopyDepth endif - ! cross-derivative terms w.r.t. the temperature of the vegetation canopy (J m-3 K-1) - if(ixVegNrg/=integerMissing)then - if(ixCasNrg/=integerMissing) aJac(ixOffDiag(ixVegNrg,ixCasNrg),ixCasNrg) = (dt/canopyDepth)*(-dCanopyNetFlux_dCanairTemp) - if(ixTopNrg/=integerMissing) aJac(ixOffDiag(ixVegNrg,ixTopNrg),ixTopNrg) = (dt/canopyDepth)*(-dCanopyNetFlux_dGroundTemp) - endif - - ! cross-derivative terms w.r.t. the temperature of the surface (J m-3 K-1) - if(ixTopNrg/=integerMissing)then - if(ixCasNrg/=integerMissing) aJac(ixOffDiag(ixTopNrg,ixCasNrg),ixCasNrg) = (dt/mLayerDepth(1))*(-dGroundNetFlux_dCanairTemp) - if(ixVegNrg/=integerMissing) aJac(ixOffDiag(ixTopNrg,ixVegNrg),ixVegNrg) = (dt/mLayerDepth(1))*(-dGroundNetFlux_dCanopyTemp) - endif - - endif ! if there is a need to compute energy fluxes within vegetation - - ! ----- - ! * energy fluxes for the snow+soil domain... - ! ------------------------------------------- - if(nSnowSoilNrg>0)then - do iLayer=1,nLayers ! loop through all layers in the snow+soil domain - - ! check if the state is in the subset - if(ixSnowSoilNrg(iLayer)==integerMissing) cycle - - ! - define index within the state subset and the full state vector - jState = ixSnowSoilNrg(iLayer) ! index within the state subset - - ! - diagonal elements - aJac(ixDiag,jState) = (dt/mLayerDepth(iLayer))*(-dNrgFlux_dTempBelow(iLayer-1) + dNrgFlux_dTempAbove(iLayer)) + dMat(jState) - - ! - lower-diagonal elements - if(iLayer > 1)then - if(ixSnowSoilNrg(iLayer-1)/=integerMissing) aJac(ixOffDiag(ixSnowSoilNrg(iLayer-1),jState),jState) = (dt/mLayerDepth(iLayer-1))*( dNrgFlux_dTempBelow(iLayer-1) ) - endif - - ! - upper diagonal elements - if(iLayer < nLayers)then - if(ixSnowSoilNrg(iLayer+1)/=integerMissing) aJac(ixOffDiag(ixSnowSoilNrg(iLayer+1),jState),jState) = (dt/mLayerDepth(iLayer+1))*(-dNrgFlux_dTempAbove(iLayer ) ) - endif - - end do ! (looping through energy states in the snow+soil domain) - endif ! (if the subset includes energy state variables in the snow+soil domain) - - ! ----- - ! * liquid water fluxes for the snow domain... - ! -------------------------------------------- - if(nSnowOnlyHyd>0)then - do iLayer=1,nSnow ! loop through layers in the snow domain - - ! - check that the snow layer is desired - if(ixSnowOnlyHyd(iLayer)==integerMissing) cycle - - ! - define state indices for the current layer - watState = ixSnowOnlyHyd(iLayer) ! hydrology state index within the state subset - - ! compute factor to convert liquid water derivative to total water derivative - select case( ixHydType(iLayer) ) - case(iname_watLayer); convLiq2tot = mLayerFracLiqSnow(iLayer) - case default; convLiq2tot = 1._rkind - end select - - ! - diagonal elements - aJac(ixDiag,watState) = (dt/mLayerDepth(iLayer))*iLayerLiqFluxSnowDeriv(iLayer)*convLiq2tot + dMat(watState) - - ! - lower-diagonal elements - if(iLayer > 1)then - if(ixSnowOnlyHyd(iLayer-1)/=integerMissing) aJac(ixOffDiag(ixSnowOnlyHyd(iLayer-1),watState),watState) = 0._rkind ! sub-diagonal: no dependence on other layers - endif - - ! - upper diagonal elements - if(iLayer < nSnow)then - if(ixSnowOnlyHyd(iLayer+1)/=integerMissing) aJac(ixOffDiag(ixSnowOnlyHyd(iLayer+1),watState),watState) = -(dt/mLayerDepth(iLayer+1))*iLayerLiqFluxSnowDeriv(iLayer)*convLiq2tot ! dVol(below)/dLiq(above) -- (-) - endif - - ! - compute cross-derivative terms for energy - ! NOTE: increase in volumetric liquid water content balanced by a decrease in volumetric ice content - if(nSnowOnlyNrg>0)then - - ! (define the energy state) - nrgState = ixSnowOnlyNrg(iLayer) ! index within the full state vector - if(nrgstate/=integerMissing)then ! (energy state for the current layer is within the state subset) - - ! (cross-derivative terms for the current layer) - aJac(ixOffDiag(nrgState,watState),watState) = -(1._rkind - mLayerFracLiqSnow(iLayer))*LH_fus*iden_water ! (dF/dLiq) - aJac(ixOffDiag(watState,nrgState),nrgState) = (dt/mLayerDepth(iLayer))*iLayerLiqFluxSnowDeriv(iLayer)*mLayerdTheta_dTk(iLayer) ! (dVol/dT) - - ! (cross-derivative terms for the layer below) - if(iLayer < nSnow)then - aJac(ixOffDiag(ixSnowOnlyHyd(iLayer+1),nrgState),nrgState) = -(dt/mLayerDepth(iLayer+1))*iLayerLiqFluxSnowDeriv(iLayer)*mLayerdTheta_dTk(iLayer) ! dVol(below)/dT(above) -- K-1 - endif ! (if there is a water state in the layer below the current layer in the given state subset) - - endif ! (if the energy state for the current layer is within the state subset) - endif ! (if state variables exist for energy in snow+soil layers) - - end do ! (looping through liquid water states in the snow domain) - endif ! (if the subset includes hydrology state variables in the snow domain) + ! compute terms for the Jacobian for the snow and soil domain (excluding fluxes) + do iLayer=1,nLayers + if(ixSnowSoilNrg(iLayer)/=integerMissing)& + dMat(ixSnowSoilNrg(iLayer)) = mLayerVolHtCapBulk(iLayer) + LH_fus*iden_water*mLayerdTheta_dTk(iLayer) & + + dVolHtCapBulk_dTk(iLayer) * mLayerdTemp_dt(iLayer) & + + dCm_dTk(iLayer) * mLayerdWat_dt(iLayer) & + + LH_fus * iden_water * dFracLiqWat_dTk(iLayer) * mLayerdWat_dt(iLayer) + end do - ! ----- - ! * liquid water fluxes for the soil domain... - ! -------------------------------------------- - if(nSoilOnlyHyd>0)then + ! compute terms for the Jacobian for the soil domain (excluding fluxes) do iLayer=1,nSoil + if(ixSoilOnlyHyd(iLayer)/=integerMissing)& ! writes over dMat(ixSoilOnlyHyd(iLayer) = 1.0 + dMat(ixSoilOnlyHyd(iLayer)) = dVolTot_dPsi0(iLayer) + dCompress_dPsi(iLayer) + end do - ! - check that the soil layer is desired - if(ixSoilOnlyHyd(iLayer)==integerMissing) cycle - - ! - define state indices - watState = ixSoilOnlyHyd(iLayer) ! hydrology state index within the state subset - - ! - define indices of the soil layers - jLayer = iLayer+nSnow ! index of layer in the snow+soil vector - - ! - compute the diagonal elements - ! all terms *excluding* baseflow - aJac(ixDiag,watState) = (dt/mLayerDepth(jLayer))*(-dq_dHydStateBelow(iLayer-1) + dq_dHydStateAbove(iLayer)) + dMat(watState) - - ! - compute the lower-diagonal elements - if(iLayer > 1)then - if(ixSoilOnlyHyd(iLayer-1)/=integerMissing) aJac(ixOffDiag(ixSoilOnlyHyd(iLayer-1),watState),watState) = (dt/mLayerDepth(jLayer-1))*( dq_dHydStateBelow(iLayer-1)) - endif - - ! - compute the upper-diagonal elements - if(iLayer0 .and. nSoilOnlyNrg>0)then - do iLayer=1,nSoilOnlyHyd - - ! - check that the soil layer is desired - if(ixSoilOnlyHyd(iLayer)==integerMissing) cycle - - ! - define index of hydrology state variable within the state subset - watState = ixSoilOnlyHyd(iLayer) - - ! - define indices of the soil layers - jLayer = iLayer+nSnow ! index of layer in the snow+soil vector - - ! - define the energy state variable - nrgState = ixNrgLayer(jLayer) ! index within the full state vector - - ! only compute derivatives if the energy state for the current layer is within the state subset - if(nrgstate/=integerMissing)then - - ! - compute the Jacobian for the layer itself - aJac(ixOffDiag(watState,nrgState),nrgState) = (dt/mLayerDepth(jLayer))*(-dq_dNrgStateBelow(iLayer-1) + dq_dNrgStateAbove(iLayer)) ! dVol/dT (K-1) -- flux depends on ice impedance - - ! - include derivatives w.r.t. ground evaporation - if(nSnow==0 .and. iLayer==1)then ! upper-most soil layer - if(computeVegFlux)then - aJac(ixOffDiag(watState,ixVegHyd),ixVegHyd) = (dt/mLayerDepth(jLayer))*(-dGroundEvaporation_dCanLiq/iden_water) ! dVol/dLiq (kg m-2)-1 - aJac(ixOffDiag(watState,ixCasNrg),ixCasNrg) = (dt/mLayerDepth(jLayer))*(-dGroundEvaporation_dTCanair/iden_water) ! dVol/dT (K-1) - aJac(ixOffDiag(watState,ixVegNrg),ixVegNrg) = (dt/mLayerDepth(jLayer))*(-dGroundEvaporation_dTCanopy/iden_water) ! dVol/dT (K-1) + ! define the form of the matrix + select case(ixMatrix) + case(ixBandMatrix) + ! check + if(size(aJac,1)/=nBands .or. size(aJac,2)/=size(dMat))then + message=trim(message)//'unexpected shape of the Jacobian matrix: expect aJac(nBands,nState)' + err=20; return endif - aJac(ixOffDiag(watState,ixTopNrg),ixTopNrg) = (dt/mLayerDepth(jLayer))*(-dGroundEvaporation_dTGround/iden_water) + aJac(ixOffDiag(watState,ixTopNrg),ixTopNrg) ! dVol/dT (K-1) - endif - - ! melt-freeze: compute derivative in energy with respect to mass - if(mLayerdTheta_dTk(jLayer) > verySmall)then ! ice is present - aJac(ixOffDiag(nrgState,watState),watState) = -dVolTot_dPsi0(iLayer)*LH_fus*iden_water ! dNrg/dMat (J m-3 m-1) -- dMat changes volumetric water, and hence ice content + full = .false. + case(ixFullMatrix) + ! check + if(size(aJac,1)/=size(dMat) .or. size(aJac,2)/=size(dMat))then + message=trim(message)//'unexpected shape of the Jacobian matrix: expect aJac(nState,nState)' + err=20; return + endif + full = .true. + case default; err=20; message=trim(message)//'unable to identify option for the type of matrix'; return + end select + + ! ********************************************************************************************************************************************************* + ! * PART 1: COMPUTE CROSS-DERIVATIVE JACOBIAN TERMS + ! ********************************************************************************************************************************************************* + ! ----- + ! * cross derivatives in the vegetation... + ! --------------------------------------------- + if(computeVegFlux)then ! (derivatives only defined when vegetation protrudes over the surface) + if(ixVegHyd/=integerMissing .and. ixVegNrg/=integerMissing)& + ! NOTE: dIce/dLiq = (1 - scalarFracLiqVeg); dIce*LH_fus/canopyDepth = J m-3; dLiq = kg m-2 + aJac(ixInd(full,ixVegNrg,ixVegHyd),ixVegHyd) = (-1._rkind + scalarFracLiqVeg)*LH_fus/canopyDepth & + + dVolHtCapBulk_dCanWat * scalarCanopydTemp_dt + scalarCanopyCm/canopyDepth & + - (dt/canopyDepth) * dCanopyNetFlux_dCanWat & + + LH_fus * scalarCanopydTemp_dt * dFracLiqVeg_dTkCanopy/canopyDepth + endif ! if there is a need to compute energy fluxes within vegetation + + ! ----- + ! * cross derivatives in the snow domain... + ! ---------------------------------------- + if(nSnowOnlyHyd>0 .and. nSnowOnlyNrg>0)then + do iLayer=1,nSnow ! loop through layers in the snow domain + + ! - check that the snow layer is desired + if(ixSnowOnlyNrg(iLayer)==integerMissing) cycle + ! (define the energy state) + nrgState = ixSnowOnlyNrg(iLayer) ! index within the full state vector + ! - define state indices for the current layer + watState = ixSnowOnlyHyd(iLayer) ! hydrology state index within the state subset + + if(watState/=integerMissing)then ! (water state for the current layer is within the state subset) + ! - include derivatives of energy fluxes w.r.t water fluxes for current layer + aJac(ixInd(full,nrgState,watState),watState) = (-1._rkind + mLayerFracLiqSnow(iLayer))*LH_fus*iden_water & + + dVolHtCapBulk_dTheta(iLayer) * mLayerdTemp_dt(iLayer) + mLayerCm(iLayer) & + + (dt/mLayerDepth(iLayer))*(-dNrgFlux_dWatBelow(iLayer-1) + dNrgFlux_dWatAbove(iLayer)) & + + LH_fus*iden_water * mLayerdTemp_dt(iLayer) * dFracLiqWat_dTk(iLayer) ! (dF/dLiq) + endif ! (if the water state for the current layer is within the state subset) + + end do ! (looping through snow layers) + endif ! (if there are state variables for both water and energy in the snow domain) + + ! ----- + ! * cross derivatives in the soil domain... + ! ---------------------------------------- + if(nSoilOnlyHyd>0 .and. nSoilOnlyNrg>0)then + do iLayer=1,nSoilOnlyNrg + + ! - check that the soil layer is desired + if(ixSoilOnlyNrg(iLayer)==integerMissing) cycle + ! - define indices of the soil layers + jLayer = iLayer+nSnow ! index of layer in the snow+soil vector + ! - define the energy state variable + nrgState = ixSoilOnlyNrg(iLayer) ! index within the full state vector + ! - define index of hydrology state variable within the state subset + watState = ixSoilOnlyHyd(iLayer) + + ! only compute derivatives if the water state for the current layer is within the state subset + if(watState/=integerMissing)then + ! - include derivatives in energy fluxes w.r.t. with respect to water for current layer + aJac(ixInd(full,nrgState,watState),watState) = dVolHtCapBulk_dPsi0(iLayer) * mLayerdTemp_dt(jLayer) & + + mLayerCm(jLayer) * dVolTot_dPsi0(iLayer) + dCm_dPsi0(iLayer) * mLayerdWat_dt(jLayer) & + + (dt/mLayerDepth(jLayer))*(-dNrgFlux_dWatBelow(jLayer-1) + dNrgFlux_dWatAbove(jLayer)) + if(mLayerdTheta_dTk(jLayer) > tiny(1.0_rkind))& ! ice is present + aJac(ixInd(full,nrgState,watState),watState) = -LH_fus*iden_water * dVolTot_dPsi0(iLayer) + aJac(ixInd(full,nrgState,watState),watState) ! dNrg/dMat (J m-3 m-1) -- dMat changes volumetric water, and hence ice content + endif ! (if the water state for the current layer is within the state subset) + + end do ! (looping through energy states in the soil domain) + endif ! (if there are state variables for both water and energy in the soil domain) + + ! ********************************************************************************************************************************************************* + ! * PART 2: COMPUTE FLUX JACOBIAN TERMS + ! ********************************************************************************************************************************************************* + call fluxJacAdd(full,dt,nSnow,nSoil,nLayers,computeVegFlux,computeBaseflow,& + indx_data,prog_data,diag_data,deriv_data,dBaseflow_dMatric,& + dMat,aJac,err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + deallocate(dMat) + + ! ********************************************************************************************************************************************************* + ! * PART 3: JACOBIAN PRINT (IF DESIRED) + ! ********************************************************************************************************************************************************* + if(globalPrintFlag .or. any(isNan(aJac)))then + if(full) then + print*, '** full analytical Jacobian:' + write(*,'(a4,1x,100(i12,1x))') 'xCol', (iLayer, iLayer=min(iJac1,nState),min(iJac2,nState)) + do iLayer=min(iJac1,nState),min(iJac2,nState) + write(*,'(i4,1x,100(e12.5,1x))') iLayer, aJac(min(iJac1,nState):min(iJac2,nState),iLayer) + end do else - aJac(ixOffDiag(nrgState,watState),watState) = 0._rkind + print*, '** banded analytical Jacobian:' + write(*,'(a4,1x,100(i17,1x))') 'xCol', (iLayer, iLayer=min(iJac1,nState),min(iJac2,nState)) + do iLayer=kl+1,nBands + write(*,'(i4,1x,100(e17.10,1x))') iLayer, (aJac(iLayer,jLayer),jLayer=min(iJac1,nState),min(iJac2,nState)) + end do endif - - ! - compute lower diagonal elements - if(iLayer>1)then - if(ixSoilOnlyHyd(iLayer-1)/=integerMissing) aJac(ixOffDiag(ixSoilOnlyHyd(iLayer-1),nrgState),nrgState) = (dt/mLayerDepth(jLayer-1))*( dq_dNrgStateBelow(iLayer-1)) ! K-1 + endif + if(any(isNan(aJac)))then; message=trim(message)//'NaN in Jacobian';err=20; return; endif + + end associate ! end association to variables in the data structures + +end subroutine computJacob + +! *********************************************************************************************************** +! public subroutine to compute flux parts of the Jacobian that are shared between IDA and BE +! *********************************************************************************************************** +subroutine fluxJacAdd(& + ! input: model control + full, & ! intent(in): flag to indicate if the matrix is full (true) or banded (false) + dt, & ! intent(in): length of the time step (seconds) + nSnow, & ! intent(in): number of snow layers + nSoil, & ! intent(in): number of soil layers + nLayers, & ! intent(in): total number of layers + computeVegFlux, & ! intent(in): flag to indicate if we need to compute fluxes over vegetation + computeBaseflow, & ! intent(in): flag to indicate if we need to compute baseflow + ! input: data structures + indx_data, & ! intent(in): index data + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(in): model diagnostic variables for a local HRU + deriv_data, & ! intent(in): derivatives in model fluxes w.r.t. relevant state variables + dBaseflow_dMatric, & ! intent(in): derivative in baseflow w.r.t. matric head (s-1) + ! input-output: Jacobian and its diagonal + dMat, & ! intent(in): diagonal of the Jacobian matrix + aJac, & ! intent(inout): Jacobian matrix with flux terms added + ! output: error control + err,message) ! intent(out): error code and error message + ! ----------------------------------------------------------------------------------------------------------------- + implicit none + ! input: model control + logical(lgt),intent(in) :: full ! flag to indicate if the matrix is full (true) or banded (false) + real(rkind),intent(in) :: dt ! length of the time step (seconds) + integer(i4b),intent(in) :: nSnow ! number of snow layers + integer(i4b),intent(in) :: nSoil ! number of soil layers + integer(i4b),intent(in) :: nLayers ! total number of layers in the snow and soil domains + logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation + logical(lgt),intent(in) :: computeBaseflow ! flag to indicate if computing baseflow + ! input: data structures + type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers + type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU + type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(in) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + real(rkind),intent(in) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + ! input-output: Jacobian and its diagonal + real(rkind),intent(in) :: dMat(:) ! diagonal of the Jacobian matrix + real(rkind),intent(inout) :: aJac(:,:) ! Jacobian matrix with flux terms added + ! output variables + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! -------------------------------------------------------------- + ! * local variables + ! -------------------------------------------------------------- + ! indices of model state variables + integer(i4b) :: qState ! index of cross-derivative state variable for baseflow + integer(i4b) :: nrgState ! energy state variable + integer(i4b) :: watState ! hydrology state variable + ! indices of model layers + integer(i4b) :: iLayer,pLayer ! index of model layer + integer(i4b) :: jLayer ! index of model layer within the full state vector (hydrology) + integer(i4b) :: denseLimit ! index of the limiting dense layer + ! conversion factors + real(rkind) :: convLiq2tot ! factor to convert liquid water derivative to total water derivative + ! -------------------------------------------------------------- + ! associate variables from data structures + associate(& + ! indices of model state variables + ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy air space energy state variable + ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable + ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) + ixTopNrg => indx_data%var(iLookINDEX%ixTopNrg)%dat(1) ,& ! intent(in): [i4b] index of upper-most energy state in the snow+soil subdomain + ixTopHyd => indx_data%var(iLookINDEX%ixTopHyd)%dat(1) ,& ! intent(in): [i4b] index of upper-most hydrology state in the snow+soil subdomain + ixAqWat => indx_data%var(iLookINDEX%ixAqWat)%dat(1) ,& ! intent(in): [i4b] index of water storage in the aquifer + ! vector of energy indices for the snow and soil domains + ! NOTE: states not in the subset are equal to integerMissing + ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the snow and soil domains + ixSnowOnlyNrg => indx_data%var(iLookINDEX%ixSnowOnlyNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the snow domain + ixSoilOnlyNrg => indx_data%var(iLookINDEX%ixSoilOnlyNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the soil domain + ! vector of hydrology indices for the snow and soil domains + ! NOTE: states not in the subset are equal to integerMissing + ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the snow and soil domains + ixSnowOnlyHyd => indx_data%var(iLookINDEX%ixSnowOnlyHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the snow domain + ixSoilOnlyHyd => indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the soil domain + ! number of state variables of a specific type + nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg)%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow and soil domains + nSnowOnlyNrg => indx_data%var(iLookINDEX%nSnowOnlyNrg)%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow domain + nSoilOnlyNrg => indx_data%var(iLookINDEX%nSoilOnlyNrg)%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the soil domain + nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd)%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the snow and soil domains + nSnowOnlyHyd => indx_data%var(iLookINDEX%nSnowOnlyHyd)%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the snow domain + nSoilOnlyHyd => indx_data%var(iLookINDEX%nSoilOnlyHyd)%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the soil domain + ! type and index of model control volume + ixHydType => indx_data%var(iLookINDEX%ixHydType)%dat ,& ! intent(in): [i4b(:)] index of the type of hydrology states in snow and soil domains + ! derivatives in net vegetation energy fluxes w.r.t. relevant state variables + dCanairNetFlux_dCanairTemp => deriv_data%var(iLookDERIV%dCanairNetFlux_dCanairTemp)%dat(1) ,& ! intent(in): [dp] derivative in net canopy air space flux w.r.t. canopy air temperature + dCanairNetFlux_dCanopyTemp => deriv_data%var(iLookDERIV%dCanairNetFlux_dCanopyTemp)%dat(1) ,& ! intent(in): [dp] derivative in net canopy air space flux w.r.t. canopy temperature + dCanairNetFlux_dGroundTemp => deriv_data%var(iLookDERIV%dCanairNetFlux_dGroundTemp)%dat(1) ,& ! intent(in): [dp] derivative in net canopy air space flux w.r.t. ground temperature + dCanopyNetFlux_dCanairTemp => deriv_data%var(iLookDERIV%dCanopyNetFlux_dCanairTemp)%dat(1) ,& ! intent(in): [dp] derivative in net canopy flux w.r.t. canopy air temperature + dCanopyNetFlux_dCanopyTemp => deriv_data%var(iLookDERIV%dCanopyNetFlux_dCanopyTemp)%dat(1) ,& ! intent(in): [dp] derivative in net canopy flux w.r.t. canopy temperature + dCanopyNetFlux_dGroundTemp => deriv_data%var(iLookDERIV%dCanopyNetFlux_dGroundTemp)%dat(1) ,& ! intent(in): [dp] derivative in net canopy flux w.r.t. ground temperature + dGroundNetFlux_dCanairTemp => deriv_data%var(iLookDERIV%dGroundNetFlux_dCanairTemp)%dat(1) ,& ! intent(in): [dp] derivative in net ground flux w.r.t. canopy air temperature + dGroundNetFlux_dCanopyTemp => deriv_data%var(iLookDERIV%dGroundNetFlux_dCanopyTemp)%dat(1) ,& ! intent(in): [dp] derivative in net ground flux w.r.t. canopy temperature + dGroundNetFlux_dCanWat => deriv_data%var(iLookDERIV%dGroundNetFlux_dCanWat)%dat(1) ,& ! intent(in): [dp] derivative in net ground fluxes w.r.t. canopy total water content + ! derivatives in evaporative fluxes w.r.t. relevant state variables + dCanopyEvaporation_dTCanair => deriv_data%var(iLookDERIV%dCanopyEvaporation_dTCanair)%dat(1) ,& ! intent(in): [dp] derivative in canopy evaporation w.r.t. canopy air temperature + dCanopyEvaporation_dTCanopy => deriv_data%var(iLookDERIV%dCanopyEvaporation_dTCanopy)%dat(1) ,& ! intent(in): [dp] derivative in canopy evaporation w.r.t. canopy temperature + dCanopyEvaporation_dTGround => deriv_data%var(iLookDERIV%dCanopyEvaporation_dTGround)%dat(1) ,& ! intent(in): [dp] derivative in canopy evaporation w.r.t. ground temperature + dCanopyEvaporation_dCanWat => deriv_data%var(iLookDERIV%dCanopyEvaporation_dCanWat)%dat(1) ,& ! intent(in): [dp] derivative in canopy evaporation w.r.t. canopy total water content + dGroundEvaporation_dTCanair => deriv_data%var(iLookDERIV%dGroundEvaporation_dTCanair)%dat(1) ,& ! intent(in): [dp] derivative in ground evaporation w.r.t. canopy air temperature + dGroundEvaporation_dTCanopy => deriv_data%var(iLookDERIV%dGroundEvaporation_dTCanopy)%dat(1) ,& ! intent(in): [dp] derivative in ground evaporation w.r.t. canopy temperature + dGroundEvaporation_dTGround => deriv_data%var(iLookDERIV%dGroundEvaporation_dTGround)%dat(1) ,& ! intent(in): [dp] derivative in ground evaporation w.r.t. ground temperature + dGroundEvaporation_dCanWat => deriv_data%var(iLookDERIV%dGroundEvaporation_dCanWat)%dat(1) ,& ! intent(in): [dp] derivative in ground evaporation w.r.t. canopy total water content + ! derivatives in canopy water w.r.t canopy temperature + dCanLiq_dTcanopy => deriv_data%var(iLookDERIV%dCanLiq_dTcanopy)%dat(1) ,& ! intent(in): [dp] derivative in canopy liquid storage w.r.t. temperature + ! derivatives in canopy liquid fluxes w.r.t. canopy water + scalarCanopyLiqDeriv => deriv_data%var(iLookDERIV%scalarCanopyLiqDeriv)%dat(1) ,& ! intent(in): [dp] derivative in (throughfall + drainage) w.r.t. canopy liquid water + ! derivatives in energy fluxes at the interface of snow+soil layers w.r.t. temperature in layers above and below + dNrgFlux_dTempAbove => deriv_data%var(iLookDERIV%dNrgFlux_dTempAbove)%dat ,& ! intent(in): [dp(:)] derivatives in the flux w.r.t. temperature in the layer above + dNrgFlux_dTempBelow => deriv_data%var(iLookDERIV%dNrgFlux_dTempBelow)%dat ,& ! intent(in): [dp(:)] derivatives in the flux w.r.t. temperature in the layer below + ! derivatives in energy fluxes at the interface of snow+soil layers w.r.t. water state in layers above and below + dNrgFlux_dWatAbove => deriv_data%var(iLookDERIV%dNrgFlux_dWatAbove)%dat ,& ! intent(in): [dp(:)] derivatives in the flux w.r.t. water state in the layer above + dNrgFlux_dWatBelow => deriv_data%var(iLookDERIV%dNrgFlux_dWatBelow)%dat ,& ! intent(in): [dp(:)] derivatives in the flux w.r.t. water state in the layer below + ! derivatives in soil transpiration w.r.t. canopy state variables + mLayerdTrans_dTCanair => deriv_data%var(iLookDERIV%mLayerdTrans_dTCanair)%dat ,& ! intent(in): [dp(:)] derivatives in the soil layer transpiration flux w.r.t. canopy air temperature + mLayerdTrans_dTCanopy => deriv_data%var(iLookDERIV%mLayerdTrans_dTCanopy)%dat ,& ! intent(in): [dp(:)] derivatives in the soil layer transpiration flux w.r.t. canopy temperature + mLayerdTrans_dTGround => deriv_data%var(iLookDERIV%mLayerdTrans_dTGround)%dat ,& ! intent(in): [dp(:)] derivatives in the soil layer transpiration flux w.r.t. ground temperature + mLayerdTrans_dCanWat => deriv_data%var(iLookDERIV%mLayerdTrans_dCanWat)%dat ,& ! intent(in): [dp(:)] derivatives in the soil layer transpiration flux w.r.t. canopy total water + ! derivatives in aquifer transpiration w.r.t. canopy state variables + dAquiferTrans_dTCanair => deriv_data%var(iLookDERIV%dAquiferTrans_dTCanair)%dat(1) ,& ! intent(in): [dp] derivatives in the aquifer transpiration flux w.r.t. canopy air temperature + dAquiferTrans_dTCanopy => deriv_data%var(iLookDERIV%dAquiferTrans_dTCanopy)%dat(1) ,& ! intent(in): [dp] derivatives in the aquifer transpiration flux w.r.t. canopy temperature + dAquiferTrans_dTGround => deriv_data%var(iLookDERIV%dAquiferTrans_dTGround)%dat(1) ,& ! intent(in): [dp] derivatives in the aquifer transpiration flux w.r.t. ground temperature + dAquiferTrans_dCanWat => deriv_data%var(iLookDERIV%dAquiferTrans_dCanWat)%dat(1) ,& ! intent(in): [dp] derivatives in the aquifer transpiration flux w.r.t. canopy total water + ! derivative in liquid water fluxes at the interface of snow layers w.r.t. volumetric liquid water content in the layer above + iLayerLiqFluxSnowDeriv => deriv_data%var(iLookDERIV%iLayerLiqFluxSnowDeriv)%dat ,& ! intent(in): [dp(:)] derivative in vertical liquid water flux at layer interfaces + ! derivative in liquid water fluxes for the soil domain w.r.t hydrology state variables + dq_dHydStateAbove => deriv_data%var(iLookDERIV%dq_dHydStateAbove)%dat ,& ! intent(in): [dp(:)] derivatives in flux at layer interfaces w.r.t. states in the layer above + dq_dHydStateBelow => deriv_data%var(iLookDERIV%dq_dHydStateBelow)%dat ,& ! intent(in): [dp(:)] derivatives in flux at layer interfaces w.r.t. states in the layer below + dq_dHydStateLayerSurfVec => deriv_data%var(iLookDERIV%dq_dHydStateLayerSurfVec)%dat ,& ! intent(in): [dp(:)] derivatives in the flux in soil surface interface w.r.t. state variables in layers + ! derivative in baseflow flux w.r.t. aquifer storage + dBaseflow_dAquifer => deriv_data%var(iLookDERIV%dBaseflow_dAquifer)%dat(1) ,& ! intent(in): [dp(:)] derivative in baseflow flux w.r.t. aquifer storage (s-1) + ! derivative in liquid water fluxes for the soil domain w.r.t energy state variables + dq_dNrgStateAbove => deriv_data%var(iLookDERIV%dq_dNrgStateAbove)%dat ,& ! intent(in): [dp(:)] derivatives in flux at layer interfaces w.r.t. states in the layer above + dq_dNrgStateBelow => deriv_data%var(iLookDERIV%dq_dNrgStateBelow)%dat ,& ! intent(in): [dp(:)] derivatives in flux at layer interfaces w.r.t. states in the layer below + dq_dNrgStateLayerSurfVec => deriv_data%var(iLookDERIV%dq_dNrgStateLayerSurfVec)%dat ,& ! intent(in): [dp(:)] derivatives in the flux in soil surface interface w.r.t. state variables in layers + ! derivative in liquid water fluxes for the soil and snow domain w.r.t temperature + mLayerdTheta_dTk => deriv_data%var(iLookDERIV%mLayerdTheta_dTk)%dat ,& ! intent(in): [dp(:)] derivative in volumetric liquid water content w.r.t. temperature + ! diagnostic variables + scalarFracLiqVeg => diag_data%var(iLookDIAG%scalarFracLiqVeg)%dat(1) ,& ! intent(in): [dp] fraction of liquid water on vegetation (-) + mLayerFracLiqSnow => diag_data%var(iLookDIAG%mLayerFracLiqSnow)%dat ,& ! intent(in): [dp(:)] fraction of liquid water in each snow layer (-) + scalarSoilControl => diag_data%var(iLookDIAG%scalarSoilControl)%dat(1) ,& ! intent(in): [dp] soil control on infiltration for derivative + mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat ,& ! intent(in): [dp(:)] volumetric fraction of ice in each layer start of step (-) + ! canopy and layer depth + canopyDepth => diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1) ,& ! intent(in): [dp ] canopy depth (m) + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat & ! intent(in): [dp(:)] depth of each layer in the snow+soil sub-domain (m) + ) ! making association with data in structures + ! -------------------------------------------------------------- + ! initialize error control + err=0; message='fluxJacAdd/' + ! ----- + ! * energy and liquid fluxes over vegetation... + ! --------------------------------------------- + if(computeVegFlux)then ! (derivatives only defined when vegetation protrudes over the surface) + + ! * energy fluxes with the canopy water + if(ixVegHyd/=integerMissing)then + + ! * cross-derivative terms w.r.t. system temperatures (kg m-2 K-1) + if(ixCasNrg/=integerMissing) aJac(ixInd(full,ixVegHyd,ixCasNrg),ixCasNrg) = -dCanopyEvaporation_dTCanair*dt + ! dt*scalarCanopyLiqDeriv*dCanLiq_dTcanopy is the derivative in throughfall and canopy drainage with canopy temperature + if(ixVegNrg/=integerMissing) aJac(ixInd(full,ixVegHyd,ixVegNrg),ixVegNrg) = -dCanopyEvaporation_dTCanopy*dt + dt*scalarCanopyLiqDeriv*dCanLiq_dTcanopy + ! * liquid water fluxes for vegetation canopy (-), dt*scalarFracLiqVeg*scalarCanopyLiqDeriv is the derivative in throughfall and canopy drainage with canopy water + aJac(ixInd(full,ixVegHyd,ixVegHyd),ixVegHyd) = -scalarFracLiqVeg*(dCanopyEvaporation_dCanWat - scalarCanopyLiqDeriv)*dt + dMat(ixVegHyd) + if(ixTopNrg/=integerMissing) aJac(ixInd(full,ixVegHyd,ixTopNrg),ixTopNrg) = -dCanopyEvaporation_dTGround*dt + + ! * cross-derivative terms w.r.t. canopy water (kg-1 m2) + if(nSnow>0)then + if(ixTopHyd/=integerMissing) aJac(ixInd(full,ixTopHyd,ixVegHyd),ixVegHyd) = (dt/mLayerDepth(1))*(-scalarFracLiqVeg*scalarCanopyLiqDeriv)/iden_water + else + if(ixTopHyd/=integerMissing) aJac(ixInd(full,ixTopHyd,ixVegHyd),ixVegHyd) = (dt/mLayerDepth(1))*(-scalarSoilControl*scalarFracLiqVeg*scalarCanopyLiqDeriv)/iden_water + endif + + ! * cross-derivative terms w.r.t. canopy liquid water (J m-1 kg-1) + if(ixTopNrg/=integerMissing) aJac(ixInd(full,ixTopNrg,ixVegHyd),ixVegHyd) = (dt/mLayerDepth(1))*(-dGroundNetFlux_dCanWat) endif - ! compute upper-diagonal elements - if(iLayer0)then + if(ixTopHyd/=integerMissing) aJac(ixInd(full,ixTopHyd,ixVegNrg),ixVegNrg) = (dt/mLayerDepth(1))*(-scalarCanopyLiqDeriv*dCanLiq_dTcanopy)/iden_water + else + if(ixTopHyd/=integerMissing) aJac(ixInd(full,ixTopHyd,ixVegNrg),ixVegNrg) = (dt/mLayerDepth(1))*(-scalarSoilControl*scalarCanopyLiqDeriv*dCanLiq_dTcanopy)/iden_water + endif endif - endif ! (if the energy state for the current layer is within the state subset) - - end do ! (looping through soil layers) - endif ! (if there are state variables for both water and energy in the soil domain) - - if(globalPrintFlag)then - print*, '** banded analytical Jacobian:' - write(*,'(a4,1x,100(i17,1x))') 'xCol', (iLayer, iLayer=min(iJac1,nState),min(iJac2,nState)) - do iLayer=kl+1,nBands - write(*,'(i4,1x,100(e17.10,1x))') iLayer, (aJac(iLayer,jLayer),jLayer=min(iJac1,nState),min(iJac2,nState)) - end do - end if - !print*, 'PAUSE: banded analytical Jacobian'; read(*,*) - - ! ********************************************************************************************************************************************************* - ! ********************************************************************************************************************************************************* - ! * PART 2: FULL MATRIX - ! ********************************************************************************************************************************************************* - ! ********************************************************************************************************************************************************* - case(ixFullMatrix) - - ! check - if(size(aJac,1)/=size(dMat) .or. size(aJac,2)/=size(dMat))then - message=trim(message)//'unexpected shape of the Jacobian matrix: expect aJac(nState,nState)' - err=20; return - end if - - ! ----- - ! * energy and liquid fluxes over vegetation... - ! --------------------------------------------- - if(computeVegFlux)then ! (derivatives only defined when vegetation protrudes over the surface) - - ! * liquid water fluxes for vegetation canopy (-) - if(ixVegHyd/=integerMissing) aJac(ixVegHyd,ixVegHyd) = -scalarFracLiqVeg*(dCanopyEvaporation_dCanLiq - scalarCanopyLiqDeriv)*dt + 1._rkind - - ! * cross-derivative terms for canopy water - if(ixVegHyd/=integerMissing)then - ! cross-derivative terms w.r.t. system temperatures (kg m-2 K-1) - if(ixCasNrg/=integerMissing) aJac(ixVegHyd,ixCasNrg) = -dCanopyEvaporation_dTCanair*dt - if(ixVegNrg/=integerMissing) aJac(ixVegHyd,ixVegNrg) = -dCanopyEvaporation_dTCanopy*dt + dt*scalarCanopyLiqDeriv*dCanLiq_dTcanopy - if(ixTopNrg/=integerMissing) aJac(ixVegHyd,ixTopNrg) = -dCanopyEvaporation_dTGround*dt - ! cross-derivative terms w.r.t. canopy water (kg-1 m2) - if(ixTopHyd/=integerMissing) aJac(ixTopHyd,ixVegHyd) = (dt/mLayerDepth(1))*(-scalarSoilControl*scalarFracLiqVeg*scalarCanopyLiqDeriv)/iden_water - ! cross-derivative terms w.r.t. canopy liquid water (J m-1 kg-1) - ! NOTE: dIce/dLiq = (1 - scalarFracLiqVeg); dIce*LH_fus/canopyDepth = J m-3; dLiq = kg m-2 - if(ixVegNrg/=integerMissing) aJac(ixVegNrg,ixVegHyd) = (dt/canopyDepth) *(-dCanopyNetFlux_dCanLiq) - (1._rkind - scalarFracLiqVeg)*LH_fus/canopyDepth ! dF/dLiq - if(ixTopNrg/=integerMissing) aJac(ixTopNrg,ixVegHyd) = (dt/mLayerDepth(1))*(-dGroundNetFlux_dCanLiq) - endif - - ! cross-derivative terms w.r.t. canopy temperature (K-1) - if(ixVegNrg/=integerMissing)then - if(ixTopHyd/=integerMissing) aJac(ixTopHyd,ixVegNrg) = (dt/mLayerDepth(1))*(-scalarSoilControl*scalarCanopyLiqDeriv*dCanLiq_dTcanopy)/iden_water - endif - - ! energy fluxes with the canopy air space (J m-3 K-1) - if(ixCasNrg/=integerMissing)then - aJac(ixCasNrg,ixCasNrg) = (dt/canopyDepth)*(-dCanairNetFlux_dCanairTemp) + dMat(ixCasNrg) - if(ixVegNrg/=integerMissing) aJac(ixCasNrg,ixVegNrg) = (dt/canopyDepth)*(-dCanairNetFlux_dCanopyTemp) - if(ixTopNrg/=integerMissing) aJac(ixCasNrg,ixTopNrg) = (dt/canopyDepth)*(-dCanairNetFlux_dGroundTemp) - endif - - ! energy fluxes with the vegetation canopy (J m-3 K-1) - if(ixVegNrg/=integerMissing)then - if(ixCasNrg/=integerMissing) aJac(ixVegNrg,ixCasNrg) = (dt/canopyDepth)*(-dCanopyNetFlux_dCanairTemp) - aJac(ixVegNrg,ixVegNrg) = (dt/canopyDepth)*(-dCanopyNetFlux_dCanopyTemp) + dMat(ixVegNrg) - if(ixTopNrg/=integerMissing) aJac(ixVegNrg,ixTopNrg) = (dt/canopyDepth)*(-dCanopyNetFlux_dGroundTemp) - endif - - ! energy fluxes with the surface (J m-3 K-1) - if(ixTopNrg/=integerMissing)then - if(ixCasNrg/=integerMissing) aJac(ixTopNrg,ixCasNrg) = (dt/mLayerDepth(1))*(-dGroundNetFlux_dCanairTemp) - if(ixVegNrg/=integerMissing) aJac(ixTopNrg,ixVegNrg) = (dt/mLayerDepth(1))*(-dGroundNetFlux_dCanopyTemp) - endif - - endif ! if there is a need to compute energy fluxes within vegetation - - ! ----- - ! * energy fluxes for the snow+soil domain... - ! ------------------------------------------- - if(nSnowSoilNrg>0)then - do iLayer=1,nLayers ! loop through all layers in the snow+soil domain - - ! check if the state is in the subset - if(ixSnowSoilNrg(iLayer)==integerMissing) cycle - - ! - define index within the state subset and the full state vector - jState = ixSnowSoilNrg(iLayer) ! index within the state subset - - ! - diagonal elements - aJac(jState,jState) = (dt/mLayerDepth(iLayer))*(-dNrgFlux_dTempBelow(iLayer-1) + dNrgFlux_dTempAbove(iLayer)) + dMat(jState) - - ! - lower-diagonal elements - if(iLayer > 1)then - if(ixSnowSoilNrg(iLayer-1)/=integerMissing) aJac(ixSnowSoilNrg(iLayer-1),jState) = (dt/mLayerDepth(iLayer-1))*( dNrgFlux_dTempBelow(iLayer-1) ) - endif - - ! - upper diagonal elements - if(iLayer < nLayers)then - if(ixSnowSoilNrg(iLayer+1)/=integerMissing) aJac(ixSnowSoilNrg(iLayer+1),jState) = (dt/mLayerDepth(iLayer+1))*(-dNrgFlux_dTempAbove(iLayer ) ) - endif - - end do ! (looping through energy states in the snow+soil domain) - endif ! (if the subset includes energy state variables in the snow+soil domain) - - ! ----- - ! * liquid water fluxes for the snow domain... - ! -------------------------------------------- - if(nSnowOnlyHyd>0)then - do iLayer=1,nSnow ! loop through layers in the snow domain - - ! - check that the snow layer is desired - if(ixSnowOnlyHyd(iLayer)==integerMissing) cycle - - ! - define state indices for the current layer - watState = ixSnowOnlyHyd(iLayer) ! hydrology state index within the state subset - - ! compute factor to convert liquid water derivative to total water derivative - select case( ixHydType(iLayer) ) - case(iname_watLayer); convLiq2tot = mLayerFracLiqSnow(iLayer) - case default; convLiq2tot = 1._rkind - end select - - ! - diagonal elements - aJac(watState,watState) = (dt/mLayerDepth(iLayer))*iLayerLiqFluxSnowDeriv(iLayer)*convLiq2tot + dMat(watState) - - ! - lower-diagonal elements - if(iLayer > 1)then - if(ixSnowOnlyHyd(iLayer-1)/=integerMissing) aJac(ixSnowOnlyHyd(iLayer-1),watState) = 0._rkind ! sub-diagonal: no dependence on other layers - endif - - ! - upper diagonal elements - if(iLayer < nSnow)then - if(ixSnowOnlyHyd(iLayer+1)/=integerMissing) aJac(ixSnowOnlyHyd(iLayer+1),watState) = -(dt/mLayerDepth(iLayer+1))*iLayerLiqFluxSnowDeriv(iLayer)*convLiq2tot ! dVol(below)/dLiq(above) -- (-) - endif - - ! - compute cross-derivative terms for energy - ! NOTE: increase in volumetric liquid water content balanced by a decrease in volumetric ice content - if(nSnowOnlyNrg>0)then - - ! (define the energy state) - nrgState = ixSnowOnlyNrg(iLayer) ! index within the full state vector - if(nrgstate/=integerMissing)then ! (energy state for the current layer is within the state subset) - - ! (cross-derivative terms for the current layer) - aJac(nrgState,watState) = -(1._rkind - mLayerFracLiqSnow(iLayer))*LH_fus*iden_water ! (dF/dLiq) - aJac(watState,nrgState) = (dt/mLayerDepth(iLayer))*iLayerLiqFluxSnowDeriv(iLayer)*mLayerdTheta_dTk(iLayer) ! (dVol/dT) - - ! (cross-derivative terms for the layer below) - if(iLayer < nSnow)then - aJac(ixSnowOnlyHyd(iLayer+1),nrgState) = -(dt/mLayerDepth(iLayer+1))*iLayerLiqFluxSnowDeriv(iLayer)*mLayerdTheta_dTk(iLayer) ! dVol(below)/dT(above) -- K-1 - endif ! (if there is a water state in the layer below the current layer in the given state subset) - - endif ! (if the energy state for the current layer is within the state subset) - endif ! (if state variables exist for energy in snow+soil layers) - - end do ! (looping through liquid water states in the snow domain) - endif ! (if the subset includes hydrology state variables in the snow domain) - - ! ----- - ! * liquid water fluxes for the soil domain... - ! -------------------------------------------- - if(nSoilOnlyHyd>0)then - - do iLayer=1,nSoil - - ! - check that the soil layer is desired - if(ixSoilOnlyHyd(iLayer)==integerMissing) cycle - - ! - define state indices - watState = ixSoilOnlyHyd(iLayer) ! hydrology state index within the state subset - - ! - define indices of the soil layers - jLayer = iLayer+nSnow ! index of layer in the snow+soil vector - - ! - compute the diagonal elements - ! all terms *excluding* baseflow - aJac(watState,watState) = (dt/mLayerDepth(jLayer))*(-dq_dHydStateBelow(iLayer-1) + dq_dHydStateAbove(iLayer)) + dMat(watState) - - ! - compute the lower-diagonal elements - if(iLayer > 1)then - if(ixSoilOnlyHyd(iLayer-1)/=integerMissing) aJac(ixSoilOnlyHyd(iLayer-1),watState) = (dt/mLayerDepth(jLayer-1))*( dq_dHydStateBelow(iLayer-1)) - endif - - ! - compute the upper-diagonal elements - if(iLayer0 .and. nSoilOnlyNrg>0)then - do iLayer=1,nSoilOnlyHyd - - ! - check that the soil layer is desired - if(ixSoilOnlyHyd(iLayer)==integerMissing) cycle - - ! - define index of hydrology state variable within the state subset - watState = ixSoilOnlyHyd(iLayer) - - ! - define indices of the soil layers - jLayer = iLayer+nSnow ! index of layer in the snow+soil vector - - ! - define the energy state variable - nrgState = ixNrgLayer(jLayer) ! index within the full state vector - - ! only compute derivatives if the energy state for the current layer is within the state subset - if(nrgstate/=integerMissing)then - - ! - compute the Jacobian for the layer itself - aJac(watState,nrgState) = (dt/mLayerDepth(jLayer))*(-dq_dNrgStateBelow(iLayer-1) + dq_dNrgStateAbove(iLayer)) ! dVol/dT (K-1) -- flux depends on ice impedance - - ! - include derivatives w.r.t. ground evaporation - if(nSnow==0 .and. iLayer==1)then ! upper-most soil layer - if(computeVegFlux)then - aJac(watState,ixVegHyd) = (dt/mLayerDepth(jLayer))*(-dGroundEvaporation_dCanLiq/iden_water) ! dVol/dLiq (kg m-2)-1 - aJac(watState,ixCasNrg) = (dt/mLayerDepth(jLayer))*(-dGroundEvaporation_dTCanair/iden_water) ! dVol/dT (K-1) - aJac(watState,ixVegNrg) = (dt/mLayerDepth(jLayer))*(-dGroundEvaporation_dTCanopy/iden_water) ! dVol/dT (K-1) - endif - aJac(watState,ixTopNrg) = (dt/mLayerDepth(jLayer))*(-dGroundEvaporation_dTGround/iden_water) + aJac(watState,ixTopNrg) ! dVol/dT (K-1) + ! * energy fluxes with the canopy air space (J m-3 K-1) + if(ixCasNrg/=integerMissing)then + aJac(ixInd(full,ixCasNrg,ixCasNrg),ixCasNrg) = (dt/canopyDepth)*(-dCanairNetFlux_dCanairTemp) + dMat(ixCasNrg) + if(ixVegNrg/=integerMissing) aJac(ixInd(full,ixCasNrg,ixVegNrg),ixVegNrg) = (dt/canopyDepth)*(-dCanairNetFlux_dCanopyTemp) + if(ixTopNrg/=integerMissing) aJac(ixInd(full,ixCasNrg,ixTopNrg),ixTopNrg) = (dt/canopyDepth)*(-dCanairNetFlux_dGroundTemp) endif - ! melt-freeze: compute derivative in energy with respect to mass - if(mLayerdTheta_dTk(jLayer) > verySmall)then ! ice is present - aJac(nrgState,watState) = -dVolTot_dPsi0(iLayer)*LH_fus*iden_water ! dNrg/dMat (J m-3 m-1) -- dMat changes volumetric water, and hence ice content - else - aJac(nrgState,watState) = 0._rkind + ! * energy fluxes with the vegetation canopy (J m-3 K-1) + if(ixVegNrg/=integerMissing)then + if(ixCasNrg/=integerMissing) aJac(ixInd(full,ixVegNrg,ixCasNrg),ixCasNrg) = (dt/canopyDepth)*(-dCanopyNetFlux_dCanairTemp) + aJac(ixInd(full,ixVegNrg,ixVegNrg),ixVegNrg) = (dt/canopyDepth)*(-dCanopyNetFlux_dCanopyTemp) + dMat(ixVegNrg) + if(ixTopNrg/=integerMissing) aJac(ixInd(full,ixVegNrg,ixTopNrg),ixTopNrg) = (dt/canopyDepth)*(-dCanopyNetFlux_dGroundTemp) endif - ! - compute lower diagonal elements - if(iLayer>1)then - if(ixSoilOnlyHyd(iLayer-1)/=integerMissing) aJac(ixSoilOnlyHyd(iLayer-1),nrgState) = (dt/mLayerDepth(jLayer-1))*( dq_dNrgStateBelow(iLayer-1)) ! K-1 + ! * energy fluxes with the surface (J m-3 K-1) + if(ixTopNrg/=integerMissing)then + if(ixCasNrg/=integerMissing) aJac(ixInd(full,ixTopNrg,ixCasNrg),ixCasNrg) = (dt/mLayerDepth(1))*(-dGroundNetFlux_dCanairTemp) + if(ixVegNrg/=integerMissing) aJac(ixInd(full,ixTopNrg,ixVegNrg),ixVegNrg) = (dt/mLayerDepth(1))*(-dGroundNetFlux_dCanopyTemp) endif - ! compute upper-diagonal elements - if(iLayer0)then + do iLayer=1,nLayers ! loop through all layers in the snow and soil domains + + ! check if the state is in the subset + if(ixSnowSoilNrg(iLayer)==integerMissing) cycle + ! - define index within the state subset and the full state vector + nrgState = ixSnowSoilNrg(iLayer) ! index within the state subset + + ! - diagonal elements + aJac(ixInd(full,nrgState,nrgState),nrgState) = (dt/mLayerDepth(iLayer))*(-dNrgFlux_dTempBelow(iLayer-1) + dNrgFlux_dTempAbove(iLayer)) + dMat(nrgState) + + ! - super-diagonal elements + if(iLayer>1)then + if(ixSnowSoilNrg(iLayer-1)/=integerMissing) aJac(ixInd(full,ixSnowSoilNrg(iLayer-1),nrgState),nrgState) = (dt/mLayerDepth(iLayer-1))*( dNrgFlux_dTempBelow(iLayer-1) ) + endif + + ! - sub-diagonal elements + if(iLayer0)then + do iLayer=1,nSnow ! loop through layers in the snow domain + + ! - check that the snow layer is desired + if(ixSnowOnlyHyd(iLayer)==integerMissing) cycle + ! - define state indices for the current layer + watState = ixSnowOnlyHyd(iLayer) ! hydrology state index within the state subset + + ! compute factor to convert liquid water derivative to total water derivative + select case( ixHydType(iLayer) ) + case(iname_watLayer); convLiq2tot = mLayerFracLiqSnow(iLayer) + case default; convLiq2tot = 1._rkind + end select + + ! - diagonal elements, water does not move upwards in snow + aJac(ixInd(full,watState,watState),watState) = (dt/mLayerDepth(iLayer))*iLayerLiqFluxSnowDeriv(iLayer)*convLiq2tot + dMat(watState) + + ! - sub-diagonal elements for snow, sub-diagonal only (water does not move upwards in snow) + if(iLayer0 .and. nSnowOnlyNrg>0)then + do iLayer=1,nSnow ! loop through layers in the snow domain + + ! (define the energy state) + nrgState = ixSnowOnlyNrg(iLayer) ! index within the full state vector + ! - define state indices for the current layer + watState = ixSnowOnlyHyd(iLayer) ! hydrology state index within the state subset + + if(nrgState/=integerMissing .and. watState/=integerMissing)then + ! - include derivatives of water fluxes w.r.t energy fluxes for current layer, water does not move upwards in snow + aJac(ixInd(full,watState,nrgState),nrgState) = (dt/mLayerDepth(iLayer))*iLayerLiqFluxSnowDeriv(iLayer)*mLayerdTheta_dTk(iLayer) ! (dVol/dT) + endif ! (if both the energy and water states for the current layer are within the state subset) + + if(watState/=integerMissing)then + ! - include derivatives of heat capacity w.r.t water for layer above + if(iLayer>1)then ! have layer above + if(ixSnowSoilNrg(iLayer-1)/=integerMissing) aJac(ixInd(full,ixSnowSoilNrg(iLayer-1),watState),watState) = (dt/mLayerDepth(iLayer-1))*( dNrgFlux_dWatBelow(iLayer-1) ) + endif + + ! - include derivatives of heat capacity w.r.t water for layer below + if(iLayer0))then ! have layer below + if(ixSnowSoilNrg(iLayer+1)/=integerMissing) aJac(ixInd(full,ixSnowSoilNrg(iLayer+1),watState),watState) = (dt/mLayerDepth(iLayer+1))*(-dNrgFlux_dWatAbove(iLayer) ) + endif + endif ! (if the water state for the current layer is within the state subset) + + if(nrgState/=integerMissing)then + ! - sub-diagonal elements for snow, sub-diagonal only (water does not move upwards in snow) + if(iLayer0)then + do iLayer=1,nSoil + + ! - check that the soil layer is desired + if(ixSoilOnlyHyd(iLayer)==integerMissing) cycle + ! - define state indices + watState = ixSoilOnlyHyd(iLayer) ! hydrology state index within the state subset + ! - define indices of the soil layers + jLayer = iLayer+nSnow ! index of layer in the snow+soil vector + ! - compute the diagonal elements + ! all terms *excluding* baseflow + aJac(ixInd(full,watState,watState),watState) = (dt/mLayerDepth(jLayer))*(-dq_dHydStateBelow(iLayer-1) + dq_dHydStateAbove(iLayer)) + dMat(watState) + + ! - compute the super-diagonal elements + if(iLayer>1)then + if(ixSoilOnlyHyd(iLayer-1)/=integerMissing) aJac(ixInd(full,ixSoilOnlyHyd(iLayer-1),watState),watState) = (dt/mLayerDepth(jLayer-1))*( dq_dHydStateBelow(iLayer-1)) + endif + + ! - compute the sub-diagonal elements + if(iLayeriLayer .and. qstate - watState <= ku) .or. full) & + aJac(ixInd(full,watState,qState),qState) = (dt/mLayerDepth(jLayer))*dBaseflow_dMatric(iLayer,pLayer) + aJac(ixInd(full,watState,qState),qState) + endif + end do + endif ! (if computed baseflow) + + ! - include derivatives for surface infiltration below surface + if(ixSoilOnlyHyd(1)/=integerMissing .and. all(dq_dHydStateLayerSurfVec/=realMissing))then + if(watState - ixSoilOnlyHyd(1) <= ku .or. full) & + aJac(ixInd(full,ixSoilOnlyHyd(1),watState),watState) = -(dt/mLayerDepth(nSnow+1))*dq_dHydStateLayerSurfVec(iLayer) + aJac(ixInd(full,ixSoilOnlyHyd(1),watState),watState) + endif + end do ! (looping through hydrology states in the soil domain) + + ! - include derivatives for surface infiltration above surface if there is snow (vegetation handled already) + if(nSnow>0 .and. ixSoilOnlyHyd(1)/=integerMissing .and. all(dq_dHydStateLayerSurfVec/=realMissing))then ! have snow above first soil layer + denseLimit = nSnow ! if passed through a too dense snowpack, need to find top dense layer (bottom layer always included, dense or not) + do pLayer=nSnow,1,-1 + if(mLayerVolFracIce(pLayer)<=maxVolIceContent) exit + denseLimit = pLayer + end do + do pLayer=denseLimit,nSnow + if(ixSnowOnlyHyd(pLayer)/=integerMissing)then + ! compute factor to convert liquid water derivative to total water derivative + select case( ixHydType(pLayer) ) + case(iname_watLayer); convLiq2tot = mLayerFracLiqSnow(pLayer) + case default; convLiq2tot = 1._rkind + end select + if(ixSoilOnlyHyd(1) - ixSnowOnlyHyd(pLayer) <= kl .or. full) & + aJac(ixInd(full,ixSoilOnlyHyd(1),ixSnowOnlyHyd(pLayer)),ixSnowOnlyHyd(pLayer)) = -(dt/mLayerDepth(nSnow+1))*scalarSoilControl*iLayerLiqFluxSnowDeriv(pLayer)*convLiq2tot + aJac(ixInd(full,ixSoilOnlyHyd(1),ixSnowOnlyHyd(pLayer)),ixSnowOnlyHyd(pLayer)) + endif + end do ! (looping through snow layers above soil until non-dense layer) + endif ! (if snow present above soil) + endif ! (if the subset includes hydrology state variables in the soil domain) + + ! ----- + ! * liquid water fluxes for the aquifer... + ! ---------------------------------------- + if(ixAqWat/=integerMissing) then + aJac(ixInd(full,ixAqWat,ixAqWat),ixAqWat) = -dBaseflow_dAquifer*dt + dMat(ixAqWat) + if(ixSoilOnlyNrg(nSoil)/=integerMissing) aJac(ixInd(full,ixAqWat,ixSoilOnlyNrg(nSoil)),ixSoilOnlyNrg(nSoil)) = -dq_dNrgStateAbove(nSoil)*dt ! dAquiferRecharge_dTk = d_iLayerLiqFluxSoil(nSoil)_dTk + if(ixSoilOnlyHyd(nSoil)/=integerMissing) aJac(ixInd(full,ixAqWat,ixSoilOnlyHyd(nSoil)),ixSoilOnlyHyd(nSoil)) = -dq_dHydStateAbove(nSoil)*dt ! dAquiferRecharge_dWat = d_iLayerLiqFluxSoil(nSoil)_dWat + ! - include derivatives of energy and water w.r.t soil transpiration (dependent on canopy transpiration) + if(computeVegFlux)then + if(ixCasNrg/=integerMissing)then + if(ixAqWat-ixCasNrg <= kl .or. full) aJac(ixInd(full,ixAqWat,ixCasNrg),ixCasNrg) = -dAquiferTrans_dTCanair*dt ! dVol/dT (K-1) + endif + if(ixVegNrg/=integerMissing)then + if(ixAqWat-ixVegNrg <= kl .or. full) aJac(ixInd(full,ixAqWat,ixVegNrg),ixVegNrg) = -dAquiferTrans_dTCanopy*dt ! dVol/dT (K-1) + endif + if(ixVegHyd/=integerMissing)then + if(ixAqWat-ixVegHyd <= kl .or. full) aJac(ixInd(full,ixAqWat,ixVegHyd),ixVegHyd) = -dAquiferTrans_dCanWat*dt ! dVol/dLiq (kg m-2)-1 + endif + if(ixTopNrg/=integerMissing)then + if(ixAqWat-ixTopNrg <= kl .or. full) aJac(ixInd(full,ixAqWat,ixTopNrg),ixTopNrg) = -dAquiferTrans_dTGround*dt ! dVol/dT (K-1) + endif endif + endif ! (if aquifer water state is in the subset) + + ! ----- + ! * cross derivatives in the soil domain... + ! ---------------------------------------- + if(nSoilOnlyHyd>0 .and. nSoilOnlyNrg>0)then + do iLayer=1,nSoilOnlyNrg + + ! - define indices of the soil layers + jLayer = iLayer+nSnow ! index of layer in the snow+soil vector + ! - define the energy state variable + nrgState = ixSoilOnlyNrg(iLayer) ! index within the full state vector + ! - define index of hydrology state variable within the state subset + watState = ixSoilOnlyHyd(iLayer) + + if(watState/=integerMissing .and. nrgState/=integerMissing)then + ! - include derivatives in liquid water fluxes w.r.t. temperature for current layer + aJac(ixInd(full,watState,nrgState),nrgState) = (dt/mLayerDepth(jLayer))*(-dq_dNrgStateBelow(iLayer-1) + dq_dNrgStateAbove(iLayer)) ! dVol/dT (K-1) -- flux depends on ice impedance + + ! - include derivatives w.r.t. ground evaporation + if(nSnow==0 .and. iLayer==1)then + aJac(ixInd(full,ixTopHyd,ixTopNrg),ixTopNrg) = (dt/mLayerDepth(jLayer))*(-dGroundEvaporation_dTGround/iden_water) + aJac(ixInd(full,ixTopHyd,ixTopNrg),ixTopNrg) ! dVol/dT (K-1) + endif + endif !(if both the energy and water states for the current layer are within the state subset) + + if(watState/=integerMissing)then + ! - include derivatives w.r.t. ground evaporation + if(nSnow==0 .and. iLayer==1)then + if(computeVegFlux)then ! surface soil layer, assume here that kl>=4 + if(ixCasNrg/=integerMissing) aJac(ixInd(full,ixTopHyd,ixCasNrg),ixCasNrg) = (dt/mLayerDepth(jLayer))*(-dGroundEvaporation_dTCanair/iden_water) ! dVol/dT (K-1) + if(ixVegNrg/=integerMissing) aJac(ixInd(full,ixTopHyd,ixVegNrg),ixVegNrg) = (dt/mLayerDepth(jLayer))*(-dGroundEvaporation_dTCanopy/iden_water) + aJac(ixInd(full,ixTopHyd,ixVegNrg),ixVegNrg) ! dVol/dT (K-1) + if(ixVegHyd/=integerMissing) aJac(ixInd(full,ixTopHyd,ixVegHyd),ixVegHyd) = (dt/mLayerDepth(jLayer))*(-dGroundEvaporation_dCanWat/iden_water) + aJac(ixInd(full,ixTopHyd,ixVegHyd),ixVegHyd) ! dVol/dLiq (kg m-2)-1 + endif + endif + + ! - include derivatives of energy and water w.r.t soil transpiration (dependent on canopy transpiration) + if(computeVegFlux)then + if(ixCasNrg/=integerMissing)then + if(watState-ixCasNrg <= kl .or. full) aJac(ixInd(full,watState,ixCasNrg),ixCasNrg) = (dt/mLayerDepth(jLayer))*(-mLayerdTrans_dTCanair(iLayer)) + aJac(ixInd(full,watState,ixCasNrg),ixCasNrg) ! dVol/dT (K-1) + endif + if(ixVegNrg/=integerMissing)then + if(watState-ixVegNrg <= kl .or. full) aJac(ixInd(full,watState,ixVegNrg),ixVegNrg) = (dt/mLayerDepth(jLayer))*(-mLayerdTrans_dTCanopy(iLayer)) + aJac(ixInd(full,watState,ixVegNrg),ixVegNrg) ! dVol/dT (K-1) + endif + if(ixVegHyd/=integerMissing)then + if(watState-ixVegHyd <= kl .or. full) aJac(ixInd(full,watState,ixVegHyd),ixVegHyd) = (dt/mLayerDepth(jLayer))*(-mLayerdTrans_dCanWat(iLayer)) + aJac(ixInd(full,watState,ixVegHyd),ixVegHyd) ! dVol/dLiq (kg m-2)-1 + endif + if(ixTopNrg/=integerMissing)then + if(watState-ixTopNrg <= kl .or. full) aJac(ixInd(full,watState,ixTopNrg),ixTopNrg) = (dt/mLayerDepth(jLayer))*(-mLayerdTrans_dTGround(iLayer)) + aJac(ixInd(full,watState,ixTopNrg),ixTopNrg) ! dVol/dT (K-1) + endif + endif + + ! - include derivatives of heat capacity w.r.t water fluxes for layer above + if(iLayer>1 .or. (iLayer==1 .and. nSnow>0))then ! have layer above + if(ixSnowSoilNrg(jLayer-1)/=integerMissing) aJac(ixInd(full,ixSnowSoilNrg(jLayer-1),watState),watState) = (dt/mLayerDepth(jLayer-1))*( dNrgFlux_dWatBelow(jLayer-1) ) + endif + + ! include derivatives of heat capacity w.r.t water fluxes for layer below + if(iLayer1)then + if(ixSoilOnlyHyd(iLayer-1)/=integerMissing) aJac(ixInd(full,ixSoilOnlyHyd(iLayer-1),nrgState),nrgState) = (dt/mLayerDepth(jLayer-1))*( dq_dNrgStateBelow(iLayer-1)) ! K-1 + endif + + ! compute sub-diagonal elements + if(iLayer0 .and. ixSoilOnlyHyd(1)/=integerMissing .and. all(dq_dNrgStateLayerSurfVec/=realMissing))then ! have snow above first soil layer + denseLimit = nSnow ! if passed through a too dense snowpack, need to find top dense layer (bottom layer always included, dense or not) + do pLayer=nSnow,1,-1 + if(mLayerVolFracIce(pLayer)<=maxVolIceContent) exit + denseLimit = pLayer + end do + do pLayer=denseLimit,nSnow + if(ixSnowOnlyNrg(pLayer)/=integerMissing)then + if(ixSoilOnlyHyd(1) - ixSnowOnlyNrg(pLayer) <= kl .or. full) & + aJac(ixInd(full,ixSoilOnlyHyd(1),ixSnowOnlyNrg(pLayer)),ixSnowOnlyNrg(pLayer)) = -(dt/mLayerDepth(nSnow+1))*scalarSoilControl*iLayerLiqFluxSnowDeriv(pLayer)*mLayerdTheta_dTk(pLayer) + aJac(ixInd(full,ixSoilOnlyHyd(1),ixSnowOnlyNrg(pLayer)),ixSnowOnlyNrg(pLayer)) + endif + end do ! (looping through snow layers above soil until non-dense layer) + endif ! (if snow present above soil) + + endif ! (if there are state variables for both water and energy in the soil domain) + + end associate ! end association to variables in the data structures + +end subroutine fluxJacAdd + +! ********************************************************************************************************** +! public function: get the index in the band-diagonal matrix or full matrix +! ********************************************************************************************************** +function ixInd(full,jState,iState) + implicit none + logical(lgt),intent(in) :: full ! true if using full matrix, false if using band-diagonal matrix + integer(i4b),intent(in) :: jState ! off-diagonal state + integer(i4b),intent(in) :: iState ! diagonal state + integer(i4b) :: ixInd ! index in the band-diagonal matrix or full matrix + + if(full) then + ixInd = jState + else + ixInd = ixDiag + jState - iState + endif +end function ixInd + +#ifdef SUNDIALS_ACTIVE +! ********************************************************************************************************** +! public function computJacob4kinsol: the interface to compute the Jacobian matrix dF/dy + c dF/dy' for IDA solver +! ********************************************************************************************************** +! Return values: +! 0 = success, +! 1 = recoverable error, +! -1 = non-recoverable error +! ---------------------------------------------------------------- +integer(c_int) function computJacob4kinsol(sunvec_y, sunvec_r, sunmat_J, & + user_data, sunvec_temp1, sunvec_temp2 & + ) result(ierr) bind(C, name='computJacob4kinsol') + + !======= Inclusions =========== + use, intrinsic :: iso_c_binding + use fsundials_core_mod + use fnvector_serial_mod + use fsunmatrix_band_mod + use fsunmatrix_dense_mod + use type4kinsol + + !======= Declarations ========= + implicit none + + ! calling variables + type(N_Vector) :: sunvec_y ! solution N_Vector + type(N_Vector) :: sunvec_r ! residual N_Vector + type(SUNMatrix) :: sunmat_J ! Jacobian SUNMatrix + type(c_ptr), value :: user_data ! user-defined data + type(N_Vector) :: sunvec_temp1 ! temporary N_Vector + type(N_Vector) :: sunvec_temp2 ! temporary N_Vector + + ! pointers to data in SUNDIALS vectors + real(c_double), pointer :: Jac(:,:) ! Jacobian matrix + type(data4kinsol), pointer :: eqns_data ! equations data + + ! class objects for subroutine arguments + type(in_type_computJacob) :: in_computJacob ! intent(in) computJacob arguments + type(out_type_computJacob) :: out_computJacob ! intent(out) computJacob arguments +! ---------------------------------------------------------------- + + ! get equations data from user-defined data + call c_f_pointer(user_data,eqns_data) + + ! get data arrays from SUNDIALS vectors + if (eqns_data%ixMatrix==ixBandMatrix) Jac(1:nBands, 1:eqns_data%nState) => FSUNBandMatrix_Data(sunmat_J) + if (eqns_data%ixMatrix==ixFullMatrix) Jac(1:eqns_data%nState, 1:eqns_data%nState) => FSUNDenseMatrix_Data(sunmat_J) + + ! compute the analytical Jacobian matrix + ! NOTE: The derivatives were computed in the previous call to computFlux + ! This occurred either at the call to eval8summa at the start of systemSolv + ! or in the call to eval8summa in the previous iteration + call initialize_computJacob ! pack in_computJacob object + call computJacob(& + ! input: model control + in_computJacob, & + ! input: data structures + eqns_data%indx_data, & ! intent(in): index data + eqns_data%prog_data, & ! intent(in): model prognostic variables for a local HRU + eqns_data%diag_data, & ! intent(in): model diagnostic variables for a local HRU + eqns_data%deriv_data, & ! intent(in): derivatives in model fluxes w.r.t. relevant state variables + eqns_data%dBaseflow_dMatric, & ! intent(in): derivative in baseflow w.r.t. matric head (s-1) + ! input-output: Jacobian and its diagonal + eqns_data%dMat, & ! intent(inout): diagonal of the Jacobian matrix + Jac, & ! intent(out): Jacobian matrix + ! output: error control + out_computJacob) ! intent(out): error code and error message + call finalize_computJacob ! unpack out_computJacob object + if(eqns_data%err > 0)then; eqns_data%message=trim(eqns_data%message); ierr=-1; return; endif + if(eqns_data%err < 0)then; eqns_data%message=trim(eqns_data%message); ierr=1; return; endif + + ! return success + ierr = 0 + return + + contains + + subroutine initialize_computJacob + ! *** Transfer data to in_computJacob class object from local variables *** + call in_computJacob % initialize(eqns_data%dt_cur,eqns_data%nSnow,eqns_data%nSoil,eqns_data%nLayers,eqns_data%computeVegFlux,(eqns_data%model_decisions(iLookDECISIONS%groundwatr)%iDecision==qbaseTopmodel),eqns_data%ixMatrix) + end subroutine initialize_computJacob + + subroutine finalize_computJacob + ! *** Transfer data from out_computJacob class object to local variables *** + call out_computJacob % finalize(eqns_data % err,eqns_data % message) + end subroutine finalize_computJacob + +end function computJacob4kinsol +#endif - endif ! (if the energy state for the current layer is within the state subset) - - end do ! (looping through soil layers) - endif ! (if there are state variables for both water and energy in the soil domain) - - ! print the Jacobian - if(globalPrintFlag)then - print*, '** analytical Jacobian (full):' - write(*,'(a4,1x,100(i12,1x))') 'xCol', (iLayer, iLayer=min(iJac1,nState),min(iJac2,nState)) - do iLayer=min(iJac1,nState),min(iJac2,nState) - write(*,'(i4,1x,100(e12.5,1x))') iLayer, aJac(min(iJac1,nState):min(iJac2,nState),iLayer) - end do - end if - - ! *** - ! check - case default; err=20; message=trim(message)//'unable to identify option for the type of matrix'; return - - end select ! type of matrix - - ! end association to variables in the data structures - end associate - - end subroutine computJacob - - - ! ********************************************************************************************************** - ! private function: get the off-diagonal index in the band-diagonal matrix - ! ********************************************************************************************************** - function ixOffDiag(jState,iState) - implicit none - integer(i4b),intent(in) :: jState ! off-diagonal state - integer(i4b),intent(in) :: iState ! diagonal state - integer(i4b) :: ixOffDiag ! off-diagonal index in gthe band-diagonal matrix - ixOffDiag = ixBandOffset + jState - iState - end function ixOffDiag end module computJacob_module diff --git a/build/source/engine/computJacobWithPrime.f90 b/build/source/engine/computJacobWithPrime.f90 new file mode 100644 index 000000000..aa327af11 --- /dev/null +++ b/build/source/engine/computJacobWithPrime.f90 @@ -0,0 +1,568 @@ +! SUMMA - Structure for Unifying Multiple Modeling Alternatives +! Copyright (C) 2014-2015 NCAR/RAL +! +! This file is part of SUMMA +! +! For more information see: http://www.ral.ucar.edu/projects/summa +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see . + +module computJacobWithPrime_module + +! data types +USE nrtype + +! derived types to define the data structures +USE data_types,only:& + var_ilength, & ! data vector with variable length dimension (i4b) + var_dlength, & ! data vector with variable length dimension (rkind) + model_options ! defines the model decisions + +! named variables for structure elements +USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure +USE var_lookup,only:iLookPARAM ! named variables for structure elements +USE var_lookup,only:iLookPROG ! named variables for structure elements +USE var_lookup,only:iLookINDEX ! named variables for structure elements +USE var_lookup,only:iLookDIAG ! named variables for structure elements +USE var_lookup,only:iLookDERIV ! named variables for structure elements + +! access the global print flag +USE globalData,only:globalPrintFlag + +! access missing values +USE globalData,only:integerMissing ! missing integer +USE globalData,only:realMissing ! missing real number + +! named variables to describe the state variable type +USE globalData,only:iname_watLayer ! named variable defining the total water state variable for snow+soil layers +USE globalData,only:maxVolIceContent ! snow maximum volumetric ice content to store water (-) + +! access named variables to describe the form and structure of the matrices used in the numerical solver +USE globalData,only: kl ! number of sub-diagonal bands, assume kl>=4 +USE globalData,only: ixDiag ! index for the diagonal band +USE globalData,only: nBands ! length of the leading dimension of the band diagonal matrix +USE globalData,only: ixFullMatrix ! named variable for the full Jacobian matrix +USE globalData,only: ixBandMatrix ! named variable for the band diagonal matrix +USE globalData,only: iJac1 ! first layer of the Jacobian to print +USE globalData,only: iJac2 ! last layer of the Jacobian to print + +! constants +USE multiconst,only:& + LH_fus, & ! latent heat of fusion (J kg-1) + iden_water ! intrinsic density of liquid water (kg m-3) + +! look-up values for the choice of groundwater parameterization +USE mDecisions_module,only: & + qbaseTopmodel, & ! TOPMODEL-ish baseflow parameterization + bigBucket, & ! a big bucket (lumped aquifer model) + noExplicit ! no explicit groundwater parameterization + +! look-up values for the form of Richards' equation +USE mDecisions_module,only: & + moisture, & ! moisture-based form of Richards' equation + mixdform ! mixed form of Richards' equation + +! look-up values for the choice of variable in energy equations (BE residual or IDA state variable) +USE mDecisions_module,only: & + closedForm, & ! use temperature with closed form heat capacity + enthalpyFormLU, & ! use enthalpy with soil temperature-enthalpy lookup tables + enthalpyForm ! use enthalpy with soil temperature-enthalpy analytical solution + +implicit none +private +public::computJacobWithPrime +public::computJacob4ida +contains + + +! ********************************************************************************************************** +! public subroutine computJacobWithPrime: compute the Jacobian matrix +! ********************************************************************************************************** +subroutine computJacobWithPrime(& + ! input: model control + cj, & ! intent(in): this scalar changes whenever the step size or method order changes + dt, & ! intent(in): length of the time step (seconds) + nSnow, & ! intent(in): number of snow layers + nSoil, & ! intent(in): number of soil layers + nLayers, & ! intent(in): total number of layers + computeVegFlux, & ! intent(in): flag to indicate if we need to compute fluxes over vegetation + computeBaseflow, & ! intent(in): flag to indicate if we need to compute baseflow + ixMatrix, & ! intent(in): form of the Jacobian matrix + specificStorage, & ! intent(in): specific storage coefficient (m-1) + theta_sat, & ! intent(in): soil porosity (-) + ixRichards, & ! intent(in): choice of option for Richards' equation + enthalpyStateVec, & ! intent(in): flag if enthalpy is state variable + ! input: data structures + indx_data, & ! intent(in): index data + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(in): model diagnostic variables for a local HRU + deriv_data, & ! intent(in): derivatives in model fluxes w.r.t. relevant state variables + dBaseflow_dMatric, & ! intent(in): derivative in baseflow w.r.t. matric head (s-1) + ! input: state variables + mLayerTempPrime, & ! intent(in): vector of derivative value for layer temperature (K) + mLayerMatricHeadPrime, & ! intent(in): vector of derivative value for layer matric head + mLayerVolFracWatPrime, & ! intent(in): vector of derivative value for layer water volume fraction + scalarCanopyTempPrime, & ! intent(in): derivative value for temperature of the vegetation canopy (K) + scalarCanopyWatPrime, & ! intent(in): derivative value for water content of the vegetation canopy + ! input-output: Jacobian and its diagonal + dMat0, & ! intent(in): diagonal of the Jacobian matrix excluding fluxes, not depending on the state vector + aJac, & ! intent(out): Jacobian matrix + ! output: error control + err,message) ! intent(out): error code and error message + ! ----------------------------------------------------------------------------------------------------------------- + ! provide access to subroutines + use computJacob_module,only:fluxJacAdd + use computJacob_module,only:ixInd + ! ----------------------------------------------------------------------------------------------------------------- + implicit none + ! input: model control + real(rkind),intent(in) :: cj ! this scalar changes whenever the step size or method order changes + real(rkind),intent(in) :: dt ! length of the time step (seconds) + integer(i4b),intent(in) :: nSnow ! number of snow layers + integer(i4b),intent(in) :: nSoil ! number of soil layers + integer(i4b),intent(in) :: nLayers ! total number of layers in the snow and soil domains + logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation + logical(lgt),intent(in) :: computeBaseflow ! flag to indicate if computing baseflow + integer(i4b),intent(in) :: ixMatrix ! form of the Jacobian matrix + real(rkind),intent(in) :: specificStorage ! specific storage coefficient (m-1) + real(rkind),intent(in) :: theta_sat(:) ! soil porosity (-) + integer(i4b),intent(in) :: ixRichards ! choice of option for Richards' equation + logical(lgt),intent(in) :: enthalpyStateVec ! flag if enthalpy is state variable + ! input: data structures + type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers + type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU + type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(in) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + real(rkind),intent(in) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + ! input: state variables + real(rkind),intent(in) :: mLayerTempPrime(:) ! vector of derivative value for layer temperature + real(rkind),intent(in) :: mLayerMatricHeadPrime(:) ! vector of derivative value for layer matric head + real(rkind),intent(in) :: mLayerVolFracWatPrime(:) ! vector of derivative value for layer water volume fraction + real(rkind),intent(in) :: scalarCanopyTempPrime ! derivative value for temperature of the vegetation canopy (K) + real(rkind),intent(in) :: scalarCanopyWatPrime ! derivative value for water content of the vegetation canopy + ! input-output: Jacobian and its diagonal + real(rkind),intent(in) :: dMat0(:) ! diagonal of the Jacobian matrix excluding fluxes, not depending on the state vector + real(rkind),intent(out) :: aJac(:,:) ! Jacobian matrix + ! output variables + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! -------------------------------------------------------------- + ! * local variables + ! -------------------------------------------------------------- + real(rkind),allocatable :: dMat(:) ! diagonal of the Jacobian matrix excluding fluxes, depending on the state vector + ! indices of model state variables + integer(i4b) :: nrgState ! energy state variable + integer(i4b) :: watState ! hydrology state variable + integer(i4b) :: nState ! number of state variables + integer(i4b),allocatable :: nrgRows(:) ! indices of rows for energy column + integer(i4b),allocatable :: watRows(:) ! indices of rows for hydrology column + ! indices of model layers + integer(i4b) :: iLayer ! index of model layer + integer(i4b) :: jLayer ! index of model layer within the full state vector (hydrology) + ! conversion factors + real(rkind) :: LH_fu0 ! latent heat of fusion, modified to be 0 if using enthalpy formulation and not using + character(LEN=256) :: cmessage ! error message of downwind routine + logical(lgt) :: full ! flag to indicate if the matrix is full (true) or banded (false) + ! -------------------------------------------------------------- + ! associate variables from data structures + associate(& + ! indices of model state variables + ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy air space energy state variable + ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable + ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) + ixAqWat => indx_data%var(iLookINDEX%ixAqWat)%dat(1) ,& ! intent(in): [i4b] index of water storage in the aquifer + ! vector of energy indices for the snow and soil domains + ! NOTE: states not in the subset are equal to integerMissing + ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the snow and soil domains + ixSnowOnlyNrg => indx_data%var(iLookINDEX%ixSnowOnlyNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the snow domain + ixSoilOnlyNrg => indx_data%var(iLookINDEX%ixSoilOnlyNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the soil domain + ! vector of hydrology indices for the snow and soil domains + ! NOTE: states not in the subset are equal to integerMissing + ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the snow and soil domains + ixSnowOnlyHyd => indx_data%var(iLookINDEX%ixSnowOnlyHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the snow domain + ixSoilOnlyHyd => indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the soil domain + ! number of state variables of a specific type + nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg)%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow and soil domains + nSnowOnlyNrg => indx_data%var(iLookINDEX%nSnowOnlyNrg)%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow domain + nSoilOnlyNrg => indx_data%var(iLookINDEX%nSoilOnlyNrg)%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the soil domain + nSnowOnlyHyd => indx_data%var(iLookINDEX%nSnowOnlyHyd)%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the snow domain + nSoilOnlyHyd => indx_data%var(iLookINDEX%nSoilOnlyHyd)%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the soil domain + ! derivatives in net vegetation energy fluxes w.r.t. relevant state variables + dCanopyNetFlux_dCanWat => deriv_data%var(iLookDERIV%dCanopyNetFlux_dCanWat)%dat(1) ,& ! intent(in): [dp] derivative in net canopy fluxes w.r.t. canopy total water content + ! derivatives in canopy water w.r.t canopy temperature + dTheta_dTkCanopy => deriv_data%var(iLookDERIV%dTheta_dTkCanopy)%dat(1) ,& ! intent(in): [dp] derivative in volumetric liquid water content w.r.t. temperature + d2Theta_dTkCanopy2 => deriv_data%var(iLookDERIV%d2Theta_dTkCanopy2)%dat(1) ,& ! intent(in): [dp] second derivative in volumetric liquid water content w.r.t. temperature + dFracLiqVeg_dTkCanopy => deriv_data%var(iLookDERIV%dFracLiqVeg_dTkCanopy)%dat(1) ,& ! intent(in): [dp] derivative in fraction of (throughfall + drainage) w.r.t. temperature + ! derivatives in energy fluxes at the interface of snow+soil layers w.r.t. water state in layers above and below + dNrgFlux_dWatAbove => deriv_data%var(iLookDERIV%dNrgFlux_dWatAbove)%dat ,& ! intent(in): [dp(:)] derivatives in the flux w.r.t. water state in the layer above + dNrgFlux_dWatBelow => deriv_data%var(iLookDERIV%dNrgFlux_dWatBelow)%dat ,& ! intent(in): [dp(:)] derivatives in the flux w.r.t. water state in the layer below + ! derivative in liquid water fluxes for the soil domain w.r.t hydrology state variables + dVolTot_dPsi0 => deriv_data%var(iLookDERIV%dVolTot_dPsi0)%dat ,& ! intent(in): [dp(:)] derivatives in total water content w.r.t. total water matric potential + d2VolTot_dPsi02 => deriv_data%var(iLookDERIV%d2VolTot_dPsi02)%dat ,& ! intent(in): [dp(:)] second derivatives in total water content w.r.t. total water matric potential + dCompress_dPsi => deriv_data%var(iLookDERIV%dCompress_dPsi)%dat ,& ! intent(in): [dp(:)] derivatives in compressibility w.r.t matric head + ! derivative in liquid water fluxes for the soil and snow domain w.r.t temperature + dFracLiqWat_dTk => deriv_data%var(iLookDERIV%dFracLiqWat_dTk)%dat ,& ! intent(in): [dp(:)] derivatives in fraction of liquid water w.r.t. temperature + mLayerdTheta_dTk => deriv_data%var(iLookDERIV%mLayerdTheta_dTk)%dat ,& ! intent(in): [dp(:)] derivatives in volumetric liquid water content w.r.t. temperature + mLayerd2Theta_dTk2 => deriv_data%var(iLookDERIV%mLayerd2Theta_dTk2)%dat ,& ! intent(in): [dp(:)] second derivatives of volumetric liquid water content w.r.t. temperature + ! derivative in bulk heat capacity w.r.t. relevant state variables + dVolHtCapBulk_dPsi0 => deriv_data%var(iLookDERIV%dVolHtCapBulk_dPsi0)%dat ,& ! intent(in): [dp(:)] derivatives in bulk heat capacity w.r.t. matric potential + dVolHtCapBulk_dTheta => deriv_data%var(iLookDERIV%dVolHtCapBulk_dTheta)%dat ,& ! intent(in): [dp(:)] derivatives in bulk heat capacity w.r.t. volumetric water content + dVolHtCapBulk_dCanWat => deriv_data%var(iLookDERIV%dVolHtCapBulk_dCanWat)%dat(1) ,& ! intent(in): [dp ] derivative in bulk heat capacity w.r.t. volumetric water content + dVolHtCapBulk_dTk => deriv_data%var(iLookDERIV%dVolHtCapBulk_dTk)%dat ,& ! intent(in): [dp(:)] derivatives in bulk heat capacity w.r.t. temperature + dVolHtCapBulk_dTkCanopy => deriv_data%var(iLookDERIV%dVolHtCapBulk_dTkCanopy)%dat(1) ,& ! intent(in): [dp ] derivative in bulk heat capacity w.r.t. temperature + ! derivative in Cm w.r.t. relevant state variables + dCm_dPsi0 => deriv_data%var(iLookDERIV%dCm_dPsi0)%dat ,& ! intent(in): [dp(:)] derivative sin heat capacity w.r.t. matric potential (J kg-1) + dCm_dTk => deriv_data%var(iLookDERIV%dCm_dTk)%dat ,& ! intent(in): [dp(:)] derivatives in heat capacity w.r.t. temperature (J kg-1 K-2) + dCm_dTkCanopy => deriv_data%var(iLookDERIV%dCm_dTkCanopy)%dat(1) ,& ! intent(in): [dp ] derivative in heat capacity w.r.t. canopy temperature (J kg-1 K-2) + ! derivatives of temperature if enthalpy is the state variable + dCanairTemp_dEnthalpy => deriv_data%var(iLookDERIV%dCanairTemp_dEnthalpy)%dat(1) ,& ! intent(in): [dp] derivative incanopy air temperature w.r.t. enthalpy + dCanopyTemp_dEnthalpy => deriv_data%var(iLookDERIV%dCanopyTemp_dEnthalpy)%dat(1) ,& ! intent(in): [dp] derivative incanopy temperature w.r.t. enthalpy + dTemp_dEnthalpy => deriv_data%var(iLookDERIV%dTemp_dEnthalpy)%dat ,& ! intent(in): [dp(:)] derivatives in temperature w.r.t. enthalpy + dCanopyTemp_dCanWat => deriv_data%var(iLookDERIV%dCanopyTemp_dCanWat)%dat(1) ,& ! intent(in): [dp] derivative incanopy temperature w.r.t. volumetric water content + dTemp_dTheta => deriv_data%var(iLookDERIV%dTemp_dTheta)%dat ,& ! intent(in): [dp(:)] derivatives in temperature w.r.t. volumetric water content + dTemp_dPsi0 => deriv_data%var(iLookDERIV%dTemp_dPsi0)%dat ,& ! intent(in): [dp(:)] derivatives in temperature w.r.t. total water matric potential + ! diagnostic variables + scalarFracLiqVeg => diag_data%var(iLookDIAG%scalarFracLiqVeg)%dat(1) ,& ! intent(in): [dp] fraction of liquid water on vegetation (-) + scalarBulkVolHeatCapVeg => diag_data%var(iLookDIAG%scalarBulkVolHeatCapVeg)%dat(1) ,& ! intent(in): [dp] bulk volumetric heat capacity of vegetation (J m-3 K-1) + scalarCanopyCm => diag_data%var(iLookDIAG%scalarCanopyCm)%dat(1) ,& ! intent(in): [dp] Cm of canopy (J kg-1 K-1) + mLayerFracLiqSnow => diag_data%var(iLookDIAG%mLayerFracLiqSnow)%dat ,& ! intent(in): [dp(:)] fraction of liquid water in each snow layer (-) + mLayerVolHtCapBulk => diag_data%var(iLookDIAG%mLayerVolHtCapBulk)%dat ,& ! intent(in): [dp(:)] bulk volumetric heat capacity in each snow+soil layer (J m-3 K-1) + mLayerCm => diag_data%var(iLookDIAG%mLayerCm)%dat ,& ! intent(in): [dp(:)] Cm in each snow+soil layer (J kg-1 K-1) + ! canopy and layer depth + canopyDepth => diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1) ,& ! intent(in): [dp ] canopy depth (m) + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat & ! intent(in): [dp(:)] depth of each layer in the snow+soil sub-domain (m) + ) ! making association with data in structures + ! -------------------------------------------------------------- + ! initialize error control + err=0; message='computJacobWithPrime/' + + ! ********************************************************************************************************************************************************* + ! * PART 0: PRELIMINARIES (INITIALIZE JACOBIAN AND COMPUTE TIME-VARIABLE DIAGONAL TERMS) + ! ********************************************************************************************************************************************************* + ! get the number of state variables + nState = size(dMat0) + + ! initialize the Jacobian and diagonal + ! NOTE: this needs to be done every time, since Jacobian matrix is modified in the solver and dMat is modified below + aJac(:,:) = 0._rkind ! analytical Jacobian matrix + allocate(dMat(nState)) + dMat = dMat0 * cj ! dMat0(ixCasNrg) = Cp_air*iden_air and dMat0(Wat states) = 1.0 + + if(computeVegFlux)then + ! compute terms in the Jacobian for vegetation (excluding fluxes) + if(ixVegNrg/=integerMissing)& + dMat(ixVegNrg) = ( scalarBulkVolHeatCapVeg + LH_fus*iden_water*dTheta_dTkCanopy ) * cj & + + dVolHtCapBulk_dTkCanopy * scalarCanopyTempPrime & + + dCm_dTkCanopy * scalarCanopyWatPrime/canopyDepth & + + LH_fus*iden_water * scalarCanopyTempPrime * d2Theta_dTkCanopy2 & + + LH_fus * dFracLiqVeg_dTkCanopy * scalarCanopyWatPrime/canopyDepth + endif + + ! compute terms for the Jacobian for the snow and soil domains (excluding fluxes) + do iLayer=1,nLayers + if(ixSnowSoilNrg(iLayer)/=integerMissing)& + dMat(ixSnowSoilNrg(iLayer)) = ( mLayerVolHtCapBulk(iLayer) + LH_fus*iden_water*mLayerdTheta_dTk(iLayer) ) * cj & + + dVolHtCapBulk_dTk(iLayer) * mLayerTempPrime(iLayer) & + + dCm_dTk(iLayer) * mLayerVolFracWatPrime(iLayer) & + + LH_fus*iden_water * mLayerTempPrime(iLayer) * mLayerd2Theta_dTk2(iLayer) & + + LH_fus*iden_water * dFracLiqWat_dTk(iLayer) * mLayerVolFracWatPrime(iLayer) + end do + + ! compute terms for the Jacobian for the soil domain (excluding fluxes) + do iLayer=1,nSoil + if(ixSoilOnlyHyd(iLayer)/=integerMissing)then ! writes over dMat(ixSoilOnlyHyd(iLayer) = 1.0 * cj above + dMat(ixSoilOnlyHyd(iLayer)) = ( dVolTot_dPsi0(iLayer) + dCompress_dPsi(iLayer) ) * cj + d2VolTot_dPsi02(iLayer) * mLayerMatricHeadPrime(iLayer) + if(ixRichards==mixdform)& + dMat(ixSoilOnlyHyd(iLayer)) = dMat(ixSoilOnlyHyd(iLayer)) + specificStorage * dVolTot_dPsi0(iLayer) * mLayerMatricHeadPrime(iLayer)/theta_sat(iLayer) + endif + end do + + ! if using enthalpy as a state variable, zero out usual RHS terms and add them end of the iteration loop + ! NOTE: other terms on RHS that are not fluxes are zeroed out by not computing heat capacity and Cm and their derivatives + if(enthalpyStateVec)then + if(ixCasNrg/=integerMissing) dMat(ixCasNrg) = 0._rkind + if(ixVegNrg/=integerMissing) dMat(ixVegNrg) = 0._rkind + do iLayer=1,nLayers + if(ixSnowSoilNrg(iLayer)/=integerMissing) dMat(ixSnowSoilNrg(iLayer)) = 0._rkind + end do + LH_fu0 = 0._rkind ! set to 0 to not use RHS terms + else + LH_fu0 = LH_fus ! use regular value + endif + + ! define the form of the matrix + select case(ixMatrix) + case(ixBandMatrix) + ! check + if(size(aJac,1)/=nBands .or. size(aJac,2)/=size(dMat))then + message=trim(message)//'unexpected shape of the Jacobian matrix: expect aJac(nBands,nState)' + err=20; return + endif + full = .false. + case(ixFullMatrix) + ! check + if(size(aJac,1)/=size(dMat) .or. size(aJac,2)/=size(dMat))then + message=trim(message)//'unexpected shape of the Jacobian matrix: expect aJac(nState,nState)' + err=20; return + endif + full = .true. + case default; err=20; message=trim(message)//'unable to identify option for the type of matrix'; return + end select + + ! ********************************************************************************************************************************************************* + ! * PART 1: COMPUTE CROSS-DERIVATIVE JACOBIAN TERMS + ! ********************************************************************************************************************************************************* + ! ----- + ! * cross derivatives in the vegetation... + ! --------------------------------------------- + if(computeVegFlux)then ! (derivatives only defined when vegetation protrudes over the surface) + if(ixVegHyd/=integerMissing .and. ixVegNrg/=integerMissing)& + ! NOTE: dIce/dLiq = (1 - scalarFracLiqVeg); dIce*LH_fu0/canopyDepth = J m-3; dLiq = kg m-2 + aJac(ixInd(full,ixVegNrg,ixVegHyd),ixVegHyd) = (-1._rkind + scalarFracLiqVeg)*LH_fu0/canopyDepth * cj & + + dVolHtCapBulk_dCanWat * scalarCanopyTempPrime + scalarCanopyCm/canopyDepth * cj & + - (dt/canopyDepth) * dCanopyNetFlux_dCanWat & + + LH_fu0 * scalarCanopyTempPrime * dFracLiqVeg_dTkCanopy/canopyDepth + endif ! if there is a need to compute energy fluxes within vegetation + + ! ----- + ! * cross derivatives in the snow domain... + ! ---------------------------------------- + if(nSnowOnlyHyd>0 .and. nSnowOnlyNrg>0)then + do iLayer=1,nSnow ! loop through layers in the snow domain + + ! - check that the snow layer is desired + if(ixSnowOnlyNrg(iLayer)==integerMissing) cycle + ! (define the energy state) + nrgState = ixSnowOnlyNrg(iLayer) ! index within the full state vector + ! - define state indices for the current layer + watState = ixSnowOnlyHyd(iLayer) ! hydrology state index within the state subset + + if(watState/=integerMissing)then ! (water state for the current layer is within the state subset) + ! - include derivatives of energy fluxes w.r.t water fluxes for current layer + aJac(ixInd(full,nrgState,watState),watState) = (-1._rkind + mLayerFracLiqSnow(iLayer))*LH_fu0*iden_water * cj & + + dVolHtCapBulk_dTheta(iLayer) * mLayerTempPrime(iLayer) + mLayerCm(iLayer) * cj & + + (dt/mLayerDepth(iLayer))*(-dNrgFlux_dWatBelow(iLayer-1) + dNrgFlux_dWatAbove(iLayer)) & + + LH_fu0*iden_water * mLayerTempPrime(iLayer) * dFracLiqWat_dTk(iLayer) ! (dF/dLiq) + endif ! (if the water state for the current layer is within the state subset) + + end do ! (looping through snow layers) + endif ! (if there are state variables for both water and energy in the snow domain) + + ! ----- + ! * cross derivatives in the soil domain... + ! ---------------------------------------- + if(nSoilOnlyHyd>0 .and. nSoilOnlyNrg>0)then + do iLayer=1,nSoilOnlyNrg + + ! - check that the soil layer is desired + if(ixSoilOnlyNrg(iLayer)==integerMissing) cycle + ! - define indices of the soil layers + jLayer = iLayer+nSnow ! index of layer in the snow+soil vector + ! - define the energy state variable + nrgState = ixSoilOnlyNrg(iLayer) ! index within the full state vector + ! - define index of hydrology state variable within the state subset + watState = ixSoilOnlyHyd(iLayer) + + ! only compute derivatives if the water state for the current layer is within the state subset + if(watState/=integerMissing)then + ! - include derivatives in energy fluxes w.r.t. with respect to water for current layer + aJac(ixInd(full,nrgState,watState),watState) = dVolHtCapBulk_dPsi0(iLayer) * mLayerTempPrime(jLayer) & + + mLayerCm(jLayer) * dVolTot_dPsi0(iLayer) * cj + dCm_dPsi0(iLayer) * mLayerVolFracWatPrime(jLayer) & + + (dt/mLayerDepth(jLayer))*(-dNrgFlux_dWatBelow(jLayer-1) + dNrgFlux_dWatAbove(jLayer)) & + + mLayerCm(jLayer) * d2VolTot_dPsi02(iLayer) * mLayerMatricHeadPrime(iLayer) + if(mLayerdTheta_dTk(jLayer) > tiny(1.0_rkind))& ! ice is present + aJac(ixInd(full,nrgState,watState),watState) = -LH_fu0*iden_water * dVolTot_dPsi0(iLayer) * cj & + - LH_fu0*iden_water * mLayerMatricHeadPrime(iLayer) * d2VolTot_dPsi02(iLayer) + aJac(ixInd(full,nrgState,watState),watState) ! dNrg/dMat (J m-3 m-1) -- dMat changes volumetric water, and hence ice content + endif ! (if the water state for the current layer is within the state subset) + + end do ! (looping through energy states in the soil domain) + endif ! (if there are state variables for both water and energy in the soil domain) + + ! ********************************************************************************************************************************************************* + ! * PART 2: COMPUTE FLUX JACOBIAN TERMS + ! ********************************************************************************************************************************************************* + call fluxJacAdd(full,dt,nSnow,nSoil,nLayers,computeVegFlux,computeBaseflow,& + indx_data,prog_data,diag_data,deriv_data,dBaseflow_dMatric,& + dMat,aJac,err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + deallocate(dMat) + + ! ********************************************************************************************************************************************************* + ! * PART 3: CLEAN UP JACOBIAN (IF USING ENTHALPY AS A STATE VARIABLE) AND PRINT (IF DESIRED) + ! ********************************************************************************************************************************************************* + ! * if desired, modify to use enthalpy as a state variable instead of temperature + ! NOTE, dMat(Nrg states) was used as 0 and now 1._rkind * cj is added instead + ! ---------------------------------------- + if(enthalpyStateVec)then + + if(full) then + allocate(watRows(nState),nrgRows(nState)) ! all rows are used + do jLayer=1,nState + watRows(jLayer) = jLayer + nrgRows(jLayer) = jLayer + end do + else + allocate(watRows(nBands-1),nrgRows(nBands-1)) ! only the bands are used + do jLayer=1,nBands-1 ! water row nBand would add a 0 value from the nrg matrix since it's out of range + watRows(jLayer) = jLayer + nrgRows(jLayer) = jLayer + 1 + enddo + endif + + if(ixCasNrg/=integerMissing)then + aJac(:,ixCasNrg) = aJac(:,ixCasNrg) * dCanairTemp_dEnthalpy + aJac(ixInd(full,ixCasNrg,ixCasNrg),ixCasNrg) = aJac(ixInd(full,ixCasNrg,ixCasNrg),ixCasNrg) + 1._rkind * cj + endif + + if(ixVegNrg/=integerMissing)then + if(ixVegHyd/=integerMissing) aJac(watRows,ixVegHyd) = aJac(watRows,ixVegHyd) + aJac(nrgRows,ixVegNrg) * dCanopyTemp_dCanWat + aJac(:,ixVegNrg) = aJac(:,ixVegNrg) * dCanopyTemp_dEnthalpy + aJac(ixInd(full,ixVegNrg,ixVegNrg),ixVegNrg) = aJac(ixInd(full,ixVegNrg,ixVegNrg),ixVegNrg) + 1._rkind * cj + endif + + if(nSnowSoilNrg>0)then + do iLayer=1,nLayers + nrgState = ixSnowSoilNrg(iLayer) + if(nrgState==integerMissing) cycle + watState = ixSnowSoilHyd(iLayer) + if(watState/=integerMissing)then + if(iLayer<=nSnow)then + aJac(watRows,watState) = aJac(watRows,watState) + aJac(nrgRows,nrgState) * dTemp_dTheta(iLayer) + else + aJac(watRows,watState) = aJac(watRows,watState) + aJac(nrgRows,nrgState) * dTemp_dPsi0(iLayer-nSnow) + endif + endif + aJac(:,nrgState) = aJac(:,nrgState) * dTemp_dEnthalpy(iLayer) + aJac(ixInd(full,nrgState,nrgState),nrgState) = aJac(ixInd(full,nrgState,nrgState),nrgState) + 1._rkind * cj + enddo + endif + else + allocate(watRows(0),nrgRows(0)) ! dummy allocation to avoid compiler warning + endif + deallocate(watRows,nrgRows) + + ! print the Jacobian + if(globalPrintFlag .or. any(isNan(aJac)))then + if(full) then + print*, '** full analytical Jacobian:' + write(*,'(a4,1x,100(i12,1x))') 'xCol', (iLayer, iLayer=min(iJac1,nState),min(iJac2,nState)) + do iLayer=min(iJac1,nState),min(iJac2,nState) + write(*,'(i4,1x,100(e12.5,1x))') iLayer, aJac(min(iJac1,nState):min(iJac2,nState),iLayer) + end do + else + print*, '** banded analytical Jacobian:' + write(*,'(a4,1x,100(i17,1x))') 'xCol', (iLayer, iLayer=min(iJac1,nState),min(iJac2,nState)) + do iLayer=kl+1,nBands + write(*,'(i4,1x,100(e17.10,1x))') iLayer, (aJac(iLayer,jLayer),jLayer=min(iJac1,nState),min(iJac2,nState)) + end do + endif + endif + if(any(isNan(aJac)))then; message=trim(message)//'NaN in Jacobian';err=20; return; endif + + end associate ! end association to variables in the data structures + +end subroutine computJacobWithPrime + +! ********************************************************************************************************** +! public function computJacob4ida: the interface to compute the Jacobian matrix dF/dy + c dF/dy' for IDA solver +! ********************************************************************************************************** +! Return values: +! 0 = success, +! 1 = recoverable error, +! -1 = non-recoverable error +! ---------------------------------------------------------------- +integer(c_int) function computJacob4ida(t, cj, sunvec_y, sunvec_yp, sunvec_r, & + sunmat_J, user_data, sunvec_temp1, sunvec_temp2, sunvec_temp3) & + result(ierr) bind(C,name='computJacob4ida') + + !======= Inclusions =========== + use, intrinsic :: iso_c_binding + use fsundials_core_mod + use fnvector_serial_mod + use fsunmatrix_band_mod + use fsunmatrix_dense_mod + use type4ida + + !======= Declarations ========= + implicit none + + ! calling variables + real(rkind), value :: t ! current time + real(rkind), value :: cj ! step size scaling factor + type(N_Vector) :: sunvec_y ! solution N_Vector + type(N_Vector) :: sunvec_yp ! derivative N_Vector + type(N_Vector) :: sunvec_r ! residual N_Vector + type(SUNMatrix) :: sunmat_J ! Jacobian SUNMatrix + type(c_ptr), value :: user_data ! user-defined data + type(N_Vector) :: sunvec_temp1 ! temporary N_Vector + type(N_Vector) :: sunvec_temp2 ! temporary N_Vector + type(N_Vector) :: sunvec_temp3 ! temporary N_Vector + + ! pointers to data in SUNDIALS vectors + real(rkind), pointer :: Jac(:,:) ! Jacobian matrix + type(data4ida), pointer :: eqns_data ! equations data + ! ---------------------------------------------------------------- + + ! get equations data from user-defined data + call c_f_pointer(user_data, eqns_data) + + ! get data arrays from SUNDIALS vectors + if (eqns_data%ixMatrix==ixBandMatrix) Jac(1:nBands, 1:eqns_data%nState) => FSUNBandMatrix_Data(sunmat_J) + if (eqns_data%ixMatrix==ixFullMatrix) Jac(1:eqns_data%nState, 1:eqns_data%nState) => FSUNDenseMatrix_Data(sunmat_J) + + ! compute the analytical Jacobian matrix + ! NOTE: The derivatives were computed in the previous call to computFlux + ! This occurred either at the call to eval8summaWithPrime at the start of systemSolv + ! or in the call to eval8summaWithPrime in the previous iteration + call computJacobWithPrime(& + ! input: model control + cj, & ! intent(in): this scalar changes whenever the step size or method order changes + 1._qp, & ! intent(in): length of the time step (seconds) + eqns_data%nSnow, & ! intent(in): number of snow layers + eqns_data%nSoil, & ! intent(in): number of soil layers + eqns_data%nLayers, & ! intent(in): total number of layers + eqns_data%computeVegFlux, & ! intent(in): flag to indicate if we need to compute fluxes over vegetation + eqns_data%model_decisions(iLookDECISIONS%groundwatr)%iDecision==qbaseTopmodel, & ! intent(in): flag to indicate if we need to compute baseflow + eqns_data%ixMatrix, & ! intent(in): form of the Jacobian matrix + eqns_data%mpar_data%var(iLookPARAM%specificStorage)%dat(1), & ! intent(in): specific storage coefficient (m-1) + eqns_data%mpar_data%var(iLookPARAM%theta_sat)%dat, & ! intent(in): soil porosity (-) + eqns_data%model_decisions(iLookDECISIONS%f_Richards)%iDecision, & ! intent(in): choice of option for Richards' equation + eqns_data%model_decisions(iLookDECISIONS%nrgConserv)%iDecision.ne.closedForm, & ! intent(in): flag if enthalpy is state variable + ! input: data structures + eqns_data%indx_data, & ! intent(in): index data + eqns_data%prog_data, & ! intent(in): model prognostic variables for a local HRU + eqns_data%diag_data, & ! intent(in): model diagnostic variables for a local HRU + eqns_data%deriv_data, & ! intent(in): derivatives in model fluxes w.r.t. relevant state variables + eqns_data%dBaseflow_dMatric, & ! intent(in): derivative in baseflow w.r.t. matric head (s-1) + ! input: state variables + eqns_data%mLayerTempPrime, & ! intent(in): derivative value for temperature of each snow+soil layer (K) + eqns_data%mLayerMatricHeadPrime, & ! intent(in): derivative value for matric head of each snow+soil layer (m) + eqns_data%mLayerVolFracWatPrime, & ! intent(in): derivative value for volumetric total water content of each snow+soil layer (-) + eqns_data%scalarCanopyTempPrime, & ! intent(in): derivative value for temperature of the vegetation canopy (K) + eqns_data%scalarCanopyWatPrime, & ! intent(in): derivative value for total water content of the vegetation canopy (kg m-2) + ! input-output: Jacobian and its diagonal + eqns_data%dMat, & ! intent(in): diagonal of the Jacobian matrix excluding fluxes, not depending on the state vector + Jac, & ! intent(out): Jacobian matrix + ! output: error control + eqns_data%err,eqns_data%message) ! intent(out): error code and error message + if(eqns_data%err > 0)then; eqns_data%message=trim(eqns_data%message); ierr=-1; return; endif + if(eqns_data%err < 0)then; eqns_data%message=trim(eqns_data%message); ierr=1; return; endif + + ! return success + ierr = 0 + return + +end function computJacob4ida + +end module computJacobWithPrime_module diff --git a/build/source/engine/computResid.f90 b/build/source/engine/computResid.f90 old mode 100755 new mode 100644 index 3d3a6602a..82f51d903 --- a/build/source/engine/computResid.f90 +++ b/build/source/engine/computResid.f90 @@ -26,7 +26,7 @@ module computResid_module ! derived types to define the data structures USE data_types,only:& var_ilength, & ! data vector with variable length dimension (i4b) - var_dlength ! data vector with variable length dimension (dp) + var_dlength ! data vector with variable length dimension (rkind) ! named variables USE var_lookup,only:iLookPROG ! named variables for structure elements @@ -71,206 +71,258 @@ module computResid_module public::computResid contains - ! ********************************************************************************************************** - ! public subroutine computResid: compute the residual vector - ! ********************************************************************************************************** - subroutine computResid(& - ! input: model control - dt, & ! intent(in): length of the time step (seconds) - nSnow, & ! intent(in): number of snow layers - nSoil, & ! intent(in): number of soil layers - nLayers, & ! intent(in): total number of layers - ! input: flux vectors - sMul, & ! intent(in): state vector multiplier (used in the residual calculations) - fVec, & ! intent(in): flux vector - ! input: state variables (already disaggregated into scalars and vectors) - scalarCanairTempTrial, & ! intent(in): trial value for the temperature of the canopy air space (K) - scalarCanopyTempTrial, & ! intent(in): trial value for the temperature of the vegetation canopy (K) - scalarCanopyHydTrial, & ! intent(in): trial value of canopy water (kg m-2), either liquid water content or total water content - mLayerTempTrial, & ! intent(in): trial value for the temperature of each snow and soil layer (K) - mLayerVolFracHydTrial, & ! intent(in): trial vector of volumetric water content (-), either liquid water content or total water content - scalarAquiferStorageTrial, & ! intent(in): trial value of storage of water in the aquifer (m) - ! input: diagnostic variables defining the liquid water and ice content (function of state variables) - scalarCanopyIceTrial, & ! intent(in): trial value for the ice on the vegetation canopy (kg m-2) - mLayerVolFracIceTrial, & ! intent(in): trial value for the volumetric ice in each snow and soil layer (-) - ! input: data structures - prog_data, & ! intent(in): model prognostic variables for a local HRU - diag_data, & ! intent(in): model diagnostic variables for a local HRU - flux_data, & ! intent(in): model fluxes for a local HRU - indx_data, & ! intent(in): index data - ! output - rAdd, & ! intent(out): additional (sink) terms on the RHS of the state equation - rVec, & ! intent(out): residual vector - err,message) ! intent(out): error control - ! -------------------------------------------------------------------------------------------------------------------------------- - implicit none - ! input: model control - real(rkind),intent(in) :: dt ! length of the time step (seconds) - integer(i4b),intent(in) :: nSnow ! number of snow layers - integer(i4b),intent(in) :: nSoil ! number of soil layers - integer(i4b),intent(in) :: nLayers ! total number of layers in the snow+soil domain - ! input: flux vectors - real(rkind),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) - real(rkind),intent(in) :: fVec(:) ! flux vector - ! input: state variables (already disaggregated into scalars and vectors) - real(rkind),intent(in) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) - real(rkind),intent(in) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) - real(rkind),intent(in) :: scalarCanopyHydTrial ! trial value for canopy water (kg m-2), either liquid water content or total water content - real(rkind),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) - real(rkind),intent(in) :: mLayerVolFracHydTrial(:) ! trial vector of volumetric water content (-), either liquid water content or total water content - real(rkind),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) - ! input: diagnostic variables defining the liquid water and ice content (function of state variables) - real(rkind),intent(in) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) - real(rkind),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) - ! input: data structures - type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU - type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU - type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU - type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers - ! output - real(rkind),intent(out) :: rAdd(:) ! additional (sink) terms on the RHS of the state equation - real(rkind),intent(out) :: rVec(:) ! NOTE: qp ! residual vector - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! -------------------------------------------------------------------------------------------------------------------------------- - ! local variables - ! -------------------------------------------------------------------------------------------------------------------------------- - integer(i4b) :: iLayer ! index of layer within the snow+soil domain - integer(i4b),parameter :: ixVegVolume=1 ! index of the desired vegetation control volumne (currently only one veg layer) - real(rkind) :: scalarCanopyHyd ! canopy water content (kg m-2), either liquid water content or total water content - real(rkind),dimension(nLayers) :: mLayerVolFracHyd ! vector of volumetric water content (-), either liquid water content or total water content - ! -------------------------------------------------------------------------------------------------------------------------------- - ! -------------------------------------------------------------------------------------------------------------------------------- - ! link to the necessary variables for the residual computations - associate(& - ! model state variables (vegetation canopy) - scalarCanairTemp => prog_data%var(iLookPROG%scalarCanairTemp)%dat(1) ,& ! intent(in): [dp] temperature of the canopy air space (K) - scalarCanopyTemp => prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1) ,& ! intent(in): [dp] temperature of the vegetation canopy (K) - scalarCanopyIce => prog_data%var(iLookPROG%scalarCanopyIce)%dat(1) ,& ! intent(in): [dp] mass of ice on the vegetation canopy (kg m-2) - scalarCanopyLiq => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1) ,& ! intent(in): [dp] mass of liquid water on the vegetation canopy (kg m-2) - scalarCanopyWat => prog_data%var(iLookPROG%scalarCanopyWat)%dat(1) ,& ! intent(in): [dp] mass of total water on the vegetation canopy (kg m-2) - ! model state variables (snow and soil domains) - mLayerTemp => prog_data%var(iLookPROG%mLayerTemp)%dat ,& ! intent(in): [dp(:)] temperature of each snow/soil layer (K) - mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat ,& ! intent(in): [dp(:)] volumetric fraction of ice (-) - mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat ,& ! intent(in): [dp(:)] volumetric fraction of liquid water (-) - mLayerVolFracWat => prog_data%var(iLookPROG%mLayerVolFracWat)%dat ,& ! intent(in): [dp(:)] volumetric fraction of total water (-) - ! model state variables (aquifer) - scalarAquiferStorage => prog_data%var(iLookPROG%scalarAquiferStorage)%dat(1) ,& ! intent(in): [dp] storage of water in the aquifer (m) - ! canopy and layer depth - canopyDepth => diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1) ,& ! intent(in): [dp] canopy depth (m) - mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat ,& ! intent(in): [dp(:)] depth of each layer in the snow-soil sub-domain (m) - ! model fluxes (sink terms in the soil domain) - mLayerTranspire => flux_data%var(iLookFLUX%mLayerTranspire)%dat ,& ! intent(in): [dp] transpiration loss from each soil layer (m s-1) - mLayerBaseflow => flux_data%var(iLookFLUX%mLayerBaseflow)%dat ,& ! intent(in): [dp(:)] baseflow from each soil layer (m s-1) - mLayerCompress => diag_data%var(iLookDIAG%mLayerCompress)%dat ,& ! intent(in): [dp(:)] change in storage associated with compression of the soil matrix (-) - ! number of state variables of a specific type - nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg )%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow+soil domain - nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the snow+soil domain - nSoilOnlyHyd => indx_data%var(iLookINDEX%nSoilOnlyHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the soil domain - ! model indices - ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy air space energy state variable - ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable - ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) - ixAqWat => indx_data%var(iLookINDEX%ixAqWat)%dat(1) ,& ! intent(in): [i4b] index of water storage in the aquifer - ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in): [i4b(:)] indices for energy states in the snow+soil subdomain - ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in): [i4b(:)] indices for hydrology states in the snow+soil subdomain - ixSoilOnlyHyd => indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat ,& ! intent(in): [i4b(:)] indices for hydrology states in the soil subdomain - ixStateType => indx_data%var(iLookINDEX%ixStateType)%dat ,& ! intent(in): [i4b(:)] indices defining the type of the state (iname_nrgLayer...) - ixHydCanopy => indx_data%var(iLookINDEX%ixHydCanopy)%dat ,& ! intent(in): [i4b(:)] index of the hydrology states in the canopy domain - ixHydType => indx_data%var(iLookINDEX%ixHydType)%dat ,& ! intent(in): [i4b(:)] named variables defining the type of hydrology states in snow+soil domain - layerType => indx_data%var(iLookINDEX%layerType)%dat & ! intent(in): [i4b(:)] named variables defining the type of layer in snow+soil domain - ) ! association to necessary variables for the residual computations - ! -------------------------------------------------------------------------------------------------------------------------------- - ! initialize error control - err=0; message="computResid/" +! ********************************************************************************************************** +! public subroutine computResid: compute the residual vector +! ********************************************************************************************************** +subroutine computResid(& + ! input: model control + dt, & ! intent(in): length of the time step (seconds) + nSnow, & ! intent(in): number of snow layers + nSoil, & ! intent(in): number of soil layers + nLayers, & ! intent(in): total number of layers + mixdformNrg, & ! intent(in): flag to use enthalpy formulation + ! input: flux vectors + sMul, & ! intent(in): state vector multiplier (used in the residual calculations) + fVec, & ! intent(in): flux vector + ! input: state variables (already disaggregated into scalars and vectors) + scalarCanairTempTrial, & ! intent(in): trial value for the temperature of the canopy air space (K) + scalarCanopyTempTrial, & ! intent(in): trial value for the temperature of the vegetation canopy (K) + scalarCanopyWatTrial, & ! intent(in): trial value for the water on the vegetation canopy (kg m-2) + mLayerTempTrial, & ! intent(in): trial value for the temperature of each snow and soil layer (K) + scalarAquiferStorageTrial, & ! intent(in): trial value of storage of water in the aquifer (m) + ! input: diagnostic variables defining the liquid water and ice content (function of state variables) + scalarCanopyIceTrial, & ! intent(in): trial value for the ice on the vegetation canopy (kg m-2) + scalarCanopyLiqTrial, & ! intent(in): trial value for the liq on the vegetation canopy (kg m-2) + mLayerVolFracIceTrial, & ! intent(in): trial value for the volumetric ice in each snow and soil layer (-) + mLayerVolFracWatTrial, & ! intent(in): trial value for the volumetric water in each snow and soil layer (-) + mLayerVolFracLiqTrial, & ! intent(in): trial value for the volumetric liq in each snow and soil layer (-) + ! input: enthalpy terms + scalarCanopyCmTrial, & ! intent(in): Cm for vegetation canopy (J kg-1) + mLayerCmTrial, & ! intent(in): Cm for each snow+soil layer (J m-3) + scalarCanairEnthalpyTrial, & ! intent(in): trial value for enthalpy of the canopy air space (J m-3) + scalarCanopyEnthTempTrial, & ! intent(in): trial value for temperature component of enthalpy of the vegetation canopy (J m-3) + mLayerEnthTempTrial, & ! intent(in): trial vector of temperature component of enthalpy of each snow+soil layer (J m-3) + ! input: data structures + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(in): model diagnostic variables for a local HRU + flux_data, & ! intent(in): model fluxes for a local HRU + indx_data, & ! intent(in): index data + ! output + rAdd, & ! intent(out): additional (sink) terms on the RHS of the state equation + rVec, & ! intent(out): residual vector + err,message) ! intent(out): error control + ! -------------------------------------------------------------------------------------------------------------------------------- + implicit none + ! input: model control + real(rkind),intent(in) :: dt ! length of the time step (seconds) + integer(i4b),intent(in) :: nSnow ! number of snow layers + integer(i4b),intent(in) :: nSoil ! number of soil layers + integer(i4b),intent(in) :: nLayers ! total number of layers in the snow+soil domain + logical(lgt),intent(in) :: mixdformNrg ! flag to use enthalpy formulation + ! input: flux vectors + real(qp),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) + real(rkind),intent(in) :: fVec(:) ! flux vector + ! input: state variables (already disaggregated into scalars and vectors) + real(rkind),intent(in) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) + real(rkind),intent(in) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) + real(rkind),intent(in) :: scalarCanopyWatTrial ! trial value for canopy total water content (kg m-2) + real(rkind),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) + real(rkind),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) + ! input: diagnostic variables defining the liquid water and ice content (function of state variables) + real(rkind),intent(in) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) + real(rkind),intent(in) :: scalarCanopyLiqTrial ! trial value for the liq on the vegetation canopy (kg m-2) + real(rkind),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) + real(rkind),intent(in) :: mLayerVolFracWatTrial(:) ! trial value for the volumetric water in each snow and soil layer (-) + real(rkind),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for the volumetric water in each snow and soil layer (-) + ! input: enthalpy terms + real(rkind),intent(in) :: scalarCanopyCmTrial ! Cm for vegetation canopy (J kg-1) + real(rkind),intent(in) :: mLayerCmTrial(:) ! Cm for each snow+soil layer (J m-3) + real(rkind),intent(in) :: scalarCanairEnthalpyTrial ! trial value for enthalpy of the canopy air space (J m-3) + real(rkind),intent(in) :: scalarCanopyEnthTempTrial ! trial value for temperature component of enthalpy of the vegetation canopy (J m-3) + real(rkind),intent(in) :: mLayerEnthTempTrial(:) ! trial vector of temperature component of enthalpy of each snow+soil layer (J m-3) + ! input: data structures + type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU + type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU + type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers + ! output + real(rkind),intent(out) :: rAdd(:) ! additional (sink) terms on the RHS of the state equation + real(qp),intent(out) :: rVec(:) ! NOTE: qp ! residual vector + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! -------------------------------------------------------------------------------------------------------------------------------- + ! local variables + ! -------------------------------------------------------------------------------------------------------------------------------- + integer(i4b) :: iLayer ! index of layer within the snow+soil domain + integer(i4b),parameter :: ixVegVolume=1 ! index of the desired vegetation control volumne (currently only one veg layer) + real(rkind) :: scalarCanopyHydTrial ! trial value of canopy water content (kg m-2), either liquid water content or total water content + real(rkind) :: scalarCanopyHyd ! canopy water content (kg m-2), either liquid water content or total water content + real(rkind),dimension(nLayers) :: mLayerVolFracHydTrial ! trial vector of volumetric water content (-), either liquid water content or total water content + real(rkind),dimension(nLayers) :: mLayerVolFracHyd ! vector of volumetric water content (-), either liquid water content or total water content + ! -------------------------------------------------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------------------------------------------------- + ! link to the necessary variables for the residual computations + associate(& + ! model state variables (vegetation canopy) + scalarCanairTemp => prog_data%var(iLookPROG%scalarCanairTemp)%dat(1) ,& ! intent(in): [dp] temperature of the canopy air space (K) + scalarCanopyTemp => prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1) ,& ! intent(in): [dp] temperature of the vegetation canopy (K) + scalarCanopyIce => prog_data%var(iLookPROG%scalarCanopyIce)%dat(1) ,& ! intent(in): [dp] mass of ice on the vegetation canopy (kg m-2) + scalarCanopyLiq => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1) ,& ! intent(in): [dp] mass of liquid water on the vegetation canopy (kg m-2) + scalarCanopyWat => prog_data%var(iLookPROG%scalarCanopyWat)%dat(1) ,& ! intent(in): [dp] mass of total water on the vegetation canopy (kg m-2) + ! model state variables (snow and soil domains) + mLayerTemp => prog_data%var(iLookPROG%mLayerTemp)%dat ,& ! intent(in): [dp(:)] temperature of each snow/soil layer (K) + mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat ,& ! intent(in): [dp(:)] volumetric fraction of ice (-) + mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat ,& ! intent(in): [dp(:)] volumetric fraction of liquid water (-) + mLayerVolFracWat => prog_data%var(iLookPROG%mLayerVolFracWat)%dat ,& ! intent(in): [dp(:)] volumetric fraction of total water (-) + ! enthalpy terms + scalarCanairEnthalpy => prog_data%var(iLookPROG%scalarCanairEnthalpy)%dat(1) ,& ! intent(in): [dp] enthalpy of the canopy air space (J m-3) + scalarCanopyEnthTemp => diag_data%var(iLookDIAG%scalarCanopyEnthTemp)%dat(1) ,& ! intent(in): [dp] temperature component of enthalpy of the vegetation canopy (J m-3) + mLayerEnthTemp => diag_data%var(iLookDIAG%mLayerEnthTemp)%dat ,& ! intent(in): [dp(:)] temperature component of enthalpy of the snow+soil layers (J m-3) + ! model state variables (aquifer) + scalarAquiferStorage => prog_data%var(iLookPROG%scalarAquiferStorage)%dat(1) ,& ! intent(in): [dp] storage of water in the aquifer (m) + ! canopy and layer depth + canopyDepth => diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1) ,& ! intent(in): [dp] canopy depth (m) + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat ,& ! intent(in): [dp(:)] depth of each layer in the snow-soil sub-domain (m) + ! model fluxes (sink terms in the soil domain) + mLayerTranspire => flux_data%var(iLookFLUX%mLayerTranspire)%dat ,& ! intent(in): [dp] transpiration loss from each soil layer (m s-1) + mLayerBaseflow => flux_data%var(iLookFLUX%mLayerBaseflow)%dat ,& ! intent(in): [dp(:)] baseflow from each soil layer (m s-1) + mLayerCompress => diag_data%var(iLookDIAG%mLayerCompress)%dat ,& ! intent(in): [dp(:)] change in storage associated with compression of the soil matrix (-) + ! number of state variables of a specific type + nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg )%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow+soil domain + nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the snow+soil domain + nSoilOnlyHyd => indx_data%var(iLookINDEX%nSoilOnlyHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the soil domain + ! model indices + ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy air space energy state variable + ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable + ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) + ixAqWat => indx_data%var(iLookINDEX%ixAqWat)%dat(1) ,& ! intent(in): [i4b] index of water storage in the aquifer + ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in): [i4b(:)] indices for energy states in the snow+soil subdomain + ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in): [i4b(:)] indices for hydrology states in the snow+soil subdomain + ixSoilOnlyHyd => indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat ,& ! intent(in): [i4b(:)] indices for hydrology states in the soil subdomain + ixStateType => indx_data%var(iLookINDEX%ixStateType)%dat ,& ! intent(in): [i4b(:)] indices defining the type of the state (iname_nrgLayer...) + ixHydCanopy => indx_data%var(iLookINDEX%ixHydCanopy)%dat ,& ! intent(in): [i4b(:)] index of the hydrology states in the canopy domain + ixHydType => indx_data%var(iLookINDEX%ixHydType)%dat ,& ! intent(in): [i4b(:)] named variables defining the type of hydrology states in snow+soil domain + layerType => indx_data%var(iLookINDEX%layerType)%dat & ! intent(in): [i4b(:)] named variables defining the type of layer in snow+soil domain + ) ! association to necessary variables for the residual computations + ! -------------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message="computResid/" - ! --- - ! * compute sink terms... - ! ----------------------- + ! --- + ! * compute sink terms... + ! ----------------------- - ! intialize additional terms on the RHS as zero - rAdd(:) = 0._rkind + ! intialize additional terms on the RHS as zero + rAdd(:) = 0._rkind - ! compute energy associated with melt freeze for the vegetation canopy - if(ixVegNrg/=integerMissing) rAdd(ixVegNrg) = rAdd(ixVegNrg) + LH_fus*(scalarCanopyIceTrial - scalarCanopyIce)/canopyDepth ! energy associated with melt/freeze (J m-3) + ! compute energy associated with melt freeze for the vegetation canopy + if(ixVegNrg/=integerMissing) rAdd(ixVegNrg) = rAdd(ixVegNrg) + LH_fus*( scalarCanopyIceTrial - scalarCanopyIce )/canopyDepth ! energy associated with melt/freeze (J m-3) - ! compute energy associated with melt/freeze for snow - ! NOTE: allow expansion of ice during melt-freeze for snow; deny expansion of ice during melt-freeze for soil - if(nSnowSoilNrg>0)then - do concurrent (iLayer=1:nLayers,ixSnowSoilNrg(iLayer)/=integerMissing) ! (loop through non-missing energy state variables in the snow+soil domain) - select case( layerType(iLayer) ) - case(iname_snow); rAdd( ixSnowSoilNrg(iLayer) ) = rAdd( ixSnowSoilNrg(iLayer) ) + LH_fus*iden_ice *(mLayerVolFracIceTrial(iLayer) - mLayerVolFracIce(iLayer)) - case(iname_soil); rAdd( ixSnowSoilNrg(iLayer) ) = rAdd( ixSnowSoilNrg(iLayer) ) + LH_fus*iden_water*(mLayerVolFracIceTrial(iLayer) - mLayerVolFracIce(iLayer)) - end select - end do ! looping through non-missing energy state variables in the snow+soil domain - endif + ! compute energy associated with melt/freeze for snow + ! NOTE: allow expansion of ice during melt-freeze for snow; deny expansion of ice during melt-freeze for soil + if(nSnowSoilNrg>0)then + do concurrent (iLayer=1:nLayers,ixSnowSoilNrg(iLayer)/=integerMissing) ! (loop through non-missing energy state variables in the snow+soil domain) + select case( layerType(iLayer) ) + case(iname_snow); rAdd( ixSnowSoilNrg(iLayer) ) = rAdd( ixSnowSoilNrg(iLayer) ) + LH_fus*iden_ice *( mLayerVolFracIceTrial(iLayer) - mLayerVolFracIce(iLayer) ) + case(iname_soil); rAdd( ixSnowSoilNrg(iLayer) ) = rAdd( ixSnowSoilNrg(iLayer) ) + LH_fus*iden_water*( mLayerVolFracIceTrial(iLayer) - mLayerVolFracIce(iLayer) ) + end select + end do ! looping through non-missing energy state variables in the snow+soil domain + endif - ! sink terms soil hydrology (-) - ! NOTE 1: state variable is volumetric water content, so melt-freeze is not included - ! NOTE 2: ground evaporation was already included in the flux at the upper boundary - ! NOTE 3: rAdd(ixSnowOnlyWat)=0, and is defined in the initialization above - ! NOTE 4: same sink terms for matric head and liquid matric potential - if(nSoilOnlyHyd>0)then - do concurrent (iLayer=1:nSoil,ixSoilOnlyHyd(iLayer)/=integerMissing) ! (loop through non-missing hydrology state variables in the snow+soil domain) - rAdd( ixSoilOnlyHyd(iLayer) ) = rAdd( ixSoilOnlyHyd(iLayer) ) + dt*(mLayerTranspire(iLayer) - mLayerBaseflow(iLayer) )/mLayerDepth(iLayer+nSnow) - mLayerCompress(iLayer) - end do ! looping through non-missing energy state variables in the snow+soil domain - endif + ! sink terms soil hydrology (-) + ! NOTE 1: state variable is volumetric water content, so melt-freeze is not included + ! NOTE 2: ground evaporation was already included in the flux at the upper boundary + ! NOTE 3: rAdd(ixSnowOnlyWat)=0, and is defined in the initialization above + ! NOTE 4: same sink terms for matric head and liquid matric potential + if(nSoilOnlyHyd>0)then + do concurrent (iLayer=1:nSoil,ixSoilOnlyHyd(iLayer)/=integerMissing) ! (loop through non-missing hydrology state variables in the snow+soil domain) + rAdd( ixSoilOnlyHyd(iLayer) ) = rAdd( ixSoilOnlyHyd(iLayer) ) + ( ( mLayerTranspire(iLayer) - mLayerBaseflow(iLayer) )/mLayerDepth(iLayer+nSnow) - mLayerCompress(iLayer) )*dt + end do ! looping through non-missing energy state variables in the snow+soil domain + endif - ! --- - ! * compute the residual vector... - ! -------------------------------- + ! --- + ! * compute the residual vector... + ! -------------------------------- - ! compute the residual vector for the vegetation canopy - ! NOTE: sMul(ixVegHyd) = 1, but include as it converts all variables to quadruple precision - ! --> energy balance - if(ixCasNrg/=integerMissing) rVec(ixCasNrg) = sMul(ixCasNrg)*scalarCanairTempTrial - ( (sMul(ixCasNrg)*scalarCanairTemp + fVec(ixCasNrg)*dt) + rAdd(ixCasNrg) ) - if(ixVegNrg/=integerMissing) rVec(ixVegNrg) = sMul(ixVegNrg)*scalarCanopyTempTrial - ( (sMul(ixVegNrg)*scalarCanopyTemp + fVec(ixVegNrg)*dt) + rAdd(ixVegNrg) ) + ! compute the residual vector for the vegetation canopy + ! NOTE: sMul(ixVegHyd) = 1, but include as it converts all variables to quadruple precision + ! --> energy balance + if(mixdformNrg)then + if(ixCasNrg/=integerMissing) rVec(ixCasNrg) = ( scalarCanairEnthalpyTrial - scalarCanairEnthalpy ) - ( fVec(ixCasNrg)*dt + rAdd(ixCasNrg) ) + if(ixVegNrg/=integerMissing) rVec(ixVegNrg) = ( scalarCanopyEnthTempTrial - scalarCanopyEnthTemp ) - ( fVec(ixVegNrg)*dt + rAdd(ixVegNrg) ) + else + if(ixCasNrg/=integerMissing) rVec(ixCasNrg) = sMul(ixCasNrg)*( scalarCanairTempTrial - scalarCanairTemp ) - ( fVec(ixCasNrg)*dt + rAdd(ixCasNrg) ) + if(ixVegNrg/=integerMissing) rVec(ixVegNrg) = sMul(ixVegNrg)*( scalarCanopyTempTrial - scalarCanopyTemp ) + scalarCanopyCmTrial*( scalarCanopyWatTrial - scalarCanopyWat )/canopyDepth & + - ( fVec(ixVegNrg)*dt + rAdd(ixVegNrg) ) + endif + ! --> mass balance + if(ixVegHyd/=integerMissing)then + scalarCanopyHydTrial = merge(scalarCanopyWatTrial, scalarCanopyLiqTrial, (ixStateType( ixHydCanopy(ixVegVolume) )==iname_watCanopy) ) + scalarCanopyHyd = merge(scalarCanopyWat, scalarCanopyLiq, (ixStateType( ixHydCanopy(ixVegVolume) )==iname_watCanopy) ) + rVec(ixVegHyd) = sMul(ixVegHyd)*scalarCanopyHydTrial - ( sMul(ixVegHyd)*scalarCanopyHyd + fVec(ixVegHyd)*dt + rAdd(ixVegHyd) ) + endif - ! --> mass balance - if(ixVegHyd/=integerMissing)then - scalarCanopyHyd = merge(scalarCanopyWat, scalarCanopyLiq, (ixStateType( ixHydCanopy(ixVegVolume) )==iname_watCanopy) ) - rVec(ixVegHyd) = sMul(ixVegHyd)*scalarCanopyHydTrial - ( (sMul(ixVegHyd)*scalarCanopyHyd + fVec(ixVegHyd)*dt) + rAdd(ixVegHyd) ) - endif + ! compute the residual vector for the snow and soil sub-domains for energy + if(nSnowSoilNrg>0)then + do concurrent (iLayer=1:nLayers,ixSnowSoilNrg(iLayer)/=integerMissing) ! (loop through non-missing energy state variables in the snow+soil domain) + if(mixdformNrg)then + rVec( ixSnowSoilNrg(iLayer) ) = ( mLayerEnthTempTrial(iLayer) - mLayerEnthTemp(iLayer) ) - ( fVec( ixSnowSoilNrg(iLayer) )*dt + rAdd( ixSnowSoilNrg(iLayer) ) ) + else + rVec( ixSnowSoilNrg(iLayer) ) = sMul( ixSnowSoilNrg(iLayer) )*( mLayerTempTrial(iLayer) - mLayerTemp(iLayer) ) + mLayerCmTrial(iLayer)*( mLayerVolFracWatTrial(iLayer) - mLayerVolFracWat(iLayer) ) & + - ( fVec( ixSnowSoilNrg(iLayer) )*dt + rAdd( ixSnowSoilNrg(iLayer) ) ) + endif + end do ! looping through non-missing energy state variables in the snow+soil domain + endif - ! compute the residual vector for the snow and soil sub-domains for energy - if(nSnowSoilNrg>0)then - do concurrent (iLayer=1:nLayers,ixSnowSoilNrg(iLayer)/=integerMissing) ! (loop through non-missing energy state variables in the snow+soil domain) - rVec( ixSnowSoilNrg(iLayer) ) = sMul( ixSnowSoilNrg(iLayer) )*mLayerTempTrial(iLayer) - ( (sMul( ixSnowSoilNrg(iLayer) )*mLayerTemp(iLayer) + fVec( ixSnowSoilNrg(iLayer) )*dt) + rAdd( ixSnowSoilNrg(iLayer) ) ) - end do ! looping through non-missing energy state variables in the snow+soil domain - endif + ! compute the residual vector for the snow and soil sub-domains for hydrology + ! NOTE: residual depends on choice of state variable + if(nSnowSoilHyd>0)then + do concurrent (iLayer=1:nLayers,ixSnowSoilHyd(iLayer)/=integerMissing) ! (loop through non-missing hydrology state variables in the snow+soil domain) + ! (get the correct state variable) + mLayerVolFracHydTrial(iLayer) = merge(mLayerVolFracWatTrial(iLayer), mLayerVolFracLiqTrial(iLayer) , (ixHydType(iLayer)==iname_watLayer .or. ixHydType(iLayer)==iname_matLayer) ) + mLayerVolFracHyd(iLayer) = merge(mLayerVolFracWat(iLayer), mLayerVolFracLiq(iLayer), (ixHydType(iLayer)==iname_watLayer .or. ixHydType(iLayer)==iname_matLayer) ) + ! (compute the residual) + rVec( ixSnowSoilHyd(iLayer) ) = ( mLayerVolFracHydTrial(iLayer) - mLayerVolFracHyd(iLayer) ) - ( fVec( ixSnowSoilHyd(iLayer) )*dt + rAdd( ixSnowSoilHyd(iLayer) ) ) + end do ! looping through non-missing energy state variables in the snow+soil domain + endif - ! compute the residual vector for the snow and soil sub-domains for hydrology - ! NOTE: residual depends on choice of state variable - if(nSnowSoilHyd>0)then - do concurrent (iLayer=1:nLayers,ixSnowSoilHyd(iLayer)/=integerMissing) ! (loop through non-missing hydrology state variables in the snow+soil domain) - ! (get the correct state variable) - mLayerVolFracHyd(iLayer) = merge(mLayerVolFracWat(iLayer), mLayerVolFracLiq(iLayer), (ixHydType(iLayer)==iname_watLayer .or. ixHydType(iLayer)==iname_matLayer) ) - ! (compute the residual) - rVec( ixSnowSoilHyd(iLayer) ) = mLayerVolFracHydTrial(iLayer) - ( (mLayerVolFracHyd(iLayer) + fVec( ixSnowSoilHyd(iLayer) )*dt) + rAdd( ixSnowSoilHyd(iLayer) ) ) - end do ! looping through non-missing energy state variables in the snow+soil domain - endif + ! compute the residual vector for the aquifer + if(ixAqWat/=integerMissing) rVec(ixAqWat) = sMul(ixAqWat)*( scalarAquiferStorageTrial - scalarAquiferStorage ) - ( fVec(ixAqWat)*dt + rAdd(ixAqWat) ) - ! compute the residual vector for the aquifer - if(ixAqWat/=integerMissing) rVec(ixAqWat) = sMul(ixAqWat)*scalarAquiferStorageTrial - ( (sMul(ixAqWat)*scalarAquiferStorage + fVec(ixAqWat)*dt) + rAdd(ixAqWat) ) + ! print the state variables if requested + if(globalPrintFlag)then + write(*,'(a)') 'In computResid:' + write(*,'(a,i4)') ' nSnow = ', nSnow + write(*,'(a,i4)') ' nSoil = ', nSoil + write(*,'(a,i4)') ' nLayers = ', nLayers + write(*,'(a,f12.5)') ' dt = ', dt + write(*,'(a,1x,100(e12.5,1x))') ' sMul = ', sMul(min(iJac1,size(sMul)):min(iJac2,size(sMul))) + write(*,'(a,1x,100(e12.5,1x))') ' fVec = ', fVec(min(iJac1,size(fVec)):min(iJac2,size(fVec))) + write(*,'(a,f12.5)') ' scalarCanairTempTrial = ', scalarCanairTempTrial + write(*,'(a,f12.5)') ' scalarCanopyTempTrial = ', scalarCanopyTempTrial + write(*,'(a,f12.5)') ' scalarCanopyWatTrial = ', scalarCanopyWatTrial + write(*,'(a,1x,100(e12.5,1x))') ' mLayerTempTrial = ', mLayerTempTrial(min(iJac1,size(mLayerTempTrial)):min(iJac2,size(mLayerTempTrial))) + write(*,'(a,f12.5)') ' scalarAquiferStorageTrial = ', scalarAquiferStorageTrial + write(*,'(a,f12.5)') ' scalarCanopyIceTrial = ', scalarCanopyIceTrial + write(*,'(a,f12.5)') ' scalarCanopyLiqTrial = ', scalarCanopyLiqTrial + write(*,'(a,1x,100(e12.5,1x))') ' mLayerVolFracIceTrial = ', mLayerVolFracIceTrial(min(iJac1,size(mLayerVolFracIceTrial)):min(iJac2,size(mLayerVolFracIceTrial))) + write(*,'(a,1x,100(e12.5,1x))') ' mLayerVolFracWatTrial = ', mLayerVolFracWatTrial(min(iJac1,size(mLayerVolFracWatTrial)):min(iJac2,size(mLayerVolFracWatTrial))) + write(*,'(a,1x,100(e12.5,1x))') ' mLayerVolFracLiqTrial = ', mLayerVolFracLiqTrial(min(iJac1,size(mLayerVolFracLiqTrial)):min(iJac2,size(mLayerVolFracLiqTrial))) + write(*,'(a,f12.5)') ' scalarCanopyCmTrial = ', scalarCanopyCmTrial + write(*,'(a,1x,100(e12.5,1x))') ' mLayerCmTrial = ', mLayerCmTrial(min(iJac1,size(mLayerCmTrial)):min(iJac2,size(mLayerCmTrial))) + write(*,'(a,f12.5)') ' scalarCanairEnthalpyTrial = ', scalarCanairEnthalpyTrial + write(*,'(a,f12.5)') ' scalarCanopyEnthTempTrial = ', scalarCanopyEnthTempTrial + write(*,'(a,1x,100(e12.5,1x))') ' mLayerEnthTempTrial = ', mLayerEnthTempTrial(min(iJac1,size(mLayerEnthTempTrial)):min(iJac2,size(mLayerEnthTempTrial))) + endif - ! print result - if(globalPrintFlag)then - write(*,'(a,1x,100(e12.5,1x))') 'rVec = ', rVec(min(iJac1,size(rVec)):min(iJac2,size(rVec))) - write(*,'(a,1x,100(e12.5,1x))') 'fVec = ', fVec(min(iJac1,size(rVec)):min(iJac2,size(rVec))) - !print*, 'PAUSE:'; read(*,*) - endif + if(globalPrintFlag .or. any(isNan(rVec)))then + write(*,'(a,1x,100(e12.5,1x))') 'rVec = ', rVec(min(iJac1,size(rVec)):min(iJac2,size(rVec))) + write(*,'(a,1x,100(e12.5,1x))') 'fVec = ', fVec(min(iJac1,size(rVec)):min(iJac2,size(rVec))) + endif + if(any(isNan(rVec)))then; message=trim(message)//'NaN in residuals'; err=20; return; endif - ! check - if(any(isNan(rVec)))then - message=trim(message)//'vector of residuals contains NaN value(s)' ! formerly known as the Indian bread error - write(*,'(a,1x,100(e12.5,1x))') 'rVec = ', rVec(min(iJac1,size(rVec)):min(iJac2,size(rVec))) - write(*,'(a,1x,100(e12.5,1x))') 'fVec = ', fVec(min(iJac1,size(rVec)):min(iJac2,size(rVec))) - err=20; return - endif + end associate - ! end association with the necessary variabiles for the residual calculations - end associate - - end subroutine computResid +end subroutine computResid end module computResid_module diff --git a/build/source/engine/computResidWithPrime.f90 b/build/source/engine/computResidWithPrime.f90 new file mode 100644 index 000000000..0e91931d5 --- /dev/null +++ b/build/source/engine/computResidWithPrime.f90 @@ -0,0 +1,294 @@ + + +module computResidWithPrime_module + +! data types +USE nrtype + +! derived types to define the data structures +USE data_types,only:& + var_ilength, & ! data vector with variable length dimension (i4b) + var_dlength ! data vector with variable length dimension (rkind) + +! named variables +USE var_lookup,only:iLookPROG ! named variables for structure elements +USE var_lookup,only:iLookDIAG ! named variables for structure elements +USE var_lookup,only:iLookFLUX ! named variables for structure elements +USE var_lookup,only:iLookINDEX ! named variables for structure elements + +! access the global print flag +USE globalData,only:globalPrintFlag + +! access missing values +USE globalData,only:integerMissing ! missing integer +USE globalData,only:realMissing ! missing real number + +! define access to state variables to print +USE globalData,only: iJac1 ! first layer of the Jacobian to print +USE globalData,only: iJac2 ! last layer of the Jacobian to print + +! domain types +USE globalData,only:iname_veg ! named variables for vegetation +USE globalData,only:iname_snow ! named variables for snow +USE globalData,only:iname_soil ! named variables for soil + +! named variables to describe the state variable type +USE globalData,only:iname_nrgCanair ! named variable defining the energy of the canopy air space +USE globalData,only:iname_nrgCanopy ! named variable defining the energy of the vegetation canopy +USE globalData,only:iname_watCanopy ! named variable defining the mass of water on the vegetation canopy +USE globalData,only:iname_nrgLayer ! named variable defining the energy state variable for snow+soil layers +USE globalData,only:iname_watLayer ! named variable defining the total water state variable for snow+soil layers +USE globalData,only:iname_liqLayer ! named variable defining the liquid water state variable for snow+soil layers +USE globalData,only:iname_matLayer ! named variable defining the matric head state variable for soil layers +USE globalData,only:iname_lmpLayer ! named variable defining the liquid matric potential state variable for soil layers + +! constants +USE multiconst,only:& + LH_fus, & ! latent heat of fusion (J kg-1) + iden_ice, & ! intrinsic density of ice (kg m-3) + iden_water ! intrinsic density of liquid water (kg m-3) +! privacy +implicit none +public::computResidWithPrime +contains + +! ********************************************************************************************************** +! public subroutine computResidWithPrime: compute the residual vector +! ********************************************************************************************************** +subroutine computResidWithPrime(& + ! input: model control + dt, & ! intent(in): length of the time step (seconds) + nSnow, & ! intent(in): number of snow layers + nSoil, & ! intent(in): number of soil layers + nLayers, & ! intent(in): total number of layers + enthalpyStateVec, & ! intent(in): flag if enthalpy is state variable + ! input: flux vectors + sMul, & ! intent(in): state vector multiplier (used in the residual calculations) + fVec, & ! intent(in): flux vector + ! input: state variables (already disaggregated into scalars and vectors) + scalarCanairTempPrime, & ! intent(in): prime value for the temperature of the canopy air space (K s-1) + scalarCanopyTempPrime, & ! intent(in): prime value for the temperature of the vegetation canopy (K s-1) + scalarCanopyWatPrime, & ! intent(in): prime value for the water on the vegetation canopy (kg m-2 s-1) + mLayerTempPrime, & ! intent(in): prime vector of the temperature of each snow and soil layer (K s-1) + scalarAquiferStoragePrime, & ! intent(in): prime value for storage of water in the aquifer (m s-1) + ! input: diagnostic variables defining the liquid water and ice content (function of state variables) + scalarCanopyIcePrime, & ! intent(in): prime value for the ice on the vegetation canopy (kg m-2 s-1) + scalarCanopyLiqPrime, & ! intent(in): prime value for the liq on the vegetation canopy (kg m-2 s-1) + mLayerVolFracIcePrime, & ! intent(in): prime vector of the volumetric ice in each snow and soil layer (s-1) + mLayerVolFracWatPrime, & ! intent(in): prime vector of the volumetric water in each snow and soil layer (s-1) + mLayerVolFracLiqPrime, & ! intent(in): prime vector of the volumetric liq in each snow and soil layer (s-1) + ! input: enthalpy terms + scalarCanopyCmTrial, & ! intent(in): Cm for vegetation canopy (J kg-1) + mLayerCmTrial, & ! intent(in): Cm for each snow+soil layer (J m-3) + scalarCanairEnthalpyPrime, & ! intent(in): prime value for the enthalpy of the canopy air space (W m-3) + scalarCanopyEnthalpyPrime, & ! intent(in): prime value for the of enthalpy of the vegetation canopy (W m-3) + mLayerEnthalpyPrime, & ! intent(in): prime vector of the of enthalpy of each snow and soil layer (W m-3) + ! input: data structures + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(in): model diagnostic variables for a local HRU + flux_data, & ! intent(in): model fluxes for a local HRU + indx_data, & ! intent(in): index data + ! output + rAdd, & ! intent(out): additional (sink) terms on the RHS of the state equation + rVec, & ! intent(out): residual vector + err,message) ! intent(out): error control + ! -------------------------------------------------------------------------------------------------------------------------------- + implicit none + ! input: model control + real(rkind),intent(in) :: dt ! length of the time step (seconds) + integer(i4b),intent(in) :: nSnow ! number of snow layers + integer(i4b),intent(in) :: nSoil ! number of soil layers + integer(i4b),intent(in) :: nLayers ! total number of layers in the snow+soil domain + logical(lgt),intent(in) :: enthalpyStateVec ! flag if enthalpy is state variable + ! input: flux vectors + real(qp),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) + real(rkind),intent(in) :: fVec(:) ! flux vector + ! input: state variables (already disaggregated into scalars and vectors) + real(rkind),intent(in) :: scalarCanairTempPrime ! prime value for temperature of the canopy air space (K s-1) + real(rkind),intent(in) :: scalarCanopyTempPrime ! prime value for temperature of the vegetation canopy (K s-1) + real(rkind),intent(in) :: scalarCanopyWatPrime ! prime value for canopy total water content (kg m-2 s-1) + real(rkind),intent(in) :: mLayerTempPrime(:) ! prime vector of temperature of each snow/soil layer (K s-1) content + real(rkind),intent(in) :: scalarAquiferStoragePrime ! prime value of aquifer storage (m s-1) + ! input: diagnostic variables defining the liquid water and ice content (function of state variables) + real(rkind),intent(in) :: scalarCanopyIcePrime ! prime value for mass of ice on the vegetation canopy (kg m-2 s-1) + real(rkind),intent(in) :: scalarCanopyLiqPrime ! prime value for the liq on the vegetation canopy (kg m-2 s-1) + real(rkind),intent(in) :: mLayerVolFracIcePrime(:) ! prime vector of volumetric fraction of ice (s-1) + real(rkind),intent(in) :: mLayerVolFracWatPrime(:) ! prime vector of the volumetric water in each snow and soil layer (s-1) + real(rkind),intent(in) :: mLayerVolFracLiqPrime(:) ! prime vector of the volumetric water in each snow and soil layer (s-1) + ! input: enthalpy terms + real(rkind),intent(in) :: scalarCanopyCmTrial ! Cm for vegetation canopy (J kg-1) + real(rkind),intent(in) :: mLayerCmTrial(:) ! Cm for each snow+soil layer (J m-3) + real(rkind),intent(in) :: scalarCanairEnthalpyPrime ! prime value for enthalpy of the canopy air space (W m-3) + real(rkind),intent(in) :: scalarCanopyEnthalpyPrime ! prime value for enthalpy of the vegetation canopy (W m-3) + real(rkind),intent(in) :: mLayerEnthalpyPrime(:) ! prime vector of enthalpy of each snow and soil layer (W m-3) + ! input: data structures + type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU + type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU + type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers + ! output + real(rkind),intent(out) :: rAdd(:) ! additional (sink) terms on the RHS of the state equation + real(qp),intent(out) :: rVec(:) ! NOTE: qp ! residual vector + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! -------------------------------------------------------------------------------------------------------------------------------- + ! local variables + ! -------------------------------------------------------------------------------------------------------------------------------- + integer(i4b) :: iLayer ! index of layer within the snow+soil domain + integer(i4b),parameter :: ixVegVolume=1 ! index of the desired vegetation control volumne (currently only one veg layer) + real(rkind) :: scalarCanopyHydPrime ! trial value for canopy water (kg m-2), either liquid water content or total water content + real(rkind),dimension(nLayers) :: mLayerVolFracHydPrime ! vector of volumetric water content (-), either liquid water content or total water content + ! -------------------------------------------------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------------------------------------------------- + ! link to the necessary variables for the residual computations + associate(& + ! canopy and layer depth + canopyDepth => diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1) ,& ! intent(in): [dp] canopy depth (m) + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat ,& ! intent(in): [dp(:)] depth of each layer in the snow-soil sub-domain (m) + ! model fluxes (sink terms in the soil domain) + mLayerTranspire => flux_data%var(iLookFLUX%mLayerTranspire)%dat ,& ! intent(in): [dp] transpiration loss from each soil layer (m s-1) + mLayerBaseflow => flux_data%var(iLookFLUX%mLayerBaseflow)%dat ,& ! intent(in): [dp(:)] baseflow from each soil layer (m s-1) + mLayerCompress => diag_data%var(iLookDIAG%mLayerCompress)%dat ,& ! intent(in): [dp(:)] change in storage associated with compression of the soil matrix (-) + ! number of state variables of a specific type + nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg )%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow+soil domain + nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the snow+soil domain + nSoilOnlyHyd => indx_data%var(iLookINDEX%nSoilOnlyHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the soil domain + ! model indices + ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy air space energy state variable + ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable + ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) + ixAqWat => indx_data%var(iLookINDEX%ixAqWat)%dat(1) ,& ! intent(in): [i4b] index of water storage in the aquifer + ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in): [i4b(:)] indices for energy states in the snow+soil subdomain + ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in): [i4b(:)] indices for hydrology states in the snow+soil subdomain + ixSoilOnlyHyd => indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat ,& ! intent(in): [i4b(:)] indices for hydrology states in the soil subdomain + ixStateType => indx_data%var(iLookINDEX%ixStateType)%dat ,& ! intent(in): [i4b(:)] indices defining the type of the state (iname_nrgLayer...) + ixHydCanopy => indx_data%var(iLookINDEX%ixHydCanopy)%dat ,& ! intent(in): [i4b(:)] index of the hydrology states in the canopy domain + ixHydType => indx_data%var(iLookINDEX%ixHydType)%dat ,& ! intent(in): [i4b(:)] named variables defining the type of hydrology states in snow+soil domain + layerType => indx_data%var(iLookINDEX%layerType)%dat & ! intent(in): [i4b(:)] named variables defining the type of layer in snow+soil domain + ) ! association to necessary variables for the residual computations + ! -------------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message="computResidWithPrime/" + + ! --- + ! * compute sink terms... + ! ----------------------- + + ! intialize additional terms on the RHS as zero + rAdd(:) = 0._rkind + + ! add melt freeze terms only if not using enthalpy terms + ! NOTE: would need to use these if were using enthTemp terms + if(.not.enthalpyStateVec)then + ! compute energy associated with melt freeze for the vegetation canopy + if(ixVegNrg/=integerMissing) rAdd(ixVegNrg) = rAdd(ixVegNrg) + LH_fus*scalarCanopyIcePrime/canopyDepth ! energy associated with melt/freeze (J m-3) + + ! compute energy associated with melt/freeze for snow + ! NOTE: allow expansion of ice during melt-freeze for snow; deny expansion of ice during melt-freeze for soil + if(nSnowSoilNrg>0)then + do concurrent (iLayer=1:nLayers,ixSnowSoilNrg(iLayer)/=integerMissing) ! (loop through non-missing energy state variables in the snow+soil domain) + select case( layerType(iLayer) ) + case(iname_snow); rAdd( ixSnowSoilNrg(iLayer) ) = rAdd( ixSnowSoilNrg(iLayer) ) + LH_fus*iden_ice * mLayerVolFracIcePrime(iLayer) + case(iname_soil); rAdd( ixSnowSoilNrg(iLayer) ) = rAdd( ixSnowSoilNrg(iLayer) ) + LH_fus*iden_water * mLayerVolFracIcePrime(iLayer) + end select + end do ! looping through non-missing energy state variables in the snow+soil domain + endif + + endif + + ! sink terms soil hydrology (-) + ! NOTE 1: state variable is volumetric water content, so melt-freeze is not included + ! NOTE 2: ground evaporation was already included in the flux at the upper boundary + ! NOTE 3: rAdd(ixSnowOnlyWat)=0, and is defined in the initialization above + ! NOTE 4: same sink terms for matric head and liquid matric potential + if(nSoilOnlyHyd>0)then + do concurrent (iLayer=1:nSoil,ixSoilOnlyHyd(iLayer)/=integerMissing) ! (loop through non-missing hydrology state variables in the snow+soil domain) + rAdd( ixSoilOnlyHyd(iLayer) ) = rAdd( ixSoilOnlyHyd(iLayer) ) + ( ( mLayerTranspire(iLayer) - mLayerBaseflow(iLayer) )/mLayerDepth(iLayer+nSnow) - mLayerCompress(iLayer) )*dt + end do ! looping through non-missing energy state variables in the snow+soil domain + endif + + ! --- + ! * compute the residual vector... + ! -------------------------------- + + ! compute the residual vector for the vegetation canopy + ! NOTE: sMul(ixVegHyd) = 1, but include as it converts all variables to quadruple precision + ! --> energy balance + if(enthalpyStateVec)then + if(ixCasNrg/=integerMissing) rVec(ixCasNrg) = scalarCanairEnthalpyPrime - ( fVec(ixCasNrg)*dt + rAdd(ixCasNrg) ) + if(ixVegNrg/=integerMissing) rVec(ixVegNrg) = scalarCanopyEnthalpyPrime - ( fVec(ixVegNrg)*dt + rAdd(ixVegNrg) ) + else + if(ixCasNrg/=integerMissing) rVec(ixCasNrg) = sMul(ixCasNrg) * scalarCanairTempPrime - ( fVec(ixCasNrg)*dt + rAdd(ixCasNrg) ) + if(ixVegNrg/=integerMissing) rVec(ixVegNrg) = sMul(ixVegNrg) * scalarCanopyTempPrime + scalarCanopyCmTrial * scalarCanopyWatPrime/canopyDepth & + - ( fVec(ixVegNrg)*dt + rAdd(ixVegNrg) ) + endif + ! --> mass balance + if(ixVegHyd/=integerMissing)then + scalarCanopyHydPrime = merge(scalarCanopyWatPrime, scalarCanopyLiqPrime, (ixStateType( ixHydCanopy(ixVegVolume) )==iname_watCanopy) ) + rVec(ixVegHyd) = sMul(ixVegHyd)*scalarCanopyHydPrime - ( fVec(ixVegHyd)*dt + rAdd(ixVegHyd) ) + endif + + ! compute the residual vector for the snow and soil sub-domains for energy + if(nSnowSoilNrg>0)then + do concurrent (iLayer=1:nLayers,ixSnowSoilNrg(iLayer)/=integerMissing) ! (loop through non-missing energy state variables in the snow+soil domain) + if(enthalpyStateVec)then + rVec( ixSnowSoilNrg(iLayer) ) = mLayerEnthalpyPrime(iLayer) - ( fVec( ixSnowSoilNrg(iLayer) )*dt + rAdd( ixSnowSoilNrg(iLayer) ) ) + else + rVec( ixSnowSoilNrg(iLayer) ) = sMul( ixSnowSoilNrg(iLayer) ) * mLayerTempPrime(iLayer) + mLayerCmTrial(iLayer) * mLayerVolFracWatPrime(iLayer) & + - ( fVec( ixSnowSoilNrg(iLayer) )*dt + rAdd( ixSnowSoilNrg(iLayer) ) ) + endif + end do ! looping through non-missing energy state variables in the snow+soil domain + endif + + ! compute the residual vector for the snow and soil sub-domains for hydrology + ! NOTE: residual depends on choice of state variable + if(nSnowSoilHyd>0)then + do concurrent (iLayer=1:nLayers,ixSnowSoilHyd(iLayer)/=integerMissing) ! (loop through non-missing hydrology state variables in the snow+soil domain) + ! (get the correct state variable) + mLayerVolFracHydPrime(iLayer) = merge(mLayerVolFracWatPrime(iLayer), mLayerVolFracLiqPrime(iLayer), (ixHydType(iLayer)==iname_watLayer .or. ixHydType(iLayer)==iname_matLayer) ) + ! (compute the residual) + rVec( ixSnowSoilHyd(iLayer) ) = mLayerVolFracHydPrime(iLayer) - ( fVec( ixSnowSoilHyd(iLayer) )*dt + rAdd( ixSnowSoilHyd(iLayer) ) ) + end do ! looping through non-missing energy state variables in the snow+soil domain + endif + + ! compute the residual vector for the aquifer + if(ixAqWat/=integerMissing) rVec(ixAqWat) = sMul(ixAqWat)*scalarAquiferStoragePrime - ( fVec(ixAqWat)*dt + rAdd(ixAqWat) ) + + ! print the state variables if requested + if(globalPrintFlag)then + write(*,'(a)') 'In computResidWithPrime:' + write(*,'(a,i4)') ' nSnow = ', nSnow + write(*,'(a,i4)') ' nSoil = ', nSoil + write(*,'(a,i4)') ' nLayers = ', nLayers + write(*,'(a,f12.5)') ' dt = ', dt + write(*,'(a,1x,100(e12.5,1x))') ' sMul = ', sMul(min(iJac1,size(sMul)):min(iJac2,size(sMul))) + write(*,'(a,1x,100(e12.5,1x))') ' fVec = ', fVec(min(iJac1,size(fVec)):min(iJac2,size(fVec))) + write(*,'(a,f12.5)') ' scalarCanairTempPrime = ', scalarCanairTempPrime + write(*,'(a,f12.5)') ' scalarCanopyTempPrime = ', scalarCanopyTempPrime + write(*,'(a,f12.5)') ' scalarCanopyWatPrime = ', scalarCanopyWatPrime + write(*,'(a,1x,100(e12.5,1x))') ' mLayerTempPrime = ', mLayerTempPrime(min(iJac1,size(mLayerTempPrime)):min(iJac2,size(mLayerTempPrime))) + write(*,'(a,f12.5)') ' scalarAquiferStoragePrime = ', scalarAquiferStoragePrime + write(*,'(a,f12.5)') ' scalarCanopyIcePrime = ', scalarCanopyIcePrime + write(*,'(a,f12.5)') ' scalarCanopyLiqPrime = ', scalarCanopyLiqPrime + write(*,'(a,1x,100(e12.5,1x))') ' mLayerVolFracIcePrime = ', mLayerVolFracIcePrime(min(iJac1,size(mLayerVolFracIcePrime)):min(iJac2,size(mLayerVolFracIcePrime))) + write(*,'(a,1x,100(e12.5,1x))') ' mLayerVolFracWatPrime = ', mLayerVolFracWatPrime(min(iJac1,size(mLayerVolFracWatPrime)):min(iJac2,size(mLayerVolFracWatPrime))) + write(*,'(a,1x,100(e12.5,1x))') ' mLayerVolFracLiqPrime = ', mLayerVolFracLiqPrime(min(iJac1,size(mLayerVolFracLiqPrime)):min(iJac2,size(mLayerVolFracLiqPrime))) + write(*,'(a,f12.5)') ' scalarCanopyCmTrial = ', scalarCanopyCmTrial + write(*,'(a,1x,100(e12.5,1x))') ' mLayerCmTrial = ', mLayerCmTrial(min(iJac1,size(mLayerCmTrial)):min(iJac2,size(mLayerCmTrial))) + write(*,'(a,f12.5)') ' scalarCanairEnthalpyPrime = ', scalarCanairEnthalpyPrime + write(*,'(a,f12.5)') ' scalarCanopyEnthalpyPrime = ', scalarCanopyEnthalpyPrime + write(*,'(a,1x,100(e12.5,1x))') ' mLayerEnthalpyPrime = ', mLayerEnthalpyPrime(min(iJac1,size(mLayerEnthalpyPrime)):min(iJac2,size(mLayerEnthalpyPrime))) + endif + + ! print result + if(globalPrintFlag .or. any(isNan(rVec)))then + write(*,'(a,1x,100(e12.5,1x))') 'rVec = ', rVec(min(iJac1,size(rVec)):min(iJac2,size(rVec))) + write(*,'(a,1x,100(e12.5,1x))') 'fVec = ', fVec(min(iJac1,size(rVec)):min(iJac2,size(rVec))) + endif + if(any(isNan(rVec)))then; message=trim(message)//'NaN in residuals'; err=20; return; endif + + end associate + +end subroutine computResidWithPrime + +end module computResidWithPrime_module diff --git a/build/source/engine/computSnowDepth.f90 b/build/source/engine/computSnowDepth.f90 new file mode 100644 index 000000000..ff4215068 --- /dev/null +++ b/build/source/engine/computSnowDepth.f90 @@ -0,0 +1,146 @@ +module computSnowDepth_module + +! data types +USE nrtype + +! physical constants +USE multiconst,only:& + iden_ice, & ! intrinsic density of ice (kg m-3) + iden_water ! intrinsic density of liquid water (kg m-3) + +! data types +USE data_types,only:& + var_i, & ! x%var(:) (i4b) + var_d, & ! x%var(:) (rkind) + var_ilength, & ! x%var(:)%dat (i4b) + var_dlength, & ! x%var(:)%dat (rkind) + zLookup ! x%z(:)%var(:)%lookup(:) (rkind) + +! named variables for parent structures +USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure +USE var_lookup,only:iLookPROG ! named variables for structure elements +USE var_lookup,only:iLookDIAG ! named variables for structure elements +USE var_lookup,only:iLookFLUX ! named variables for structure elements +USE var_lookup,only:iLookPARAM ! named variables for structure elements +USE var_lookup,only:iLookINDEX ! named variables for structure elements +USE globalData,only:iname_snow ! named variables for snow +USE globalData,only:iname_soil ! named variables for soil + + +! privacy +implicit none +private +public::computSnowDepth + +real(rkind),parameter :: verySmall=1.e-6_rkind ! used as an additive constant to check if substantial difference among real numbers + +contains + +! ************************************************************************************************ +! public subroutine computSnowDepth: compute snow depth for one sub timestep +! ************************************************************************************************ +subroutine computSnowDepth(& + dt_sub, & + nSnow, & ! intent(in) + scalarSnowSublimation, & ! intent(in) + mLayerVolFracLiq, & ! intent(inout) + mLayerVolFracIce, & ! intent(inout) + mLayerTemp, & ! intent(in) + mLayerMeltFreeze, & ! intent(in) + mpar_data, & ! intent(in) + ! output + tooMuchSublim, & ! intent(out): flag to denote that there was too much sublimation in a given time step + mLayerDepth, & ! intent(inout) + ! error control + err,message) ! intent(out): error control + + USE snwDensify_module,only:snwDensify ! snow densification (compaction and cavitation) + + implicit none + real(qp),intent(in) :: dt_sub + integer(i4b),intent(in) :: nSnow ! number of snow layers + real(rkind),intent(in) :: scalarSnowSublimation + real(rkind),intent(inout) :: mLayerVolFracLiq(:) + real(rkind),intent(inout) :: mLayerVolFracIce(:) + real(rkind),intent(in) :: mLayerTemp(:) + real(rkind),intent(in) :: mLayerMeltFreeze(:) + type(var_dlength),intent(in) :: mpar_data ! model parameters + logical(lgt) :: tooMuchSublim ! flag to denote that there was too much sublimation in a given time step + real(rkind),intent(inout) :: mLayerDepth(:) + + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + + ! local variables + character(len=256) :: cmessage ! error message + integer(i4b) :: iSnow ! index of snow layers + real(rkind) :: massLiquid ! mass liquid water (kg m-2) + + ! * compute change in ice content of the top snow layer due to sublimation... + ! --------------------------------------------------------------------------- + ! initialize the flags + tooMuchSublim=.false. ! too much sublimation (merge snow layers) + ! NOTE: this is done BEFORE densification + if(nSnow > 0)then ! snow layers exist + + ! try to remove ice from the top layer + iSnow=1 + + ! save the mass of liquid water (kg m-2) + massLiquid = mLayerDepth(iSnow)*mLayerVolFracLiq(iSnow)*iden_water + + ! add/remove the depth of snow gained/lost by frost/sublimation (m) + ! NOTE: assume constant density + mLayerDepth(iSnow) = mLayerDepth(iSnow) + dt_sub*scalarSnowSublimation/(mLayerVolFracIce(iSnow)*iden_ice) + + ! check that we did not remove the entire layer + if(mLayerDepth(iSnow) < verySmall)then + tooMuchSublim=.true. + return + endif + + ! update the volumetric fraction of liquid water + mLayerVolFracLiq(iSnow) = massLiquid / (mLayerDepth(iSnow)*iden_water) + + ! no snow + else + + ! no snow: check that sublimation is zero + if(abs(scalarSnowSublimation) > verySmall)then + message=trim(message)//'sublimation of snow has been computed when no snow exists' + err=20; return + end if + + end if ! (if snow layers exist) + + + ! *** account for compaction and cavitation in the snowpack... + ! ------------------------------------------------------------ + if(nSnow>0)then + call snwDensify(& + ! intent(in): variables + dt_sub, & ! intent(in): time step (s) + nSnow, & ! intent(in): number of snow layers + mLayerTemp(1:nSnow), & ! intent(in): temperature of each layer (K) + mLayerMeltFreeze(1:nSnow), & ! intent(in): volumetric melt in each layer (kg m-3) + ! intent(in): parameters + mpar_data%var(iLookPARAM%densScalGrowth)%dat(1), & ! intent(in): density scaling factor for grain growth (kg-1 m3) + mpar_data%var(iLookPARAM%tempScalGrowth)%dat(1), & ! intent(in): temperature scaling factor for grain growth (K-1) + mpar_data%var(iLookPARAM%grainGrowthRate)%dat(1), & ! intent(in): rate of grain growth (s-1) + mpar_data%var(iLookPARAM%densScalOvrbdn)%dat(1), & ! intent(in): density scaling factor for overburden pressure (kg-1 m3) + mpar_data%var(iLookPARAM%tempScalOvrbdn)%dat(1), & ! intent(in): temperature scaling factor for overburden pressure (K-1) + mpar_data%var(iLookPARAM%baseViscosity)%dat(1), & ! intent(in): viscosity coefficient at T=T_frz and snow density=0 (kg m-2 s) + ! intent(inout): state variables + mLayerDepth(1:nSnow), & ! intent(inout): depth of each layer (m) + mLayerVolFracLiq(1:nSnow), & ! intent(inout): volumetric fraction of liquid water after itertations (-) + mLayerVolFracIce(1:nSnow), & ! intent(inout): volumetric fraction of ice after itertations (-) + ! output: error control + err,cmessage) ! intent(out): error control + if(err/=0)then; err=55; message=trim(message)//trim(cmessage); return; end if + end if ! if snow layers exist + +end subroutine computSnowDepth + + +end module computSnowDepth_module + diff --git a/build/source/engine/computThermConduct.f90 b/build/source/engine/computThermConduct.f90 new file mode 100644 index 000000000..028969fe0 --- /dev/null +++ b/build/source/engine/computThermConduct.f90 @@ -0,0 +1,395 @@ + +module computThermConduct_module + +! data types +USE nrtype + +! derived types to define the data structures +USE data_types,only:& + var_d, & ! data vector (rkind) + var_ilength, & ! data vector with variable length dimension (i4b) + var_dlength ! data vector with variable length dimension (rkind) + +! physical constants +USE multiconst,only:& + iden_ice, & ! intrinsic density of ice (kg m-3) + iden_water, & ! intrinsic density of water (kg m-3) + ! thermal conductivity + lambda_air, & ! thermal conductivity of air (J s-1 m-1) + lambda_ice, & ! thermal conductivity of ice (J s-1 m-1) + lambda_water ! thermal conductivity of water (J s-1 m-1) + +! missing values +USE globalData,only:integerMissing ! missing integer +USE globalData,only:realMissing ! missing real number + +! named variables that define the layer type +USE globalData,only:iname_snow ! snow +USE globalData,only:iname_soil ! soil + +! named variables +USE var_lookup,only:iLookPROG ! named variables for structure elements +USE var_lookup,only:iLookDIAG ! named variables for structure elements +USE var_lookup,only:iLookFLUX ! named variables for structure elements +USE var_lookup,only:iLookPARAM ! named variables for structure elements +USE var_lookup,only:iLookINDEX ! named variables for structure elements + + +! provide access to named variables for thermal conductivity of soil +USE globalData,only:model_decisions ! model decision structure +USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure + +! provide access to look-up values for model decisions +USE mDecisions_module,only: & + ! look-up values for choice of thermal conductivity representation for snow + Yen1965, & ! Yen (1965) + Mellor1977, & ! Mellor (1977) + Jordan1991, & ! Jordan (1991) + Smirnova2000, & ! Smirnova et al. (2000) + ! look-up values for choice of thermal conductivity representation for soil + funcSoilWet, & ! function of soil wetness + mixConstit, & ! mixture of constituents + hanssonVZJ, & ! test case for the mizoguchi lab experiment, Hansson et al. VZJ 2004 + ! look-up values for the form of Richards' equation + moisture, & ! moisture-based form of Richards' equation + mixdform ! mixed form of Richards' equation + +! privacy +implicit none +private +public::computThermConduct +contains + + +! ********************************************************************************************************** +! public subroutine computThermConduct: recompute diagnostic energy variables (thermal conductivity) +! NOTE: does every layer regardless if layer or layer+1 is in state subset, could fix for speedup +! ********************************************************************************************************** +subroutine computThermConduct(& + ! input: control variables + nLayers, & ! intent(in): total number of layers + ! input: state variables + mLayerTemp, & ! intent(in): temperature at the current iteration (K) + mLayerMatricHead, & ! intent(in): matric head at the current iteration(m) + mLayerVolFracIce, & ! intent(in): volumetric fraction of ice at the start of the sub-step (-) + mLayerVolFracLiq, & ! intent(in): volumetric fraction of liquid water at the start of the sub-step (-) + ! input: pre-computed derivatives + mLayerdTheta_dTk, & ! intent(in): derivative in volumetric liquid water content w.r.t. temperature (K-1) + mLayerFracLiqSnow, & ! intent(in): fraction of liquid water (-) + ! input/output: data structures + mpar_data, & ! intent(in): model parameters + indx_data, & ! intent(in): model layer indices + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + ! output: derivatives + dThermalC_dWatAbove, & ! intent(out): derivative in the thermal conductivity w.r.t. water state in the layer above + dThermalC_dWatBelow, & ! intent(out): derivative in the thermal conductivity w.r.t. water state in the layer above + dThermalC_dTempAbove, & ! intent(out): derivative in the thermal conductivity w.r.t. energy state in the layer above + dThermalC_dTempBelow, & ! intent(out): derivative in the thermal conductivity w.r.t. energy state in the layer above + ! output: error control + err,message) ! intent(out): error control + + ! utility modules + USE snow_utils_module,only:tcond_snow ! compute thermal conductivity of snow + USE soil_utils_module,only:crit_soilT ! compute critical temperature below which ice exists + USE soil_utils_module,only:dTheta_dPsi ! compute derivative of the soil moisture characteristic w.r.t. psi (m-1) + USE soil_utils_module,only:dPsi_dTheta ! compute derivative of the soil moisture characteristic w.r.t. theta (m) + + implicit none + ! -------------------------------------------------------------------------------------------------------------------------------------- + ! input: model control + integer(i4b),intent(in) :: nLayers ! total number of layers in the snow+soil domain + ! input: trial model state variables + real(rkind),intent(in) :: mLayerTemp(:) ! temperature in each layer at the current iteration (m) + real(rkind),intent(in) :: mLayerMatricHead(:) ! matric head in each layer at the current iteration (m) + real(rkind),intent(in) :: mLayerVolFracIce(:) ! volumetric fraction of ice at the current iteration (-) + real(rkind),intent(in) :: mLayerVolFracLiq(:) ! volumetric fraction of liquid at the current iteration (-) + ! input: pre-computed derivatives + real(rkind),intent(in) :: mLayerdTheta_dTk(:) ! derivative in volumetric liquid water content w.r.t. temperature (K-1) + real(rkind),intent(in) :: mLayerFracLiqSnow(:) ! fraction of liquid water (-) + ! input/output: data structures + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_ilength),intent(in) :: indx_data ! model layer indices + type(var_dlength),intent(in) :: prog_data ! model prognostic variables for a local HRU + type(var_dlength),intent(inout) :: diag_data ! model diagnostic variables for a local HRU + ! output: derivatives + real(rkind),intent(out) :: dThermalC_dWatAbove(0:) ! derivative in the thermal conductivity w.r.t. water state in the layer above + real(rkind),intent(out) :: dThermalC_dWatBelow(0:) ! derivative in the thermal conductivity w.r.t. water state in the layer above + real(rkind),intent(out) :: dThermalC_dTempAbove(0:) ! derivative in the thermal conductivity w.r.t. energy state in the layer above + real(rkind),intent(out) :: dThermalC_dTempBelow(0:) ! derivative in the thermal conductivity w.r.t. energy state in the layer above + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! -------------------------------------------------------------------------------------------------------------------------------- + ! local variables + character(LEN=256) :: cmessage ! error message of downwind routine + integer(i4b) :: iLayer ! index of model layer + integer(i4b) :: iSoil ! index of soil layer + real(rkind) :: TCn ! thermal conductivity below the layer interface (W m-1 K-1) + real(rkind) :: TCp ! thermal conductivity above the layer interface (W m-1 K-1) + real(rkind) :: zdn ! height difference between interface and lower value (m) + real(rkind) :: zdp ! height difference between interface and upper value (m) + real(rkind) :: bulkden_soil ! bulk density of soil (kg m-3) + real(rkind) :: lambda_drysoil ! thermal conductivity of dry soil (W m-1) + real(rkind) :: lambda_wetsoil ! thermal conductivity of wet soil (W m-1) + real(rkind) :: lambda_wet ! thermal conductivity of the wet material + real(rkind) :: relativeSat ! relative saturation (-) + real(rkind) :: kerstenNum ! the Kersten number (-), defining weight applied to conductivity of the wet medium + real(rkind) :: den ! denominator in the thermal conductivity calculations + real(rkind) :: Tcrit ! temperature where all water is unfrozen (K) + real(rkind),dimension(nLayers) :: dThermalC_dWat ! derivative in thermal conductivity w.r.t. matric head or volumetric liquid water + real(rkind),dimension(nLayers) :: dThermalC_dNrg ! derivative in thermal conductivity w.r.t. temperature + real(rkind) :: dlambda_wet_dWat ! derivative in thermal conductivity of wet material w.r.t.soil water state variable + real(rkind) :: dlambda_wet_dTk ! derivative in thermal conductivity of wet material w.r.t. temperature + real(rkind) :: dkerstenNum_dWat ! derivative in Kersten number w.r.t. soil water state variable + real(rkind) :: dVolFracLiq_dWat ! derivative in vol fraction of liquid w.r.t. water state variable + real(rkind) :: dVolFracIce_dWat ! derivative in vol fraction of ice w.r.t. water state variable + real(rkind) :: dVolFracLiq_dTk ! derivative in vol fraction of liquid w.r.t. temperature + real(rkind) :: dVolFracIce_dTk ! derivative in vol fraction of ice w.r.t. temperature + ! local variables to reproduce the thermal conductivity of Hansson et al. VZJ 2005 + real(rkind),parameter :: c1=0.55_rkind ! optimized parameter from Hansson et al. VZJ 2005 (W m-1 K-1) + real(rkind),parameter :: c2=0.8_rkind ! optimized parameter from Hansson et al. VZJ 2005 (W m-1 K-1) + real(rkind),parameter :: c3=3.07_rkind ! optimized parameter from Hansson et al. VZJ 2005 (-) + real(rkind),parameter :: c4=0.13_rkind ! optimized parameter from Hansson et al. VZJ 2005 (W m-1 K-1) + real(rkind),parameter :: c5=4._rkind ! optimized parameter from Hansson et al. VZJ 2005 (-) + real(rkind),parameter :: f1=13.05_rkind ! optimized parameter from Hansson et al. VZJ 2005 (-) + real(rkind),parameter :: f2=1.06_rkind ! optimized parameter from Hansson et al. VZJ 2005 (-) + real(rkind) :: fArg,xArg ! temporary variables (see Hansson et al. VZJ 2005 for details) + real(rkind) :: dxArg_dWat,dxArg_dTk ! derivates of the temporary variables with respect to soil water state variable and temperature + + ! -------------------------------------------------------------------------------------------------------------------------------- + ! associate variables in data structure + associate(& + ! input: model decisions + ixRichards => model_decisions(iLookDECISIONS%f_Richards)%iDecision, & ! intent(in): [i4b] index of the form of Richards' equation + ixThCondSnow => model_decisions(iLookDECISIONS%thCondSnow)%iDecision, & ! intent(in): [i4b] choice of method for thermal conductivity of snow + ixThCondSoil => model_decisions(iLookDECISIONS%thCondSoil)%iDecision, & ! intent(in): [i4b] choice of method for thermal conductivity of soil + ! input: coordinate variables + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1), & ! intent(in): [dp] number of snow layers + nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1), & ! intent(in): [dp] number of soil layers + layerType => indx_data%var(iLookINDEX%layerType)%dat, & ! intent(in): [dp(:)] layer type (iname_soil or iname_snow) + mLayerHeight => prog_data%var(iLookPROG%mLayerHeight)%dat, & ! intent(in): [dp(:)] height at the mid-point of each layer (m) + iLayerHeight => prog_data%var(iLookPROG%iLayerHeight)%dat, & ! intent(in): [dp(:)] height at the interface of each layer (m) + ! input: heat capacity and thermal conductivity + fixedThermalCond_snow => mpar_data%var(iLookPARAM%fixedThermalCond_snow)%dat(1), & ! intent(in): [dp] temporally constant thermal conductivity of snow (W m-1 K-1) + ! input: depth varying soil parameters + iden_soil => mpar_data%var(iLookPARAM%soil_dens_intr)%dat, & ! intent(in): [dp(:)] intrinsic density of soil (kg m-3) + thCond_soil => mpar_data%var(iLookPARAM%thCond_soil)%dat, & ! intent(in): [dp(:)] thermal conductivity of soil (W m-1 K-1) + theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat, & ! intent(in): [dp(:)] soil porosity (-) + frac_sand => mpar_data%var(iLookPARAM%frac_sand)%dat, & ! intent(in): [dp(:)] fraction of sand (-) + frac_silt => mpar_data%var(iLookPARAM%frac_silt)%dat, & ! intent(in): [dp(:)] fraction of silt (-) + frac_clay => mpar_data%var(iLookPARAM%frac_clay)%dat, & ! intent(in): [dp(:)] fraction of clay (-) + vGn_m => diag_data%var(iLookDIAG%scalarVGn_m)%dat, & ! intent(in): [dp(:)] van Genutchen "m" parameter (-) + vGn_n => mpar_data%var(iLookPARAM%vGn_n)%dat, & ! intent(in): [dp(:)] van Genutchen "n" parameter (-) + vGn_alpha => mpar_data%var(iLookPARAM%vGn_alpha)%dat, & ! intent(in): [dp(:)] van Genutchen "alpha" parameter (m-1) + theta_res => mpar_data%var(iLookPARAM%theta_res)%dat, & ! intent(in): [dp(:)] soil residual volumetric water content (-) + ! input: snow parameters + snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1), & ! intent(in): [dp] scaling parameter for the snow freezing curve (K-1) + ! output: diagnostic variables and derivatives (diagnostic as may be treated as constant) + mLayerThermalC => diag_data%var(iLookDIAG%mLayerThermalC)%dat, & ! intent(out): [dp(:)] thermal conductivity at the mid-point of each layer (W m-1 K-1) + iLayerThermalC => diag_data%var(iLookDIAG%iLayerThermalC)%dat, & ! intent(out): [dp(:)] thermal conductivity at the interface of each layer (W m-1 K-1) + mLayerVolFracAir => diag_data%var(iLookDIAG%mLayerVolFracAir)%dat & ! intent(out): [dp(:)] volumetric fraction of air in each layer (-) + ) ! association of local variables with information in the data structures + ! -------------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message="computThermConduct/" + + ! initialize the soil layer + iSoil=integerMissing + + ! loop through layers + do iLayer=1,nLayers + + ! get the soil layer + if(iLayer>nSnow) iSoil = iLayer-nSnow + + ! compute the thermal conductivity of dry and wet soils (W m-1) + ! NOTE: this is actually constant over the simulation, and included here for clarity + if(ixThCondSoil == funcSoilWet .and. layerType(iLayer)==iname_soil)then + bulkden_soil = iden_soil(iSoil)*( 1._rkind - theta_sat(iSoil) ) + lambda_drysoil = (0.135_rkind*bulkden_soil + 64.7_rkind) / (iden_soil(iSoil) - 0.947_rkind*bulkden_soil) + lambda_wetsoil = (8.80_rkind*frac_sand(iSoil) + 2.92_rkind*frac_clay(iSoil)) / (frac_sand(iSoil) + frac_clay(iSoil)) + end if + + ! ***** + ! * compute the volumetric fraction of air in each layer... + ! ********************************************************* + select case(layerType(iLayer)) + case(iname_soil); mLayerVolFracAir(iLayer) = theta_sat(iSoil) - (mLayerVolFracIce(iLayer) + mLayerVolFracLiq(iLayer)) + case(iname_snow); mLayerVolFracAir(iLayer) = 1._rkind - (mLayerVolFracIce(iLayer) + mLayerVolFracLiq(iLayer)) + case default; err=20; message=trim(message)//'unable to identify type of layer (snow or soil) to compute volumetric fraction of air'; return + end select + + ! ***** + ! * compute the thermal conductivity of snow and soil and derivatives at the mid-point of each layer... + ! *************************************************************************************************** + dThermalC_dWat(iLayer) = 0._rkind + dThermalC_dNrg(iLayer) = 0._rkind + + select case(layerType(iLayer)) + + ! ***** soil + case(iname_soil) + + select case(ixRichards) ! (form of Richards' equation) + case(moisture) + dVolFracLiq_dWat = 1._rkind + dVolFracIce_dWat = dPsi_dTheta(mLayerVolFracLiq(iLayer),vGn_alpha(iSoil),theta_res(iSoil),theta_sat(iSoil),vGn_n(iSoil),vGn_m(iSoil)) - 1._rkind + case(mixdform) + Tcrit = crit_soilT( mLayerMatricHead(iSoil) ) + if(mLayerTemp(iLayer) < Tcrit) then + dVolFracLiq_dWat = 0._rkind + dVolFracIce_dWat = dTheta_dPsi(mLayerMatricHead(iSoil),vGn_alpha(iSoil),theta_res(iSoil),theta_sat(iSoil),vGn_n(iSoil),vGn_m(iSoil)) + else + dVolFracLiq_dWat = dTheta_dPsi(mLayerMatricHead(iSoil),vGn_alpha(iSoil),theta_res(iSoil),theta_sat(iSoil),vGn_n(iSoil),vGn_m(iSoil)) + dVolFracIce_dWat = 0._rkind + endif + end select + dVolFracLiq_dTk = mLayerdTheta_dTk(iLayer) !already zeroed out if not below critical temperature + dVolFracIce_dTk = -dVolFracLiq_dTk !often can and will simplify one of these terms out + + ! select option for thermal conductivity of soil + select case(ixThCondSoil) + + ! ** function of soil wetness + case(funcSoilWet) + + ! compute the thermal conductivity of the wet material (W m-1) + lambda_wet = lambda_wetsoil**( 1._rkind - theta_sat(iSoil) ) * lambda_water**theta_sat(iSoil) * lambda_ice**(theta_sat(iSoil) - mLayerVolFracLiq(iLayer)) + dlambda_wet_dWat = -lambda_wet * log(lambda_ice) * dVolFracLiq_dWat + dlambda_wet_dTk = -lambda_wet * log(lambda_ice) * dVolFracLiq_dTk + + relativeSat = (mLayerVolFracIce(iLayer) + mLayerVolFracLiq(iLayer))/theta_sat(iSoil) ! relative saturation + ! drelativeSat_dWat = dPsi0_dWat/theta_sat(iLayer), and drelativeSat_dTk = 0 (so dkerstenNum_dTk = 0) + ! compute the Kersten number (-) + if(relativeSat > 0.1_rkind)then ! log10(0.1) = -1 + kerstenNum = log10(relativeSat) + 1._rkind + dkerstenNum_dWat = (dVolFracIce_dWat + dVolFracLiq_dWat) / ( theta_sat(iSoil) * relativeSat * log(10._rkind) ) + else + kerstenNum = 0._rkind ! dry thermal conductivity + dkerstenNum_dWat = 0._rkind + endif + ! ...and, compute the thermal conductivity + mLayerThermalC(iLayer) = kerstenNum*lambda_wet + (1._rkind - kerstenNum)*lambda_drysoil + + ! compute derivatives + dThermalC_dWat(iLayer) = dkerstenNum_dWat * ( lambda_wet - lambda_drysoil ) + kerstenNum*dlambda_wet_dWat + dThermalC_dNrg(iLayer) = kerstenNum*dlambda_wet_dTk + + ! ** mixture of constituents + case(mixConstit) + mLayerThermalC(iLayer) = thCond_soil(iSoil) * ( 1._rkind - theta_sat(iSoil) ) + & ! soil component + lambda_ice * mLayerVolFracIce(iLayer) + & ! ice component + lambda_water * mLayerVolFracLiq(iLayer) + & ! liquid water component + lambda_air * mLayerVolFracAir(iLayer) ! air component + ! compute derivatives + dThermalC_dWat(iLayer) = lambda_ice*dVolFracIce_dWat + lambda_water*dVolFracLiq_dWat + lambda_air*(-dVolFracIce_dWat - dVolFracLiq_dWat) + dThermalC_dNrg(iLayer) = (lambda_ice - lambda_water) * dVolFracIce_dTk + + ! ** test case for the mizoguchi lab experiment, Hansson et al. VZJ 2004 + case(hanssonVZJ) + fArg = 1._rkind + f1*mLayerVolFracIce(iLayer)**f2 + xArg = mLayerVolFracLiq(iLayer) + fArg*mLayerVolFracIce(iLayer) + dxArg_dWat = dVolFracLiq_dWat + dVolFracIce_dWat * (1._rkind + f1*(f2+1)*mLayerVolFracIce(iLayer)**f2) + dxArg_dTk = dVolFracIce_dTk * f1*(f2+1)*mLayerVolFracIce(iLayer)**f2 + ! ...and, compute the thermal conductivity + mLayerThermalC(iLayer) = c1 + c2*xArg + (c1 - c4)*exp(-(c3*xArg)**c5) + + ! compute derivatives + dThermalC_dWat(iLayer) = ( c2 - c5*c3*(c3*xArg)**(c5-1)*(c1 - c4)*exp(-(c3*xArg)**c5) ) * dxArg_dWat + dThermalC_dNrg(iLayer) = ( c2 - c5*c3*(c3*xArg)**(c5-1)*(c1 - c4)*exp(-(c3*xArg)**c5) ) * dxArg_dTk + + ! ** check + case default; err=20; message=trim(message)//'unable to identify option for thermal conductivity of soil'; return + + end select ! option for the thermal conductivity of soil + + ! ***** snow + case(iname_snow) + dVolFracIce_dWat = ( 1._rkind - mLayerFracLiqSnow(iLayer) )*(iden_water/iden_ice) + dVolFracIce_dTk = -mLayerdTheta_dTk(iLayer)*(iden_water/iden_ice) + + ! temporally constant thermal conductivity + if(ixThCondSnow==Smirnova2000)then + mLayerThermalC(iLayer) = fixedThermalCond_snow + dThermalC_dWat(iLayer) = 0._rkind + dThermalC_dNrg(iLayer) = 0._rkind + ! thermal conductivity as a function of snow density + else + call tcond_snow(mLayerVolFracIce(iLayer)*iden_ice, & ! input: snow density (kg m-3) + mLayerThermalC(iLayer), & ! output: thermal conductivity (W m-1 K-1) + err,cmessage) ! output: error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + select case(ixThCondSnow) + case(Yen1965) + dThermalC_dWat(iLayer) = 2._rkind * 3.217d-6 * mLayerVolFracIce(iLayer) * iden_ice**2_i4b * dVolFracIce_dWat + dThermalC_dNrg(iLayer) = 2._rkind * 3.217d-6 * mLayerVolFracIce(iLayer) * iden_ice**2_i4b * dVolFracIce_dTk + case(Mellor1977) + dThermalC_dWat(iLayer) = 2._rkind * 2.576d-6 * mLayerVolFracIce(iLayer) * iden_ice**2_i4b * dVolFracIce_dWat + dThermalC_dNrg(iLayer) = 2._rkind * 2.576d-6 * mLayerVolFracIce(iLayer) * iden_ice**2_i4b * dVolFracIce_dTk + case(Jordan1991) + dThermalC_dWat(iLayer) = ( 7.75d-5 + 2._rkind * 1.105d-6 * mLayerVolFracIce(iLayer) * iden_ice ) * (lambda_ice-lambda_air) * iden_ice * dVolFracIce_dWat + dThermalC_dNrg(iLayer) = ( 7.75d-5 + 2._rkind * 1.105d-6 * mLayerVolFracIce(iLayer) * iden_ice ) * (lambda_ice-lambda_air) * iden_ice * dVolFracIce_dTk + end select ! option for the thermal conductivity of snow + end if + + ! * error check + case default; err=20; message=trim(message)//'unable to identify type of layer (snow or soil) to compute thermal conductivity'; return + + end select + + end do ! looping through layers + + ! ***** + ! * compute the thermal conductivity of snow at the interface of each layer... + ! **************************************************************************** + do iLayer=1,nLayers-1 ! (loop through layers) + ! get temporary variables + TCn = mLayerThermalC(iLayer) ! thermal conductivity below the layer interface (W m-1 K-1) + TCp = mLayerThermalC(iLayer+1) ! thermal conductivity above the layer interface (W m-1 K-1) + zdn = iLayerHeight(iLayer) - mLayerHeight(iLayer) ! height difference between interface and lower value (m) + zdp = mLayerHeight(iLayer+1) - iLayerHeight(iLayer) ! height difference between interface and upper value (m) + den = TCn*zdp + TCp*zdn ! denominator + ! compute thermal conductivity + if(TCn+TCp > epsilon(TCn))then + iLayerThermalC(iLayer) = (TCn*TCp*(zdn + zdp)) / den + dThermalC_dWatBelow(iLayer) = ( TCn*(zdn + zdp) - iLayerThermalC(iLayer)*zdn ) / den * dThermalC_dWat(iLayer+1) + dThermalC_dWatAbove(iLayer) = ( TCp*(zdn + zdp) - iLayerThermalC(iLayer)*zdp ) / den * dThermalC_dWat(iLayer) + dThermalC_dTempBelow(iLayer) = ( TCn*(zdn + zdp) - iLayerThermalC(iLayer)*zdn ) / den * dThermalC_dNrg(iLayer+1) + dThermalC_dTempAbove(iLayer) = ( TCp*(zdn + zdp) - iLayerThermalC(iLayer)*zdp ) / den * dThermalC_dNrg(iLayer) + else + iLayerThermalC(iLayer) = (TCn*zdn + TCp*zdp) / (zdn + zdp) + dThermalC_dWatBelow(iLayer) = zdp / (zdn + zdp) * dThermalC_dWat(iLayer+1) + dThermalC_dWatAbove(iLayer) = zdn / (zdn + zdp) * dThermalC_dWat(iLayer) + dThermalC_dTempBelow(iLayer) = zdp / (zdn + zdp) * dThermalC_dNrg(iLayer+1) + dThermalC_dTempAbove(iLayer) = zdn / (zdn + zdp) * dThermalC_dNrg(iLayer) + endif + end do ! looping through layers + + ! special case of hansson + if(ixThCondSoil==hanssonVZJ)then + iLayerThermalC(0) = 28._rkind*(0.5_rkind*(iLayerHeight(1) - iLayerHeight(0))) + dThermalC_dWatBelow(0) = 0._rkind + dThermalC_dTempBelow(0) = 0._rkind + else + iLayerThermalC(0) = mLayerThermalC(1) + dThermalC_dWatBelow(0) = dThermalC_dWat(1) + dThermalC_dTempBelow(0) = dThermalC_dNrg(1) + end if + dThermalC_dWatAbove(0) = realMissing + dThermalC_dTempAbove(0) = realMissing + + ! assume the thermal conductivity at the domain boundaries is equal to the thermal conductivity of the layer + iLayerThermalC(nLayers) = mLayerThermalC(nLayers) + dThermalC_dWatAbove(nLayers) = dThermalC_dWat(nLayers) + dThermalC_dTempAbove(nLayers) = dThermalC_dNrg(nLayers) + dThermalC_dWatBelow(nLayers) = realMissing + dThermalC_dTempBelow(nLayers) = realMissing + + ! end association to variables in the data structure + end associate + +end subroutine computThermConduct + + +end module computThermConduct_module diff --git a/build/source/engine/convE2Temp.f90 b/build/source/engine/convE2Temp.f90 deleted file mode 100755 index 0408c3fca..000000000 --- a/build/source/engine/convE2Temp.f90 +++ /dev/null @@ -1,230 +0,0 @@ -! SUMMA - Structure for Unifying Multiple Modeling Alternatives -! Copyright (C) 2014-2020 NCAR/RAL; University of Saskatchewan; University of Washington -! -! This file is part of SUMMA -! -! For more information see: http://www.ral.ucar.edu/projects/summa -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see . - -module convE2Temp_module - -! data types -USE nrtype -USE data_types,only:var_dlength ! data vector with variable length dimension (dp): x%var(:)%dat(:) - -! constants -USE multiconst, only: Tfreeze, & ! freezing point of water (K) - Cp_soil,Cp_water,Cp_ice,& ! specific heat of soil, water and ice (J kg-1 K-1) - LH_fus ! latent heat of fusion (J kg-1) - -! indices within parameter structure -USE var_lookup,only:iLookPARAM ! named variables to define structure element - -! privacy -implicit none -private -public::E2T_lookup -public::E2T_nosoil -public::temp2ethpy - -! define the look-up table used to compute temperature based on enthalpy -integer(i4b),parameter :: nlook=10001 ! number of elements in the lookup table -real(rkind),dimension(nlook),public :: E_lookup ! enthalpy values (J kg-1) -real(rkind),dimension(nlook),public :: T_lookup ! temperature values (K) -contains - - - ! ************************************************************************************************************************ - ! public subroutine E2T_lookup: define a look-up table to compute specific enthalpy based on temperature, assuming no soil - ! ************************************************************************************************************************ - subroutine E2T_lookup(mpar_data,err,message) - USE nr_utility_module,only:arth ! use to build vectors with regular increments - USE spline_int_module,only:spline,splint ! use for cubic spline interpolation - implicit none - ! declare dummy variables - type(var_dlength),intent(in) :: mpar_data ! model parameters - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! declare local variables - character(len=128) :: cmessage ! error message in downwind routine - real(rkind),parameter :: T_start=260.0_rkind ! start temperature value where all liquid water is assumed frozen (K) - real(rkind) :: T_incr,E_incr ! temperature/enthalpy increments - real(rkind),dimension(nlook) :: Tk ! initial temperature vector - real(rkind),dimension(nlook) :: Ey ! initial enthalpy vector - real(rkind),parameter :: waterWght=1._rkind ! weight applied to total water (kg m-3) --- cancels out - real(rkind),dimension(nlook) :: T2deriv ! 2nd derivatives of the interpolating function at tabulated points - integer(i4b) :: ilook ! loop through lookup table - ! initialize error control - err=0; message="E2T_lookup/" - ! associate - associate( snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1) ) - ! define initial temperature vector - T_incr = (Tfreeze - T_start) / real(nlook-1, kind(rkind)) ! temperature increment - Tk = arth(T_start,T_incr,nlook) - ! ***** compute specific enthalpy (NOTE: J m-3 --> J kg-1) ***** - do ilook=1,nlook - Ey(ilook) = temp2ethpy(Tk(ilook),waterWght,snowfrz_scale)/waterWght ! (J m-3 --> J kg-1) - end do - ! define the final enthalpy vector - E_incr = (-Ey(1)) / real(nlook-1, kind(rkind)) ! enthalpy increment - E_lookup = arth(Ey(1),E_incr,nlook) - ! use cubic spline interpolation to obtain temperature values at the desired values of enthalpy - call spline(Ey,Tk,1.e30_rkind,1.e30_rkind,T2deriv,err,cmessage) ! get the second derivatives - if(err/=0) then; message=trim(message)//trim(cmessage); return; end if - do ilook=1,nlook - call splint(Ey,Tk,T2deriv,E_lookup(ilook),T_lookup(ilook),err,cmessage) - if(err/=0) then; message=trim(message)//trim(cmessage); return; end if - !write(*,'(i6,1x,2(f20.4,1x))') ilook, E_lookup(ilook), T_lookup(ilook) - end do - end associate - end subroutine E2T_lookup - - - ! ************************************************************************************************************************ - ! public subroutine E2T_nosoil: compute temperature based on specific enthalpy -- appropriate when no dry mass, as in snow - ! ************************************************************************************************************************ - subroutine E2T_nosoil(Ey,BulkDenWater,fc_param,Tk,err,message) - ! compute temperature based on enthalpy -- appropriate when no dry mass, as in snow - implicit none - ! declare dummy variables - real(rkind),intent(in) :: Ey ! total enthalpy (J m-3) - real(rkind),intent(in) :: BulkDenWater ! bulk density of water (kg m-3) - real(rkind),intent(in) :: fc_param ! freezing curve parameter (K-1) - real(rkind),intent(out) :: Tk ! initial temperature guess / final temperature value (K) - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! declare local variables - real(rkind),parameter :: dx=1.d-8 ! finite difference increment (J kg-1) - real(rkind),parameter :: atol=1.d-12 ! convergence criteria (J kg-1) - real(rkind) :: E_spec ! specific enthalpy (J kg-1) - real(rkind) :: E_incr ! enthalpy increment - integer(i4b) :: niter=15 ! maximum number of iterations - integer(i4b) :: iter ! iteration index - integer(i4b) :: i0 ! position in lookup table - real(rkind) :: Tg0,Tg1 ! trial temperatures (K) - real(rkind) :: Ht0,Ht1 ! specific enthalpy, based on the trial temperatures (J kg-1) - real(rkind) :: f0,f1 ! function evaluations (difference between enthalpy guesses) - real(rkind) :: dh ! enthalpy derivative - real(rkind) :: dT ! temperature increment - ! initialize error control - err=0; message="E2T_nosoil/" - ! convert input of total enthalpy (J m-3) to total specific enthalpy (J kg-1) - E_spec = Ey/BulkDenWater ! (NOTE: no soil) - !write(*,'(a,1x,10(e20.10,1x))') 'E_spec, E_lookup(1)', E_spec, E_lookup(1) - - ! ***** get initial guess and derivative assuming all water is frozen - if(E_spec E_lookup(i0+1) .or. & - i0 < 1 .or. i0+1 > nlook)then - err=10; message=trim(message)//'problem finding appropriate value in lookup table'; return - end if - ! get temperature guess - Tg0 = T_lookup(i0) - Tg1 = T_lookup(i0+1) - ! compute function evaluations - f0 = E_lookup(i0) - E_spec - f1 = E_lookup(i0+1) - E_spec - end if - - ! compute initial derivative - dh = (f1 - f0) / (Tg1 - Tg0) - ! compute initial change in T - dT = -f0/dh - !write(*,'(a,1x,f12.5,1x,10(e20.10,1x))') 'Tg1, f0, f1, dh, dT = ', Tg1, f0, f1, dh, dT - ! exit if already close enough - if(abs(dT) diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1) ) ! intent(out): [dp] canopy depth (m) - - ! start by NOT pausing - pauseFlag=.false. - - ! start by assuming that the step is successful - stepFailure = .false. - doLayerMerge = .false. - - ! initialize flags to modify the veg layers or modify snow layers - modifiedLayers = .false. ! flag to denote that snow layers were modified - modifiedVegState = .false. ! flag to denote that vegetation states were modified - - ! define the first step - firstSubStep = .true. - - ! count the number of snow and soil layers - ! NOTE: need to re-compute the number of snow and soil layers at the start of each sub-step because the number of layers may change - ! (nSnow and nSoil are shared in the data structure) - nSnow = count(indx_data%var(iLookINDEX%layerType)%dat==iname_snow) - nSoil = count(indx_data%var(iLookINDEX%layerType)%dat==iname_soil) - - ! compute the total number of snow and soil layers - nLayers = nSnow + nSoil - - ! create temporary data structures for prognostic variables - call resizeData(prog_meta(:),prog_data,prog_temp,err=err,message=cmessage) - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif - - ! create temporary data structures for diagnostic variables - call resizeData(diag_meta(:),diag_data,diag_temp,err=err,message=cmessage) - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif - - ! create temporary data structures for index variables - call resizeData(indx_meta(:),indx_data,indx_temp,err=err,message=cmessage) - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif - - ! allocate space for the local fluxes - call allocLocal(averageFlux_meta(:)%var_info,flux_mean,nSnow,nSoil,err,cmessage) - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if - - ! initialize compression, surface melt pond, and effective Rainfall - sfcMeltPond = 0._rkind ! change in storage associated with the surface melt pond (kg m-2) - totalSoilCompress = 0._rkind ! change in soil storage associated with compression of the matrix (kg m-2) - effRainfall = 0._rkind ! mean total effective rainfall over snow - - ! initialize mean fluxes - do iVar=1,size(averageFlux_meta) - flux_mean%var(iVar)%dat(:) = 0._rkind - end do - - ! associate local variables with information in the data structures - associate(& - ! state variables in the vegetation canopy - scalarCanopyLiq => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1) ,& ! canopy liquid water (kg m-2) - scalarCanopyIce => prog_data%var(iLookPROG%scalarCanopyIce)%dat(1) ,& ! canopy ice content (kg m-2) - ! state variables in the soil domain - mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat(nSnow+1:nLayers) ,& ! depth of each soil layer (m) - mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat(nSnow+1:nLayers) ,& ! volumetric ice content in each soil layer (-) - mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat(nSnow+1:nLayers) ,& ! volumetric liquid water content in each soil layer (-) - scalarAquiferStorage => prog_data%var(iLookPROG%scalarAquiferStorage)%dat(1) ,& ! aquifer storage (m) - scalarTotalSoilIce => diag_data%var(iLookDIAG%scalarTotalSoilIce)%dat(1) ,& ! total ice in the soil column (kg m-2) - scalarTotalSoilLiq => diag_data%var(iLookDIAG%scalarTotalSoilLiq)%dat(1) ,& ! total liquid water in the soil column (kg m-2) - scalarTotalSoilWat => diag_data%var(iLookDIAG%scalarTotalSoilWat)%dat(1) & ! total water in the soil column (kg m-2) - ) ! (association of local variables with information in the data structures - - ! save the liquid water and ice on the vegetation canopy - scalarInitCanopyLiq = scalarCanopyLiq ! initial liquid water on the vegetation canopy (kg m-2) - scalarInitCanopyIce = scalarCanopyIce ! initial ice on the vegetation canopy (kg m-2) - - ! compute total soil moisture and ice at the *START* of the step (kg m-2) - scalarTotalSoilLiq = sum(iden_water*mLayerVolFracLiq(1:nSoil)*mLayerDepth(1:nSoil)) - scalarTotalSoilIce = sum(iden_water*mLayerVolFracIce(1:nSoil)*mLayerDepth(1:nSoil)) ! NOTE: no expansion and hence use iden_water - - ! compute storage of water in the canopy and the soil - balanceCanopyWater0 = scalarCanopyLiq + scalarCanopyIce - balanceSoilWater0 = scalarTotalSoilLiq + scalarTotalSoilIce - - ! get the total aquifer storage at the start of the time step (kg m-2) - balanceAquifer0 = scalarAquiferStorage*iden_water - - ! save liquid water content - if(printBalance)then - allocate(liqSnowInit(nSnow), liqSoilInit(nSoil), stat=err) - if(err/=0)then - message=trim(message)//'unable to allocate space for the initial vectors' - err=20; return - endif - if(nSnow>0) liqSnowInit = prog_data%var(iLookPROG%mLayerVolFracLiq)%dat(1:nSnow) - liqSoilInit = mLayerVolFracLiq - endif - - ! end association of local variables with information in the data structures - end associate - - ! short-cut to the algorithmic control parameters - ! NOTE - temporary assignment of minstep to foce something reasonable - minstep = 10._rkind ! mpar_data%var(iLookPARAM%minstep)%dat(1) ! minimum time step (s) - maxstep = mpar_data%var(iLookPARAM%maxstep)%dat(1) ! maximum time step (s) - !print*, 'minstep, maxstep = ', minstep, maxstep - - ! compute the number of layers with roots - nLayersRoots = count(prog_data%var(iLookPROG%iLayerHeight)%dat(nSnow:nLayers-1) < mpar_data%var(iLookPARAM%rootingDepth)%dat(1)-verySmall) - if(nLayersRoots == 0)then - message=trim(message)//'no roots within the soil profile' - err=20; return - end if - - ! define the foliage nitrogen factor - diag_data%var(iLookDIAG%scalarFoliageNitrogenFactor)%dat(1) = 1._rkind ! foliage nitrogen concentration (1.0 = saturated) - - ! save SWE - oldSWE = prog_data%var(iLookPROG%scalarSWE)%dat(1) - !print*, 'nSnow = ', nSnow - !print*, 'oldSWE = ', oldSWE - - ! *** compute phenology... - ! ------------------------ - - ! compute the temperature of the root zone: used in vegetation phenology - diag_data%var(iLookDIAG%scalarRootZoneTemp)%dat(1) = sum(prog_data%var(iLookPROG%mLayerTemp)%dat(nSnow+1:nSnow+nLayersRoots)) / real(nLayersRoots, kind(rkind)) - - ! remember if we compute the vegetation flux on the previous sub-step - computeVegFluxOld = computeVegFlux - - ! compute the exposed LAI and SAI and whether veg is buried by snow - call vegPhenlgy(& - ! input/output: data structures - model_decisions, & ! intent(in): model decisions - type_data, & ! intent(in): type of vegetation and soil - attr_data, & ! intent(in): spatial attributes - mpar_data, & ! intent(in): model parameters - prog_data, & ! intent(in): model prognostic variables for a local HRU - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - ! output - computeVegFlux, & ! intent(out): flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) - canopyDepth, & ! intent(out): canopy depth (m) - exposedVAI, & ! intent(out): exposed vegetation area index (m2 m-2) - err,cmessage) ! intent(out): error control - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if - - ! check - if(computeVegFlux)then - if(canopyDepth < epsilon(canopyDepth))then - message=trim(message)//'canopy depth is zero when computeVegFlux flag is .true.' - err=20; return - endif - endif - - ! flag the case where number of vegetation states has changed - modifiedVegState = (computeVegFlux.neqv.computeVegFluxOld) - - ! *** compute wetted canopy area... - ! --------------------------------- - - ! compute maximum canopy liquid water (kg m-2) - diag_data%var(iLookDIAG%scalarCanopyLiqMax)%dat(1) = mpar_data%var(iLookPARAM%refInterceptCapRain)%dat(1)*exposedVAI - - ! compute maximum canopy ice content (kg m-2) - ! NOTE 1: this is used to compute the snow fraction on the canopy, as used in *BOTH* the radiation AND canopy sublimation routines - ! NOTE 2: this is a different variable than the max ice used in the throughfall (snow interception) calculations - ! NOTE 3: use maximum per unit leaf area storage capacity for snow (kg m-2) - select case(model_decisions(iLookDECISIONS%snowIncept)%iDecision) - case(lightSnow); diag_data%var(iLookDIAG%scalarCanopyIceMax)%dat(1) = exposedVAI*mpar_data%var(iLookPARAM%refInterceptCapSnow)%dat(1) - case(stickySnow); diag_data%var(iLookDIAG%scalarCanopyIceMax)%dat(1) = exposedVAI*mpar_data%var(iLookPARAM%refInterceptCapSnow)%dat(1)*4._rkind - case default; message=trim(message)//'unable to identify option for maximum branch interception capacity'; err=20; return - end select ! identifying option for maximum branch interception capacity - !print*, 'diag_data%var(iLookDIAG%scalarCanopyLiqMax)%dat(1) = ', diag_data%var(iLookDIAG%scalarCanopyLiqMax)%dat(1) - !print*, 'diag_data%var(iLookDIAG%scalarCanopyIceMax)%dat(1) = ', diag_data%var(iLookDIAG%scalarCanopyIceMax)%dat(1) - - ! compute wetted fraction of the canopy - ! NOTE: assume that the wetted fraction is constant over the substep for the radiation calculations - if(computeVegFlux)then - - ! compute wetted fraction of the canopy - call wettedFrac(& - ! input - .false., & ! flag to denote if derivatives are required - .false., & ! flag to denote if derivatives are calculated numerically - (prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1) < Tfreeze), & ! flag to denote if the canopy is frozen - varNotUsed1, & ! derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) - varNotUsed2, & ! fraction of liquid water on the canopy - prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1), & ! canopy liquid water (kg m-2) - prog_data%var(iLookPROG%scalarCanopyIce)%dat(1), & ! canopy ice (kg m-2) - diag_data%var(iLookDIAG%scalarCanopyLiqMax)%dat(1), & ! maximum canopy liquid water (kg m-2) - diag_data%var(iLookDIAG%scalarCanopyLiqMax)%dat(1), & ! maximum canopy ice content (kg m-2) - mpar_data%var(iLookPARAM%canopyWettingFactor)%dat(1), & ! maximum wetted fraction of the canopy (-) - mpar_data%var(iLookPARAM%canopyWettingExp)%dat(1), & ! exponent in canopy wetting function (-) - ! output - diag_data%var(iLookDIAG%scalarCanopyWetFraction)%dat(1), & ! canopy wetted fraction (-) - dCanopyWetFraction_dWat, & ! derivative in wetted fraction w.r.t. canopy liquid water content (kg-1 m2) - dCanopyWetFraction_dT, & ! derivative in wetted fraction w.r.t. canopy liquid water content (kg-1 m2) - err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if - - ! vegetation is completely buried by snow (or no veg exists at all) - else - diag_data%var(iLookDIAG%scalarCanopyWetFraction)%dat(1) = 0._rkind - dCanopyWetFraction_dWat = 0._rkind - dCanopyWetFraction_dT = 0._rkind - end if - - ! *** compute snow albedo... - ! -------------------------- - ! NOTE: this should be done before the radiation calculations - ! NOTE: uses snowfall; should really use canopy throughfall + canopy unloading - call snowAlbedo(& - ! input: model control - data_step, & ! intent(in): model time step (s) - (nSnow > 0), & ! intent(in): logical flag to denote if snow is present - ! input/output: data structures - model_decisions, & ! intent(in): model decisions - mpar_data, & ! intent(in): model parameters - flux_data, & ! intent(in): model flux variables - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - prog_data, & ! intent(inout): model prognostic variables for a local HRU - ! output: error control - err,cmessage) ! intent(out): error control - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if - - - ! *** compute canopy sw radiation fluxes... - ! ----------------------------------------- - call vegSWavRad(& - data_step, & ! intent(in): time step (s) -- only used in Noah-MP radiation, to compute albedo - nSnow, & ! intent(in): number of snow layers - nSoil, & ! intent(in): number of soil layers - nLayers, & ! intent(in): total number of layers - computeVegFlux, & ! intent(in): logical flag to compute vegetation fluxes (.false. if veg buried by snow) - type_data, & ! intent(in): type of vegetation and soil - prog_data, & ! intent(inout): model prognostic variables for a local HRU - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - flux_data, & ! intent(inout): model flux variables - err,cmessage) ! intent(out): error control - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if - - - ! *** compute canopy throughfall and unloading... - ! ----------------------------------------------- - ! NOTE 1: this needs to be done before solving the energy and liquid water equations, to account for the heat advected with precipitation (and throughfall/unloading) - ! NOTE 2: the unloading flux is computed using canopy drip (scalarCanopyLiqDrainage) from the previous time step - call canopySnow(& - ! input: model control - data_step, & ! intent(in): time step (seconds) - exposedVAI, & ! intent(in): exposed vegetation area index (m2 m-2) - computeVegFlux, & ! intent(in): flag to denote if computing energy flux over vegetation - ! input/output: data structures - model_decisions, & ! intent(in): model decisions - forc_data, & ! intent(in): model forcing data - mpar_data, & ! intent(in): model parameters - diag_data, & ! intent(in): model diagnostic variables for a local HRU - prog_data, & ! intent(inout): model prognostic variables for a local HRU - flux_data, & ! intent(inout): model flux variables - ! output: error control - err,cmessage) ! intent(out): error control - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if - - ! adjust canopy temperature to account for new snow - if(computeVegFlux)then ! logical flag to compute vegetation fluxes (.false. if veg buried by snow) - call tempAdjust(& - ! input: derived parameters - canopyDepth, & ! intent(in): canopy depth (m) - ! input/output: data structures - mpar_data, & ! intent(in): model parameters - prog_data, & ! intent(inout): model prognostic variables for a local HRU - diag_data, & ! intent(out): model diagnostic variables for a local HRU - ! output: error control - err,cmessage) ! intent(out): error control - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if - endif ! if computing fluxes over vegetation - - ! initialize drainage and throughfall - ! NOTE 1: this needs to be done before solving the energy and liquid water equations, to account for the heat advected with precipitation - ! NOTE 2: this initialization needs to be done AFTER the call to canopySnow, since canopySnow uses canopy drip drom the previous time step - if(.not.computeVegFlux)then - flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1) = flux_data%var(iLookFLUX%scalarRainfall)%dat(1) - flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._rkind - else - flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1) = 0._rkind - flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._rkind - end if - - ! **************************************************************************************************** - ! *** MAIN SOLVER ************************************************************************************ - ! **************************************************************************************************** - - ! initialize the length of the sub-step - dt_solv = 0._rkind ! length of time step that has been completed (s) - dt_init = min(data_step,maxstep) ! initial substep length (s) - dt_sub = dt_init ! length of substep - dtSave = dt_init ! length of substep - - ! initialize the number of sub-steps - nsub=0 - - ! loop through sub-steps - substeps: do ! continuous do statement with exit clause (alternative to "while") - - ! print progress - !print*, '*** new substep' - !write(*,'(a,3(f11.4,1x))') 'dt_sub, dt_init = ', dt_sub, dt_init - - ! print progress - if(globalPrintFlag)then - write(*,'(a,1x,4(f13.5,1x))') ' start of step: dt_init, dt_sub, dt_solv, data_step: ', dt_init, dt_sub, dt_solv, data_step - print*, 'stepFailure = ', stepFailure - print*, 'before resizeData: nSnow, nSoil = ', nSnow, nSoil - endif + CALL system_clock(count_rate=count_rate) + CALL system_clock(i_start) - ! increment the number of sub-steps - nsub = nsub+1 - - ! resize the "indx_data" structure - ! NOTE: this is necessary because the length of index variables depends on a given split - ! --> the resize here is overwritten later (in indexSplit) - ! --> admittedly ugly, and retained for now - if(stepFailure)then - call resizeData(indx_meta(:),indx_temp,indx_data,err=err,message=cmessage) - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif - else - call resizeData(indx_meta(:),indx_data,indx_temp,err=err,message=cmessage) - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif + ! check that the decision is supported + if(model_decisions(iLookDECISIONS%groundwatr)%iDecision==bigBucket .and. & + model_decisions(iLookDECISIONS%spatial_gw)%iDecision/=localColumn)then + message=trim(message)//'expect "spatial_gw" decision to equal localColumn when "groundwatr" decision is bigBucket' + err=20; return endif - ! save/recover copies of index variables - do iVar=1,size(indx_data%var) - !print*, 'indx_meta(iVar)%varname = ', trim(indx_meta(iVar)%varname) - select case(stepFailure) - case(.false.); indx_temp%var(iVar)%dat(:) = indx_data%var(iVar)%dat(:) - case(.true.); indx_data%var(iVar)%dat(:) = indx_temp%var(iVar)%dat(:) - end select - end do ! looping through variables - - ! save/recover copies of prognostic variables - do iVar=1,size(prog_data%var) - !print*, 'prog_meta(iVar)%varname = ', trim(prog_meta(iVar)%varname) - select case(stepFailure) - case(.false.); prog_temp%var(iVar)%dat(:) = prog_data%var(iVar)%dat(:) - case(.true.); prog_data%var(iVar)%dat(:) = prog_temp%var(iVar)%dat(:) - end select - end do ! looping through variables - - ! save/recover copies of diagnostic variables - do iVar=1,size(diag_data%var) - select case(stepFailure) - case(.false.); diag_temp%var(iVar)%dat(:) = diag_data%var(iVar)%dat(:) - case(.true.); diag_data%var(iVar)%dat(:) = diag_temp%var(iVar)%dat(:) - end select - end do ! looping through variables - - ! re-assign dimension lengths - nSnow = count(indx_data%var(iLookINDEX%layerType)%dat==iname_snow) - nSoil = count(indx_data%var(iLookINDEX%layerType)%dat==iname_soil) - nLayers = nSnow+nSoil - - ! *** merge/sub-divide snow layers... - ! ----------------------------------- - call volicePack(& - ! input/output: model data structures - doLayerMerge, & ! intent(in): flag to force merge of snow layers - model_decisions, & ! intent(in): model decisions - mpar_data, & ! intent(in): model parameters - indx_data, & ! intent(inout): type of each layer - prog_data, & ! intent(inout): model prognostic variables for a local HRU - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - flux_data, & ! intent(inout): model fluxes for a local HRU - ! output - modifiedLayers, & ! intent(out): flag to denote that layers were modified - err,cmessage) ! intent(out): error control - if(err/=0)then; err=55; message=trim(message)//trim(cmessage); return; end if - - ! save the number of snow and soil layers - nSnow = indx_data%var(iLookINDEX%nSnow)%dat(1) - nSoil = indx_data%var(iLookINDEX%nSoil)%dat(1) - nLayers = indx_data%var(iLookINDEX%nLayers)%dat(1) - - - ! compute the indices for the model state variables - if(firstSubStep .or. modifiedVegState .or. modifiedLayers)then - call indexState(computeVegFlux, & ! intent(in): flag to denote if computing the vegetation flux - includeAquifer, & ! intent(in): flag to denote if included the aquifer - nSnow,nSoil,nLayers, & ! intent(in): number of snow and soil layers, and total number of layers - indx_data, & ! intent(inout): indices defining model states and layers - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if - end if - - ! recreate the temporary data structures - ! NOTE: resizeData(meta, old, new, ..) - if(modifiedVegState .or. modifiedLayers)then - - ! create temporary data structures for prognostic variables - call resizeData(prog_meta(:),prog_data,prog_temp,copy=.true.,err=err,message=cmessage) - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif - - ! create temporary data structures for diagnostic variables - call resizeData(diag_meta(:),diag_data,diag_temp,copy=.true.,err=err,message=cmessage) - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif - - ! create temporary data structures for index variables - call resizeData(indx_meta(:),indx_data,indx_temp,copy=.true.,err=err,message=cmessage) - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif - - do iVar=1,size(indx_data%var) - !print*, 'indx_meta(iVar)%varname = ', trim(indx_meta(iVar)%varname) - select case(stepFailure) - case(.false.); indx_temp%var(iVar)%dat(:) = indx_data%var(iVar)%dat(:) - case(.true.); indx_data%var(iVar)%dat(:) = indx_temp%var(iVar)%dat(:) - end select - end do ! looping through variables - - endif ! if modified the states - - ! define the number of state variables - nState = indx_data%var(iLookINDEX%nState)%dat(1) - - ! *** compute diagnostic variables for each layer... - ! -------------------------------------------------- - ! NOTE: this needs to be done AFTER volicePack, since layers may have been sub-divided and/or merged - call diagn_evar(& - ! input: control variables - computeVegFlux, & ! intent(in): flag to denote if computing the vegetation flux - canopyDepth, & ! intent(in): canopy depth (m) - ! input/output: data structures - mpar_data, & ! intent(in): model parameters - indx_data, & ! intent(in): model layer indices - prog_data, & ! intent(in): model prognostic variables for a local HRU - diag_data, & ! intent(inout): model diagnostic variables for a local HRU + ! check if the aquifer is included + includeAquifer = (model_decisions(iLookDECISIONS%groundwatr)%iDecision==bigBucket) + + ! initialize variables + call initialize_coupled_em + + ! link canopy depth to the information in the data structure + canopy: associate(& + snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1) ,& ! scaling parameter for the snow freezing curve (K-1) + canopyDepth => diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1) ,& ! depth of the vegetation canopy (m) + specificHeatVeg => mpar_data%var(iLookPARAM%specificHeatVeg)%dat(1) ,& ! specific heat of vegetation (J kg-1 K-1) + maxMassVegetation => mpar_data%var(iLookPARAM%maxMassVegetation)%dat(1) & ! maximum mass of vegetation (kg m-2) + ) + + ! define the first step and first and last inner steps + firstSubStep = .true. + firstInnerStep = .true. + lastInnerStep = .false. + + ! create temporary data structures for prognostic variables + call resizeData(prog_meta(:),prog_data,prog_temp,err=err,message=cmessage) + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif + + ! create temporary data structures for diagnostic variables + call resizeData(diag_meta(:),diag_data,diag_temp,err=err,message=cmessage) + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif + + ! create temporary data structures for index variables + call resizeData(indx_meta(:),indx_data,indx_temp,err=err,message=cmessage) + call resizeData(indx_meta(:),indx_data,indx_temp0,err=err,message=cmessage) + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif + + ! allocate space for the local fluxes + call allocLocal(averageFlux_meta(:)%var_info,flux_mean,nSnow,nSoil,err,cmessage) + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if + call allocLocal(averageFlux_meta(:)%var_info,flux_inner,nSnow,nSoil,err,cmessage) + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if + + ! initialize fluxes to average over data_step (averaged over substep in varSubStep) + do iVar=1,size(averageFlux_meta) + flux_mean%var(iVar)%dat(:) = 0._rkind + end do + + ! associate local variables with information in the data structures + associate(& + ! model decisions + ixNumericalMethod => model_decisions(iLookDECISIONS%num_method)%iDecision ,& ! choice of numerical solver + ixNrgConserv => model_decisions(iLookDECISIONS%nrgConserv)%iDecision ,& ! choice of variable in either energy backward Euler residual or IDA state variable + ! state variables in the vegetation canopy + scalarCanopyLiq => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1) ,& ! canopy liquid water (kg m-2) + scalarCanopyIce => prog_data%var(iLookPROG%scalarCanopyIce)%dat(1) ,& ! canopy ice content (kg m-2) + ! state variables in the soil domain + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat(nSnow+1:nLayers) ,& ! depth of each soil layer (m) + mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat(nSnow+1:nLayers) ,& ! volumetric ice content in each soil layer (-) + mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat(nSnow+1:nLayers) ,& ! volumetric liquid water content in each soil layer (-) + scalarAquiferStorage => prog_data%var(iLookPROG%scalarAquiferStorage)%dat(1) ,& ! aquifer storage (m) + scalarTotalSoilIce => diag_data%var(iLookDIAG%scalarTotalSoilIce)%dat(1) ,& ! total ice in the soil column (kg m-2) + scalarTotalSoilLiq => diag_data%var(iLookDIAG%scalarTotalSoilLiq)%dat(1) ,& ! total liquid water in the soil column (kg m-2) + scalarTotalSoilWat => diag_data%var(iLookDIAG%scalarTotalSoilWat)%dat(1) & ! total water in the soil column (kg m-2) + ) ! (association of local variables with information in the data structures + + + ! identify the need to check the mass balance, both methods should work if tolerance coarse enough + select case(ixNumericalMethod) + case(ida); checkMassBalance_ds = .false. ! IDA balance agreement levels are controlled by set tolerances + case(kinsol, homegrown); checkMassBalance_ds = .true. ! KINSOL or homegrown give finite difference dt_sub fluxes and were summed for an average flux + case default; err=20; message=trim(message)//'expect num_method to be ida, kinsol, or homegrown (or itertive, which is homegrown)'; return + end select + + ! set the number of substeps for a BE solver + be_steps = NINT(mpar_data%var(iLookPARAM%be_steps)%dat(1)) ! number of substeps for a BE solver + if (be_steps < 1) then + message=trim(message)//'expect be_steps to be greater than 0' + err=20; return + end if + if (ixNumericalMethod == ida) be_steps = 1_i4b ! IDA does not use substeps + + ! set the flag to compute enthalpy, may want to have this true always if want to output enthalpy + computeEnthalpy = .false. + enthalpyStateVec = .false. + use_lookup = .false. + if(ixNumericalMethod.ne.ida)then + if(ixNrgConserv.ne.closedForm .or. computNrgBalance_var) computeEnthalpy = .true. ! compute energy balance or need enthalpy in residual + else ! enthalpy state variable only implemented for IDA, energy conserved in IDA without using enthTemp + if(ixNrgConserv.ne.closedForm) enthalpyStateVec = .true. ! enthalpy as state variable + endif + if(ixNrgConserv==enthalpyFormLU) use_lookup = .true. ! use lookup tables for soil temperature-enthalpy instead of analytical solution + + ! save the liquid water and ice on the vegetation canopy + scalarInitCanopyLiq = scalarCanopyLiq ! initial liquid water on the vegetation canopy (kg m-2) + scalarInitCanopyIce = scalarCanopyIce ! initial ice on the vegetation canopy (kg m-2) + + ! compute total soil moisture and ice at the *START* of the step (kg m-2) + scalarTotalSoilLiq = sum(iden_water*mLayerVolFracLiq(1:nSoil)*mLayerDepth(1:nSoil)) + scalarTotalSoilIce = sum(iden_water*mLayerVolFracIce(1:nSoil)*mLayerDepth(1:nSoil)) ! NOTE: no expansion and hence use iden_water + + ! compute storage of water in the canopy and the soil + balanceCanopyWater0 = scalarCanopyLiq + scalarCanopyIce + balanceSoilWater0 = scalarTotalSoilLiq + scalarTotalSoilIce + + ! get the total aquifer storage at the start of the time step (kg m-2) + balanceAquifer0 = scalarAquiferStorage*iden_water + + ! save liquid water content + if(printBalance)then + allocate(liqSnowInit(nSnow), liqSoilInit(nSoil), stat=err) + if(err/=0)then + message=trim(message)//'unable to allocate space for the initial vectors' + err=20; return + endif + if(nSnow>0) liqSnowInit = prog_data%var(iLookPROG%mLayerVolFracLiq)%dat(1:nSnow) + liqSoilInit = mLayerVolFracLiq + endif + + ! end association of local variables with information in the data structures + end associate + + ! short-cut to the algorithmic control parameters + ! NOTE - temporary assignment of minstep to foce something reasonable + ! changing the maxstep parameter will make the outer and inner loop computations here in coupled_em happen more frequently + ! changing the be_steps parameter will make the inner loop computations in opSplittin happen more frequently (e.g. be_steps = 32.0 give BE32) + minstep = mpar_data%var(iLookPARAM%minstep)%dat(1) ! minimum time step (s) + maxstep = mpar_data%var(iLookPARAM%maxstep)%dat(1) ! maximum time step (s) + maxstep_op = mpar_data%var(iLookPARAM%maxstep)%dat(1)/be_steps ! maximum time step (s) to run opSplittin over + + ! compute the number of layers with roots + nLayersRoots = count(prog_data%var(iLookPROG%iLayerHeight)%dat(nSnow:nLayers-1) < mpar_data%var(iLookPARAM%rootingDepth)%dat(1)-verySmall) + if(nLayersRoots == 0)then + message=trim(message)//'no roots within the soil profile' + err=20; return + end if + + ! define the foliage nitrogen factor + diag_data%var(iLookDIAG%scalarFoliageNitrogenFactor)%dat(1) = 1._rkind ! foliage nitrogen concentration (1.0 = saturated) + + ! save SWE + oldSWE = prog_data%var(iLookPROG%scalarSWE)%dat(1) + + ! *** compute phenology... + ! ------------------------ + + ! compute the temperature of the root zone: used in vegetation phenology + diag_data%var(iLookDIAG%scalarRootZoneTemp)%dat(1) = sum(prog_data%var(iLookPROG%mLayerTemp)%dat(nSnow+1:nSnow+nLayersRoots)) / real(nLayersRoots, kind(rkind)) + + ! remember if we compute the vegetation flux on the previous sub-step + computeVegFluxOld = computeVegFlux + + ! compute the exposed LAI and SAI and whether veg is buried by snow + call vegPhenlgy(& + ! model control + nSnow, & ! intent(in): number of snow layers + model_decisions, & ! intent(in): model decisions + ! input/output: data structures + fracJulDay, & ! intent(in): fractional julian days since the start of year + yearLength, & ! intent(in): number of days in the current year + type_data, & ! intent(in): type of vegetation and soil + attr_data, & ! intent(in): spatial attributes + mpar_data, & ! intent(in): model parameters + prog_data, & ! intent(inout): model prognostic variables for a local HRU + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + ! output + computeVegFlux, & ! intent(out): flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) + canopyDepth, & ! intent(out): canopy depth (m) + exposedVAI, & ! intent(out): exposed vegetation area index (m2 m-2) + err,cmessage) ! intent(out): error control + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if + + ! check + if(computeVegFlux)then + if(canopyDepth < epsilon(canopyDepth))then + message=trim(message)//'canopy depth is zero when computeVegFlux flag is .true.' + err=20; return + endif + endif + + ! flag the case where number of vegetation states has changed + modifiedVegState = (computeVegFlux.neqv.computeVegFluxOld) + + ! *** compute wetted canopy area... + ! --------------------------------- + + ! compute maximum canopy liquid water (kg m-2) + diag_data%var(iLookDIAG%scalarCanopyLiqMax)%dat(1) = mpar_data%var(iLookPARAM%refInterceptCapRain)%dat(1)*exposedVAI + + ! compute maximum canopy ice content (kg m-2) + ! NOTE 1: this is used to compute the snow fraction on the canopy, as used in *BOTH* the radiation AND canopy sublimation routines + ! NOTE 2: this is a different variable than the max ice used in the throughfall (snow interception) calculations + ! NOTE 3: use maximum per unit leaf area storage capacity for snow (kg m-2) + select case(model_decisions(iLookDECISIONS%snowIncept)%iDecision) + case(lightSnow); diag_data%var(iLookDIAG%scalarCanopyIceMax)%dat(1) = exposedVAI*mpar_data%var(iLookPARAM%refInterceptCapSnow)%dat(1) + case(stickySnow); diag_data%var(iLookDIAG%scalarCanopyIceMax)%dat(1) = exposedVAI*mpar_data%var(iLookPARAM%refInterceptCapSnow)%dat(1)*4._rkind + case default; message=trim(message)//'unable to identify option for maximum branch interception capacity'; err=20; return + end select ! identifying option for maximum branch interception capacity + + ! compute wetted fraction of the canopy + ! NOTE: assume that the wetted fraction is constant over the substep for the radiation calculations + if(computeVegFlux)then + + ! compute wetted fraction of the canopy + call wettedFrac(& + ! input + .false., & ! flag to denote if derivatives are required + (prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1) < Tfreeze), & ! flag to denote if the canopy is frozen + varNotUsed1, & ! derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) + varNotUsed2, & ! fraction of liquid water on the canopy + prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1), & ! canopy liquid water (kg m-2) + prog_data%var(iLookPROG%scalarCanopyIce)%dat(1), & ! canopy ice (kg m-2) + diag_data%var(iLookDIAG%scalarCanopyLiqMax)%dat(1), & ! maximum canopy liquid water (kg m-2) + diag_data%var(iLookDIAG%scalarCanopyIceMax)%dat(1), & ! maximum canopy ice content (kg m-2) + mpar_data%var(iLookPARAM%canopyWettingFactor)%dat(1), & ! maximum wetted fraction of the canopy (-) + mpar_data%var(iLookPARAM%canopyWettingExp)%dat(1), & ! exponent in canopy wetting function (-) + ! output + diag_data%var(iLookDIAG%scalarCanopyWetFraction)%dat(1), & ! canopy wetted fraction (-) + dCanopyWetFraction_dWat, & ! derivative in wetted fraction w.r.t. canopy liquid water content (kg-1 m2) + dCanopyWetFraction_dT, & ! derivative in wetted fraction w.r.t. canopy liquid water content (kg-1 m2) + err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + + ! vegetation is completely buried by snow (or no veg exists at all) + else + diag_data%var(iLookDIAG%scalarCanopyWetFraction)%dat(1) = 0._rkind + dCanopyWetFraction_dWat = 0._rkind + dCanopyWetFraction_dT = 0._rkind + end if + + ! *** compute snow albedo... + ! -------------------------- + ! NOTE: this should be done before the radiation calculations + ! NOTE: uses snowfall; should really use canopy throughfall + canopy unloading + call snowAlbedo(& + ! input: model control + data_step, & ! intent(in): model time step (s) + (nSnow > 0), & ! intent(in): logical flag to denote if snow is present + ! input/output: data structures + model_decisions, & ! intent(in): model decisions + mpar_data, & ! intent(in): model parameters + flux_data, & ! intent(in): model flux variables + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + prog_data, & ! intent(inout): model prognostic variables for a local HRU + ! output: error control + err,cmessage) ! intent(out): error control + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if + + ! *** compute canopy sw radiation fluxes... + ! ----------------------------------------- + call vegSWavRad(& + data_step, & ! intent(in): time step (s) -- only used in Noah-MP radiation, to compute albedo + nSnow, & ! intent(in): number of snow layers + nSoil, & ! intent(in): number of soil layers + nLayers, & ! intent(in): total number of layers + computeVegFlux, & ! intent(in): logical flag to compute vegetation fluxes (.false. if veg buried by snow) + type_data, & ! intent(in): type of vegetation and soil + prog_data, & ! intent(inout): model prognostic variables for a local HRU + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + flux_data, & ! intent(inout): model flux variables + err,cmessage) ! intent(out): error control + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if + + ! *** compute canopy throughfall and unloading... + ! ----------------------------------------------- + ! NOTE 1: this needs to be done before solving the energy and liquid water equations, to account for the heat advected with precipitation (and throughfall/unloading) + ! NOTE 2: the unloading flux is computed using canopy drip (scalarCanopyLiqDrainage) from the previous time step + ! this changes canopy ice + call canopySnow(& + ! input: model control + data_step, & ! intent(in): time step (seconds) + exposedVAI, & ! intent(in): exposed vegetation area index (m2 m-2) + computeVegFlux, & ! intent(in): flag to denote if computing energy flux over vegetation + ! input/output: data structures + model_decisions, & ! intent(in): model decisions + forc_data, & ! intent(in): model forcing data + mpar_data, & ! intent(in): model parameters + diag_data, & ! intent(in): model diagnostic variables for a local HRU + prog_data, & ! intent(inout): model prognostic variables for a local HRU + flux_data, & ! intent(inout): model flux variables + ! output: error control + err,cmessage) ! intent(out): error control + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if + + ! adjust canopy temperature to account for new snow + if(computeVegFlux)then ! logical flag to compute vegetation fluxes (.false. if veg buried by snow) + call tempAdjust(& + ! input: derived parameters + canopyDepth, & ! intent(in): canopy depth (m) + ! input/output: data structures + mpar_data, & ! intent(in): model parameters + prog_data, & ! intent(inout): model prognostic variables for a local HRU + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + ! output: error control + err,cmessage) ! intent(out): error control + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if + + ! change enthalpy based on new canopy temperature and water content, only if will need enthalpy for energy balance + if(enthalpyStateVec .or. computeEnthalpy)then + ! associate local variables with variables in the data structures + enthalpyVeg: associate(& + ! state variables in the vegetation canopy + scalarCanopyTemp => prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1) ,& ! canopy temperature (K) + scalarCanopyEnthTemp => diag_data%var(iLookDIAG%scalarCanopyEnthTemp)%dat(1) ,& ! canopy temperature component of enthalpy (J m-3) + scalarCanopyEnthalpy => prog_data%var(iLookPROG%scalarCanopyEnthalpy)%dat(1) ,& ! enthalpy of the vegetation canopy (J m-3) + scalarCanopyLiq => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1) ,& ! mass of liquid water on the vegetation canopy (kg m-2) + scalarCanopyIce => prog_data%var(iLookPROG%scalarCanopyIce)%dat(1) & ! mass of ice on the vegetation canopy (kg m-2) + ) ! (associate local variables with model parameters) + call T2enthTemp_veg(& + canopyDepth, & ! intent(in): canopy depth (m) + specificHeatVeg, & ! intent(in): specific heat of vegetation (J kg-1 K-1) + maxMassVegetation, & ! intent(in): maximum mass of vegetation (kg m-2) + snowfrz_scale, & ! intent(in): scaling parameter for the snow freezing curve (K-1) + scalarCanopyTemp, & ! intent(in): canopy temperature (K) + (scalarCanopyLiq+scalarCanopyIce), & ! intent(in): canopy water content (kg m-2) + scalarCanopyEnthTemp) ! intent(out): temperature component of enthalpy of the vegetation canopy (J m-3) + scalarCanopyEnthalpy = scalarCanopyEnthTemp - LH_fus * scalarCanopyIce/ canopyDepth ! new ice and/or temperature + end associate enthalpyVeg + end if ! (need to recalculate enthalpy state variable) + end if ! if computing fluxes over vegetation + + ! initialize drainage and throughfall + ! NOTE 1: this needs to be done before solving the energy and liquid water equations, to account for the heat advected with precipitation + ! NOTE 2: this initialization needs to be done AFTER the call to canopySnow, since canopySnow uses canopy drip drom the previous time step + if(.not.computeVegFlux)then + flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1) = flux_data%var(iLookFLUX%scalarRainfall)%dat(1) + else + flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1) = 0._rkind + end if + flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._rkind + + ! **************************************************************************************************** + ! *** MAIN SOLVER ************************************************************************************ + ! **************************************************************************************************** + + ! initialize the length of the sub-step and counters + whole_step = maxstep + dt_solv = 0._rkind ! length of time step that has been completed (s) + dt_solvInner = 0._rkind ! length of time step that has been completed (s) in whole_step subStep + dt_init = min(data_step,whole_step,maxstep_op) / dt_init_factor ! initial substep length (s) + dt_sub = dt_init + dtSave = whole_step ! length of whole substep + + ! initialize the number of sub-steps + nsub = 0 + nsub_success = 0 + + ! initialize if used a balance + bal_veg = .false. + bal_snow = .false. + bal_soil = .false. + bal_aq = .false. + + ! loop through sub-steps + substeps: do ! continuous do statement with exit clause (alternative to "while") + + dt_sub = min(data_step,whole_step,maxstep_op,dt_sub) ! adjust for possible whole_step changes + + ! print progress + if(globalPrintFlag)then + write(*,'(a,1x,4(f13.5,1x))') ' start of step: dt_init, dt_sub, dt_solv, data_step: ', dt_init, dt_sub, dt_solv, data_step + print*, 'stepFailure = ', stepFailure + print*, 'before resizeData: nSnow, nSoil = ', nSnow, nSoil + endif + + ! increment the number of sub-steps + nsub = nsub+1 + + ! resize the "indx_data" structure + ! NOTE: this is necessary because the length of index variables depends on a given split + ! --> the resize here is overwritten later (in indexSplit) + ! --> admittedly ugly, and retained for now + if(stepFailure)then ! resize temp to current data, later in code current data is set to lastInnerStep data + call resizeData(indx_meta(:),indx_temp,indx_data,err=err,message=cmessage) + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif + else ! resize current data to temp0, temp0 is saved for next run + call resizeData(indx_meta(:),indx_data,indx_temp0,err=err,message=cmessage) + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif + do iVar=1,size(indx_data%var) + indx_temp0%var(iVar)%dat(:) = indx_data%var(iVar)%dat(:) + end do + endif + + ! check if on outer loop, always do outer if after failed step and on then on reduced whole_step + do_outer = .false. + if(stepFailure) firstInnerStep = .true. + if(firstInnerStep) do_outer = .true. + + if(do_outer)then + + if(.not.stepFailure)then + call resizeData(indx_meta(:),indx_data,indx_temp,err=err,message=cmessage) + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif + endif + + ! save/recover copies of index variables, temp saved on lastInnerStep, failed starts at lastInnerStep + do iVar=1,size(indx_data%var) + select case(stepFailure) + case(.false.); indx_temp%var(iVar)%dat(:) = indx_data%var(iVar)%dat(:) + case(.true.); indx_data%var(iVar)%dat(:) = indx_temp%var(iVar)%dat(:) + end select + end do ! looping through variables + + ! save/recover copies of prognostic variables + do iVar=1,size(prog_data%var) + select case(stepFailure) + case(.false.); prog_temp%var(iVar)%dat(:) = prog_data%var(iVar)%dat(:) + case(.true.); prog_data%var(iVar)%dat(:) = prog_temp%var(iVar)%dat(:) + end select + end do ! looping through variables + + ! save/recover copies of diagnostic variables + do iVar=1,size(diag_data%var) + select case(stepFailure) + case(.false.); diag_temp%var(iVar)%dat(:) = diag_data%var(iVar)%dat(:) + case(.true.); diag_data%var(iVar)%dat(:) = diag_temp%var(iVar)%dat(:) + end select + end do ! looping through variables + + ! re-assign dimension lengths + nSnow = count(indx_data%var(iLookINDEX%layerType)%dat==iname_snow) + nSoil = count(indx_data%var(iLookINDEX%layerType)%dat==iname_soil) + nLayers = nSnow+nSoil + + ! *** merge/sub-divide snow layers... + ! ----------------------------------- + call volicePack(& + ! input/output: model data structures + doLayerMerge, & ! intent(in): flag to force merge of snow layers + model_decisions, & ! intent(in): model decisions + mpar_data, & ! intent(in): model parameters + indx_data, & ! intent(inout): type of each layer + prog_data, & ! intent(inout): model prognostic variables for a local HRU + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + flux_data, & ! intent(inout): model fluxes for a local HRU + ! output + modifiedLayers, & ! intent(out): flag to denote that layers were modified + err,cmessage) ! intent(out): error control + if(err/=0)then; err=55; message=trim(message)//trim(cmessage); return; end if + + ! save the number of snow and soil layers + nSnow = indx_data%var(iLookINDEX%nSnow)%dat(1) + nSoil = indx_data%var(iLookINDEX%nSoil)%dat(1) + nLayers = indx_data%var(iLookINDEX%nLayers)%dat(1) + + ! compute the indices for the model state variables + if(firstSubStep .or. modifiedVegState .or. modifiedLayers)then + call indexState(computeVegFlux, & ! intent(in): flag to denote if computing the vegetation flux + includeAquifer, & ! intent(in): flag to denote if included the aquifer + nSnow,nSoil,nLayers, & ! intent(in): number of snow and soil layers, and total number of layers + indx_data, & ! intent(inout): indices defining model states and layers + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + end if + + ! get enthalpy from temperature if new layering + if( (enthalpyStateVec .or. computeEnthalpy) .and. modifiedLayers )then + ! associate local variables with variables in the data structures + enthalpySnow: associate(& + ! variables in the snow and soil domains + mLayerTemp => prog_data%var(iLookPROG%mLayerTemp)%dat ,& ! temperature (K) + mLayerEnthTemp => diag_data%var(iLookDIAG%mLayerEnthTemp)%dat ,& ! temperature component of enthalpy (J m-3) + mLayerEnthalpy => prog_data%var(iLookPROG%mLayerEnthalpy)%dat ,& ! enthalpy (J m-3) + mLayerVolFracWat => prog_data%var(iLookPROG%mLayerVolFracWat)%dat ,& ! volumetric fraction of total water in each snow layer (-) + mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat ,& ! volumetric fraction of liquid water (-) + mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat ,& ! volumetric fraction of ice in each snow layer (-) + mLayerMatricHead => prog_data%var(iLookPROG%mLayerMatricHead)%dat ,& ! matric head (m) + ! depth-varying soil parameters + soil_dens_intr => mpar_data%var(iLookPARAM%soil_dens_intr)%dat ,& ! surface layer intrinsic soil density (kg m-3) + vGn_m => diag_data%var(iLookDIAG%scalarVGn_m)%dat ,& ! van Genutchen "m" parameter (-) + vGn_n => mpar_data%var(iLookPARAM%vGn_n)%dat ,& ! van Genutchen "n" parameter (-) + vGn_alpha => mpar_data%var(iLookPARAM%vGn_alpha)%dat ,& ! van Genutchen "alpha" parameter (m-1) + theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat ,& ! soil porosity (-) + theta_res => mpar_data%var(iLookPARAM%theta_res)%dat & ! soil residual volumetric water content (-) + ) ! (associate local variables with model parameters) + + if(nSnow>0)then + do iLayer=1,nSnow + mLayerVolFracWat(iLayer) = mLayerVolFracLiq(iLayer) + mLayerVolFracIce(iLayer)*(iden_ice/iden_water) + ! compute enthalpy for snow layers + call T2enthTemp_snow(& + snowfrz_scale, & ! intent(in): scaling parameter for the snow freezing curve (K-1) + mLayerTemp(iLayer), & ! intent(in): layer temperature (K) + mLayerVolFracWat(iLayer), & ! intent(in): volumetric total water content (-) + mLayerEnthTemp(iLayer)) ! intent(out): temperature component of enthalpy of each snow layer (J m-3) + mLayerEnthalpy(iLayer) = mLayerEnthTemp(iLayer) - iden_ice * LH_fus * mLayerVolFracIce(iLayer) + end do ! looping through snow layers + endif + do iLayer=nSnow+1,nLayers + mLayerVolFracWat(iLayer) = mLayerVolFracLiq(iLayer) + mLayerVolFracIce(iLayer) + ! compute enthalpy for soil layers + iSoil = iLayer - nSnow + call T2enthTemp_soil(& + use_lookup, & ! intent(in): flag to use the lookup table for soil enthalpy + soil_dens_intr(iSoil), & ! intent(in): intrinsic soil density (kg m-3) + vGn_alpha(iSoil),vGn_n(iSoil),theta_sat(iSoil),theta_res(iSoil),vGn_m(iSoil), & ! intent(in): soil parameters + iSoil, & ! intent(in): index of the control volume within the domain + lookup_data, & ! intent(in): lookup table data structure + realMissing, & ! intent(in): lower value of integral (not computed) + mLayerTemp(iLayer), & ! intent(in): layer temperature (K) + mLayerMatricHead(iSoil), & ! intent(in): matric head (m) + mLayerEnthTemp(iLayer), & ! intent(out): temperature component of enthalpy soil layer (J m-3) + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + mLayerEnthalpy(iLayer) = mLayerEnthTemp(iLayer) - iden_water * LH_fus * mLayerVolFracIce(iLayer) + end do ! looping through soil layers + end associate enthalpySnow + end if ! (need to recalculate enthalpy state variable) + + ! recreate the temporary data structures + ! NOTE: resizeData(meta, old, new, ..) + if(modifiedVegState .or. modifiedLayers)then + + ! create temporary data structures for prognostic variables + call resizeData(prog_meta(:),prog_data,prog_temp,copy=.true.,err=err,message=cmessage) + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif + + ! create temporary data structures for diagnostic variables + call resizeData(diag_meta(:),diag_data,diag_temp,copy=.true.,err=err,message=cmessage) + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif + + ! create temporary data structures for index variables + call resizeData(indx_meta(:),indx_data,indx_temp,copy=.true.,err=err,message=cmessage) + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif + + do iVar=1,size(indx_data%var) + select case(stepFailure) + case(.false.); indx_temp%var(iVar)%dat(:) = indx_data%var(iVar)%dat(:) + case(.true.); indx_data%var(iVar)%dat(:) = indx_temp%var(iVar)%dat(:) + end select + end do ! looping through variables + + endif ! if modified the states + + ! define the number of state variables + nState = indx_data%var(iLookINDEX%nState)%dat(1) + + ! *** compute diagnostic variables for each layer... + ! -------------------------------------------------- + ! NOTE: this needs to be done AFTER volicePack, since layers may have been sub-divided and/or merged, and need to specifically send in canopy depth + call diagn_evar(& + ! input: control variables + computeVegFlux, & ! intent(in): flag to denote if computing the vegetation flux + diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1), & ! intent(in): canopy depth (m), send in specific value since diag_data may have changed + ! input/output: data structures + mpar_data, & ! intent(in): model parameters + indx_data, & ! intent(in): model layer indices + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + ! output: error control + err,cmessage) ! intent(out): error control + if(err/=0)then; err=55; message=trim(message)//trim(cmessage); return; end if + + ! *** compute melt of the "snow without a layer"... + ! ------------------------------------------------- + ! NOTE: forms a surface melt pond, which drains into the upper-most soil layer through the time step + ! (check for the special case of "snow without a layer") + ! this pond melts evenly over entire time of maxstep until it gets recomputed because based on SWE when computed + if(nSnow==0) then + call implctMelt(& + ! input/output: integrated snowpack properties + prog_data%var(iLookPROG%scalarSWE)%dat(1), & ! intent(inout): snow water equivalent (kg m-2) + prog_data%var(iLookPROG%scalarSnowDepth)%dat(1), & ! intent(inout): snow depth (m) + prog_data%var(iLookPROG%scalarSfcMeltPond)%dat(1), & ! intent(out): surface melt pond (kg m-2) + ! input/output: properties of the upper-most soil layer + prog_data%var(iLookPROG%mLayerTemp)%dat(nSnow+1), & ! intent(inout): surface layer temperature (K) + prog_data%var(iLookPROG%mLayerDepth)%dat(nSnow+1), & ! intent(inout): surface layer depth (m) + diag_data%var(iLookDIAG%mLayerVolHtCapBulk)%dat(nSnow+1),& ! intent(in): surface layer volumetric heat capacity (J m-3 K-1) + ! output: error control + err,cmessage ) ! intent(out): error control + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if + endif + + ! save volumetric ice content at the start of the step + ! NOTE: used for volumetric loss due to melt-freeze + if (allocated(mLayerVolFracIceInit)) deallocate(mLayerVolFracIceInit) ! prep for potential size change + allocate(mLayerVolFracIceInit(nLayers)); mLayerVolFracIceInit = prog_data%var(iLookPROG%mLayerVolFracIce)%dat + + ! make sure have consistent state variables to start, later done in updateVars + ! associate local variables with information in the data structures + init: associate(& + ! depth-varying soil parameters + soil_dens_intr => mpar_data%var(iLookPARAM%soil_dens_intr)%dat(1) ,& ! intent(in): [dp] surface layer intrinsic soil density (kg m-3) + vGn_m => diag_data%var(iLookDIAG%scalarVGn_m)%dat ,& ! intent(in): [dp(:)] van Genutchen "m" parameter (-) + vGn_n => mpar_data%var(iLookPARAM%vGn_n)%dat ,& ! intent(in): [dp(:)] van Genutchen "n" parameter (-) + vGn_alpha => mpar_data%var(iLookPARAM%vGn_alpha)%dat ,& ! intent(in): [dp(:)] van Genutchen "alpha" parameter (m-1) + theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat ,& ! intent(in): [dp(:)] soil porosity (-) + theta_res => mpar_data%var(iLookPARAM%theta_res)%dat ,& ! intent(in): [dp(:)] soil residual volumetric water content (-) + ! variables in the vegetation canopy + scalarCanopyIce => prog_data%var(iLookPROG%scalarCanopyIce)%dat(1) ,& ! intent(in): [dp] mass of ice on the vegetation canopy (kg m-2) + scalarCanopyLiq => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1) ,& ! intent(in): [dp] mass of liquid water on the vegetation canopy (kg m-2) + scalarCanopyWat => prog_data%var(iLookPROG%scalarCanopyWat)%dat(1) ,& ! intent(out): [dp] mass of total water on the vegetation canopy (kg m-2) + ! variables in the snow and soil domains + mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat ,& ! intent(in): [dp(:)] volumetric fraction of ice (-) + mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat ,& ! intent(in): [dp(:)] volumetric fraction of liquid water (-) + mLayerVolFracWat => prog_data%var(iLookPROG%mLayerVolFracWat)%dat ,& ! intent(out): [dp(:)] volumetric fraction of total water (-) + mLayerMatricHead => prog_data%var(iLookPROG%mLayerMatricHead)%dat ,& ! intent(in): [dp(:)] matric head (m) + mLayerMatricHeadLiq => diag_data%var(iLookDIAG%mLayerMatricHeadLiq)%dat & ! intent(out): [dp(:)] matric potential of liquid water (m) + ) ! associations to variables in data structures + + ! compute the total water content in the vegetation canopy + scalarCanopyWat = scalarCanopyLiq + scalarCanopyIce ! kg m-2 + + ! compute the total water content in snow and soil, no ice expansion allowed for soil + if(nSnow>0)& + mLayerVolFracWat( 1:nSnow ) = mLayerVolFracLiq( 1:nSnow ) + mLayerVolFracIce( 1:nSnow )*(iden_ice/iden_water) + mLayerVolFracWat(nSnow+1:nLayers) = mLayerVolFracLiq(nSnow+1:nLayers) + mLayerVolFracIce(nSnow+1:nLayers) + + ! compute enthalpy of the top soil layer if changed with surface melt pond + if( (enthalpyStateVec .or. computeEnthalpy) .and. nSnow==0 .and. prog_data%var(iLookPROG%scalarSWE)%dat(1)>0._rkind )then + call T2enthTemp_soil(& + use_lookup, & ! intent(in): flag to use the lookup table for soil enthalpy + soil_dens_intr, & ! intent(in): intrinsic soil density (kg m-3) + vGn_alpha(1),vGn_n(1),theta_sat(1),theta_res(1),vGn_m(1), & ! intent(in): van Genutchen soil parameters + 1_i4b, & ! intent(in): index of the control volume within the domain + lookup_data, & ! intent(in): lookup table data structure + realMissing, & ! intent(in): lower value of integral (not computed) + prog_data%var(iLookPROG%mLayerTemp)%dat(nSnow+1), & ! intent(in): surface layer temperature (K) + mLayerMatricHead(1), & ! intent(in): surface layer matric head (m) + diag_data%var(iLookDIAG%mLayerEnthTemp)%dat(nSnow+1), & ! intent(out): temperature component of enthalpy soil layer (J m-3) + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + prog_data%var(iLookPROG%mLayerEnthalpy)%dat(nSnow+1) = diag_data%var(iLookDIAG%mLayerEnthTemp)%dat(nSnow+1) - iden_water * LH_fus * mLayerVolFracIce(nSnow+1) + end if + + ! compute the liquid water matric potential (m) + ! NOTE: include ice content as part of the solid porosity - major effect of ice is to reduce the pore size; ensure that effSat=1 at saturation + ! (from Zhao et al., J. Hydrol., 1997: Numerical analysis of simultaneous heat and mass transfer...) + do iSoil=1,nSoil + call liquidHead(mLayerMatricHead(iSoil),mLayerVolFracLiq(nSnow+iSoil),mLayerVolFracIce(nSnow+iSoil), & ! input: state variables + vGn_alpha(iSoil),vGn_n(iSoil),theta_sat(iSoil),theta_res(iSoil),vGn_m(iSoil), & ! input: parameters + matricHeadLiq=mLayerMatricHeadLiq(iSoil), & ! output: liquid water matric potential (m) + err=err,message=cmessage) ! output: error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + end do ! looping through soil layers (computing liquid water matric potential) + + end associate init + + ! correct increments (if need to redo inner step) and reset increment + dt_solv = dt_solv - dt_solvInner + dt_solvInner = 0._rkind + lastInnerStep = .false. + + ! initialize sublimation sums to average over whole_step + sumCanopySublimation = 0._rkind + sumSnowSublimation = 0._rkind + sumLatHeatCanopyEvap = 0._rkind + sumSenHeatCanopy = 0._rkind + ! initialize fluxes to average over whole_step (averaged over substep in varSubStep) + do iVar=1,size(averageFlux_meta) + flux_inner%var(iVar)%dat(:) = 0._rkind + end do + innerEffRainfall = 0._rkind ! mean total effective rainfall over snow + innerSoilCompress = 0._rkind ! mean total soil compression + innerBalance = 0._rkind ! mean total balance array + if (allocated(innerBalanceLayerNrg)) deallocate(innerBalanceLayerNrg) + allocate(innerBalanceLayerNrg(nLayers)); innerBalanceLayerNrg = 0._rkind ! mean total balance of energy in layers + if (allocated(innerBalanceLayerMass)) deallocate(innerBalanceLayerMass) ! deallocate if already allocated to permit size change + allocate(innerBalanceLayerMass(nLayers)); innerBalanceLayerMass = 0._rkind ! mean total balance of mass in layers + sumStepSize= 0._rkind ! initialize the sum of the step sizes + + endif ! (do_outer loop) + + ! *** solve model equations... + ! ---------------------------- + ! save input step + dtSave = whole_step + + ! get the new solution + call opSplittin(& + ! input: model control + nSnow, & ! intent(in): number of snow layers + nSoil, & ! intent(in): number of soil layers + nLayers, & ! intent(in): total number of layers + nState, & ! intent(in): total number of layers + dt_sub, & ! intent(in): length of the model sub-step + whole_step, & ! intent(in): length of whole step for surface drainage and average flux + (dt_solv= whole_step) lastInnerStep = .true. + if(dt_solv + dt_sub >= data_step-verySmall) lastInnerStep = .true. + + ! check if on outer loop + do_outer = .false. + if(lastInnerStep) do_outer = .true. + + if(do_outer)then + + ! *** remove ice due to sublimation and freeze calculations... + ! NOTE: In the future this should be moved into the solver, makes a big difference + ! -------------------------------------------------------------- + sublime: associate(& + mLayerMeltFreeze => diag_data%var(iLookDIAG%mLayerMeltFreeze)%dat, & ! melt-freeze in each snow and soil layer (kg m-3) + scalarCanopyLiq => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1), & ! liquid water stored on the vegetation canopy (kg m-2) + scalarCanopyIce => prog_data%var(iLookPROG%scalarCanopyIce)%dat(1), & ! ice stored on the vegetation canopy (kg m-2) + scalarCanopyWat => prog_data%var(iLookPROG%scalarCanopyWat)%dat(1), & ! canopy ice content (kg m-2) + mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat, & ! volumetric fraction of ice in the snow+soil domain (-) + mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat, & ! volumetric fraction of liquid water in the snow+soil domain (-) + mLayerVolFracWat => prog_data%var(iLookPROG%mLayerVolFracWat)%dat, & ! volumetric fraction of total water (-) + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat & ! depth of each snow+soil layer (m) + ) ! associations to variables in data structures + + ! compute the melt in each snow and soil layer + if(nSnow>0)& + mLayerMeltFreeze(1:nSnow) = -( mLayerVolFracIce(1:nSnow) - mLayerVolFracIceInit(1:nSnow) ) *iden_ice + mLayerMeltFreeze(nSnow+1:nLayers) = -( mLayerVolFracIce(nSnow+1:nLayers) - mLayerVolFracIceInit(nSnow+1:nLayers) )*iden_water + deallocate(mLayerVolFracIceInit) + + ! * compute change in canopy ice content due to sublimation... + ! ------------------------------------------------------------ + if(computeVegFlux)then + + ! remove mass of ice on the canopy + scalarCanopyIce = scalarCanopyIce + sumCanopySublimation + + ! if removed all ice, take the remaining sublimation from water + if(scalarCanopyIce < 0._rkind)then + scalarCanopyLiq = scalarCanopyLiq + scalarCanopyIce + scalarCanopyIce = 0._rkind + endif + + ! modify fluxes and mean fluxes if there is insufficient canopy water to support the converged sublimation rate over the whole time step + if(scalarCanopyLiq < 0._rkind)then + ! --> superfluous sublimation flux + superflousSub = -scalarCanopyLiq/whole_step ! kg m-2 s-1 + superflousNrg = superflousSub*LH_sub ! W m-2 (J m-2 s-1) + ! --> update fluxes and states + sumCanopySublimation = sumCanopySublimation + superflousSub*whole_step + sumLatHeatCanopyEvap = sumLatHeatCanopyEvap + superflousNrg*whole_step + sumSenHeatCanopy = sumSenHeatCanopy - superflousNrg*whole_step + scalarCanopyLiq = 0._rkind + endif + + ! update water + scalarCanopyWat = scalarCanopyLiq + scalarCanopyIce + if(enthalpyStateVec .or. computeEnthalpy)then ! recompute enthalpy of the canopy if changed water and ice content + call T2enthTemp_veg(& + diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1), & ! intent(in): canopy depth (m), send in specific value since diag_data may have changed + specificHeatVeg, & ! intent(in): specific heat of vegetation (J kg-1 K-1) + maxMassVegetation, & ! intent(in): maximum mass of vegetation (kg m-2) + snowfrz_scale, & ! intent(in): scaling parameter for the snow freezing curve (K-1) + prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1), & ! intent(in): canopy temperature (K) + scalarCanopyWat, & ! intent(in): canopy water content (kg m-2) + diag_data%var(iLookDIAG%scalarCanopyEnthTemp)%dat(1)) ! intent(out): temperature component of enthalpy of the vegetation canopy (J m-3) + prog_data%var(iLookPROG%scalarCanopyEnthalpy)%dat(1) = diag_data%var(iLookDIAG%scalarCanopyEnthTemp)%dat(1) - LH_fus * scalarCanopyIce/ diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1) + endif + end if ! (if computing the vegetation flux) + + ! * compute change in ice content of the top snow layer due to sublimation + ! and account for compaction and cavitation in the snowpack... + ! ------------------------------------------------------------------------ + call computSnowDepth(& + whole_step, & ! intent(in) + nSnow, & ! intent(in) + sumSnowSublimation/whole_step, & ! intent(in) + mLayerVolFracLiq, & ! intent(inout) + mLayerVolFracIce, & ! intent(inout) + prog_data%var(iLookPROG%mLayerTemp)%dat, & ! intent(in) + mLayerMeltFreeze, & ! intent(in) + mpar_data, & ! intent(in) + ! output + tooMuchSublim, & ! intent(out): flag to denote that there was too much sublimation in a given time step + mLayerDepth, & ! intent(inout) + ! error control + err,message) ! intent(out): error control + if(err/=0)then; err=55; return; end if + + ! process the flag for too much sublimation + if(tooMuchSublim)then + stepFailure = .true. + doLayerMerge = .true. + else + doLayerMerge = .false. + endif + + ! handle special case of the step failure + ! NOTE: need to revert back to the previous state vector that we were happy with and reduce the time step + if(stepFailure)then + ! halve whole_step, for more frequent outer loop updates + whole_step = dtSave/2._rkind + ! check that the step is not tiny + if(whole_step < minstep)then + print*, 'ixSolution', ixSolution + print*, 'dtSave, dt_sub', dtSave, whole_step + message=trim(message)//'length of the coupled step is below the minimum step length' + err=20; return + endif + ! try again, restart step (at end inner step) + deallocate(innerBalanceLayerNrg) + deallocate(innerBalanceLayerMass) + cycle substeps + endif + + ! update coordinate variables + call calcHeight(& + ! input/output: data structures + indx_data, & ! intent(in): layer type + prog_data, & ! intent(inout): model variables for a local HRU + ! output: error control + err,cmessage) + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if + + ! recompute snow depth, SWE, and layer water + if(nSnow > 0)then + prog_data%var(iLookPROG%scalarSnowDepth)%dat(1) = sum( mLayerDepth(1:nSnow) ) + prog_data%var(iLookPROG%scalarSWE)%dat(1) = sum( (mLayerVolFracLiq(1:nSnow)*iden_water & + + mLayerVolFracIce(1:nSnow)*iden_ice) * mLayerDepth(1:nSnow) ) + mLayerVolFracWat(1:nSnow) = mLayerVolFracLiq(1:nSnow) + mLayerVolFracIce(1:nSnow)*iden_ice/iden_water + if(enthalpyStateVec .or. computeEnthalpy)then ! recompute enthalpy of layers if changed water and ice content + do iLayer=1,nSnow + call T2enthTemp_snow(& + snowfrz_scale, & ! intent(in): scaling parameter for the snow freezing curve (K-1) + prog_data%var(iLookPROG%mLayerTemp)%dat(iLayer), & ! intent(in): layer temperature (K) + mLayerVolFracWat(iLayer), & ! intent(in): volumetric total water content (-) + diag_data%var(iLookDIAG%mLayerEnthTemp)%dat(iLayer)) ! intent(out): temperature component of enthalpy of each snow layer (J m-3) + prog_data%var(iLookPROG%mLayerEnthalpy)%dat(iLayer) = diag_data%var(iLookDIAG%mLayerEnthTemp)%dat(iLayer) - iden_ice * LH_fus * mLayerVolFracIce(iLayer) + end do ! looping through snow layers + endif + endif + + end associate sublime + + ! increment change in storage associated with the surface melt pond (kg m-2) + if(nSnow==0) sfcMeltPond = sfcMeltPond + prog_data%var(iLookPROG%scalarSfcMeltPond)%dat(1) + + endif ! (do_outer loop) + + ! **************************************************************************************************** + ! *** END MAIN SOLVER ******************************************************************************** + ! **************************************************************************************************** + + ! increment mean fluxes, soil compression, and effective rainfall, reset on whole_step + dt_wght = dt_sub/whole_step ! define weight applied to each sub-step + do iVar=1,size(averageFlux_meta) + flux_inner%var(iVar)%dat(:) = flux_inner%var(iVar)%dat(:) + flux_data%var(averageFlux_meta(iVar)%ixParent)%dat(:)*dt_wght + end do + innerSoilCompress(:) = innerSoilCompress(:) + diag_data%var(iLookDIAG%mLayerCompress)%dat(:)*dt_wght + if (nSnow>0) innerEffRainfall = innerEffRainfall + ( flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1) + flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) )*dt_wght + + ! sum the balance of energy and water per state + if(computeVegFlux)then + innerBalance(1) = innerBalance(1) + diag_data%var(iLookDIAG%balanceCasNrg)%dat(1)*dt_wght ! W m-3 + innerBalance(2) = innerBalance(2) + diag_data%var(iLookDIAG%balanceVegNrg)%dat(1)*dt_wght ! W m-3 + innerBalance(3) = innerBalance(3) + diag_data%var(iLookDIAG%balanceVegMass)%dat(1)*dt_wght/diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1) ! kg m-3 s-1 + bal_veg = .true. + endif + innerBalance(4) = innerBalance(4) + diag_data%var(iLookDIAG%balanceAqMass)%dat(1)*dt_wght * iden_water ! kg m-2 s-1 (no depth to aquifer) + innerBalanceLayerNrg(:) = innerBalanceLayerNrg(:) + diag_data%var(iLookDIAG%balanceLayerNrg)%dat(:)*dt_wght ! W m-3 + innerBalanceLayerMass(:) = innerBalanceLayerMass(:) + diag_data%var(iLookDIAG%balanceLayerMass)%dat(:)*dt_wght * iden_water ! kg m-3 s-1 + + ! save balance of energy and water per snow+soil layer after inner step, since can change nLayers with outer steps + diag_data%var(iLookDIAG%balanceLayerNrg)%dat(:) = innerBalanceLayerNrg(:) + diag_data%var(iLookDIAG%balanceLayerMass)%dat(:) = innerBalanceLayerMass(:) + + ! compute the balance of energy and water per entire snow and soil domain, in W m-3 and kg m-2 s-1 respectively + diag_data%var(iLookDIAG%balanceSnowNrg)%dat(1) = 0._rkind + diag_data%var(iLookDIAG%balanceSoilNrg)%dat(1) = 0._rkind + diag_data%var(iLookDIAG%balanceSnowMass)%dat(1) = 0._rkind + diag_data%var(iLookDIAG%balanceSoilMass)%dat(1) = 0._rkind + do iLayer=1,nLayers + select case (indx_data%var(iLookINDEX%layerType)%dat(iLayer)) + case (iname_snow) + lyr_wght = prog_data%var(iLookPROG%mLayerDepth)%dat(iLayer) / sum( prog_data%var(iLookPROG%mLayerDepth)%dat(1:nSnow) ) + diag_data%var(iLookDIAG%balanceSnowNrg)%dat(1) = diag_data%var(iLookDIAG%balanceSnowNrg)%dat(1) + innerBalanceLayerNrg(iLayer)*lyr_wght + diag_data%var(iLookDIAG%balanceSnowMass)%dat(1) = diag_data%var(iLookDIAG%balanceSnowMass)%dat(1) + innerBalanceLayerMass(iLayer)*lyr_wght + bal_snow = .true. + case (iname_soil) + lyr_wght = prog_data%var(iLookPROG%mLayerDepth)%dat(iLayer) / sum( prog_data%var(iLookPROG%mLayerDepth)%dat(nSnow+1:nLayers) ) + diag_data%var(iLookDIAG%balanceSoilNrg)%dat(1) = diag_data%var(iLookDIAG%balanceSoilNrg)%dat(1) + innerBalanceLayerNrg(iLayer)*lyr_wght + diag_data%var(iLookDIAG%balanceSoilMass)%dat(1) = diag_data%var(iLookDIAG%balanceSoilMass)%dat(1) + innerBalanceLayerMass(iLayer)*lyr_wght + bal_soil = .true. + end select + end do + if (model_decisions(iLookDECISIONS%groundwatr)%iDecision == bigBucket) bal_aq = .true. ! aquifer does not change existance with time steps + + if(do_outer)then + deallocate(innerBalanceLayerNrg) + deallocate(innerBalanceLayerMass) + endif + + ! increment sub-step accepted step + dt_solvInner = dt_solvInner + dt_sub + dt_solv = dt_solv + dt_sub + + ! update first and last inner steps if did successful lastInnerStep, increment fluxes and flux variables over data_step + if (lastInnerStep)then + firstInnerStep = .true. + lastInnerStep = .false. + dt_solvInner = 0._rkind + + dt_wght = whole_step/data_step ! define weight applied to each sub-step + do iVar=1,size(averageFlux_meta) + flux_mean%var(iVar)%dat(:) = flux_mean%var(iVar)%dat(:) + flux_inner%var(iVar)%dat(:)*dt_wght + end do + meanCanopySublimation = meanCanopySublimation + sumCanopySublimation/data_step + meanLatHeatCanopyEvap = meanLatHeatCanopyEvap + sumLatHeatCanopyEvap/data_step + meanSenHeatCanopy = meanSenHeatCanopy + sumSenHeatCanopy/data_step + meanSoilCompress(:) = meanSoilCompress(:) + innerSoilCompress(:)*dt_wght + meanBalance(1) = meanBalance(1) + innerBalance(1)*dt_wght + meanBalance(2) = meanBalance(2) + innerBalance(2)*dt_wght + meanBalance(3) = meanBalance(3) + innerBalance(3)*dt_wght + meanBalance(4) = meanBalance(4) + innerBalance(4)*dt_wght + meanBalance(5) = meanBalance(5) + diag_data%var(iLookDIAG%balanceSnowNrg)%dat(1)*dt_wght + meanBalance(6) = meanBalance(6) + diag_data%var(iLookDIAG%balanceSoilNrg)%dat(1)*dt_wght + meanBalance(7) = meanBalance(7) + diag_data%var(iLookDIAG%balanceSnowMass)%dat(1)*dt_wght + meanBalance(8) = meanBalance(8) + diag_data%var(iLookDIAG%balanceSoilMass)%dat(1)*dt_wght + + effRainfall = effRainfall + innerEffRainfall*dt_wght + flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarCanopySublimation))%dat(1) = meanCanopySublimation + flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarLatHeatCanopyEvap))%dat(1) = meanLatHeatCanopyEvap + flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarSenHeatCanopy))%dat(1) = meanSenHeatCanopy + + ! add mean step size for the data_step to the total step size sum + diag_data%var(iLookDIAG%meanStepSize)%dat(1) = diag_data%var(iLookDIAG%meanStepSize)%dat(1) + sumStepSize + endif + + ! save the time step to initialize the subsequent step + if(dt_solv= data_step-verySmall) then + exit substeps + endif + + ! adjust length of the sub-step (make sure that we don't exceed the step) + dt_sub = min(data_step - dt_solv, dt_sub) + + end do substeps ! (sub-step loop) + diag_data%var(iLookDIAG%meanStepSize)%dat(1) = diag_data%var(iLookDIAG%meanStepSize)%dat(1)/nsub_success + + ! *** add snowfall to the snowpack... + ! ----------------------------------- + ! add new snowfall to the snowpack + ! NOTE: This needs to be done AFTER the call to canopySnow, since throughfall and unloading are computed in canopySnow + call newsnwfall(& + ! input: model control + data_step, & ! time step (seconds) + (nSnow > 0), & ! logical flag if snow layers exist + snowfrz_scale, & ! freeezing curve parameter for snow (K-1) + ! input: diagnostic scalar variables + diag_data%var(iLookDIAG%scalarSnowfallTemp)%dat(1), & ! computed temperature of fresh snow (K) + diag_data%var(iLookDIAG%scalarNewSnowDensity)%dat(1), & ! computed density of new snow (kg m-3) + flux_data%var(iLookFLUX%scalarThroughfallSnow)%dat(1), & ! throughfall of snow through the canopy (kg m-2 s-1) + flux_data%var(iLookFLUX%scalarCanopySnowUnloading)%dat(1), & ! unloading of snow from the canopy (kg m-2 s-1) + ! input/output: state variables + prog_data%var(iLookPROG%scalarSWE)%dat(1), & ! SWE (kg m-2) + prog_data%var(iLookPROG%scalarSnowDepth)%dat(1), & ! total snow depth (m) + prog_data%var(iLookPROG%mLayerTemp)%dat(1), & ! temperature of the top layer (K) + prog_data%var(iLookPROG%mLayerDepth)%dat(1), & ! depth of the top layer (m) + prog_data%var(iLookPROG%mLayerVolFracIce)%dat(1), & ! volumetric fraction of ice of the top layer (-) + prog_data%var(iLookPROG%mLayerVolFracLiq)%dat(1), & ! volumetric fraction of liquid water of the top layer (-) ! output: error control - err,cmessage) ! intent(out): error control - if(err/=0)then; err=55; message=trim(message)//trim(cmessage); return; end if - - - ! *** compute melt of the "snow without a layer"... - ! ------------------------------------------------- - ! NOTE: forms a surface melt pond, which drains into the upper-most soil layer through the time step - ! (check for the special case of "snow without a layer") - if(nSnow==0)then - call implctMelt(& - ! input/output: integrated snowpack properties - prog_data%var(iLookPROG%scalarSWE)%dat(1), & ! intent(inout): snow water equivalent (kg m-2) - prog_data%var(iLookPROG%scalarSnowDepth)%dat(1), & ! intent(inout): snow depth (m) - prog_data%var(iLookPROG%scalarSfcMeltPond)%dat(1), & ! intent(inout): surface melt pond (kg m-2) - ! input/output: properties of the upper-most soil layer - prog_data%var(iLookPROG%mLayerTemp)%dat(nSnow+1), & ! intent(inout): surface layer temperature (K) - prog_data%var(iLookPROG%mLayerDepth)%dat(nSnow+1), & ! intent(inout): surface layer depth (m) - diag_data%var(iLookDIAG%mLayerVolHtCapBulk)%dat(nSnow+1),& ! intent(inout): surface layer volumetric heat capacity (J m-3 K-1) - ! output: error control - err,cmessage ) ! intent(out): error control - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if + err,cmessage) ! error control + if(err/=0)then; err=30; message=trim(message)//trim(cmessage); return; end if + + ! recompute snow depth, SWE, and top layer water + if(nSnow > 0)then + prog_data%var(iLookPROG%scalarSnowDepth)%dat(1) = sum( prog_data%var(iLookPROG%mLayerDepth)%dat(1:nSnow)) + prog_data%var(iLookPROG%scalarSWE)%dat(1) = sum( (prog_data%var(iLookPROG%mLayerVolFracLiq)%dat(1:nSnow)*iden_water + & + prog_data%var(iLookPROG%mLayerVolFracIce)%dat(1:nSnow)*iden_ice) & + * prog_data%var(iLookPROG%mLayerDepth)%dat(1:nSnow) ) + prog_data%var(iLookPROG%mLayerVolFracWat)%dat(1) = prog_data%var(iLookPROG%mLayerVolFracLiq)%dat(1) & + + prog_data%var(iLookPROG%mLayerVolFracIce)%dat(1)*iden_ice/iden_water + if(enthalpyStateVec .or. computeEnthalpy)then ! compute enthalpy of the top snow layer + call T2enthTemp_snow(& + snowfrz_scale, & ! intent(in): scaling parameter for the snow freezing curve (K-1) + prog_data%var(iLookPROG%mLayerTemp)%dat(1), & ! temperature of the top layer (K) + prog_data%var(iLookPROG%mLayerVolFracWat)%dat(1), & ! intent(in): volumetric total water content (-) + diag_data%var(iLookDIAG%mLayerEnthTemp)%dat(1)) ! intent(out): temperature component of enthalpy of each snow layer (J m-3) + prog_data%var(iLookPROG%mLayerEnthalpy)%dat(1) = diag_data%var(iLookDIAG%mLayerEnthTemp)%dat(1) - iden_ice * LH_fus * prog_data%var(iLookPROG%mLayerVolFracIce)%dat(1) + end if + end if + + ! re-assign dimension lengths + nSnow = count(indx_data%var(iLookINDEX%layerType)%dat==iname_snow) + nSoil = count(indx_data%var(iLookINDEX%layerType)%dat==iname_soil) + nLayers = nSnow+nSoil + + ! update coordinate variables + call calcHeight(& + ! input/output: data structures + indx_data, & ! intent(in): layer type + prog_data, & ! intent(inout): model variables for a local HRU + ! output: error control + err,cmessage) + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if + + ! overwrite flux_data and soil compression with the timestep-average value (returns timestep-average fluxes for scalar variables) + do iVar=1,size(averageFlux_meta) + flux_data%var(averageFlux_meta(iVar)%ixParent)%dat(:) = flux_mean%var(iVar)%dat(:) + end do + ! keep soil compression as an average like the fluxes, will not want to do this if nSoil can change + diag_data%var(iLookDIAG%mLayerCompress)%dat(:) = meanSoilCompress + diag_data%var(iLookDIAG%scalarSoilCompress)%dat(1) = sum( meanSoilCompress(1:nSoil)*iden_water & + * prog_data%var(iLookPROG%mLayerDepth)%dat(nSnow+1:nLayers) ) + deallocate(innerSoilCompress) + deallocate(meanSoilCompress) + + ! *********************************************************************************************************************************** + ! --- + ! *** balance checks and summary variable saving... + ! --------------------- + + ! save the average melt pond storage in the data structures + prog_data%var(iLookPROG%scalarSfcMeltPond)%dat(1) = sfcMeltPond + + ! associate local variables with information in the data structures + associate(& + ! model forcing + scalarSnowfall => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarSnowfall) )%dat(1) ,& ! computed snowfall rate (kg m-2 s-1) + scalarRainfall => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarRainfall) )%dat(1) ,& ! computed rainfall rate (kg m-2 s-1) + ! canopy fluxes + averageThroughfallSnow => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarThroughfallSnow) )%dat(1) ,& ! snow that reaches the ground without ever touching the canopy (kg m-2 s-1) + averageThroughfallRain => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarThroughfallRain) )%dat(1) ,& ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) + averageCanopySnowUnloading => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarCanopySnowUnloading))%dat(1) ,& ! unloading of snow from the vegetion canopy (kg m-2 s-1) + averageCanopyLiqDrainage => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarCanopyLiqDrainage) )%dat(1) ,& ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) + averageCanopySublimation => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarCanopySublimation) )%dat(1) ,& ! canopy sublimation/frost (kg m-2 s-1) + averageCanopyEvaporation => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarCanopyEvaporation) )%dat(1) ,& ! canopy evaporation/condensation (kg m-2 s-1) + ! snow fluxes + averageSnowSublimation => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarSnowSublimation) )%dat(1) ,& ! sublimation from the snow surface (kg m-2 s-1) + averageSnowDrainage => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarSnowDrainage) )%dat(1) ,& ! drainage from the bottom of the snowpack (m s-1) + ! soil fluxes + averageSoilInflux => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarInfiltration) )%dat(1) ,& ! influx of water at the top of the soil profile (m s-1) + averageSoilDrainage => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarSoilDrainage) )%dat(1) ,& ! drainage from the bottom of the soil profile (m s-1) + averageSoilBaseflow => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarSoilBaseflow) )%dat(1) ,& ! total baseflow from throughout the soil profile (m s-1) + averageSoilCompress => diag_data%var( iLookDIAG%scalarSoilCompress) %dat(1) ,& ! soil compression (kg m-2 s-1) + averageGroundEvaporation => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarGroundEvaporation) )%dat(1) ,& ! soil evaporation (kg m-2 s-1) + averageCanopyTranspiration => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarCanopyTranspiration))%dat(1) ,& ! canopy transpiration (kg m-2 s-1) + ! state variables in the vegetation canopy + scalarCanopyWat => prog_data%var(iLookPROG%scalarCanopyWat)%dat(1) ,& ! canopy ice content (kg m-2) + scalarCanopyIce => prog_data%var(iLookPROG%scalarCanopyIce)%dat(1) ,& ! ice content of the vegetation canopy (kg m-2) + scalarCanopyEnthTemp => diag_data%var(iLookDIAG%scalarCanopyEnthTemp)%dat(1) ,& ! temperature component of enthalpy of the vegetation canopy (K) + scalarCanopyEnthalpy => prog_data%var(iLookPROG%scalarCanopyEnthalpy)%dat(1) ,& ! enthalpy of the vegetation canopy (J m-3) + ! state variables in the snow+soil domains + scalarSWE => prog_data%var(iLookPROG%scalarSWE)%dat(1) ,& ! snow water equivalent (kg m-2) + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat ,& ! depth of each layer (m) + mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat ,& ! volumetric ice content in each layer (-) + mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat ,& ! volumetric liquid water content in each layer (-) + scalarTotalSoilWat => diag_data%var(iLookDIAG%scalarTotalSoilWat)%dat(1) ,& ! total water in the soil column (kg m-2) + scalarTotalSoilIce => diag_data%var(iLookDIAG%scalarTotalSoilIce)%dat(1) ,& ! total ice in the soil column (kg m-2) + scalarTotalSoilLiq => diag_data%var(iLookDIAG%scalarTotalSoilLiq)%dat(1) ,& ! total liquid water in the soil column (kg m-2) + mLayerEnthTemp => diag_data%var(iLookDIAG%mLayerEnthTemp)%dat ,& ! temperature component of enthalpy of each snow+soil layer (K) + mLayerEnthalpy => prog_data%var(iLookPROG%mLayerEnthalpy)%dat ,& ! enthalpy of each snow+soil layer (J m-3) + scalarTotalSoilEnthalpy => diag_data%var(iLookDIAG%scalarTotalSoilEnthalpy)%dat(1) ,& ! total enthalpy of the soil column (J m-3) + scalarTotalSnowEnthalpy => diag_data%var(iLookDIAG%scalarTotalSnowEnthalpy)%dat(1) ,& ! total enthalpy of the snow column (J m-3) + ! state variables in the aquifer + scalarAquiferStorage => prog_data%var(iLookPROG%scalarAquiferStorage)%dat(1) ,& ! aquifer storage (m) + ! error tolerance + absConvTol_liquid => mpar_data%var(iLookPARAM%absConvTol_liquid)%dat(1) & ! absolute convergence tolerance for vol frac liq water (-) + ) ! (association of local variables with information in the data structures + + ! save balance of energy and water per single layer domain + diag_data%var(iLookDIAG%balanceCasNrg)%dat(1) = meanBalance(1) ! W m-3 + diag_data%var(iLookDIAG%balanceVegNrg)%dat(1) = meanBalance(2) ! W m-3 will be realMissing if computeVegFlux is false + diag_data%var(iLookDIAG%balanceVegMass)%dat(1) = meanBalance(3) ! kg m-3 s-1 will be realMissing if computeVegFlux is false + diag_data%var(iLookDIAG%balanceAqMass)%dat(1) = meanBalance(4) ! kg m-2 s-1 will be realMissing if no aquifer + diag_data%var(iLookDIAG%balanceSnowNrg)%dat(1) = meanBalance(5) ! W m-3 will be realMissing if no snow during data step + diag_data%var(iLookDIAG%balanceSoilNrg)%dat(1) = meanBalance(6) ! W m-3 + diag_data%var(iLookDIAG%balanceSnowMass)%dat(1) = meanBalance(7) ! kg m-3 s-1 will be realMissing if no snow during data step + diag_data%var(iLookDIAG%balanceSoilMass)%dat(1) = meanBalance(8) ! kg m-3 s-1 + if(.not.bal_veg)then ! will be 0, make realMissing + diag_data%var(iLookDIAG%balanceCasNrg)%dat(1) = realMissing + diag_data%var(iLookDIAG%balanceVegNrg)%dat(1) = realMissing + diag_data%var(iLookDIAG%balanceVegMass)%dat(1) = realMissing + endif + if (.not.bal_snow)then ! will be 0, make realMissing + diag_data%var(iLookDIAG%balanceSnowNrg)%dat(1) = realMissing + diag_data%var(iLookDIAG%balanceSnowMass)%dat(1) = realMissing + endif + if (.not.bal_soil)then ! will be 0, make realMissing + diag_data%var(iLookDIAG%balanceSoilNrg)%dat(1) = realMissing + diag_data%var(iLookDIAG%balanceSoilMass)%dat(1) = realMissing + endif + if (.not.bal_aq)then ! will be 0, make realMissing + diag_data%var(iLookDIAG%balanceAqMass)%dat(1) = realMissing + endif + + ! ----- + ! * balance checks for the canopy... + ! ---------------------------------- + + ! if computing the vegetation flux + if(computeVegFlux)then + ! balance checks for the canopy + ! NOTE: need to put the balance checks in the sub-step loop so that we can recompute if necessary + scalarCanopyWatBalError = scalarCanopyWat - (balanceCanopyWater0 + (scalarSnowfall - averageThroughfallSnow)*data_step + (scalarRainfall - averageThroughfallRain)*data_step & + - averageCanopySnowUnloading*data_step - averageCanopyLiqDrainage*data_step + averageCanopySublimation*data_step + averageCanopyEvaporation*data_step) + if(abs(scalarCanopyWatBalError) > absConvTol_liquid*iden_water*10._rkind .and. checkMassBalance_ds)then + write(*,'(a,1x,f20.10)') 'data_step = ', data_step + write(*,'(a,1x,f20.10)') 'balanceCanopyWater0 = ', balanceCanopyWater0 + write(*,'(a,1x,f20.10)') 'balanceCanopyWater1 = ', scalarCanopyWat + write(*,'(a,1x,f20.10)') 'snowfall = ', scalarSnowfall*data_step + write(*,'(a,1x,f20.10)') 'rainfall = ', scalarRainfall*data_step + write(*,'(a,1x,f20.10)') '(snowfall - throughfallSnow) = ', (scalarSnowfall - averageThroughfallSnow)*data_step + write(*,'(a,1x,f20.10)') '(rainfall - throughfallRain) = ', (scalarRainfall - averageThroughfallRain)*data_step + write(*,'(a,1x,f20.10)') 'canopySnowUnloading = ', averageCanopySnowUnloading*data_step + write(*,'(a,1x,f20.10)') 'canopyLiqDrainage = ', averageCanopyLiqDrainage*data_step + write(*,'(a,1x,f20.10)') 'canopySublimation = ', averageCanopySublimation*data_step + write(*,'(a,1x,f20.10)') 'canopyEvaporation = ', averageCanopyEvaporation*data_step + write(*,'(a,1x,f20.10)') 'canopyWatBalError = ', scalarCanopyWatBalError + message=trim(message)//'canopy hydrology does not balance' + err=20; return + end if + endif ! if computing the vegetation flux + + ! ----- + ! * balance checks for SWE... + ! --------------------------- + + ! check the individual layers + if(printBalance .and. nSnow>0)then + write(*,'(a,1x,10(f12.8,1x))') 'liqSnowInit = ', liqSnowInit + write(*,'(a,1x,10(f12.8,1x))') 'volFracLiq = ', mLayerVolFracLiq(1:nSnow) + write(*,'(a,1x,10(f12.8,1x))') 'iLayerLiqFluxSnow = ', flux_data%var(iLookFLUX%iLayerLiqFluxSnow)%dat*iden_water*data_step + write(*,'(a,1x,10(f12.8,1x))') 'mLayerLiqFluxSnow = ', flux_data%var(iLookFLUX%mLayerLiqFluxSnow)%dat*data_step + write(*,'(a,1x,10(f12.8,1x))') 'change volFracLiq = ', mLayerVolFracLiq(1:nSnow) - liqSnowInit + deallocate(liqSnowInit, stat=err) + if(err/=0)then + message=trim(message)//'unable to deallocate space for the initial volumetric liquid water content of snow' + err=20; return + endif + endif + + ! check SWE + if(nSnow>0)then + effSnowfall = averageThroughfallSnow + averageCanopySnowUnloading + ! effRainfall is averageThroughfallRain + averageCanopyLiqDrainage only over snow + delSWE = scalarSWE - (oldSWE - sfcMeltPond) + massBalance = delSWE - (effSnowfall + effRainfall + averageSnowSublimation - averageSnowDrainage*iden_water)*data_step + if(abs(massBalance) > absConvTol_liquid*iden_water*10._rkind .and. checkMassBalance_ds)then + print*, 'nSnow = ', nSnow + print*, 'nSub = ', nSub + write(*,'(a,1x,f20.10)') 'data_step = ', data_step + write(*,'(a,1x,f20.10)') 'oldSWE = ', oldSWE + write(*,'(a,1x,f20.10)') 'newSWE = ', scalarSWE + write(*,'(a,1x,f20.10)') 'delSWE = ', delSWE + write(*,'(a,1x,f20.10)') 'effRainfall = ', effRainfall*data_step + write(*,'(a,1x,f20.10)') 'effSnowfall = ', effSnowfall*data_step + write(*,'(a,1x,f20.10)') 'sublimation = ', averageSnowSublimation*data_step + write(*,'(a,1x,f20.10)') 'snwDrainage = ', averageSnowDrainage*iden_water*data_step + write(*,'(a,1x,f20.10)') 'sfcMeltPond = ', sfcMeltPond + write(*,'(a,1x,f20.10)') 'SWE_BalErr = ', massBalance + message=trim(message)//'SWE does not balance' + err=20; return + endif ! if failed mass balance check + endif ! if snow layers exist + + ! ----- + ! * balance checks for soil... + ! ---------------------------- + + ! compute the liquid water and ice content at the end of the time step + scalarTotalSoilLiq = sum(iden_water*mLayerVolFracLiq(nSnow+1:nLayers)*mLayerDepth(nSnow+1:nLayers)) + scalarTotalSoilIce = sum(iden_water*mLayerVolFracIce(nSnow+1:nLayers)*mLayerDepth(nSnow+1:nLayers)) ! NOTE: no expansion of soil, hence use iden_water + + ! get the total water in the soil (liquid plus ice) at the end of the time step (kg m-2) + scalarTotalSoilWat = scalarTotalSoilLiq + scalarTotalSoilIce + + ! get the total aquifer storage at the start of the time step (kg m-2) + balanceAquifer1 = scalarAquiferStorage*iden_water + + ! get the input and output to/from the soil zone (kg m-2) + balanceSoilInflux = averageSoilInflux*iden_water*data_step + balanceSoilBaseflow = averageSoilBaseflow*iden_water*data_step + balanceSoilDrainage = averageSoilDrainage*iden_water*data_step + balanceSoilET = (averageCanopyTranspiration + averageGroundEvaporation)*data_step + balanceSoilCompress = averageSoilCompress*data_step + + ! check the individual layers + if(printBalance)then + write(*,'(a,1x,10(f12.8,1x))') 'liqSoilInit = ', liqSoilInit + write(*,'(a,1x,10(f12.8,1x))') 'volFracLiq = ', mLayerVolFracLiq(nSnow+1:nLayers) + write(*,'(a,1x,10(f12.8,1x))') 'iLayerLiqFluxSoil = ', flux_data%var(iLookFLUX%iLayerLiqFluxSoil)%dat*iden_water*data_step + write(*,'(a,1x,10(f12.8,1x))') 'mLayerLiqFluxSoil = ', flux_data%var(iLookFLUX%mLayerLiqFluxSoil)%dat*data_step + write(*,'(a,1x,10(f12.8,1x))') 'change volFracLiq = ', mLayerVolFracLiq(nSnow+1:nLayers) - liqSoilInit + deallocate(liqSoilInit, stat=err) + if(err/=0)then + message=trim(message)//'unable to deallocate space for the initial soil moisture' + err=20; return + endif + endif + + ! check the soil water balance + scalarSoilWatBalError = scalarTotalSoilWat - (balanceSoilWater0 + (balanceSoilInflux + balanceSoilET - balanceSoilBaseflow - balanceSoilDrainage - balanceSoilCompress) ) + if(abs(scalarSoilWatBalError) > absConvTol_liquid*iden_water*10._rkind .and. checkMassBalance_ds)then ! NOTE: kg m-2, so need coarse tolerance to account for precision issues + write(*,*) 'solution method = ', ixSolution + write(*,'(a,1x,f20.10)') 'data_step = ', data_step + write(*,'(a,1x,f20.10)') 'balanceSoilCompress = ', balanceSoilCompress + write(*,'(a,1x,f20.10)') 'scalarTotalSoilLiq = ', scalarTotalSoilLiq + write(*,'(a,1x,f20.10)') 'scalarTotalSoilIce = ', scalarTotalSoilIce + write(*,'(a,1x,f20.10)') 'balanceSoilWater0 = ', balanceSoilWater0 + write(*,'(a,1x,f20.10)') 'balanceSoilWater1 = ', scalarTotalSoilWat + write(*,'(a,1x,f20.10)') 'balanceSoilInflux = ', balanceSoilInflux + write(*,'(a,1x,f20.10)') 'balanceSoilBaseflow = ', balanceSoilBaseflow + write(*,'(a,1x,f20.10)') 'balanceSoilDrainage = ', balanceSoilDrainage + write(*,'(a,1x,f20.10)') 'balanceSoilET = ', balanceSoilET + write(*,'(a,1x,f20.10)') 'scalarSoilWatBalError = ', scalarSoilWatBalError + message=trim(message)//'soil hydrology does not balance' + err=20; return + end if + + ! ----- + ! save the enthalpy or temperature component of enthalpy, and total enthalpy + ! ---------------------------- + + if(computeEnthalpy)then ! use enthTemp to conserve energy or compute energy balance + ! initialize the enthalpy + scalarCanopyEnthalpy = scalarCanopyEnthTemp + mLayerEnthalpy = mLayerEnthTemp + ! compute enthalpy for current values + call enthTemp_or_enthalpy(& + ! input: data structures + .true., & ! intent(in): flag to convert enthTemp to enthalpy + diag_data, & ! intent(in): model diagnostic variables for a local HRU + indx_data, & ! intent(in): model indices + ! input: ice content change + scalarCanopyIce, & ! intent(in): value for canopy ice content (kg m-2) + mLayerVolFracIce, & ! intent(in): vector of volumetric ice water content (-) + ! input/output: enthalpy + scalarCanopyEnthalpy, & ! intent(inout): enthTemp to enthalpy of the vegetation canopy (J m-3) + mLayerEnthalpy, & ! intent(inout): enthTemp to enthalpy of each snow+soil layer (J m-3) + ! output: error control + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + end if + + if(enthalpyStateVec)then ! enthalpy as state variable + ! initialize the temperature component of enthalpy + scalarCanopyEnthTemp = scalarCanopyEnthalpy + mLayerEnthTemp = mLayerEnthalpy + ! compute temperature component of enthalpy for current values + call enthTemp_or_enthalpy(& + ! input: data structures + .false., & ! intent(in): flag to convert enthalpy to enthTemp + diag_data, & ! intent(in): model diagnostic variables for a local HRU + indx_data, & ! intent(in): model indices + ! input: ice content change + scalarCanopyIce, & ! intent(in): value for canopy ice content (kg m-2) + mLayerVolFracIce, & ! intent(in): vector of volumetric ice water content (-) + ! input/output: enthalpy + scalarCanopyEnthTemp, & ! intent(inout): enthalpy to enthTemp of the vegetation canopy (J m-3) + mLayerEnthTemp, & ! intent(inout): enthalpy to enthTemp of each snow+soil layer (J m-3) + ! output: error control + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + endif + ! save the total soil enthalpy + scalarTotalSoilEnthalpy = sum(mLayerEnthalpy(nSnow+1:nLayers) * mLayerDepth(nSnow+1:nLayers))/sum(mLayerDepth(nSnow+1:nLayers)) + ! save the total snow enthalpy + if(nSnow>0) scalarTotalSnowEnthalpy = sum(mLayerEnthalpy(1:nSnow) * mLayerDepth(1:nSnow))/sum(mLayerDepth(1:nSnow)) + + ! save the surface temperature (just to make things easier to visualize) + prog_data%var(iLookPROG%scalarSurfaceTemp)%dat(1) = prog_data%var(iLookPROG%mLayerTemp)%dat(1) + + end associate ! end association of local variables with information in the data structures + + end associate canopy ! end association to canopy parameters + + ! overwrite flux data with timestep-average value for all flux_mean vars, hard-coded to happen + if(.not.backwardsCompatibility)then + do iVar=1,size(flux_mean%var) + flux_data%var(averageFlux_meta(iVar)%ixParent)%dat = flux_mean%var(iVar)%dat + end do end if - ! *** solve model equations... - ! ---------------------------- - - ! save input step - dtSave = dt_sub - !write(*,'(a,1x,3(f12.5,1x))') trim(message)//'before opSplittin: dt_init, dt_sub, dt_solv = ', dt_init, dt_sub, dt_solv - - ! get the new solution - call opSplittin(& - ! input: model control - nSnow, & ! intent(in): number of snow layers - nSoil, & ! intent(in): number of soil layers - nLayers, & ! intent(in): total number of layers - nState, & ! intent(in): total number of layers - dt_sub, & ! intent(in): length of the model sub-step - (nsub==1), & ! intent(in): logical flag to denote the first substep - computeVegFlux, & ! intent(in): logical flag to compute fluxes within the vegetation canopy - ! input/output: data structures - type_data, & ! intent(in): type of vegetation and soil - attr_data, & ! intent(in): spatial attributes - forc_data, & ! intent(in): model forcing data - mpar_data, & ! intent(in): model parameters - indx_data, & ! intent(inout): index data - prog_data, & ! intent(inout): model prognostic variables for a local HRU - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - flux_data, & ! intent(inout): model fluxes for a local HRU - bvar_data, & ! intent(in): model variables for the local basin - model_decisions, & ! intent(in): model decisions - ! output: model control - dtMultiplier, & ! intent(out): substep multiplier (-) - tooMuchMelt, & ! intent(out): flag to denote that ice is insufficient to support melt - stepFailure, & ! intent(out): flag to denote that the coupled step failed - ixSolution, & ! intent(out): solution method used in this iteration - err,cmessage) ! intent(out): error code and error message - - ! check for all errors (error recovery within opSplittin) - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if - !print*, 'completed step' - !print*, 'PAUSE: '; read(*,*) - - ! process the flag for too much melt - if(tooMuchMelt)then - stepFailure = .true. - doLayerMerge = .true. - else - doLayerMerge = .false. - endif - - ! handle special case of the step failure - ! NOTE: need to revert back to the previous state vector that we were happy with and reduce the time step - if(stepFailure)then - - ! halve step - dt_sub = dtSave/2._rkind - - ! check that the step is not tiny - if(dt_sub < minstep)then - print*,ixSolution - print*, 'dtSave, dt_sub', dtSave, dt_sub - message=trim(message)//'length of the coupled step is below the minimum step length' + if(nsub>50000)then + write(message,'(a,i0)') trim(cmessage)//'number of sub-steps > 50000 for HRU ', hruId err=20; return - endif - - ! try again - cycle substeps - - endif - - ! update first step - firstSubStep=.false. - - ! *** remove ice due to sublimation... - ! -------------------------------------------------------------- - sublime: associate(& - scalarCanopySublimation => flux_data%var(iLookFLUX%scalarCanopySublimation)%dat(1), & ! sublimation from the vegetation canopy (kg m-2 s-1) - scalarSnowSublimation => flux_data%var(iLookFLUX%scalarSnowSublimation)%dat(1), & ! sublimation from the snow surface (kg m-2 s-1) - scalarLatHeatCanopyEvap => flux_data%var(iLookFLUX%scalarLatHeatCanopyEvap)%dat(1), & ! latent heat flux for evaporation from the canopy to the canopy air space (W m-2) - scalarSenHeatCanopy => flux_data%var(iLookFLUX%scalarSenHeatCanopy)%dat(1), & ! sensible heat flux from the canopy to the canopy air space (W m-2) - scalarLatHeatGround => flux_data%var(iLookFLUX%scalarLatHeatGround)%dat(1), & ! latent heat flux from ground surface below vegetation (W m-2) - scalarSenHeatGround => flux_data%var(iLookFLUX%scalarSenHeatGround)%dat(1), & ! sensible heat flux from ground surface below vegetation (W m-2) - scalarCanopyLiq => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1), & ! liquid water stored on the vegetation canopy (kg m-2) - scalarCanopyIce => prog_data%var(iLookPROG%scalarCanopyIce)%dat(1), & ! ice stored on the vegetation canopy (kg m-2) - mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat, & ! volumetric fraction of ice in the snow+soil domain (-) - mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat, & ! volumetric fraction of liquid water in the snow+soil domain (-) - mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat & ! depth of each snow+soil layer (m) - ) ! associations to variables in data structures - - ! * compute change in canopy ice content due to sublimation... - ! ------------------------------------------------------------ - if(computeVegFlux)then - - ! remove mass of ice on the canopy - scalarCanopyIce = scalarCanopyIce + scalarCanopySublimation*dt_sub - - ! if removed all ice, take the remaining sublimation from water - if(scalarCanopyIce < 0._rkind)then - scalarCanopyLiq = scalarCanopyLiq + scalarCanopyIce - scalarCanopyIce = 0._rkind - endif - - ! modify fluxes if there is insufficient canopy water to support the converged sublimation rate over the time step dt_sub - if(scalarCanopyLiq < 0._rkind)then - ! --> superfluous sublimation flux - superflousSub = -scalarCanopyLiq/dt_sub ! kg m-2 s-1 - superflousNrg = superflousSub*LH_sub ! W m-2 (J m-2 s-1) - ! --> update fluxes and states - scalarCanopySublimation = scalarCanopySublimation + superflousSub - scalarLatHeatCanopyEvap = scalarLatHeatCanopyEvap + superflousNrg - scalarSenHeatCanopy = scalarSenHeatCanopy - superflousNrg - scalarCanopyLiq = 0._rkind - endif - - end if ! (if computing the vegetation flux) - - ! * compute change in ice content of the top snow layer due to sublimation... - ! --------------------------------------------------------------------------- - ! NOTE: this is done BEFORE densification - if(nSnow > 0)then ! snow layers exist - - ! try to remove ice from the top layer - iSnow=1 - - ! save the mass of liquid water (kg m-2) - massLiquid = mLayerDepth(iSnow)*mLayerVolFracLiq(iSnow)*iden_water - - ! add/remove the depth of snow gained/lost by frost/sublimation (m) - ! NOTE: assume constant density - mLayerDepth(iSnow) = mLayerDepth(iSnow) + dt_sub*scalarSnowSublimation/(mLayerVolFracIce(iSnow)*iden_ice) - - ! check that we did not remove the entire layer - if(mLayerDepth(iSnow) < verySmall)then - stepFailure = .true. - doLayerMerge = .true. - dt_sub = max(dtSave/2._rkind, minstep) - cycle substeps - else - stepFailure = .false. - doLayerMerge = .false. - endif - - ! update the volumetric fraction of liquid water - mLayerVolFracLiq(iSnow) = massLiquid / (mLayerDepth(iSnow)*iden_water) - - ! no snow - else - - ! no snow: check that sublimation is zero - if(abs(scalarSnowSublimation) > verySmall)then - message=trim(message)//'sublimation of snow has been computed when no snow exists' - err=20; return - end if - - end if ! (if snow layers exist) - - end associate sublime - - ! *** account for compaction and cavitation in the snowpack... - ! ------------------------------------------------------------ - if(nSnow>0)then - call snwDensify(& - ! intent(in): variables - dt_sub, & ! intent(in): time step (s) - indx_data%var(iLookINDEX%nSnow)%dat(1), & ! intent(in): number of snow layers - prog_data%var(iLookPROG%mLayerTemp)%dat(1:nSnow), & ! intent(in): temperature of each layer (K) - diag_data%var(iLookDIAG%mLayerMeltFreeze)%dat(1:nSnow), & ! intent(in): volumetric melt in each layer (kg m-3) - ! intent(in): parameters - mpar_data%var(iLookPARAM%densScalGrowth)%dat(1), & ! intent(in): density scaling factor for grain growth (kg-1 m3) - mpar_data%var(iLookPARAM%tempScalGrowth)%dat(1), & ! intent(in): temperature scaling factor for grain growth (K-1) - mpar_data%var(iLookPARAM%grainGrowthRate)%dat(1), & ! intent(in): rate of grain growth (s-1) - mpar_data%var(iLookPARAM%densScalOvrbdn)%dat(1), & ! intent(in): density scaling factor for overburden pressure (kg-1 m3) - mpar_data%var(iLookPARAM%tempScalOvrbdn)%dat(1), & ! intent(in): temperature scaling factor for overburden pressure (K-1) - mpar_data%var(iLookPARAM%baseViscosity)%dat(1), & ! intent(in): viscosity coefficient at T=T_frz and snow density=0 (kg m-2 s) - ! intent(inout): state variables - prog_data%var(iLookPROG%mLayerDepth)%dat(1:nSnow), & ! intent(inout): depth of each layer (m) - prog_data%var(iLookPROG%mLayerVolFracLiq)%dat(1:nSnow), & ! intent(inout): volumetric fraction of liquid water after itertations (-) - prog_data%var(iLookPROG%mLayerVolFracIce)%dat(1:nSnow), & ! intent(inout): volumetric fraction of ice after itertations (-) - ! output: error control - err,cmessage) ! intent(out): error control - if(err/=0)then; err=55; message=trim(message)//trim(cmessage); return; end if - end if ! if snow layers exist - - ! update coordinate variables - call calcHeight(& - ! input/output: data structures - indx_data, & ! intent(in): layer type - prog_data, & ! intent(inout): model variables for a local HRU - ! output: error control - err,cmessage) - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if - - ! recompute snow depth and SWE - if(nSnow > 0)then - prog_data%var(iLookPROG%scalarSnowDepth)%dat(1) = sum( prog_data%var(iLookPROG%mLayerDepth)%dat(1:nSnow)) - prog_data%var(iLookPROG%scalarSWE)%dat(1) = sum( (prog_data%var(iLookPROG%mLayerVolFracLiq)%dat(1:nSnow)*iden_water + & - prog_data%var(iLookPROG%mLayerVolFracIce)%dat(1:nSnow)*iden_ice) & - * prog_data%var(iLookPROG%mLayerDepth)%dat(1:nSnow) ) end if - ! increment fluxes - dt_wght = dt_sub/data_step ! define weight applied to each sub-step - do iVar=1,size(averageFlux_meta) - flux_mean%var(iVar)%dat(:) = flux_mean%var(iVar)%dat(:) + flux_data%var(averageFlux_meta(iVar)%ixParent)%dat(:)*dt_wght - end do - - ! increment change in storage associated with the surface melt pond (kg m-2) - if(nSnow==0) sfcMeltPond = sfcMeltPond + prog_data%var(iLookPROG%scalarSfcMeltPond)%dat(1) - - ! increment soil compression (kg m-2) - totalSoilCompress = totalSoilCompress + diag_data%var(iLookDIAG%scalarSoilCompress)%dat(1) ! total soil compression over whole layer (kg m-2) + ! get the end time + CALL system_clock(i_end) + elapsed_time = REAL(i_end - i_start) / REAL(count_rate) - ! increment effective rainfall - if (nSnow>0) effRainfall = effRainfall + ( flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1) + flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) )*dt_wght + ! get the elapsed time + diag_data%var(iLookDIAG%wallClockTime)%dat(1) = elapsed_time - ! **************************************************************************************************** - ! *** END MAIN SOLVER ******************************************************************************** - ! **************************************************************************************************** - - ! increment sub-step - dt_solv = dt_solv + dt_sub - - ! save the time step to initialize the subsequent step - if(dt_solv= data_step-verySmall) then - exit substeps - endif - - ! adjust length of the sub-step (make sure that we don't exceed the step) - dt_sub = min(data_step - dt_solv, dt_sub) - !print*, 'dt_sub = ', dt_sub - - end do substeps ! (sub-step loop) - !print*, 'PAUSE: completed time step'; read(*,*) - - ! *** add snowfall to the snowpack... - ! ----------------------------------- - - ! add new snowfall to the snowpack - ! NOTE: This needs to be done AFTER the call to canopySnow, since throughfall and unloading are computed in canopySnow - call newsnwfall(& - ! input: model control - data_step, & ! time step (seconds) - (nSnow > 0), & ! logical flag if snow layers exist - mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1), & ! freeezing curve parameter for snow (K-1) - ! input: diagnostic scalar variables - diag_data%var(iLookDIAG%scalarSnowfallTemp)%dat(1), & ! computed temperature of fresh snow (K) - diag_data%var(iLookDIAG%scalarNewSnowDensity)%dat(1), & ! computed density of new snow (kg m-3) - flux_data%var(iLookFLUX%scalarThroughfallSnow)%dat(1), & ! throughfall of snow through the canopy (kg m-2 s-1) - flux_data%var(iLookFLUX%scalarCanopySnowUnloading)%dat(1), & ! unloading of snow from the canopy (kg m-2 s-1) - ! input/output: state variables - prog_data%var(iLookPROG%scalarSWE)%dat(1), & ! SWE (kg m-2) - prog_data%var(iLookPROG%scalarSnowDepth)%dat(1), & ! total snow depth (m) - prog_data%var(iLookPROG%mLayerTemp)%dat(1), & ! temperature of the top layer (K) - prog_data%var(iLookPROG%mLayerDepth)%dat(1), & ! depth of the top layer (m) - prog_data%var(iLookPROG%mLayerVolFracIce)%dat(1), & ! volumetric fraction of ice of the top layer (-) - prog_data%var(iLookPROG%mLayerVolFracLiq)%dat(1), & ! volumetric fraction of liquid water of the top layer (-) - ! output: error control - err,cmessage) ! error control - if(err/=0)then; err=30; message=trim(message)//trim(cmessage); return; end if - - ! re-compute snow depth and SWE - if(nSnow > 0)then - prog_data%var(iLookPROG%scalarSnowDepth)%dat(1) = sum( prog_data%var(iLookPROG%mLayerDepth)%dat(1:nSnow)) - prog_data%var(iLookPROG%scalarSWE)%dat(1) = sum( (prog_data%var(iLookPROG%mLayerVolFracLiq)%dat(1:nSnow)*iden_water + & - prog_data%var(iLookPROG%mLayerVolFracIce)%dat(1:nSnow)*iden_ice) & - * prog_data%var(iLookPROG%mLayerDepth)%dat(1:nSnow) ) - end if - !print*, 'SWE after snowfall = ', prog_data%var(iLookPROG%scalarSWE)%dat(1) - - ! re-assign dimension lengths - nSnow = count(indx_data%var(iLookINDEX%layerType)%dat==iname_snow) - nSoil = count(indx_data%var(iLookINDEX%layerType)%dat==iname_soil) - nLayers = nSnow+nSoil - - ! update coordinate variables - call calcHeight(& - ! input/output: data structures - indx_data, & ! intent(in): layer type - prog_data, & ! intent(inout): model variables for a local HRU - ! output: error control - err,cmessage) - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if - - ! overwrite flux_data with flux_mean (returns timestep-average fluxes for scalar variables) - do iVar=1,size(averageFlux_meta) - flux_data%var(averageFlux_meta(iVar)%ixParent)%dat(:) = flux_mean%var(iVar)%dat(:) - end do - - ! *********************************************************************************************************************************** - ! *********************************************************************************************************************************** - ! *********************************************************************************************************************************** - ! *********************************************************************************************************************************** - - ! --- - ! *** balance checks... - ! --------------------- - - ! save the average compression and melt pond storage in the data structures - prog_data%var(iLookPROG%scalarSfcMeltPond)%dat(1) = sfcMeltPond - - ! associate local variables with information in the data structures - associate(& - ! model forcing - scalarSnowfall => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarSnowfall) )%dat(1) ,& ! computed snowfall rate (kg m-2 s-1) - scalarRainfall => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarRainfall) )%dat(1) ,& ! computed rainfall rate (kg m-2 s-1) - ! canopy fluxes - averageThroughfallSnow => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarThroughfallSnow) )%dat(1) ,& ! snow that reaches the ground without ever touching the canopy (kg m-2 s-1) - averageThroughfallRain => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarThroughfallRain) )%dat(1) ,& ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) - averageCanopySnowUnloading => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarCanopySnowUnloading))%dat(1) ,& ! unloading of snow from the vegetion canopy (kg m-2 s-1) - averageCanopyLiqDrainage => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarCanopyLiqDrainage) )%dat(1) ,& ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) - averageCanopySublimation => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarCanopySublimation) )%dat(1) ,& ! canopy sublimation/frost (kg m-2 s-1) - averageCanopyEvaporation => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarCanopyEvaporation) )%dat(1) ,& ! canopy evaporation/condensation (kg m-2 s-1) - ! snow fluxes - averageSnowSublimation => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarSnowSublimation) )%dat(1) ,& ! sublimation from the snow surface (kg m-2 s-1) - averageSnowDrainage => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarSnowDrainage) )%dat(1) ,& ! drainage from the bottom of the snowpack (m s-1) - ! soil fluxes - averageSoilInflux => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarInfiltration) )%dat(1) ,& ! influx of water at the top of the soil profile (m s-1) - averageSoilDrainage => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarSoilDrainage) )%dat(1) ,& ! drainage from the bottom of the soil profile (m s-1) - averageSoilBaseflow => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarSoilBaseflow) )%dat(1) ,& ! total baseflow from throughout the soil profile (m s-1) - averageGroundEvaporation => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarGroundEvaporation) )%dat(1) ,& ! soil evaporation (kg m-2 s-1) - averageCanopyTranspiration => flux_mean%var(childFLUX_MEAN(iLookFLUX%scalarCanopyTranspiration))%dat(1) ,& ! canopy transpiration (kg m-2 s-1) - ! state variables in the vegetation canopy - scalarCanopyLiq => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1) ,& ! canopy liquid water (kg m-2) - scalarCanopyIce => prog_data%var(iLookPROG%scalarCanopyIce)%dat(1) ,& ! canopy ice content (kg m-2) - ! state variables in the soil domain - mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat(nSnow+1:nLayers) ,& ! depth of each soil layer (m) - mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat(nSnow+1:nLayers) ,& ! volumetric ice content in each soil layer (-) - mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat(nSnow+1:nLayers) ,& ! volumetric liquid water content in each soil layer (-) - scalarAquiferStorage => prog_data%var(iLookPROG%scalarAquiferStorage)%dat(1) ,& ! aquifer storage (m) - ! error tolerance - absConvTol_liquid => mpar_data%var(iLookPARAM%absConvTol_liquid)%dat(1) ,& ! absolute convergence tolerance for vol frac liq water (-) - scalarTotalSoilIce => diag_data%var(iLookDIAG%scalarTotalSoilIce)%dat(1) ,& ! total ice in the soil column (kg m-2) - scalarTotalSoilLiq => diag_data%var(iLookDIAG%scalarTotalSoilLiq)%dat(1) & ! total liquid water in the soil column (kg m-2) - ) ! (association of local variables with information in the data structures - - ! ----- - ! * balance checks for the canopy... - ! ---------------------------------- - - ! if computing the vegetation flux - if(computeVegFlux)then - - ! canopy water balance - balanceCanopyWater1 = scalarCanopyLiq + scalarCanopyIce - - ! balance checks for the canopy - ! NOTE: need to put the balance checks in the sub-step loop so that we can re-compute if necessary - scalarCanopyWatBalError = balanceCanopyWater1 - (balanceCanopyWater0 + (scalarSnowfall - averageThroughfallSnow)*data_step + (scalarRainfall - averageThroughfallRain)*data_step & - - averageCanopySnowUnloading*data_step - averageCanopyLiqDrainage*data_step + averageCanopySublimation*data_step + averageCanopyEvaporation*data_step) - if(abs(scalarCanopyWatBalError) > absConvTol_liquid*iden_water*10._rkind)then - print*, '** canopy water balance error:' - write(*,'(a,1x,f20.10)') 'data_step = ', data_step - write(*,'(a,1x,f20.10)') 'balanceCanopyWater0 = ', balanceCanopyWater0 - write(*,'(a,1x,f20.10)') 'balanceCanopyWater1 = ', balanceCanopyWater1 - write(*,'(a,1x,f20.10)') 'scalarSnowfall = ', scalarSnowfall - write(*,'(a,1x,f20.10)') 'scalarRainfall = ', scalarRainfall - write(*,'(a,1x,f20.10)') '(scalarSnowfall - averageThroughfallSnow) = ', (scalarSnowfall - averageThroughfallSnow)!*data_step - write(*,'(a,1x,f20.10)') '(scalarRainfall - averageThroughfallRain) = ', (scalarRainfall - averageThroughfallRain)!*data_step - write(*,'(a,1x,f20.10)') 'averageCanopySnowUnloading = ', averageCanopySnowUnloading!*data_step - write(*,'(a,1x,f20.10)') 'averageCanopyLiqDrainage = ', averageCanopyLiqDrainage!*data_step - write(*,'(a,1x,f20.10)') 'averageCanopySublimation = ', averageCanopySublimation!*data_step - write(*,'(a,1x,f20.10)') 'averageCanopyEvaporation = ', averageCanopyEvaporation!*data_step - write(*,'(a,1x,f20.10)') 'scalarCanopyWatBalError = ', scalarCanopyWatBalError - message=trim(message)//'canopy hydrology does not balance' - err=20; return - end if +contains - endif ! if computing the vegetation flux - - ! ----- - ! * balance checks for SWE... - ! --------------------------- - - ! recompute snow depth (m) and SWE (kg m-2) - if(nSnow > 0)then - prog_data%var(iLookPROG%scalarSnowDepth)%dat(1) = sum( prog_data%var(iLookPROG%mLayerDepth)%dat(1:nSnow)) - prog_data%var(iLookPROG%scalarSWE)%dat(1) = sum( (prog_data%var(iLookPROG%mLayerVolFracLiq)%dat(1:nSnow)*iden_water + & - prog_data%var(iLookPROG%mLayerVolFracIce)%dat(1:nSnow)*iden_ice) & - * prog_data%var(iLookPROG%mLayerDepth)%dat(1:nSnow) ) - end if - - ! check the individual layers - if(printBalance .and. nSnow>0)then - write(*,'(a,1x,10(f12.8,1x))') 'liqSnowInit = ', liqSnowInit - write(*,'(a,1x,10(f12.8,1x))') 'volFracLiq = ', prog_data%var(iLookPROG%mLayerVolFracLiq)%dat(1:nSnow) - write(*,'(a,1x,10(f12.8,1x))') 'iLayerLiqFluxSnow = ', flux_data%var(iLookFLUX%iLayerLiqFluxSnow)%dat*iden_water*data_step - write(*,'(a,1x,10(f12.8,1x))') 'mLayerLiqFluxSnow = ', flux_data%var(iLookFLUX%mLayerLiqFluxSnow)%dat*data_step - write(*,'(a,1x,10(f12.8,1x))') 'change volFracLiq = ', prog_data%var(iLookPROG%mLayerVolFracLiq)%dat(1:nSnow) - liqSnowInit - deallocate(liqSnowInit, stat=err) - if(err/=0)then - message=trim(message)//'unable to deallocate space for the initial volumetric liquid water content of snow' - err=20; return - endif - endif - - ! check SWE - if(nSnow>0)then - effSnowfall = averageThroughfallSnow + averageCanopySnowUnloading - ! effRainfall is averageThroughfallRain + averageCanopyLiqDrainage only over snow - newSWE = prog_data%var(iLookPROG%scalarSWE)%dat(1) - delSWE = newSWE - (oldSWE - sfcMeltPond) - massBalance = delSWE - (effSnowfall + effRainfall + averageSnowSublimation - averageSnowDrainage*iden_water)*data_step - if(abs(massBalance) > 1.d-6)then - print*, 'nSnow = ', nSnow - print*, 'nSub = ', nSub - write(*,'(a,1x,f20.10)') 'data_step = ', data_step - write(*,'(a,1x,f20.10)') 'oldSWE = ', oldSWE - write(*,'(a,1x,f20.10)') 'newSWE = ', newSWE - write(*,'(a,1x,f20.10)') 'delSWE = ', delSWE - write(*,'(a,1x,f20.10)') 'effRainfall = ', effRainfall*data_step - write(*,'(a,1x,f20.10)') 'effSnowfall = ', effSnowfall*data_step - write(*,'(a,1x,f20.10)') 'sublimation = ', averageSnowSublimation*data_step - write(*,'(a,1x,f20.10)') 'snwDrainage = ', averageSnowDrainage*iden_water*data_step - write(*,'(a,1x,f20.10)') 'sfcMeltPond = ', sfcMeltPond - write(*,'(a,1x,f20.10)') 'massBalance = ', massBalance - message=trim(message)//'SWE does not balance' - err=20; return - endif ! if failed mass balance check - endif ! if snow layers exist - - ! ----- - ! * balance checks for soil... - ! ---------------------------- - - ! compute the liquid water and ice content at the end of the time step - scalarTotalSoilLiq = sum(iden_water*mLayerVolFracLiq(1:nSoil)*mLayerDepth(1:nSoil)) - scalarTotalSoilIce = sum(iden_water*mLayerVolFracIce(1:nSoil)*mLayerDepth(1:nSoil)) ! NOTE: no expansion of soil, hence use iden_water - - ! get the total water in the soil (liquid plus ice) at the end of the time step (kg m-2) - balanceSoilWater1 = scalarTotalSoilLiq + scalarTotalSoilIce - - ! get the total aquifer storage at the start of the time step (kg m-2) - balanceAquifer1 = scalarAquiferStorage*iden_water - - ! get the input and output to/from the soil zone (kg m-2) - balanceSoilInflux = averageSoilInflux*iden_water*data_step - balanceSoilBaseflow = averageSoilBaseflow*iden_water*data_step - balanceSoilDrainage = averageSoilDrainage*iden_water*data_step - balanceSoilET = (averageCanopyTranspiration + averageGroundEvaporation)*data_step - - ! check the individual layers - if(printBalance)then - write(*,'(a,1x,10(f12.8,1x))') 'liqSoilInit = ', liqSoilInit - write(*,'(a,1x,10(f12.8,1x))') 'volFracLiq = ', mLayerVolFracLiq - write(*,'(a,1x,10(f12.8,1x))') 'iLayerLiqFluxSoil = ', flux_data%var(iLookFLUX%iLayerLiqFluxSoil)%dat*iden_water*data_step - write(*,'(a,1x,10(f12.8,1x))') 'mLayerLiqFluxSoil = ', flux_data%var(iLookFLUX%mLayerLiqFluxSoil)%dat*data_step - write(*,'(a,1x,10(f12.8,1x))') 'change volFracLiq = ', mLayerVolFracLiq - liqSoilInit - deallocate(liqSoilInit, stat=err) - if(err/=0)then - message=trim(message)//'unable to deallocate space for the initial soil moisture' - err=20; return - endif - endif - - ! check the soil water balance - scalarSoilWatBalError = balanceSoilWater1 - (balanceSoilWater0 + (balanceSoilInflux + balanceSoilET - balanceSoilBaseflow - balanceSoilDrainage - totalSoilCompress) ) - if(abs(scalarSoilWatBalError) > absConvTol_liquid*iden_water*10._rkind)then ! NOTE: kg m-2, so need coarse tolerance to account for precision issues - write(*,*) 'solution method = ', ixSolution - write(*,'(a,1x,f20.10)') 'data_step = ', data_step - write(*,'(a,1x,f20.10)') 'totalSoilCompress = ', totalSoilCompress - write(*,'(a,1x,f20.10)') 'scalarTotalSoilLiq = ', scalarTotalSoilLiq - write(*,'(a,1x,f20.10)') 'scalarTotalSoilIce = ', scalarTotalSoilIce - write(*,'(a,1x,f20.10)') 'balanceSoilWater0 = ', balanceSoilWater0 - write(*,'(a,1x,f20.10)') 'balanceSoilWater1 = ', balanceSoilWater1 - write(*,'(a,1x,f20.10)') 'balanceSoilInflux = ', balanceSoilInflux - write(*,'(a,1x,f20.10)') 'balanceSoilBaseflow = ', balanceSoilBaseflow - write(*,'(a,1x,f20.10)') 'balanceSoilDrainage = ', balanceSoilDrainage - write(*,'(a,1x,f20.10)') 'balanceSoilET = ', balanceSoilET - write(*,'(a,1x,f20.10)') 'scalarSoilWatBalError = ', scalarSoilWatBalError - write(*,'(a,1x,f20.10)') 'scalarSoilWatBalError = ', scalarSoilWatBalError/iden_water - write(*,'(a,1x,f20.10)') 'absConvTol_liquid = ', absConvTol_liquid - ! error control - message=trim(message)//'soil hydrology does not balance' - err=20; return - end if - - ! end association of local variables with information in the data structures - end associate - - ! end association to canopy depth - end associate canopy - - ! Save the total soil water (Liquid+Ice) - diag_data%var(iLookDIAG%scalarTotalSoilWat)%dat(1) = balanceSoilWater1 - ! save the surface temperature (just to make things easier to visualize) - prog_data%var(iLookPROG%scalarSurfaceTemp)%dat(1) = prog_data%var(iLookPROG%mLayerTemp)%dat(1) - - ! overwrite flux data with the timestep-average value - if(.not.backwardsCompatibility)then - do iVar=1,size(flux_mean%var) - flux_data%var(averageFlux_meta(iVar)%ixParent)%dat = flux_mean%var(iVar)%dat - end do - end if - - iLayer = nSnow+1 - !print*, 'nsub, mLayerTemp(iLayer), mLayerVolFracIce(iLayer) = ', nsub, mLayerTemp(iLayer), mLayerVolFracIce(iLayer) - !print*, 'nsub = ', nsub - if(nsub>50000)then - write(message,'(a,i0)') trim(cmessage)//'number of sub-steps > 50000 for HRU ', hruID - err=20; return - end if - - ! get the end time - call cpu_time(endTime) - - ! get the elapsed time - diag_data%var(iLookDIAG%wallClockTime)%dat(1) = endTime - startTime - - end subroutine coupled_em - - - ! ********************************************************************************************************* - ! private subroutine implctMelt: compute melt of the "snow without a layer" - ! ********************************************************************************************************* - subroutine implctMelt(& - ! input/output: integrated snowpack properties - scalarSWE, & ! intent(inout): snow water equivalent (kg m-2) - scalarSnowDepth, & ! intent(inout): snow depth (m) - scalarSfcMeltPond, & ! intent(inout): surface melt pond (kg m-2) - ! input/output: properties of the upper-most soil layer - soilTemp, & ! intent(inout): surface layer temperature (K) - soilDepth, & ! intent(inout): surface layer depth (m) - soilHeatcap, & ! intent(inout): surface layer volumetric heat capacity (J m-3 K-1) - ! output: error control - err,message ) ! intent(out): error control - implicit none - ! input/output: integrated snowpack properties - real(rkind),intent(inout) :: scalarSWE ! snow water equivalent (kg m-2) - real(rkind),intent(inout) :: scalarSnowDepth ! snow depth (m) - real(rkind),intent(inout) :: scalarSfcMeltPond ! surface melt pond (kg m-2) - ! input/output: properties of the upper-most soil layer - real(rkind),intent(inout) :: soilTemp ! surface layer temperature (K) - real(rkind),intent(inout) :: soilDepth ! surface layer depth (m) - real(rkind),intent(inout) :: soilHeatcap ! surface layer volumetric heat capacity (J m-3 K-1) - ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! local variables - real(rkind) :: nrgRequired ! energy required to melt all the snow (J m-2) - real(rkind) :: nrgAvailable ! energy available to melt the snow (J m-2) - real(rkind) :: snwDensity ! snow density (kg m-3) - ! initialize error control - err=0; message='implctMelt/' - - if(scalarSWE > 0._rkind)then - ! only melt if temperature of the top soil layer is greater than Tfreeze - if(soilTemp > Tfreeze)then - ! compute the energy required to melt all the snow (J m-2) - nrgRequired = scalarSWE*LH_fus - ! compute the energy available to melt the snow (J m-2) - nrgAvailable = soilHeatcap*(soilTemp - Tfreeze)*soilDepth - ! compute the snow density (not saved) - snwDensity = scalarSWE/scalarSnowDepth - ! compute the amount of melt, and update SWE (kg m-2) - if(nrgAvailable > nrgRequired)then - scalarSfcMeltPond = scalarSWE - scalarSWE = 0._rkind - else - scalarSfcMeltPond = nrgAvailable/LH_fus - scalarSWE = scalarSWE - scalarSfcMeltPond - end if - ! update depth - scalarSnowDepth = scalarSWE/snwDensity - ! update temperature of the top soil layer (K) - soilTemp = soilTemp - (LH_fus*scalarSfcMeltPond/soilDepth)/soilHeatcap - else ! melt is zero if the temperature of the top soil layer is less than Tfreeze - scalarSfcMeltPond = 0._rkind ! kg m-2 - end if ! (if the temperature of the top soil layer is greater than Tfreeze) - else ! melt is zero if the "snow without a layer" does not exist - scalarSfcMeltPond = 0._rkind ! kg m-2 - end if ! (if the "snow without a layer" exists) - - end subroutine implctMelt + subroutine initialize_coupled_em + ! *** Initialize steps for coupled_em subroutine *** + ! Notes: - created to ensure certain variables are initialized prior to use in calculations + ! - based on warnings from the SUMMA debug build (e.g., -Wall flag) + ! - additional initial operations may be added here in the future + + ! initialize variables + innerEffRainfall=0._rkind ! inner step average effective rainfall into snow (kg m-2 s-1) + sumCanopySublimation=0._rkind ! sum of sublimation from the vegetation canopy (kg m-2 s-1) over substep + sumLatHeatCanopyEvap=0._rkind ! sum of latent heat flux for evaporation from the canopy to the canopy air space (W m-2) over substep + sumSenHeatCanopy=0._rkind ! sum of sensible heat flux from the canopy to the canopy air space (W m-2) over substep + sumSnowSublimation=0._rkind ! sum of sublimation from the snow surface (kg m-2 s-1) over substep + sumStepSize=0._rkind ! sum solution step for the data step + innerBalance = 0._rkind ! mean total balance array + + ! get initial value of nLayers + nSnow = count(indx_data%var(iLookINDEX%layerType)%dat==iname_snow) + nSoil = count(indx_data%var(iLookINDEX%layerType)%dat==iname_soil) + nLayers = nSnow + nSoil + + ! allocate and initialize using the initial value of nLayers + allocate(innerBalanceLayerMass(nLayers)); innerBalanceLayerMass = 0._rkind ! mean total balance of mass in layers + allocate(innerBalanceLayerNrg(nLayers)); innerBalanceLayerNrg = 0._rkind ! mean total balance of energy in layers + allocate(mLayerVolFracIceInit(nLayers)); mLayerVolFracIceInit = prog_data%var(iLookPROG%mLayerVolFracIce)%dat ! volume fraction of water ice + + ! initialize the numerix tracking variables + indx_data%var(iLookINDEX%numberFluxCalc )%dat(1) = 0 ! number of flux calculations (-) + indx_data%var(iLookINDEX%numberStateSplit )%dat(1) = 0 ! number of state splitting solutions (-) + indx_data%var(iLookINDEX%numberDomainSplitNrg )%dat(1) = 0 ! number of domain splitting solutions for energy (-) + indx_data%var(iLookINDEX%numberDomainSplitMass)%dat(1) = 0 ! number of domain splitting solutions for mass (-) + indx_data%var(iLookINDEX%numberScalarSolutions)%dat(1) = 0 ! number of scalar solutions (-) + + ! initialize surface melt pond + sfcMeltPond = 0._rkind ! change in storage associated with the surface melt pond (kg m-2) + + ! initialize average over data_step (averaged over substep in varSubStep) + meanCanopySublimation = 0._rkind ! mean canopy sublimation + meanLatHeatCanopyEvap = 0._rkind ! mean latent heat flux for evaporation from the canopy + meanSenHeatCanopy = 0._rkind ! mean sensible heat flux from the canopy + effRainfall = 0._rkind ! mean total effective rainfall over snow + + diag_data%var(iLookDIAG%meanStepSize)%dat(1) = 0._rkind ! mean step size over data_step + + ! Need mean soil compression for balance checks but it is not in flux structure so handle differently + ! This will be a problem if nSoil changes (currently not possible)-- then might need to not keep the average + allocate(meanSoilCompress(nSoil)) + allocate(innerSoilCompress(nSoil)) + meanSoilCompress = 0._rkind ! mean total soil compression + + ! initialize the balance checks + meanBalance = 0._rkind + + ! start by assuming that the step is successful + stepFailure = .false. + doLayerMerge = .false. + + ! initialize flags to modify the veg layers or modify snow layers + modifiedLayers = .false. ! flag to denote that snow layers were modified + modifiedVegState = .false. ! flag to denote that vegetation states were modified + + end subroutine initialize_coupled_em + +end subroutine coupled_em + + +! ********************************************************************************************************* +! private subroutine implctMelt: compute melt of the "snow without a layer" +! ********************************************************************************************************* +subroutine implctMelt(& + ! input/output: integrated snowpack properties + scalarSWE, & ! intent(inout): snow water equivalent (kg m-2) + scalarSnowDepth, & ! intent(inout): snow depth (m) + scalarSfcMeltPond, & ! intent(out): surface melt pond (kg m-2) + ! input/output: properties of the upper-most soil layer + soilTemp, & ! intent(inout): surface layer temperature (K) + soilDepth, & ! intent(inout): surface layer depth (m) + soilHeatcap, & ! intent(in): surface layer volumetric heat capacity (J m-3 K-1) + ! output: error control + err,message ) ! intent(out): error control + implicit none + ! input/output: integrated snowpack properties + real(rkind),intent(inout) :: scalarSWE ! snow water equivalent (kg m-2) + real(rkind),intent(inout) :: scalarSnowDepth ! snow depth (m) + real(rkind),intent(out) :: scalarSfcMeltPond ! surface melt pond (kg m-2) + ! input/output: properties of the upper-most soil layer + real(rkind),intent(inout) :: soilTemp ! surface layer temperature (K) + real(rkind),intent(inout) :: soilDepth ! surface layer depth (m) + real(rkind),intent(in) :: soilHeatcap ! surface layer volumetric heat capacity (J m-3 K-1) + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! local variables + real(rkind) :: nrgRequired ! energy required to melt all the snow (J m-2) + real(rkind) :: nrgAvailable ! energy available to melt the snow (J m-2) + real(rkind) :: snwDensity ! snow density (kg m-3) + ! initialize error control + err=0; message='implctMelt/' + + if(scalarSWE > 0._rkind)then + ! only melt if temperature of the top soil layer is greater than Tfreeze + if(soilTemp > Tfreeze)then + ! compute the energy required to melt all the snow (J m-2) + nrgRequired = scalarSWE*LH_fus + ! compute the energy available to melt the snow (J m-2) + nrgAvailable = soilHeatcap*(soilTemp - Tfreeze)*soilDepth + ! compute the snow density (not saved) + snwDensity = scalarSWE/scalarSnowDepth + ! compute the amount of melt, and update SWE (kg m-2) + if(nrgAvailable > nrgRequired)then + scalarSfcMeltPond = scalarSWE + scalarSWE = 0._rkind + else + scalarSfcMeltPond = nrgAvailable/LH_fus + scalarSWE = scalarSWE - scalarSfcMeltPond + end if + ! update depth + scalarSnowDepth = scalarSWE/snwDensity + ! update temperature of the top soil layer (K) + soilTemp = soilTemp - (LH_fus*scalarSfcMeltPond/soilDepth)/soilHeatcap + else ! melt is zero if the temperature of the top soil layer is less than Tfreeze + scalarSfcMeltPond = 0._rkind ! kg m-2 + end if ! (if the temperature of the top soil layer is greater than Tfreeze) + else ! melt is zero if the "snow without a layer" does not exist + scalarSfcMeltPond = 0._rkind ! kg m-2 + end if ! (if the "snow without a layer" exists) + +end subroutine implctMelt end module coupled_em_module diff --git a/build/source/engine/derivforce.f90 b/build/source/engine/derivforce.f90 index caa7e617d..4f60278be 100644 --- a/build/source/engine/derivforce.f90 +++ b/build/source/engine/derivforce.f90 @@ -22,7 +22,7 @@ module derivforce_module ! data types USE nrtype -USE data_types,only:var_dlength ! data structure: x%var(:)%dat (dp) +USE data_types,only:var_dlength ! data structure: x%var(:)%dat (rkind) ! model constants USE multiconst,only:Tfreeze ! freezing point of pure water (K) @@ -31,9 +31,10 @@ module derivforce_module USE multiconst,only:minprhour ! number of minutes in an hour ! global time information -USE globalData,only:refJulday ! reference time (fractional julian days) +USE globalData,only:refJulDay ! reference time (fractional julian days) USE globalData,only:data_step ! length of the data step (s) -USE globalData,only:tmZoneOffsetFracDay ! time zone offset in fractional days +USE globalData,only:realMissing ! missing real number +USE globalData,only:nSpecBand ! number of spectral bands ! model decisions USE globalData,only:model_decisions ! model decision structure @@ -49,10 +50,10 @@ module derivforce_module ! look-up values for the choice of snow albedo options USE mDecisions_module,only: & - constDens, & ! Constant new snow density - anderson, & ! Anderson 1976 - hedAndPom, & ! Hedstrom and Pomeroy (1998), expoential increase - pahaut_76 ! Pahaut 1976, wind speed dependent (derived from Col de Porte, French Alps) + constDens, & ! Constant new snow density + anderson, & ! Anderson 1976 + hedAndPom, & ! Hedstrom and Pomeroy (1998), expoential increase + pahaut_76 ! Pahaut 1976, wind speed dependent (derived from Col de Porte, French Alps) ! privacy implicit none @@ -63,56 +64,55 @@ module derivforce_module ! ************************************************************************************************ ! public subroutine derivforce: compute derived forcing data ! ************************************************************************************************ - subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_data,flux_data,err,message) - USE sunGeomtry_module,only:clrsky_rad ! compute cosine of the solar zenith angle - USE conv_funcs_module,only:vapPress ! compute vapor pressure of air (Pa) - USE conv_funcs_module,only:SPHM2RELHM,RELHM2SPHM,WETBULBTMP ! conversion functions - USE snow_utils_module,only:fracliquid,templiquid ! functions to compute temperature/liquid water - USE time_utils_module,only:compcalday ! convert julian day to calendar date - USE summaFileManager,only: NC_TIME_ZONE ! time zone option from control file + subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_data,flux_data,tmZoneOffsetFracDay,err,message) + USE sunGeomtry_module,only:clrsky_rad ! compute cosine of the solar zenith angle + USE conv_funcs_module,only:vapPress ! compute vapor pressure of air (Pa) + USE conv_funcs_module,only:SPHM2RELHM,RELHM2SPHM,WETBULBTMP ! conversion functions + USE snow_utils_module,only:fracliquid,templiquid ! functions to compute temperature/liquid water + USE time_utils_module,only:compcalday ! convert julian day to calendar date + USE summaFileManager,only: NC_TIME_ZONE ! time zone option from control file ! compute derived forcing data variables implicit none ! input variables - integer(i4b), intent(in) :: time_data(:) ! vector of time data for a given time step - real(rkind), intent(inout) :: forc_data(:) ! vector of forcing data for a given time step - real(rkind), intent(in) :: attr_data(:) ! vector of model attributes - type(var_dlength),intent(in) :: mpar_data ! vector of model parameters - type(var_dlength),intent(in) :: prog_data ! data structure of model prognostic variables for a local HRU + integer(i4b),intent(in) :: time_data(:) ! vector of time data for a given time step + real(rkind),intent(inout) :: forc_data(:) ! vector of forcing data for a given time step + real(rkind),intent(in) :: attr_data(:) ! vector of model attributes + type(var_dlength),intent(in) :: mpar_data ! vector of model parameters + type(var_dlength),intent(in) :: prog_data ! data structure of model prognostic variables for a local HRU ! output variables - type(var_dlength),intent(inout) :: diag_data ! data structure of model diagnostic variables for a local HRU - type(var_dlength),intent(inout) :: flux_data ! data structure of model fluxes for a local HRU - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + type(var_dlength),intent(inout) :: diag_data ! data structure of model diagnostic variables for a local HRU + type(var_dlength),intent(inout) :: flux_data ! data structure of model fluxes for a local HRU + real(rkind),intent(inout) :: tmZoneOffsetFracDay + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message ! local time - integer(i4b) :: jyyy,jm,jd ! year, month, day - integer(i4b) :: jh,jmin ! hour, minute - real(rkind) :: dsec ! double precision seconds (not used) - real(rkind) :: timeOffset ! time offset from Grenwich (days) - real(rkind) :: julianTime ! local julian time + integer(i4b) :: jyyy,jm,jd ! year, month, day + integer(i4b) :: jh,jmin ! hour, minute + real(rkind) :: dsec ! double precision seconds (not used) + real(rkind) :: timeOffset ! time offset from Grenwich (days) + real(rkind) :: julianTime ! local julian time ! cosine of the solar zenith angle - real(rkind) :: ahour ! hour at start of time step - real(rkind) :: dataStep ! data step (hours) - real(rkind) :: slope ! HRU terrain slope (degrees) - real(rkind) :: azimuth ! HRU terrain azimuth (degrees) - real(rkind) :: hri ! average radiation index over time step DT + real(rkind) :: ahour ! hour at start of time step + real(rkind) :: dataStep ! data step (hours) + real(rkind) :: slope ! terrain slope (assume flat) + real(rkind) :: azimuth ! terrain azimuth (assume zero) + real(rkind) :: hri ! average radiation index over time step DT ! general local variables - character(len=256) :: cmessage ! error message for downwind routine - integer(i4b),parameter :: nBands=2 ! number of spectral bands - real(rkind),parameter :: valueMissing=-9999._rkind ! missing value - real(rkind),parameter :: co2Factor=355.e-6_rkind ! empirical factor to obtain partial pressure of co2 - real(rkind),parameter :: o2Factor=0.209_rkind ! empirical factor to obtain partial pressure of o2 - real(rkind),parameter :: minMeasHeight=1._rkind ! minimum measurement height (m) - real(rkind) :: relhum ! relative humidity (-) - real(rkind) :: fracrain ! fraction of precipitation that falls as rain - real(rkind) :: maxFrozenSnowTemp ! maximum temperature of snow when the snow is predominantely frozen (K) - real(rkind),parameter :: unfrozenLiq=0.01_rkind ! unfrozen liquid water used to compute maxFrozenSnowTemp (-) - real(rkind),parameter :: eps=epsilon(fracrain) ! a number that is almost negligible - real(rkind) :: Tmin,Tmax ! minimum and maximum wet bulb temperature in the time step (K) - real(rkind),parameter :: pomNewSnowDenMax=150._rkind ! Upper limit for new snow density limit in Hedstrom and Pomeroy 1998. 150 was used because at was the highest observed density at air temperatures used in this study. See Figure 4 of Hedstrom and Pomeroy (1998). - real(rkind),parameter :: andersonWarmDenLimit=2._rkind ! Upper air temperature limit in Anderson (1976) new snow density (C) - real(rkind),parameter :: andersonColdDenLimit=15._rkind! Lower air temperature limit in Anderson (1976) new snow density (C) - real(rkind),parameter :: andersonDenScal=1.5_rkind ! Scalar parameter in Anderson (1976) new snow density function (-) - real(rkind),parameter :: pahautDenWindScal=0.5_rkind ! Scalar parameter for wind impacts on density using Pahaut (1976) function (-) + character(len=256) :: cmessage ! error message for downwind routine + real(rkind),parameter :: co2Factor=355.e-6_rkind ! empirical factor to obtain partial pressure of co2 + real(rkind),parameter :: o2Factor=0.209_rkind ! empirical factor to obtain partial pressure of o2 + real(rkind),parameter :: minMeasHeight=1._rkind ! minimum measurement height (m) + real(rkind) :: relhum ! relative humidity (-) + real(rkind) :: fracrain ! fraction of precipitation that falls as rain + real(rkind) :: maxFrozenSnowTemp ! maximum temperature of snow when the snow is predominantely frozen (K) + real(rkind),parameter :: unfrozenLiq=0.01_rkind ! unfrozen liquid water used to compute maxFrozenSnowTemp (-) + real(rkind),parameter :: eps=epsilon(fracrain) ! a number that is almost negligible + real(rkind) :: Tmin,Tmax ! minimum and maximum wet bulb temperature in the time step (K) + real(rkind),parameter :: pomNewSnowDenMax=150._rkind ! Upper limit for new snow density limit in Hedstrom and Pomeroy 1998. 150 was used because at was the highest observed density at air temperatures used in this study. See Figure 4 of Hedstrom and Pomeroy (1998). + real(rkind),parameter :: andersonWarmDenLimit=2._rkind ! Upper air temperature limit in Anderson (1976) new snow density (C) + real(rkind),parameter :: andersonColdDenLimit=15._rkind! Lower air temperature limit in Anderson (1976) new snow density (C) + real(rkind),parameter :: andersonDenScal=1.5_rkind ! Scalar parameter in Anderson (1976) new snow density function (-) + real(rkind),parameter :: pahautDenWindScal=0.5_rkind ! Scalar parameter for wind impacts on density using Pahaut (1976) function (-) ! ************************************************************************************************ ! associate local variables with the information in the data structures associate(& @@ -134,7 +134,6 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat newSnowDenMultWind => mpar_data%var(iLookPARAM%newSnowDenMultWind)%dat(1) , & ! Pahaut 1976, multiplier for new snow density applied to wind speed (kg m-7/2 s-1/2) newSnowDenMultAnd => mpar_data%var(iLookPARAM%newSnowDenMultAnd)%dat(1) , & ! Anderson 1976, multiplier for new snow density for Anderson function (K-1) newSnowDenBase => mpar_data%var(iLookPARAM%newSnowDenBase)%dat(1) , & ! Anderson 1976, base value that is rasied to the (3/2) power (K) - heightCanopyTop => mpar_data%var(iLookPARAM%heightCanopyTop)%dat(1) , & ! height of the top of the canopy layer (m) ! radiation geometry variables iyyy => time_data(iLookTIME%iyyy) , & ! year im => time_data(iLookTIME%im) , & ! month @@ -147,9 +146,10 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat aspect => attr_data(iLookATTR%aspect) , & ! mean azimuth of HRU in degrees E of N (degrees) cosZenith => diag_data%var(iLookDIAG%scalarCosZenith)%dat(1) , & ! average cosine of the zenith angle over time step DT ! measurement height - mHeight => attr_data(iLookATTR%mHeight) , & ! latitude (degrees north) - adjMeasHeight => diag_data%var(iLookDIAG%scalarAdjMeasHeight)%dat(1) , & ! adjusted measurement height (m) + mHeight => attr_data(iLookATTR%mHeight) , & ! measurement height (m) + adjMeasHeight => diag_data%var(iLookDIAG%scalarAdjMeasHeight)%dat(1) , & ! adjusted measurement height for cases snowDepth>mHeight (m) scalarSnowDepth => prog_data%var(iLookPROG%scalarSnowDepth)%dat(1) , & ! snow depth on the ground surface (m) + heightCanopyTop => mpar_data%var(iLookPARAM%heightCanopyTop)%dat(1) , & ! height of the top of the canopy layer (m) ! model time secondsSinceRefTime => forc_data(iLookFORCE%time) , & ! time = seconds since reference time ! model forcing data @@ -162,6 +162,8 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat ! derived model forcing data scalarO2air => diag_data%var(iLookDIAG%scalarO2air)%dat(1) , & ! atmospheric o2 concentration (Pa) scalarCO2air => diag_data%var(iLookDIAG%scalarCO2air)%dat(1) , & ! atmospheric co2 concentration (Pa) + windspd_x => diag_data%var(iLookDIAG%windspd_x)%dat(1) , & ! wind speed at 10 meter height in x-direction (m s-1) + windspd_y => diag_data%var(iLookDIAG%windspd_y)%dat(1) , & ! wind speed at 10 meter height in y-direction (m s-1) ! radiation variables scalarFractionDirect => diag_data%var(iLookDIAG%scalarFractionDirect)%dat(1) , & ! fraction of direct radiation (0-1) spectralIncomingDirect => flux_data%var(iLookFLUX%spectralIncomingDirect)%dat , & ! downwelling direct shortwave radiation for each waveband (W m-2) @@ -178,9 +180,17 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat ! initialize error control err=0; message="derivforce/" + ! NGEN wants the wind inputted as two components, if not inputting NGEN forcing let the y direction be 0 +#ifdef NGEN_FORCING_ACTIVE + windspd = sqrt(windspd_x**2_i4b + windspd_y**2_i4b) +#else + windspd_x = windspd + windspd_y = 0._rkind +#endif + ! check spectral dimension - if(size(spectralIncomingDirect) /= nBands .or. size(spectralIncomingDiffuse) /= nBands)then - write(message,'(a,i0,a)') trim(message)//'expect ', nBands, 'spectral classes for radiation' + if(size(spectralIncomingDirect) /= nSpecBand .or. size(spectralIncomingDiffuse) /= nSpecBand)then + write(message,'(a,i0,a)') trim(message)//'expect ', nSpecBand, 'spectral classes for radiation' err=20; return end if @@ -217,14 +227,14 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat end select ! identifying option tmZoneInfo ! constrain timeOffset so that it is in the [-0.5, 0.5] range - if(timeOffset < -0.5)then - timeOffset = timeOffset + 1 - else if(timeOffset > 0.5)then - timeOffset = timeOffset - 1 + if(timeOffset<-0.5)then + timeOffset = timeOffset+1 + else if(timeOffset>0.5)then + timeOffset = timeOffset-1 endif ! compute the local time - julianTime = secondsSinceRefTime/secprday + refJulday ! julian time (days) + julianTime = secondsSinceRefTime/secprday + refJulDay ! julian time (days) ! convert julian day to year/month/day/hour/minute call compcalday(julianTime+timeOffset, & ! input = julian day @@ -236,21 +246,24 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat dataStep = data_step/secprhour ! time step (hours) ahour = real(jh,kind(rkind)) + real(jmin,kind(rkind))/minprhour - data_step/secprhour ! decimal hour (start of the step) +#ifdef ACTORS_ACTIVE + azimuth = 0._rkind ! if aspect is not an input attribute, slope & azimuth = zero (flat Earth) + slope = 0._rkind ! Actors doesn't look for this attribute for some reason FIX +#else ! check slope/aspect intent for radiation calculation if(aspect == nr_realMissing)then - azimuth = 0._dp ! if aspect is not an input attribute, slope & azimuth = zero (flat Earth) - slope = 0._dp + azimuth = 0._rkind ! if aspect is not an input attribute, slope & azimuth = zero (flat Earth) + slope = 0._rkind else - azimuth = aspect ! in degrees - slope = atan(abs(tan_slope))*180._dp/PI_D ! convert from m/m to degrees + azimuth = aspect ! in degrees + slope = atan(abs(tan_slope))*180._rkind/PI_D ! convert from m/m to degrees endif +#endif ! compute the cosine of the solar zenith angle call clrsky_rad(jm,jd,ahour,dataStep, & ! intent(in): time variables slope,azimuth,latitude, & ! intent(in): location variables hri,cosZenith) ! intent(out): cosine of the solar zenith angle - !write(*,'(a,1x,4(i2,1x),5(f9.3,1x))') 'im,id,ih,imin,ahour,dataStep,azimuth,slope,cosZenith = ', & - ! im,id,ih,imin,ahour,dataStep,azimuth,slope,cosZenith ! ensure solar radiation is non-negative if(SWRadAtm < 0._rkind) SWRadAtm = 0._rkind @@ -260,19 +273,15 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat else scalarFractionDirect = 0._rkind end if - ! compute direct shortwave radiation, in the visible and near-infra-red part of the spectrum - spectralIncomingDirect(1) = SWRadAtm*scalarFractionDirect*Frad_vis ! (direct vis) - spectralIncomingDirect(2) = SWRadAtm*scalarFractionDirect*(1._rkind - Frad_vis) ! (direct nir) - ! compute diffuse shortwave radiation, in the visible and near-infra-red part of the spectrum + + ! compute direct shortwave and diffuse radiation, in the visible and near-infra-red part of the spectrum + spectralIncomingDirect(1) = SWRadAtm*scalarFractionDirect*Frad_vis ! (direct vis) + spectralIncomingDirect(2) = SWRadAtm*scalarFractionDirect*(1._rkind - Frad_vis) ! (direct nir) spectralIncomingDiffuse(1) = SWRadAtm*(1._rkind - scalarFractionDirect)*Frad_vis ! (diffuse vis) spectralIncomingDiffuse(2) = SWRadAtm*(1._rkind - scalarFractionDirect)*(1._rkind - Frad_vis) ! (diffuse nir) - !print*,'Frad_direct,scalarFractionDirect,directScale,SWRadAtm,Frad_vis,spectralIncomingDirect: ', & - ! frad_direct,scalarFractionDirect,directScale,SWRadAtm,Frad_vis,spectralIncomingDirect - ! ensure wind speed is above a prescribed minimum value if(windspd < minwind) windspd=minwind - ! compute relative humidity (-) relhum = SPHM2RELHM(spechum, airpres, airtemp) ! if relative humidity exceeds saturation, then set relative and specific humidity to saturation @@ -283,7 +292,6 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat ! compute vapor pressure of the air above the vegetation canopy (Pa) VPair = vapPress(spechum,airpres) - !print*, 'VPair = ', VPair ! compute wet bulb temperature (K) twetbulb = WETBULBTMP(airtemp, relhum, airpres) @@ -344,7 +352,7 @@ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_dat case default; message=trim(message)//'unable to identify option for new snow density'; err=20; return end select ! identifying option for new snow density else - newSnowDensity = valueMissing + newSnowDensity = realMissing rainfall = rainfall + snowfall ! in most cases snowfall will be zero here snowfall = 0._rkind end if diff --git a/build/source/engine/diagn_evar.f90 b/build/source/engine/diagn_evar.f90 old mode 100755 new mode 100644 index 0e47dfc72..6b4e780c2 --- a/build/source/engine/diagn_evar.f90 +++ b/build/source/engine/diagn_evar.f90 @@ -22,12 +22,13 @@ module diagn_evar_module ! data types USE nrtype +USE globalData,only:realMissing ! missing real number ! derived types to define the data structures USE data_types,only:& - var_d, & ! data vector (dp) + var_d, & ! data vector (rkind) var_ilength, & ! data vector with variable length dimension (i4b) - var_dlength ! data vector with variable length dimension (dp) + var_dlength ! data vector with variable length dimension (rkind) ! named variables defining elements in the data structures USE var_lookup,only:iLookPARAM,iLookPROG,iLookDIAG,iLookINDEX ! named variables for structure elements @@ -71,12 +72,6 @@ module diagn_evar_module implicit none private public::diagn_evar - -! algorithmic parameters -real(rkind),parameter :: valueMissing=-9999._rkind ! missing value, used when diagnostic or state variables are undefined -real(rkind),parameter :: verySmall=1.e-6_rkind ! used as an additive constant to check if substantial difference among real numbers -real(rkind),parameter :: mpe=1.e-6_rkind ! prevents overflow error if division by zero -real(rkind),parameter :: dx=1.e-6_rkind ! finite difference increment contains @@ -85,14 +80,14 @@ module diagn_evar_module ! ********************************************************************************************************** subroutine diagn_evar(& ! input: control variables - computeVegFlux, & ! intent(in): flag to denote if computing the vegetation flux - canopyDepth, & ! intent(in): canopy depth (m) + computeVegFlux, & ! intent(in): flag to denote if computing the vegetation flux + canopyDepth, & ! intent(in): canopy depth (m) ! input/output: data structures mpar_data, & ! intent(in): model parameters indx_data, & ! intent(in): model layer indices prog_data, & ! intent(in): model prognostic variables for a local HRU diag_data, & ! intent(inout): model diagnostic variables for a local HRU - ! output: error control + ! output: error control err,message) ! intent(out): error control ! -------------------------------------------------------------------------------------------------------------------------------------- ! provide access to external subroutines @@ -100,7 +95,7 @@ subroutine diagn_evar(& ! -------------------------------------------------------------------------------------------------------------------------------------- ! input: model control logical(lgt),intent(in) :: computeVegFlux ! logical flag to denote if computing the vegetation flux - real(rkind),intent(in) :: canopyDepth ! depth of the vegetation canopy (m) + real(rkind),intent(in) :: canopyDepth ! depth of the vegetation canopy (m) ! input/output: data structures type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_ilength),intent(in) :: indx_data ! model layer indices @@ -111,29 +106,29 @@ subroutine diagn_evar(& character(*),intent(out) :: message ! error message ! -------------------------------------------------------------------------------------------------------------------------------- ! local variables - character(LEN=256) :: cmessage ! error message of downwind routine - integer(i4b) :: iLayer ! index of model layer - integer(i4b) :: iSoil ! index of soil layer - real(rkind) :: TCn ! thermal conductivity below the layer interface (W m-1 K-1) - real(rkind) :: TCp ! thermal conductivity above the layer interface (W m-1 K-1) - real(rkind) :: zdn ! height difference between interface and lower value (m) - real(rkind) :: zdp ! height difference between interface and upper value (m) - real(rkind) :: bulkden_soil ! bulk density of soil (kg m-3) - real(rkind) :: lambda_drysoil ! thermal conductivity of dry soil (W m-1) - real(rkind) :: lambda_wetsoil ! thermal conductivity of wet soil (W m-1) - real(rkind) :: lambda_wet ! thermal conductivity of the wet material - real(rkind) :: relativeSat ! relative saturation (-) - real(rkind) :: kerstenNum ! the Kersten number (-), defining weight applied to conductivity of the wet medium - real(rkind) :: den ! denominator in the thermal conductivity calculations + character(LEN=256) :: cmessage ! error message of downwind routine + integer(i4b) :: iLayer ! index of model layer + integer(i4b) :: iSoil ! index of soil layer + real(rkind) :: TCn ! thermal conductivity below the layer interface (W m-1 K-1) + real(rkind) :: TCp ! thermal conductivity above the layer interface (W m-1 K-1) + real(rkind) :: zdn ! height difference between interface and lower value (m) + real(rkind) :: zdp ! height difference between interface and upper value (m) + real(rkind) :: bulkden_soil ! bulk density of soil (kg m-3) + real(rkind) :: lambda_drysoil ! thermal conductivity of dry soil (W m-1) + real(rkind) :: lambda_wetsoil ! thermal conductivity of wet soil (W m-1) + real(rkind) :: lambda_wet ! thermal conductivity of the wet material + real(rkind) :: relativeSat ! relative saturation (-) + real(rkind) :: kerstenNum ! the Kersten number (-), defining weight applied to conductivity of the wet medium + real(rkind) :: den ! denominator in the thermal conductivity calculations ! local variables to reproduce the thermal conductivity of Hansson et al. VZJ 2005 - real(rkind),parameter :: c1=0.55_rkind ! optimized parameter from Hansson et al. VZJ 2005 (W m-1 K-1) - real(rkind),parameter :: c2=0.8_rkind ! optimized parameter from Hansson et al. VZJ 2005 (W m-1 K-1) - real(rkind),parameter :: c3=3.07_rkind ! optimized parameter from Hansson et al. VZJ 2005 (-) - real(rkind),parameter :: c4=0.13_rkind ! optimized parameter from Hansson et al. VZJ 2005 (W m-1 K-1) - real(rkind),parameter :: c5=4._rkind ! optimized parameter from Hansson et al. VZJ 2005 (-) - real(rkind),parameter :: f1=13.05_rkind ! optimized parameter from Hansson et al. VZJ 2005 (-) - real(rkind),parameter :: f2=1.06_rkind ! optimized parameter from Hansson et al. VZJ 2005 (-) - real(rkind) :: fArg,xArg ! temporary variables (see Hansson et al. VZJ 2005 for details) + real(rkind),parameter :: c1=0.55_rkind ! optimized parameter from Hansson et al. VZJ 2005 (W m-1 K-1) + real(rkind),parameter :: c2=0.8_rkind ! optimized parameter from Hansson et al. VZJ 2005 (W m-1 K-1) + real(rkind),parameter :: c3=3.07_rkind ! optimized parameter from Hansson et al. VZJ 2005 (-) + real(rkind),parameter :: c4=0.13_rkind ! optimized parameter from Hansson et al. VZJ 2005 (W m-1 K-1) + real(rkind),parameter :: c5=4._rkind ! optimized parameter from Hansson et al. VZJ 2005 (-) + real(rkind),parameter :: f1=13.05_rkind ! optimized parameter from Hansson et al. VZJ 2005 (-) + real(rkind),parameter :: f2=1.06_rkind ! optimized parameter from Hansson et al. VZJ 2005 (-) + real(rkind) :: fArg,xArg ! temporary variables (see Hansson et al. VZJ 2005 for details) ! -------------------------------------------------------------------------------------------------------------------------------- ! associate variables in data structure associate(& @@ -183,9 +178,9 @@ subroutine diagn_evar(& Cp_water*scalarCanopyLiquid/canopyDepth + & ! liquid water component Cp_ice*scalarCanopyIce/canopyDepth ! ice component else - scalarBulkVolHeatCapVeg = valueMissing + scalarBulkVolHeatCapVeg = realMissing end if - !print*, 'diagn_evar: scalarBulkVolHeatCapVeg = ', scalarBulkVolHeatCapVeg + ! loop through layers do iLayer=1,nLayers @@ -217,7 +212,7 @@ subroutine diagn_evar(& ! * soil case(iname_soil) mLayerVolHtCapBulk(iLayer) = iden_soil(iSoil) * Cp_soil * ( 1._rkind - theta_sat(iSoil) ) + & ! soil component - iden_ice * Cp_Ice * mLayerVolFracIce(iLayer) + & ! ice component + iden_ice * Cp_ice * mLayerVolFracIce(iLayer) + & ! ice component iden_water * Cp_water * mLayerVolFracLiq(iLayer) + & ! liquid water component iden_air * Cp_air * mLayerVolFracAir(iLayer) ! air component ! * snow @@ -225,7 +220,7 @@ subroutine diagn_evar(& mLayerVolHtCapBulk(iLayer) = iden_ice * Cp_ice * mLayerVolFracIce(iLayer) + & ! ice component iden_water * Cp_water * mLayerVolFracLiq(iLayer) + & ! liquid water component iden_air * Cp_air * mLayerVolFracAir(iLayer) ! air component - case default; err=20; message=trim(message)//'unable to identify type of layer (snow or soil) to compute olumetric heat capacity'; return + case default; err=20; message=trim(message)//'unable to identify type of layer (snow or soil) to compute volumetric heat capacity'; return end select ! ***** @@ -288,11 +283,9 @@ subroutine diagn_evar(& ! * error check case default; err=20; message=trim(message)//'unable to identify type of layer (snow or soil) to compute thermal conductivity'; return - end select - !print*, 'iLayer, mLayerThermalC(iLayer) = ', iLayer, mLayerThermalC(iLayer) + end select end do ! looping through layers - !pause ! ***** ! * compute the thermal conductivity of snow at the interface of each layer... @@ -310,7 +303,6 @@ subroutine diagn_evar(& else iLayerThermalC(iLayer) = (TCn*zdn + TCp*zdp) / (zdn + zdp) endif - !write(*,'(a,1x,i4,1x,10(f9.3,1x))') 'iLayer, TCn, TCp, zdn, zdp, iLayerThermalC(iLayer) = ', iLayer, TCn, TCp, zdn, zdp, iLayerThermalC(iLayer) end do ! looping through layers ! special case of hansson diff --git a/build/source/engine/enthalpyTemp.f90 b/build/source/engine/enthalpyTemp.f90 new file mode 100644 index 000000000..63321c2fb --- /dev/null +++ b/build/source/engine/enthalpyTemp.f90 @@ -0,0 +1,1714 @@ +! SUMMA - Structure for Unifying Multiple Modeling Alternatives +! Copyright (C) 2014-2020 NCAR/RAL; University of Saskatchewan; University of Washington +! +! This file is part of SUMMA +! +! For more information see: http://www.ral.ucar.edu/projects/summa +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see . + +module enthalpyTemp_module + +! constants +USE multiconst, only: gravity, & ! gravitational acceleration (m s-1) + Tfreeze, & ! freezing point of water (K) + Cp_soil,Cp_water,Cp_ice,Cp_air,& ! specific heat of soil, water and ice (J kg-1 K-1) + iden_water,iden_ice,iden_air,& ! intrinsic density of water and ice (kg m-3) + LH_fus ! latent heat of fusion (J kg-1) + +! data types +USE nrtype +USE data_types,only:var_iLength ! var(:)%dat(:) +USE data_types,only:var_dLength ! var(:)%dat(:) +USE data_types,only:zLookup ! z(:)%var(:)%lookup(:) + +! indices within parameter structure +USE var_lookup,only:iLookPARAM ! named variables to define structure element +USE var_lookup,only:iLookINDEX ! named variables to define structure element +USE var_lookup,only:iLookLOOKUP ! named variables to define structure element +USE var_lookup,only:iLookDIAG ! named variables for structure elements + +! data dimensions +USE var_lookup,only:maxvarLookup ! maximum number of variables in the lookup tables + +! domain types +USE globalData,only:iname_cas ! named variables for canopy air space +USE globalData,only:iname_veg ! named variables for vegetation canopy +USE globalData,only:iname_snow ! named variables for snow +USE globalData,only:iname_soil ! named variables for soil +USE globalData,only:iname_aquifer ! named variables for the aquifer + +! named variables to describe the state variable type +USE globalData,only:iname_nrgCanair ! named variable defining the energy of the canopy air space +USE globalData,only:iname_nrgCanopy ! named variable defining the energy of the vegetation canopy +USE globalData,only:iname_nrgLayer ! named variable defining the energy state variable for snow+soil layers + +! missing values +USE globalData,only:integerMissing ! missing integer +USE globalData,only:realMissing ! missing real number + +implicit none +public::T2H_lookup_snWat +public::T2L_lookup_soil +public::enthalpy2T_snwWat +public::T2enthalpy_snwWat +public::T2enthTemp_cas +public::T2enthTemp_veg +public::T2enthTemp_snow +public::T2enthTemp_soil +public::enthTemp_or_enthalpy +public::enthalpy2T_cas +public::enthalpy2T_veg +public::enthalpy2T_snow +public::enthalpy2T_soil +private::hyp_2F1_real +private::brent, brent0, diff_H_veg, diff_H_snow, diff_H_soil + +! define the snow look-up table used to compute temperature based on enthalpy +integer(i4b),parameter :: nlook=10001 ! number of elements in the lookup table +real(rkind),dimension(nlook),public :: H_lookup ! enthalpy values (J kg-1) +real(rkind),dimension(nlook),public :: T_lookup ! temperature values (K) +contains + + +! ************************************************************************************************************************ +! public subroutine T2H_lookup_snWat: define a look-up table to liquid + ice enthalpy based on temperature +! appropriate when no dry mass, as in snow +! ************************************************************************************************************************ +subroutine T2H_lookup_snWat(mpar_data, & ! intent(in): parameter data structure + err,message) + ! ------------------------------------------------------------------------------------------------------------------------- + ! downwind routines + USE nr_utility_module,only:arth ! use to build vectors with regular increments + USE spline_int_module,only:spline,splint ! use for cubic spline interpolation + implicit none + ! ------------------------------------------------------------------------------------------------------------------------- + ! declare dummy variables + type(var_dlength),intent(in) :: mpar_data ! model parameters + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! declare local variables + character(len=128) :: cmessage ! error message in downwind routine + real(rkind),parameter :: T_start=260.0_rkind ! start temperature value where all liquid water is assumed frozen (K) + real(rkind) :: T_incr,H_incr ! temperature/enthalpy increments + real(rkind),dimension(nlook) :: Tk ! initial temperature vector + real(rkind),dimension(nlook) :: Hy ! initial enthalpy vector + real(rkind),parameter :: waterWght=1._rkind ! weight applied to total water (kg m-3) --- cancels out + real(rkind),dimension(nlook) :: H2 ! 2nd derivatives of the interpolating function at tabulated points + real(rkind) :: dT ! derivative of temperature with enthalpy at H_lookup + integer(i4b) :: ilook ! loop through lookup table + ! ------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message="T2H_lookup_snWat/" + + ! associate + associate( snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1) ) + + ! define initial temperature vector + T_incr = (Tfreeze - T_start) / real(nlook-1, kind(rkind)) ! temperature increment + Tk = arth(T_start,T_incr,nlook) + ! ***** compute specific enthalpy (NOTE: J m-3 --> J kg-1) ***** + + do ilook=1,nlook + Hy(ilook) = T2enthalpy_snwWat(Tk(ilook),waterWght,snowfrz_scale)/waterWght ! (J m-3 --> J kg-1) + end do + + ! define the final enthalpy vector + H_incr = (-Hy(1)) / real(nlook-1, kind(rkind)) ! enthalpy increment + H_lookup = arth(Hy(1),H_incr,nlook) + + ! use cubic spline interpolation to obtain temperature values at the desired values of enthalpy + call spline(Hy,Tk,1.e30_rkind,1.e30_rkind,H2,err,cmessage) ! get the second derivatives + if(err/=0) then; message=trim(message)//trim(cmessage); return; end if + + do ilook=1,nlook + call splint(Hy,Tk,H2,H_lookup(ilook),T_lookup(ilook),dT,err,cmessage) + if(err/=0) then; message=trim(message)//trim(cmessage); return; end if + end do + + end associate + + end subroutine T2H_lookup_snWat + +! ************************************************************************************************************************ +! public subroutine T2L_lookup_soil: define a look-up table to compute integral of soil Clapeyron equation liquid water +! matric potential from temperature +! ************************************************************************************************************************ +subroutine T2L_lookup_soil(nSoil, & ! intent(in): number of soil layers + mpar_data, & ! intent(in): parameter data structure + lookup_data, & ! intent(inout): lookup table data structure + err,message) + ! ------------------------------------------------------------------------------------------------------------------------- + ! downwind routines + USE nr_utility_module,only:arth ! use to build vectors with regular increments + USE spline_int_module,only:spline,splint ! use for cubic spline interpolation + USE soil_utils_module,only:volFracLiq ! use to compute the volumetric fraction of liquid water + implicit none + ! ------------------------------------------------------------------------------------------------------------------------- + ! declare dummy variables + integer(i4b),intent(in) :: nSoil + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(zLookup),intent(inout) :: lookup_data ! lookup tables + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! declare local variables + character(len=128) :: cmessage ! error message in downwind routine + integer(i4b),parameter :: nLook=500 ! number of elements in the lookup table + integer(i4b),parameter :: nIntegr8=10000 ! number of points used in the numerical integration + real(rkind),parameter :: T_lower=260.0_rkind ! lowest temperature value where all liquid water is assumed frozen (K) + real(rkind),dimension(nLook) :: xTemp ! temporary vector + real(rkind) :: xIncr ! temporary increment + real(rkind) :: T_incr ! temperature increment + integer(i4b) :: iVar ! loop through variables + integer(i4b) :: iSoil ! loop through soil layers + integer(i4b) :: iLook ! loop through lookup table + integer(i4b) :: jIntegr8 ! index for numerical integration + logical(lgt) :: check ! flag to check allocation + real(rkind) :: vGn_m ! van Genuchten "m" parameter (-) + real(rkind) :: vFracLiq ! volumetric fraction of liquid water (-) + real(rkind) :: matricHead ! matric head (m) + ! ------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message="T2L_lookup_soil/" + + ! get the values of temperature for the lookup table + xIncr = 1._rkind/real(nLook-1, kind(rkind)) + xTemp = T_lower + (Tfreeze - T_lower)*sqrt(sqrt(arth(0._rkind,xIncr,nLook))) ! use sqrt(sqrt()) to give more values near freezing + + ! ----- + ! * allocate space for the lookup table... + ! ---------------------------------------- + + ! initialize checks + check=.false. + + ! allocate space for soil layers + if(allocated(lookup_data%z))then; check=.true.; else; allocate(lookup_data%z(nSoil), stat=err); endif + if(check) then; err=20; message=trim(message)//'lookup table z dimension was unexpectedly allocated already'; return; end if + if(err/=0)then; err=20; message=trim(message)//'problem allocating lookup table z dimension dimension'; return; end if + + ! allocate space for the variables in the lookup table + do iSoil=1,nSoil + if(allocated(lookup_data%z(iSoil)%var))then; check=.true.; else; allocate(lookup_data%z(iSoil)%var(maxvarLookup), stat=err); endif + if(check) then; err=20; message=trim(message)//'lookup table var dimension was unexpectedly allocated already'; return; end if + if(err/=0)then; err=20; message=trim(message)//'problem allocating lookup table var dimension dimension'; return; end if + + ! allocate space for the values in the lookup table + do iVar=1,maxvarLookup + if(allocated(lookup_data%z(iSoil)%var(iVar)%lookup))then; check=.true.; else; allocate(lookup_data%z(iSoil)%var(iVar)%lookup(nLook), stat=err); endif + if(check) then; err=20; message=trim(message)//'lookup table value dimension was unexpectedly allocated already'; return; end if + if(err/=0)then; err=20; message=trim(message)//'problem allocating lookup table vaule dimension dimension'; return; end if + + end do ! (looping through variables) + end do ! (looping through soil layers) + + ! loop through soil layers + do iSoil=1,nSoil + + ! ----- + ! * make association to variables in the data structures... + ! --------------------------------------------------------- + + associate(& + + ! associate model parameters + snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1) , & ! scaling parameter for freezing (K-1) + soil_dens_intr => mpar_data%var(iLookPARAM%soil_dens_intr)%dat(iSoil) , & ! intrinsic soil density (kg m-3) + theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat(iSoil) , & ! soil porosity (-) + theta_res => mpar_data%var(iLookPARAM%theta_res)%dat(iSoil) , & ! volumetric residual water content (-) + vGn_alpha => mpar_data%var(iLookPARAM%vGn_alpha)%dat(iSoil) , & ! van Genuchten "alpha" parameter (m-1) + vGn_n => mpar_data%var(iLookPARAM%vGn_n)%dat(iSoil) , & ! van Genuchten "n" parameter (-) + + ! associate values in the lookup table + Tk => lookup_data%z(iSoil)%var(iLookLOOKUP%temperature)%lookup , & ! temperature (K) + Ly => lookup_data%z(iSoil)%var(iLookLOOKUP%psiLiq_int)%lookup , & ! integral of mLayerPsiLiq from Tfreeze to Tk (K) + L2 => lookup_data%z(iSoil)%var(iLookLOOKUP%deriv2)%lookup & ! second derivative of the interpolating function + + ) ! end associate statement + + ! compute vGn_m + vGn_m = 1._rkind - 1._rkind/vGn_n + + ! ----- + ! * populate the lookup table... + ! ------------------------------ + + ! initialize temperature and integral + Tk(nLook) = Tfreeze + Ly(nLook) = 0._rkind + + ! loop through lookup table + do iLook=(nLook-1),1,-1 + + ! update temperature and integral + Tk(iLook) = Tk(iLook+1) + Ly(iLook) = Ly(iLook+1) + + ! get the temperature increment for the numerical integration + T_incr = (xTemp(iLook)-xTemp(iLook+1))/real(nIntegr8, kind(rkind)) + + ! numerical integration between different values of the lookup table + do jIntegr8=1,nIntegr8 + + ! update temperature + Tk(iLook) = Tk(iLook) + T_incr + + ! compute the volumetric liquid water and ice content at the mid point of the temperature increment + matricHead = (LH_fus/gravity)*(Tk(iLook) - Tfreeze - T_incr/2._rkind)/Tfreeze + vFracLiq = volFracLiq(matricHead,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) + + ! compute integral + Ly(iLook) = Ly(iLook) + vFracLiq*T_incr + + end do ! numerical integration + + end do ! loop through lookup table + + ! use cubic spline interpolation to obtain integral values at the desired values of temperature + call spline(Tk,Ly,1.e30_rkind,1.e30_rkind,L2,err,cmessage) ! get the second derivatives + if(err/=0) then; message=trim(message)//trim(cmessage); return; end if + + ! end asssociation to variables in the data structures + end associate + + end do ! (looping through soil layers) +end subroutine T2L_lookup_soil + + +! ************************************************************************************************************************ +! public subroutine enthalpy2T_snwWat: compute temperature based on specific temperature component of liquid + ice enthalpy +! appropriate when no dry mass, as in snow. Uses look-up table for enthalpy +! ************************************************************************************************************************ +subroutine enthalpy2T_snwWat(Hy,BulkDenWater,fc_param,Tk,err,message) + ! ------------------------------------------------------------------------------------------------------------------------- + implicit none + ! ------------------------------------------------------------------------------------------------------------------------- + ! declare dummy variables + real(rkind),intent(in) :: Hy ! total enthalpy (J m-3) + real(rkind),intent(in) :: BulkDenWater ! bulk density of water (kg m-3) + real(rkind),intent(in) :: fc_param ! freezing curve parameter (K-1) + real(rkind),intent(out) :: Tk ! initial temperature guess / final temperature value (K) + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! declare local variables + real(rkind),parameter :: dx=1.d-8 ! finite difference increment (J kg-1) + real(rkind),parameter :: atol=1.d-12 ! convergence criteria (J kg-1) + real(rkind) :: H_spec ! specific enthalpy (J kg-1) + real(rkind) :: H_incr ! enthalpy increment + integer(i4b) :: niter=15 ! maximum number of iterations + integer(i4b) :: iter ! iteration index + integer(i4b) :: i0 ! position in lookup table + real(rkind) :: Tg0,Tg1 ! trial temperatures (K) + real(rkind) :: Ht0,Ht1 ! specific enthalpy, based on the trial temperatures (J kg-1) + real(rkind) :: f0,f1 ! function evaluations (difference between enthalpy guesses) + real(rkind) :: dh ! enthalpy derivative + real(rkind) :: dT ! temperature increment + ! ------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message="enthalpy2T_snwWat/" + ! convert input of total enthalpy (J m-3) to total specific enthalpy (J kg-1) + H_spec = Hy/BulkDenWater ! (NOTE: no soil) + + ! ***** get initial guess and derivative assuming all water is frozen + if(H_spec H_lookup(i0+1) .or. & + i0 < 1 .or. i0+1 > nlook)then + err=10; message=trim(message)//'problem finding appropriate value in lookup table'; return + end if + ! get temperature guess + Tg0 = T_lookup(i0) + Tg1 = T_lookup(i0+1) + ! compute function evaluations + f0 = H_lookup(i0) - H_spec + f1 = H_lookup(i0+1) - H_spec + end if + + ! compute initial derivative + dh = (f1 - f0) / (Tg1 - Tg0) + ! compute initial change in T + dT = -f0/dh + ! exit if already close enough + if(abs(dT)=Tfreeze) enthTempWater = Cp_water*(Tk - Tfreeze) + + ! compute the mass component of enthalpy -- energy required to melt ice (J kg-1) + ! NOTE: negative enthalpy means require energy to bring to Tfreeze + enthMass = -LH_fus*(1._rkind - frac_liq) + + ! finally, compute the total enthalpy (J m-3) + T2enthalpy_snwWat = BulkDenWater*(enthTempWater + enthMass) !+ BulkDenSoil*enthTempSoil +end function T2enthalpy_snwWat + + +! ************************************************************************************************************************ +! public subroutine T2enthTemp_cas: compute temperature component of enthalpy from temperature and total water content, canopy air space +! ************************************************************************************************************************ +subroutine T2enthTemp_cas(& + scalarCanairTemp, & ! intent(in): canopy air temperature (K) + scalarCanairEnthalpy) ! intent(out): enthalpy of the canopy air space (J m-3) + ! ------------------------------------------------------------------------------------------------------------------------- + implicit none + ! delare dummy variables + ! ------------------------------------------------------------------------------------------------------------------------- + ! input: variables for the canopy air space + real(rkind),intent(in) :: scalarCanairTemp ! canopy air temperature (K) + ! output: enthalpy + real(rkind),intent(out) :: scalarCanairEnthalpy ! enthalpy of the canopy air space (J m-3) + ! -------------------------------------------------------------------------------------------------------------------------------- + scalarCanairEnthalpy = Cp_air * iden_air * (scalarCanairTemp - Tfreeze) + +end subroutine T2enthTemp_cas + +! ************************************************************************************************************************ +! public subroutine T2enthTemp_veg: compute temperature component of enthalpy from temperature and total water content, canopy +! ************************************************************************************************************************ +subroutine T2enthTemp_veg(& + canopyDepth, & ! intent(in): canopy depth (m) + specificHeatVeg, & ! intent(in): specific heat of vegetation (J kg-1 K-1) + maxMassVegetation, & ! intent(in): maximum mass of vegetation (kg m-2) + snowfrz_scale, & ! intent(in): scaling parameter for the snow freezing curve (K-1) + scalarCanopyTemp, & ! intent(in): canopy temperature (K) + scalarCanopyWat, & ! intent(in): canopy total water (kg m-2) + scalarCanopyEnthTemp) ! intent(out): temperature component of enthalpy of the vegetation canopy (J m-3) + ! ------------------------------------------------------------------------------------------------------------------------- + implicit none + ! delare dummy variables + ! ------------------------------------------------------------------------------------------------------------------------- + real(rkind),intent(in) :: canopyDepth ! canopy depth (m) + real(rkind),intent(in) :: specificHeatVeg ! specific heat of vegetation (J kg-1 K-1) + real(rkind),intent(in) :: maxMassVegetation ! maximum mass of vegetation (kg m-2) + real(rkind),intent(in) :: snowfrz_scale ! scaling parameter for the snow freezing curve (K-1) + ! input: variables for the vegetation canopy + real(rkind),intent(in) :: scalarCanopyTemp ! canopy temperature (K) + real(rkind),intent(in) :: scalarCanopyWat ! canopy total water (kg m-2) + ! output: enthalpy + real(rkind),intent(out) :: scalarCanopyEnthTemp ! temperature component of enthalpy of the vegetation canopy (J m-3) + ! ------------------------------------------------------------------------------------------------------------------------- + ! declare local variables + real(rkind) :: diffT ! temperature difference of temp from Tfreeze + real(rkind) :: integral ! integral of snow freezing curve + ! enthalpy + real(rkind) :: enthVeg ! enthalpy of the vegetation (J m-3) + real(rkind) :: enthLiq ! enthalpy of the liquid region (J m-3) + real(rkind) :: enthIce ! enthalpy of the ice region (J m-3) + ! -------------------------------------------------------------------------------------------------------------------------------- + diffT = scalarCanopyTemp - Tfreeze + enthVeg = specificHeatVeg * maxMassVegetation * diffT / canopyDepth + + if(diffT>=0._rkind)then + enthLiq = Cp_water * scalarCanopyWat * diffT / canopyDepth + enthIce = 0._rkind + else + integral = (1._rkind/snowfrz_scale) * atan(snowfrz_scale * diffT) + enthLiq = Cp_water * scalarCanopyWat * integral / canopyDepth + enthIce = Cp_ice * scalarCanopyWat * ( diffT - integral ) / canopyDepth + endif + + scalarCanopyEnthTemp = enthVeg + enthLiq + enthIce + +end subroutine T2enthTemp_veg + +! ************************************************************************************************************************ +! public subroutine T2enthTemp_snow: compute temperature component of enthalpy from temperature and total water content, snow layer +! ************************************************************************************************************************ +subroutine T2enthTemp_snow(& + snowfrz_scale, & ! intent(in): scaling parameter for the snow freezing curve (K-1) + mLayerTemp, & ! intent(in): layer temperature (K) + mLayerVolFracWat, & ! intent(in): volumetric total water content (-) + mLayerEnthTemp) ! intent(out): temperature component of enthalpy of each snow layer (J m-3) + ! ------------------------------------------------------------------------------------------------------------------------- + implicit none + ! delare dummy variables + ! ------------------------------------------------------------------------------------------------------------------------- + real(rkind),intent(in) :: snowfrz_scale ! scaling parameter for the snow freezing curve (K-1) + ! input: variables for the snow domain + real(rkind),intent(in) :: mLayerTemp ! layer temperature (K) + real(rkind),intent(in) :: mLayerVolFracWat ! volumetric total water content (-) + ! output: enthalpy + real(rkind),intent(out) :: mLayerEnthTemp ! temperature component of enthalpy of each snow layer (J m-3) + ! ------------------------------------------------------------------------------------------------------------------------- + ! declare local variables + real(rkind) :: diffT ! temperature difference of temp from Tfreeze + real(rkind) :: integral ! integral of snow freezing curve + ! enthalpy + real(rkind) :: enthLiq ! enthalpy of the liquid region (J m-3) + real(rkind) :: enthIce ! enthalpy of the ice region (J m-3) + real(rkind) :: enthAir ! enthalpy of air (J m-3) + ! -------------------------------------------------------------------------------------------------------------------------------- + diffT = mLayerTemp - Tfreeze ! diffT<0._rkind because snow is frozen + + if(diffT>=0._rkind)then ! diffT<0._rkind if in snow, but keep for generality and temporary upper bound violations + enthLiq = iden_water * Cp_water * mLayerVolFracWat * diffT + enthIce = 0._rkind + enthAir = iden_air * Cp_air * ( 1._rkind - mLayerVolFracWat ) * diffT + else + integral = (1._rkind/snowfrz_scale) * atan(snowfrz_scale * diffT) + enthLiq = iden_water * Cp_water * mLayerVolFracWat * integral + enthIce = iden_water * Cp_ice * mLayerVolFracWat * ( diffT - integral ) + enthAir = iden_air * Cp_air * ( diffT - mLayerVolFracWat * ( (iden_water/iden_ice)*(diffT-integral) + integral ) ) + endif + + mLayerEnthTemp = enthLiq + enthIce + enthAir + +end subroutine T2enthTemp_snow + + +! ************************************************************************************************************************ +! public subroutine T2enthTemp_soil: compute temperature component of enthalpy from temperature and total water content, soil layer +! ************************************************************************************************************************ +subroutine T2enthTemp_soil(& + use_lookup, & ! intent(in): flag to use the lookup table for soil enthalpy + soil_dens_intr, & ! intent(in): intrinsic soil density (kg m-3) + vGn_alpha, & ! intent(in): van Genutchen "alpha" parameter + vGn_n, & ! intent(in): van Genutchen "n" parameter + theta_sat, & ! intent(in): soil porosity (-) + theta_res, & ! intent(in): soil residual volumetric water content (-) + vGn_m, & ! intent(in): van Genutchen "m" parameter (-) + ixControlIndex, & ! intent(in): index of the control volume within the domain + lookup_data, & ! intent(in): lookup table data structure + integral_frz_low0, & ! intent(in): integral_frz_low if computed outside, else realMissing + mLayerTemp, & ! intent(in): layer temperature (K) + mLayerMatricHead, & ! intent(in): total water matric potential (m) + mLayerEnthTemp, & ! intent(out): temperature component of enthalpy soil layer (J m-3) + err,message) ! intent(out): error code and message + ! ------------------------------------------------------------------------------------------------------------------------- + ! downwind routines + USE soil_utils_module,only:crit_soilT ! compute critical temperature below which ice exists + USE soil_utils_module,only:volFracLiq ! compute volumetric fraction of liquid water + USE spline_int_module,only:splint ! use for cubic spline interpolation + implicit none + ! delare dummy variables + ! ------------------------------------------------------------------------------------------------------------------------- + logical(lgt),intent(in) :: use_lookup ! flag to use the lookup table for soil enthalpy, otherwise use hypergeometric function + ! input: data structures + real(rkind),intent(in) :: soil_dens_intr ! intrinsic soil density (kg m-3) + real(rkind),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter + real(rkind),intent(in) :: vGn_n ! van Genutchen "n" parameter + real(rkind),intent(in) :: theta_sat ! soil porosity (-) + real(rkind),intent(in) :: theta_res ! soil residual volumetric water content (-) + real(rkind),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) + integer(i4b),intent(in) :: ixControlIndex ! index within a given model domain + type(zLookup),intent(in) :: lookup_data ! lookup tables + real(rkind),intent(in) :: integral_frz_low0 ! integral_frz_low if computed outside, else realMissing + ! input: variables for the soil domain + real(rkind),intent(in) :: mLayerTemp ! layer temperature (K) + real(rkind),intent(in) :: mLayerMatricHead ! total water matric potential (m) + ! output: enthalpy + real(rkind),intent(out) :: mLayerEnthTemp ! temperature component of enthalpy of soil layer (J m-3) + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! returned error message + ! ------------------------------------------------------------------------------------------------------------------------- + ! declare local variables + real(rkind) :: Tcrit ! temperature where all water is unfrozen (K) + real(rkind) :: volFracWat ! volumetric fraction of total water, liquid+ice (-) + real(rkind) :: diff0 ! temperature difference of Tcrit from Tfreeze + real(rkind) :: diffT ! temperature difference of temp from Tfreeze + real(rkind) :: dL ! derivative of soil lookup table with temperature at layer temperature + real(rkind) :: arg ! argument of soil hypergeometric function + real(rkind) :: gauss_hg_T ! soil hypergeometric function result + real(rkind) :: integral_unf ! integral of unfrozen soil water content (from Tfreeze to Tcrit) + real(rkind) :: integral_frz_low ! lower limit of integral of frozen soil water content (from Tfreeze to Tcrit) + real(rkind) :: integral_frz_upp ! upper limit of integral of frozen soil water content (from Tfreeze to soil temperature) + real(rkind) :: xConst ! constant in the freezing curve function (m K-1) + real(rkind) :: mLayerPsiLiq ! liquid water matric potential (m) + character(len=256) :: cmessage ! error message in downwind routine + ! enthalpy + real(rkind) :: enthSoil ! enthalpy of soil particles (J m-3) + real(rkind) :: enthLiq ! enthalpy of the liquid region (J m-3) + real(rkind) :: enthIce ! enthalpy of the ice region (J m-3) + real(rkind) :: enthAir ! enthalpy of air (J m-3) + ! -------------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message="T2enthTemp_soil/" + + Tcrit = crit_soilT( mLayerMatricHead ) + volFracWat = volFracLiq(mLayerMatricHead,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) + diffT = mLayerTemp - Tfreeze + diff0 = Tcrit - Tfreeze + + ! *** compute enthalpy of water for unfrozen conditions + if(mlayerTemp>=Tcrit)then + enthLiq= iden_water * Cp_water * volFracWat * diffT + enthIce= 0._rkind + + ! *** compute enthalpy of water for frozen conditions + else + ! *** compute integral of mLayerPsiLiq from Tfreeze to layer temperature + ! get the unfrozen water content + integral_unf = diff0 * volFracWat + + ! get the frozen water content + if(use_lookup)then ! cubic spline interpolation for integral of mLayerPsiLiq from Tfreeze to layer temperature + ! make associate to the the lookup table + lookVars: associate(& + Tk => lookup_data%z(ixControlIndex)%var(iLookLOOKUP%temperature)%lookup, & ! temperature (K) + Ly => lookup_data%z(ixControlIndex)%var(iLookLOOKUP%psiLiq_int)%lookup, & ! integral of mLayerPsiLiq from Tfreeze to Tk (K) + L2 => lookup_data%z(ixControlIndex)%var(iLookLOOKUP%deriv2)%lookup & ! second derivative of the interpolating function + ) ! end associate statement + + ! get the lower limit of the integral + if(diff0<0._rkind)then + if(integral_frz_low0>=0)then ! = realMissing if non-compute + integral_frz_low = integral_frz_low0 + else + call splint(Tk,Ly,L2,Tcrit,integral_frz_low,dL,err,cmessage) + if(err/=0) then; message=trim(message)//trim(cmessage); return; end if + endif + else ! Tcrit=Tfreeze, i.e. mLayerMatricHeadTrial(ixControlIndex)>0 + integral_frz_low = 0._rkind + end if + ! get the upper limit of the integral + call splint(Tk,Ly,L2,mlayerTemp,integral_frz_upp,dL,err,cmessage) + if(err/=0) then; message=trim(message)//trim(cmessage); return; end if + + end associate lookVars + + else ! hypergeometric function for integral of mLayerPsiLiq from Tfreeze to layer temperature + ! get the lower limit of the integral + if(diff0<0._rkind)then + if(integral_frz_low0>=0)then ! = realMissing if non-compute + integral_frz_low = integral_frz_low0 + else + arg = (vGn_alpha * mLayerMatricHead)**vGn_n + gauss_hg_T = hyp_2F1_real(vGn_m,1._rkind/vGn_n,1._rkind + 1._rkind/vGn_n,-arg) + integral_frz_low = diff0 * ( (theta_sat - theta_res)*gauss_hg_T + theta_res ) + endif + else ! Tcrit=Tfreeze, i.e. mLayerMatricHeadTrial(ixControlIndex)>0 + integral_frz_low = 0._rkind + end if + ! get the upper limit of the integral + xConst = LH_fus/(gravity*Tfreeze) ! m K-1 (NOTE: J = kg m2 s-2) + mLayerPsiLiq = xConst*diffT ! liquid water matric potential from the Clapeyron eqution, DIFFERENT from the liquid water matric potential used in the flux calculations + arg = (vGn_alpha * mLayerPsiLiq)**vGn_n + gauss_hg_T = hyp_2F1_real(vGn_m,1._rkind/vGn_n,1._rkind + 1._rkind/vGn_n,-arg) + integral_frz_upp = diffT * ( (theta_sat - theta_res)*gauss_hg_T + theta_res ) + endif + + enthLiq = iden_water * Cp_water * (integral_unf + integral_frz_upp - integral_frz_low) + enthIce = iden_ice * Cp_ice * ( volFracWat * diffT - (integral_unf + integral_frz_upp - integral_frz_low) ) + + endif ! (if frozen conditions) + + enthSoil = soil_dens_intr * Cp_soil * ( 1._rkind - theta_sat ) * diffT + enthAir = iden_air * Cp_air * ( 1._rkind - theta_sat - volFracWat ) * diffT + + mLayerEnthTemp = enthLiq + enthIce + enthSoil + enthAir + +end subroutine T2enthTemp_soil + +! ************************************************************************************************************************ +! public subroutine enthTemp_or_enthalpy: add energy associated with thaw/freeze to temperature component of enthalpy to get total enthalpy, H, or vice versa +! ************************************************************************************************************************ +subroutine enthTemp_or_enthalpy(& + ! input: data structures + do_enthTemp2enthalpy, & ! intent(in): flag if enthalpy is to be computed from temperature component of enthalpy, or vice versa if false + diag_data, & ! intent(in): model diagnostic variables for a local HRU + indx_data, & ! intent(in): model indices + ! input: ice content change + scalarCanopyIce, & ! intent(in): value of canopy ice content (kg m-2) or prime ice content (kg m-2 s-1) + mLayerVolFracIce, & ! intent(in): vector of volumetric fraction of ice (-) or prime volumetric fraction of ice (s-1) + ! input/output: enthalpy + scalarCanopyH, & ! intent(inout): enthTemp to enthalpy of the vegetation canopy (J m-3), or vice versa if do_enthTemp2enthalpy false + mLayerH, & ! intent(inout): enthTemp to enthalpy of each snow+soil layer (J m-3), or vice versa if do_enthTemp2enthalpy false + ! output: error control + err,message) ! intent(out): error control + ! ------------------------------------------------------------------------------------------------------------------------- + implicit none + ! delare dummy variables + ! ------------------------------------------------------------------------------------------------------------------------- + ! input: data structures + logical(lgt),intent(in) :: do_enthTemp2enthalpy ! flag if enthalpy is to be computed from temperature component of enthalpy, or vice versa if false + type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU + type(var_ilength),intent(in) :: indx_data ! model indices + ! input: ice content change + real(rkind),intent(in) :: scalarCanopyIce ! value for canopy ice content (kg m-2) or prime ice content (kg m-2 s-1) + real(rkind),intent(in) :: mLayerVolFracIce(:) ! vector of volumetric fraction of ice (-) or prime volumetric fraction of ice (s-1) + ! input output: enthalpy + real(rkind),intent(inout) :: scalarCanopyH ! enthTemp to enthalpy of the vegetation canopy (J m-3), or vice versa if do_enthTemp2enthalpy false + real(rkind),intent(inout) :: mLayerH(:) ! enthTemp to enthalpy of each snow+soil layer (J m-3), or vice versa if do_enthTemp2enthalpy false + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! ------------------------------------------------------------------------------------------------------------------------- + ! declare local variables + integer(i4b) :: iState ! index of model state variable + integer(i4b) :: iLayer ! index of model layer + integer(i4b) :: ixFullVector ! index within full state vector + integer(i4b) :: ixDomainType ! name of a given model domain + integer(i4b) :: ixControlIndex ! index within a given model domain + ! ------------------------------------------------------------------------------------------------------------------------ + ! make association with variables in the data structures + associate(& + ! number of model layers, and layer type + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in): [i4b] total number of snow layers + ! mapping between the full state vector and the state subset + ixMapFull2Subset => indx_data%var(iLookINDEX%ixMapFull2Subset)%dat ,& ! intent(in): [i4b(:)] list of indices in the state subset for each state in the full state vector + ixMapSubset2Full => indx_data%var(iLookINDEX%ixMapSubset2Full)%dat ,& ! intent(in): [i4b(:)] [state subset] list of indices of the full state vector in the state subset + ! type of domain, type of state variable, and index of control volume within domain + ixDomainType_subset => indx_data%var(iLookINDEX%ixDomainType_subset)%dat ,& ! intent(in): [i4b(:)] [state subset] id of domain for desired model state variables + ixControlVolume => indx_data%var(iLookINDEX%ixControlVolume)%dat ,& ! intent(in): [i4b(:)] index of the control volume for different domains (veg, snow, soil) + ixStateType => indx_data%var(iLookINDEX%ixStateType)%dat ,& ! intent(in): [i4b(:)] indices defining the type of the state (iname_nrgLayer...) + ! canopy depth + canopyDepth => diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1) & ! intent(in): [dp] canopy depth (m) + ) ! end associate statement + ! ----------------------------------------------------------------------------------------------------------------------- + + ! initialize error control + err=0; message="enthTemp_or_enthalpy/" + + ! loop through model state variables + do iState=1,size(ixMapSubset2Full) + + ! ----- + ! - compute indices... + ! -------------------- + + ! get domain type, and index of the control volume within the domain + ixFullVector = ixMapSubset2Full(iState) ! index within full state vector + ixDomainType = ixDomainType_subset(iState) ! named variables defining the domain (iname_cas, iname_veg, etc.) + ixControlIndex = ixControlVolume(ixFullVector) ! index within a given domain + + ! check an energy state + if(ixStateType(ixFullVector)==iname_nrgCanair .or. ixStateType(ixFullVector)==iname_nrgCanopy .or. ixStateType(ixFullVector)==iname_nrgLayer)then + + ! get the layer index + select case(ixDomainType) + case(iname_cas); cycle ! canopy air space: do nothing (no water stored in canopy air space) + case(iname_veg) + if (do_enthTemp2enthalpy)then + scalarCanopyH = scalarCanopyH - LH_fus * scalarCanopyIce/ canopyDepth + else + scalarCanopyH = scalarCanopyH + LH_fus * scalarCanopyIce/ canopyDepth + end if + case(iname_snow) + iLayer = ixControlIndex + if (do_enthTemp2enthalpy)then + mLayerH(iLayer) = mLayerH(iLayer) - iden_ice * LH_fus * mLayerVolFracIce(iLayer) + else + mLayerH(iLayer) = mLayerH(iLayer) + iden_ice * LH_fus * mLayerVolFracIce(iLayer) + end if + case(iname_soil) + iLayer = ixControlIndex + nSnow + if (do_enthTemp2enthalpy)then + mLayerH(iLayer) = mLayerH(iLayer) - iden_water * LH_fus * mLayerVolFracIce(iLayer) + else + mLayerH(iLayer) = mLayerH(iLayer) + iden_water * LH_fus * mLayerVolFracIce(iLayer) + end if + case(iname_aquifer); cycle ! aquifer: do nothing (no thermodynamics in the aquifer) + case default; err=20; message=trim(message)//'expect case to be iname_cas, iname_veg, iname_snow, iname_soil, iname_aquifer'; return + end select + + end if ! if an energy layer + end do ! looping through state variables + + end associate + +end subroutine enthTemp_or_enthalpy + +! ************************************************************************************************************************ +! public subroutine enthalpy2T_cas: compute temperature from enthalpy, canopy air space +! ************************************************************************************************************************ +subroutine enthalpy2T_cas(& + computJac, & ! intent(in): flag if computing for Jacobian update + scalarCanairEnthalpy, & ! intent(in): enthalpy of the canopy air space (J m-3) + scalarCanairTemp, & ! intent(out): canopy air temperature (K) + dCanairTemp_dEnthalpy, & ! intent(inout): derivative of canopy air temperature with enthalpy + err,message) ! intent(out): error control + ! ------------------------------------------------------------------------------------------------------------------------- + implicit none + ! delare dummy variables + ! ------------------------------------------------------------------------------------------------------------------------- + logical(lgt),intent(in) :: computJac ! flag if computing for Jacobian update + ! input: enthalpy state variables + real(rkind),intent(in) :: scalarCanairEnthalpy ! enthalpy of the canopy air space (J m-3) + ! output: temperature diagnostic variables + real(rkind),intent(out) :: scalarCanairTemp ! canopy air temperature (K) + ! output: derivatives + real(rkind),intent(inout) :: dCanairTemp_dEnthalpy ! derivative of canopy air temperature with enthalpy + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! -------------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message="enthalpy2T_cas/" + + scalarCanairTemp = scalarCanairEnthalpy / ( Cp_air*iden_air ) + Tfreeze + if(computJac) dCanairTemp_dEnthalpy = 1._rkind / ( Cp_air*iden_air ) + +end subroutine enthalpy2T_cas + + +! ************************************************************************************************************************ +! public subroutine enthalpy2T_veg: compute temperature from enthalpy and total water content, canopy +! ************************************************************************************************************************ +subroutine enthalpy2T_veg(& + computJac, & ! intent(in): flag if computing for Jacobian update + canopyDepth, & ! intent(in): canopy depth (m) + specificHeatVeg, & ! intent(in): specific heat of vegetation (J kg-1 K-1) + maxMassVegetation, & ! intent(in): maximum mass of vegetation (kg m-2) + snowfrz_scale, & ! intent(in): scaling parameter for the snow freezing curve (K-1) + scalarCanopyEnthalpy, & ! intent(in): enthalpy of the vegetation canopy (J m-3) + scalarCanopyWat, & ! intent(in): canopy total water (kg m-2) + scalarCanopyTemp, & ! intent(inout): canopy temperature (K) + dCanopyTemp_dEnthalpy, & ! intent(inout): derivative of canopy temperature with enthalpy + dCanopyTemp_dCanWat, & ! intent(inout): derivative of canopy temperature with canopy water + err,message) ! intent(out): error control + ! ------------------------------------------------------------------------------------------------------------------------- + ! downwind routines + USE snow_utils_module,only:fracliquid ! compute the fraction of liquid water (snow) + USE snow_utils_module,only:dFracLiq_dTk ! differentiate the freezing curve w.r.t. temperature (snow) + implicit none + ! delare dummy variables + ! ------------------------------------------------------------------------------------------------------------------------- + logical(lgt),intent(in) :: computJac ! flag if computing for Jacobian update + ! input: data structures + real(rkind),intent(in) :: canopyDepth ! canopy depth (m) + real(rkind),intent(in) :: specificHeatVeg ! specific heat of vegetation (J kg-1 K-1) + real(rkind),intent(in) :: maxMassVegetation ! maximum mass of vegetation (kg m-2) + real(rkind),intent(in) :: snowfrz_scale ! scaling parameter for the snow freezing curve (K-1) + ! input: enthalpy state variables + real(rkind),intent(in) :: scalarCanopyEnthalpy ! enthalpy of the vegetation canopy (J m-3) + ! input: water state variables + real(rkind),intent(in) :: scalarCanopyWat ! trial value for canopy total water (kg m-2) + ! output: temperature diagnostic variables + real(rkind),intent(inout) :: scalarCanopyTemp ! trial value for canopy temperature (K) + ! output: derivatives + real(rkind),intent(inout) :: dCanopyTemp_dEnthalpy ! derivative of canopy temperature with enthalpy + real(rkind),intent(inout) :: dCanopyTemp_dCanWat ! derivative of canopy temperature with canopy water + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! ------------------------------------------------------------------------------------------------------------------------- + ! declare local variables + character(len=256) :: cmessage ! error message of downwind routine + real(rkind) :: T,T_out ! temperature (K) + real(rkind) :: diffT ! temperature difference of temp from Tfreeze + real(rkind) :: integral ! integral of snow freezing curve + real(rkind) :: fLiq ! fraction liquid + real(rkind) :: vec(9) ! vector of parameters for the enthalpy function + ! variable derivatives + real(rkind) :: dT_dEnthalpy ! derivative of temperature with enthalpy state variable + real(rkind) :: dT_dWat ! derivative of temperature with water state variable + real(rkind) :: dH_dT ! derivative of enthalpy with temperature + real(rkind) :: dH_dWat ! derivative of enthalpy with water state variable + real(rkind) :: dfLiq_dT ! derivative of fraction liquid water with temperature + real(rkind) :: denthIce_dT ! derivative of enthalpy of ice with temperature + real(rkind) :: denthLiq_dT ! derivative of enthalpy of liquid water with temperature + real(rkind) :: denthVeg_dT ! derivative of enthalpy of vegetation with temperature + real(rkind) :: denthIce_dWat ! derivative of enthalpy of ice with water state variable + real(rkind) :: denthLiq_dWat ! derivative of enthalpy of liquid water with water state variable + real(rkind) :: denthVeg_dWat ! derivative of enthalpy of vegetation with water state variable + ! -------------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message="enthalpy2T_veg/" + + ! ***** get temperature if unfrozen vegetation + if (scalarCanopyEnthalpy>=0)then + T = scalarCanopyEnthalpy * canopyDepth / ( specificHeatVeg * maxMassVegetation + Cp_water * scalarCanopyWat ) + Tfreeze + if(computJac)then + dT_dEnthalpy = canopyDepth / ( specificHeatVeg * maxMassVegetation + Cp_water * scalarCanopyWat ) + dT_dWat = -Cp_water * scalarCanopyEnthalpy * canopyDepth / ( specificHeatVeg * maxMassVegetation + Cp_water * scalarCanopyWat )**2_i4b + endif + + ! ***** iterate to find temperature if ice exists + else + ! find the root of the function + ! inputs = function, initial point, out point, lower bound, upper bound, and the vector of parameters + T = min(scalarCanopyTemp, Tfreeze) ! initial guess + vec = 0._rkind + vec(1:6) = (/scalarCanopyEnthalpy, canopyDepth, specificHeatVeg, maxMassVegetation, snowfrz_scale, scalarCanopyWat/) + call brent(diff_H_veg, T, T_out, 0._rkind, Tfreeze, vec, err, cmessage) + T = T_out + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! compute Jacobian terms + if(computJac)then + ! NOTE: dintegral_dT = fLiq + diffT = T - Tfreeze + integral = (1._rkind/snowfrz_scale) * atan(snowfrz_scale * diffT) + fLiq = fracLiquid(T, snowfrz_scale) + + ! w.r.t. temperature, NOTE: dintegral_dT = fLiq + dfLiq_dT = dFracLiq_dTk(T,snowfrz_scale) + denthLiq_dT = Cp_water * scalarCanopyWat * fLiq / canopyDepth + denthIce_dT = Cp_ice * scalarCanopyWat * (1._rkind - fLiq) / canopyDepth + denthVeg_dT = specificHeatVeg * maxMassVegetation / canopyDepth + dH_dT = denthVeg_dT + denthLiq_dT + denthIce_dT + LH_fus * dfLiq_dT * scalarCanopyWat / canopyDepth + + ! w.r.t. layer water content + denthLiq_dWat = Cp_water * diffT / canopyDepth + denthIce_dWat = 0._rkind + denthVeg_dWat = 0._rkind + dH_dWat = denthVeg_dWat + denthLiq_dWat + denthIce_dWat - LH_fus * (1._rkind - fLiq) / canopyDepth + + dT_dEnthalpy = 1._rkind / dH_dT + dT_dWat = -dH_dWat / dH_dT ! NOTE, while it is not generally appropriate to cancel partial derivatives, here this is true if it is multiplied by -1 + + endif + endif ! (if ice exists) + + ! update temperature and derivatives + scalarCanopyTemp = T + if(computJac)then + dCanopyTemp_dEnthalpy = dT_dEnthalpy + dCanopyTemp_dCanWat = dT_dWat + endif + +end subroutine enthalpy2T_veg + +! ************************************************************************************************************************ +! public subroutine enthalpy2T_snow: compute temperature from enthalpy and total water content, snow layer +! ************************************************************************************************************************ +subroutine enthalpy2T_snow(& + computJac, & ! intent(in): flag if computing for Jacobian update + snowfrz_scale, & ! intent(in): scaling parameter for the snow freezing curve (K-1) + mLayerEnthalpy, & ! intent(in): enthalpy of snow+soil layer (J m-3) + mLayerVolFracWat, & ! intent(in): volumetric total water content (-) + mLayerTemp, & ! intent(inout): layer temperature (K) + dTemp_dEnthalpy, & ! intent(inout): derivative of layer temperature with enthalpy + dTemp_dTheta, & ! intent(inout): derivative of layer temperature with volumetric total water content + err,message) ! intent(out): error control + ! ------------------------------------------------------------------------------------------------------------------------- + ! downwind routines + USE snow_utils_module,only:fracliquid ! compute the fraction of liquid water (snow) + USE snow_utils_module,only:dFracLiq_dTk ! differentiate the freezing curve w.r.t. temperature (snow) + + implicit none + ! delare dummy variables + ! ------------------------------------------------------------------------------------------------------------------------- + logical(lgt),intent(in) :: computJac ! flag if computing for Jacobian update + ! input: data structures + real(rkind),intent(in) :: snowfrz_scale ! scaling parameter for the snow freezing curve (K-1) + ! input: enthalpy state variables + real(rkind),intent(in) :: mLayerEnthalpy ! enthalpy of each snow+soil layer (J m-3) + ! input: water state variables + real(rkind),intent(in) :: mLayerVolFracWat ! volumetric total water content (-) + ! output: temperature diagnostic variables + real(rkind),intent(inout) :: mLayerTemp ! layer temperature (K) + ! output: derivatives + real(rkind),intent(inout) :: dTemp_dEnthalpy ! derivative of layer temperature with enthalpy + real(rkind),intent(inout) :: dTemp_dTheta ! derivative of layer temperature with volumetric total water content + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! ------------------------------------------------------------------------------------------------------------------------- + ! declare local variables + character(len=256) :: cmessage ! error message of downwind routine + real(rkind) :: T,T_out ! temperature (K) + real(rkind) :: diffT ! temperature difference of temp from Tfreeze + real(rkind) :: integral ! integral of snow freezing curve + real(rkind) :: fLiq ! fraction liquid + real(rkind) :: vec(9) ! vector of parameters for the enthalpy function + ! variable derivatives + real(rkind) :: dT_dEnthalpy ! derivative of temperature with enthalpy state variable + real(rkind) :: dT_dWat ! derivative of temperature with water state variable + real(rkind) :: dH_dT ! derivative of enthalpy with temperature + real(rkind) :: dH_dWat ! derivative of enthalpy with water state variable + real(rkind) :: dfLiq_dT ! derivative of fraction liquid water with temperature + real(rkind) :: denthIce_dT ! derivative of enthalpy of ice with temperature + real(rkind) :: denthLiq_dT ! derivative of enthalpy of liquid water with temperature + real(rkind) :: denthAir_dT ! derivative of enthalpy of air with temperature + real(rkind) :: denthIce_dWat ! derivative of enthalpy of ice with water state variable + real(rkind) :: denthLiq_dWat ! derivative of enthalpy of liquid water with water state variable + real(rkind) :: denthAir_dWat ! derivative of enthalpy of air with water state variable + ! -------------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message="enthalpy2T_snow/" + + ! ***** get temperature if unfrozen snow (only happens in temporary upper bound violations) + if (mLayerEnthalpy>=0)then + T = mLayerEnthalpy / ( iden_water * Cp_water * mLayerVolFracWat + iden_air * Cp_air * (1._rkind - mLayerVolFracWat) ) + Tfreeze + if(computJac)then + dT_dEnthalpy = 1._rkind / ( iden_water * Cp_water * mLayerVolFracWat + iden_air * Cp_air * (1._rkind - mLayerVolFracWat) ) + dT_dWat = -( iden_water * Cp_water - iden_air * Cp_air ) & + * mLayerEnthalpy / ( iden_water * Cp_water * mLayerVolFracWat + iden_air * Cp_air * (1._rkind - mLayerVolFracWat) )**2_i4b + endif + + ! ***** iterate to find temperature if ice exists + else + T = min(mLayerTemp, Tfreeze) ! initial guess + + ! find the root of the function + ! inputs = function, lower bound, upper bound, initial point, tolerance, integer flag if want detail + ! and the vector of parameters, snow_layer + vec = 0._rkind + vec(1:3) = (/mLayerEnthalpy, snowfrz_scale, mLayerVolFracWat/) + if(mLayerEnthalpy>0._rkind)then + T = Tfreeze - 1.e-6_rkind ! need to merge layers, don't iterate to find the temperature + else + call brent(diff_H_snow, T, T_out, 0._rkind, Tfreeze, vec, err, cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + T = T_out + endif + + ! compute Jacobian terms + if(computJac)then + ! NOTE: dintegral_dT = fLiq + diffT = T - Tfreeze + integral = (1._rkind/snowfrz_scale) * atan(snowfrz_scale * diffT) + fLiq = fracLiquid(T, snowfrz_scale) + + ! w.r.t. temperature, NOTE: dintegral_dT = fLiq + dfLiq_dT = dFracLiq_dTk(T,snowfrz_scale) + denthLiq_dT = iden_water * Cp_water * mLayerVolFracWat * fLiq + denthIce_dT = iden_water * Cp_ice * mLayerVolFracWat * (1._rkind - fLiq) + denthAir_dT = iden_air * Cp_air * (1._rkind - mLayerVolFracWat * ( (iden_water/iden_ice)*(1._rkind-fLiq) + fLiq ) ) + dH_dT = denthLiq_dT + denthIce_dT + denthAir_dT + iden_water * LH_fus * dfLiq_dT * mLayerVolFracWat + + ! w.r.t. layer water content + denthLiq_dWat = iden_water * Cp_water * integral + denthIce_dWat = iden_water * Cp_ice * ( diffT - integral ) + denthAir_dWat = -iden_air * Cp_air * ( (iden_water/iden_ice)*(diffT-integral) + integral ) + dH_dWat = denthLiq_dWat + denthIce_dWat + denthAir_dWat - iden_water * LH_fus * (1._rkind - fLiq) + + dT_dEnthalpy = 1._rkind / dH_dT + dT_dWat = -dH_dWat / dH_dT ! NOTE, while it is not generally appropriate to cancel partial derivatives, here this is true if it is multiplied by -1 + endif + endif ! (if ice exists) + + ! update temperature and derivatives + mLayerTemp = T + if(computJac)then + dTemp_dEnthalpy = dT_dEnthalpy + dTemp_dTheta = dT_dWat + endif + +end subroutine enthalpy2T_snow + +! ************************************************************************************************************************ +! public subroutine enthalpy2T_soil: compute temperature from enthalpy and total water content, soil layer +! ************************************************************************************************************************ +subroutine enthalpy2T_soil(& + computJac, & ! intent(in): flag if computing for Jacobian update + use_lookup, & ! intent(in): flag to use the lookup table for soil enthalpy + soil_dens_intr, & ! intent(in): intrinsic soil density (kg m-3) + vGn_alpha, & ! intent(in): van Genutchen "alpha" parameter + vGn_n, & ! intent(in): van Genutchen "n" parameter + theta_sat, & ! intent(in): soil porosity (-) + theta_res, & ! intent(in): soil residual volumetric water content (-) + vGn_m, & ! intent(in): van Genutchen "m" parameter (-) + ixControlIndex, & ! intent(in): index of the control volume within the domain + lookup_data, & ! intent(in): lookup table data structure + mLayerEnthalpy, & ! intent(in): enthalpy of each snow+soil layer (J m-3) + mLayerMatricHead, & ! intent(in): total water matric potential (m) + mLayerTemp, & ! intent(inout): layer temperature (K) + dTemp_dEnthalpy, & ! intent(inout): derivative of layer temperature with enthalpy + dTemp_dTheta, & ! intent(inout): derivative of layer temperature with volumetric total water content + dTemp_dPsi0, & ! intent(inout): derivative of layer temperature with total water matric potential + err,message) ! intent(out): error control + ! ------------------------------------------------------------------------------------------------------------------------- + ! downwind routines + USE spline_int_module,only:splint ! use for cubic spline interpolation + USE soil_utils_module,only:dTheta_dTk ! differentiate the freezing curve w.r.t. temperature (soil) + USE soil_utils_module,only:crit_soilT ! compute critical temperature below which ice exists + USE soil_utils_module,only:volFracLiq ! compute volumetric fraction of liquid water + USE soil_utils_module,only:dTheta_dPsi ! compute derivative of the soil moisture characteristic w.r.t. psi (m-1) + + implicit none + ! delare dummy variables + ! ------------------------------------------------------------------------------------------------------------------------- + logical(lgt),intent(in) :: computJac ! flag if computing for Jacobian update + logical(lgt),intent(in) :: use_lookup ! flag to use the lookup table for soil enthalpy, otherwise use hypergeometric function + ! input: data structures + real(rkind),intent(in) :: soil_dens_intr ! intrinsic soil density (kg m-3) + real(rkind),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter + real(rkind),intent(in) :: vGn_n ! van Genutchen "n" parameter + real(rkind),intent(in) :: theta_sat ! soil porosity (-) + real(rkind),intent(in) :: theta_res ! soil residual volumetric water content (-) + real(rkind),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) + integer(i4b),intent(in) :: ixControlIndex ! index within a given model domain + type(zLookup),intent(in) :: lookup_data ! lookup tables + ! input: enthalpy state variables + real(rkind),intent(in) :: mLayerEnthalpy ! enthalpy of each snow+soil layer (J m-3) + ! input: water state variables + real(rkind),intent(in) :: mLayerMatricHead ! total water matric potential (m) + ! output: temperature diagnostic variables + real(rkind),intent(inout) :: mLayerTemp ! layer temperature (K) + ! output: derivatives + real(rkind),intent(inout) :: dTemp_dEnthalpy ! derivative of layer temperature with enthalpy + real(rkind),intent(inout) :: dTemp_dTheta ! derivative of layer temperature with volumetric total water content + real(rkind),intent(inout) :: dTemp_dPsi0 ! derivative of layer temperature with total water matric potential + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! ------------------------------------------------------------------------------------------------------------------------- + ! declare local variables + character(len=256) :: cmessage ! error message in downwind routine + real(rkind) :: Tcrit ! temperature above which all water is unfrozen (K) + real(rkind) :: entCrit ! enthalpy above which all water is unfrozen (J m-3) + real(rkind) :: volFracWat ! volumetric fraction of total water, liquid+ice (-) + real(rkind) :: diff0 ! temperature difference of Tcrit from Tfreeze + real(rkind) :: dTcrit_dPsi0 ! derivative of temperature where all water is unfrozen (K) with matric head + real(rkind) :: dL ! derivative of soil lookup table with temperature at layer temperature + real(rkind) :: integral_unf ! integral of unfrozen soil water content (from Tfreeze to Tcrit) + real(rkind) :: integral_frz_low ! lower limit of integral of frozen soil water content (from Tfreeze to Tcrit) + real(rkind) :: xConst ! constant in the freezing curve function (m K-1) + real(rkind) :: mLayerPsiLiq ! liquid water matric potential (m) + real(rkind) :: T, T_out ! temperature (K) + real(rkind) :: diffT ! temperature difference of temp from Tfreeze + real(rkind) :: fLiq ! fraction liquid water + real(rkind) :: integral_frz_upp ! upper limit of integral of frozen soil water content (from Tfreeze to soil temperature) + real(rkind) :: arg ! argument of soil hypergeometric function + real(rkind) :: gauss_hg_T ! soil hypergeometric function result + real(rkind) :: vec(9) ! vector of parameters for the enthalpy function + ! variable derivatives + real(rkind) :: dvolFracWat_dPsi0 ! derivative of the soil water content w.r.t. matric head + real(rkind) :: dintegral_unf_dWat ! derivative of integral of unfrozen soil water content with water content + real(rkind) :: dintegral_frz_low_dWat ! derivative of integral of frozen soil water content with water content + real(rkind) :: dT_dEnthalpy ! derivative of temperature with enthalpy state variable + real(rkind) :: dT_dWat ! derivative of temperature with water state variable + real(rkind) :: dH_dT ! derivative of enthalpy with temperature + real(rkind) :: dH_dWat ! derivative of enthalpy with water state variable + real(rkind) :: dfLiq_dT ! derivative of fraction liquid water with temperature + real(rkind) :: dintegral_frz_upp_dT ! derivative of integral of frozen soil water content with temperature + real(rkind) :: denthSoil_dT ! derivative of enthalpy of soil with temperature + real(rkind) :: denthIce_dT ! derivative of enthalpy of ice with temperature + real(rkind) :: denthLiq_dT ! derivative of enthalpy of liquid water with temperature + real(rkind) :: denthAir_dT ! derivative of enthalpy of air with temperature + real(rkind) :: denthSoil_dWat ! derivative of enthalpy of soil with water state variable + real(rkind) :: denthIce_dWat ! derivative of enthalpy of ice with water state variable + real(rkind) :: denthLiq_dWat ! derivative of enthalpy of liquid water with water state variable + real(rkind) :: denthAir_dWat ! derivative of enthalpy of air with water state variable + ! -------------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message="enthalpy2T_soil/" + + Tcrit = crit_soilT(mLayerMatricHead) + diff0 = Tcrit - Tfreeze + volFracWat = volFracLiq(mLayerMatricHead,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) + dTcrit_dPsi0 = merge(gravity*Tfreeze/LH_fus,0._rkind,mLayerMatricHead<=0._rkind) + dvolFracWat_dPsi0 = dTheta_dPsi(mLayerMatricHead,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) + entCrit = ( iden_water * Cp_water * volFracWat + soil_dens_intr * Cp_soil * (1._rkind - theta_sat) & + + iden_air * Cp_air * (1._rkind - theta_sat - volFracWat) ) * diff0 + + ! ***** get temperature if unfrozen soil + if (mLayerEnthalpy>=entCrit )then + T = mLayerEnthalpy / ( iden_water * Cp_water * volFracWat + soil_dens_intr * Cp_soil * (1._rkind - theta_sat) & + + iden_air * Cp_air * (1._rkind - theta_sat - volFracWat) ) + Tfreeze + if(computJac)then + dT_dEnthalpy = 1._rkind / ( iden_water * Cp_water * volFracWat + soil_dens_intr*Cp_soil*(1._rkind - theta_sat) & + + iden_air*Cp_air*(1._rkind - theta_sat - volFracWat) ) + dT_dWat = -iden_water * Cp_water * dvolFracWat_dPsi0 * mLayerEnthalpy / ( iden_water * Cp_water * volFracWat & + + soil_dens_intr * Cp_soil * (1._rkind - theta_sat) + iden_air * Cp_air * (1._rkind - theta_sat - volFracWat) )**2_i4b + endif + + ! ***** iterate to find temperature if ice exists + else + ! *** compute integral of mLayerPsiLiq from Tfreeze to layer temperature + ! get the unfrozen water content of enthalpy + integral_unf = diff0 * volFracWat ! unfrozen water content + if(computJac) dintegral_unf_dWat = dTcrit_dPsi0 * volFracWat + diff0 * dvolFracWat_dPsi0 + + ! get the frozen water content of enthalpy, start with lower limit of the integral + if (diff0<0._rkind)then + + if(use_lookup)then ! cubic spline interpolation for integral of mLayerPsiLiq from Tfreeze to layer temperature + ! make associate to the the lookup table + lookVars: associate(& + Tk => lookup_data%z(ixControlIndex)%var(iLookLOOKUP%temperature)%lookup, & ! temperature (K) + Ly => lookup_data%z(ixControlIndex)%var(iLookLOOKUP%psiLiq_int)%lookup, & ! integral of mLayerPsiLiq from Tfreeze to Tk (K) + L2 => lookup_data%z(ixControlIndex)%var(iLookLOOKUP%deriv2)%lookup & ! second derivative of the interpolating function + ) ! end associate statement + + call splint(Tk,Ly,L2,Tcrit,integral_frz_low,dL,err,cmessage) + if(err/=0) then; message=trim(message)//trim(cmessage); return; end if + if(computJac) dintegral_frz_low_dWat = dL * dTcrit_dPsi0 + + end associate lookVars + + else ! hypergeometric function for integral of mLayerPsiLiq from Tfreeze to layer temperature + arg = (vGn_alpha * mLayerMatricHead)**vGn_n + gauss_hg_T = hyp_2F1_real(vGn_m,1._rkind/vGn_n,1._rkind + 1._rkind/vGn_n,-arg) + integral_frz_low = diff0 * ( (theta_sat - theta_res)*gauss_hg_T + theta_res ) + if(computJac) dintegral_frz_low_dWat = volFracWat * dTcrit_dPsi0 + endif + else ! Tcrit=Tfreeze, i.e. mLayerMatricHead>0 + integral_frz_low = 0._rkind + dintegral_frz_low_dWat = 0._rkind + end if + + ! find the root of the function + ! inputs = function, initial point, out point, lower bound, upper bound, and the vector of parameters + T = min(mLayerTemp, Tcrit) ! initial guess + vec(1:9) = (/mLayerEnthalpy, soil_dens_intr, vGn_alpha, vGn_n, theta_sat, theta_res, vGn_m, integral_frz_low, mLayerMatricHead/) + if (Tcrit>0._rkind) then + call brent(diff_H_soil, T, T_out, 0._rkind, Tcrit, vec, err, cmessage, use_lookup, lookup_data, ixControlIndex) + else + T_out = 0._rkind ! bail with a low temperature + end if + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + T = T_out + + ! compute Jacobian terms + if(computJac)then + ! NOTE: here fLiq is the total liquid fraction, not fraction of water fraction that is liquid + xConst = LH_fus/(gravity*Tfreeze) ! m K-1 (NOTE: J = kg m2 s-2) + diffT = T - Tfreeze + mLayerPsiLiq = xConst*diffT ! liquid water matric potential from the Clapeyron eqution, DIFFERENT from the liquid water matric potential used in the flux calculations + arg = (vGn_alpha * mLayerPsiLiq)**vGn_n + fLiq = volFracLiq(mLayerPsiLiq,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) + + ! get the upper limit of the integral + if(use_lookup)then ! cubic spline interpolation for integral of mLayerPsiLiq from Tfreeze to layer temperature + ! make associate to the the lookup table + lookVars2: associate(& + Tk => lookup_data%z(ixControlIndex)%var(iLookLOOKUP%temperature)%lookup, & ! temperature (K) + Ly => lookup_data%z(ixControlIndex)%var(iLookLOOKUP%psiLiq_int)%lookup, & ! integral of mLayerPsiLiq from Tfreeze to Tk (K) + L2 => lookup_data%z(ixControlIndex)%var(iLookLOOKUP%deriv2)%lookup & ! second derivative of the interpolating function + ) ! end associate statement + + ! integral of mLayerPsiLiq from Tfreeze to layer temperature + call splint(Tk,Ly,L2,T,integral_frz_upp,dL,err,cmessage) + if(err/=0) then; message=trim(message)//trim(cmessage); return; end if + dintegral_frz_upp_dT = dL + + end associate lookVars2 + + else ! hypergeometric function for integral of mLayerPsiLiq from Tfreeze to layer temperature + gauss_hg_T = hyp_2F1_real(vGn_m,1._rkind/vGn_n,1._rkind + 1._rkind/vGn_n,-arg) + integral_frz_upp = diffT * ( (theta_sat - theta_res)*gauss_hg_T + theta_res ) + dintegral_frz_upp_dT = fLiq + end if + + ! w.r.t. temperature + dfLiq_dT = dTheta_dTk(T,theta_res,theta_sat,vGn_alpha,vGn_n,vGn_m) + denthLiq_dT = iden_water * Cp_water * dintegral_frz_upp_dT + denthIce_dT = iden_ice * Cp_ice * ( volFracWat - dintegral_frz_upp_dT ) + denthSoil_dT = soil_dens_intr * Cp_soil * ( 1._rkind - theta_sat ) + denthAir_dT = iden_air * Cp_air * ( 1._rkind - theta_sat - volFracWat ) + dH_dT = denthLiq_dT + denthIce_dT + denthSoil_dT + denthAir_dT + iden_water * LH_fus * dfLiq_dT + + ! w.r.t. layer water content + denthLiq_dWat = iden_water * Cp_water * (dintegral_unf_dWat - dintegral_frz_low_dWat) + denthIce_dWat = iden_ice * Cp_ice * ( dvolFracWat_dPsi0 * diffT - (dintegral_unf_dWat - dintegral_frz_low_dWat) ) + denthSoil_dWat = 0._rkind + denthAir_dWat = -iden_air * Cp_air * dvolFracWat_dPsi0 * diffT + dH_dWat = denthLiq_dWat + denthIce_dWat + denthAir_dWat - iden_water * LH_fus * dvolFracWat_dPsi0 + + dT_dEnthalpy = 1._rkind / dH_dT + dT_dWat = -dH_dWat / dH_dT ! NOTE, while it is not generally appropriate to cancel partial derivatives, here this is true if it is multiplied by -1 + endif + end if ! (if ice exists) + + ! update temperature and derivatives + mLayerTemp = T + if(computJac)then + dTemp_dEnthalpy = dT_dEnthalpy + dTemp_dTheta = realMissing ! do not use + dTemp_dPsi0 = dT_dWat + endif + +end subroutine enthalpy2T_soil + +!---------------------------------------------------------------------- +! private function: compute hypergeometric function with real arguments into real result +!---------------------------------------------------------------------- + function hyp_2F1_real(a_real, b_real, c_real, z_real) + !-------------------------------------------------------------------- + USE hyp_2F1_module,only:HYP_2F1 ! use for hypergeometric function + implicit none + real(rkind),intent(in) :: a_real, b_real, c_real, z_real + complex(rkind) :: a_complex, b_complex, c_complex, z_complex, result + real(rkind) :: hyp_2F1_real + + a_complex = CMPLX(a_real, 0._rkind, rkind) + b_complex = CMPLX(b_real, 0._rkind, rkind) + c_complex = CMPLX(c_real, 0._rkind, rkind) + z_complex = CMPLX(z_real, 0._rkind, rkind) + result = HYP_2F1(a_complex, b_complex, c_complex, z_complex) + hyp_2F1_real = REAL(result, rkind) + +end function hyp_2F1_real + +!---------------------------------------------------------------------- +! private function: Brent's method to find a root of a function +!---------------------------------------------------------------------- +function brent0 (fun, x1, x2, fx1, fx2, tol_x, tol_f, detail, vec, err, message, use_lookup, lookup_data, ixControlIndex) + ! + ! Description of algorithm: + ! Find a root of function f(x) given intial bracketing interval [a,b] + ! where f(a) and f(b) must have opposite signs. At a typical step we have + ! three points a, b, and c such that f(b)f(c)<0, and a may coincide with + ! c. The points a, b, and c change during the algorithm, and the root + ! always lies in either [b,c] or [c, b]. The value b is the best + ! approximation to the root and a is the previous value of b. + ! + ! The iteration uses following selection of algorithms + ! when bracket shrinks reasonablly fast, + ! - Linear interporation if a == b + ! - Quadratic interporation if a != b and the point is in the bracket. + ! othrwise + ! - Bisection. + ! + ! Inputs: + ! fun: function to be solved + ! tol_x: tolerance for x + ! tol_f: tolerance for f(x) + ! x1, x2: Upper bound and lower bound for a function + ! detail: output result of iteration if detail is >0 + ! + ! Based on zeroin.f in netlib + ! modified from fzero.f90 by Yoki Okawa, Jan 30, 2009 + + implicit none + real(rkind) :: brent0 + integer, parameter :: d = rkind + real(rkind), intent(IN) :: x1, x2, fx1, fx2, vec(9), tol_x, tol_f + real(rkind), external :: fun + integer, intent(IN) :: detail + logical(lgt), intent(in), optional :: use_lookup + type(zLookup),intent(in), optional :: lookup_data + integer(i4b), intent(in), optional :: ixControlIndex + integer(i4b),intent(out) :: err + character(*),intent(out) :: message + + integer :: i, exitflag, disp + real(rkind) :: a, b, c, diff,e, fa, fb, fc, p, q, r, s, tol1, xm, tmp + real(rkind), parameter :: EPS = epsilon(a) + integer, parameter :: imax = 100 ! maximum number of iteration + + ! initialize error control + err=0; message='' + + exitflag = 0 + if (detail /= 0) then + disp = 1 + else + disp = 0 + end if + + ! intialize values + a = x1 + b = x2 + c = x2 + fa = fx1 + fb = fx2 + fc = fx2 + + ! check sign, should be fine since checked in main function brent + if ( (fa>0. .and. fb>0. ) .or. (fa>0. .and. fb>0. )) then + write(*,*) 'Error (brent0.f90): Root must be bracketed by two inputs' + write(*, "(' x1 = ', 1F8.4, ' x2 = ', 1F8.4, ' f(x1) = ', 1F15.4, ' f(x2) = ', 1F15.4)") a,b,fa,fb + stop + end if + + if (disp == 1 ) then + write(*,*) 'Brents method to find a root of f(x)' + write(*,*) ' ' + write(*,*) ' i x bracketsize f(x)' + end if + + ! main iteration + do i = 1, imax + ! rename c and adjust bounding interval if both a(=b) and c are same sign + if ((fb > 0. .and. fc > 0) .or. (fb <0. .and. fc < 0. ) ) then + c = a + fc = fa + e = b-a + diff = e + end if + + ! if c is better guess than b, use it. + if (abs(fc) < abs(fb) ) then + a=b + b=c + c=a + fa=fb + fb=fc + fc=fa + end if + + if (disp == 1) then + tmp = c-b + write(*,"(' ', 1I2, 2F16.10,1F20.10)") i, b, abs(b-c), fb + end if + + ! convergence check + tol1=2.0_rkind* EPS * abs(b) + 0.5_rkind*tol_x + xm = 0.5_rkind * (c - b) + if (abs(xm) < tol1 .or. abs(fb) <= tol_f ) then + exitflag = 1 + exit + end if + + ! try inverse quadratic interpolation + if (abs(e) >= tol1 .and. abs(fa) > abs(fb) ) then + s = fb/fa + if (abs(a - c) < EPS) then + p = 2.0_rkind *xm * s + q = 1.0_rkind - s + else + q = fa/fc + r = fb/fc + p = s * (2.0_rkind * xm * q * (q -r ) - (b - a) * (r - 1.0_rkind)) + q = (q - 1.0_rkind ) * (r - 1.0_rkind) * (s - 1.0_rkind) + end if + + ! accept if q is not too small to stay in bound + if (p > 0.0_rkind) q = -q + p = abs(p) + if (2.0 * p < min(3.0 * xm * q - abs(tol1* q), abs(e *q))) then + e = d + diff = p / q + else ! interpolation failed. use bisection + diff= xm + e = d + end if + else ! quadratic interpolation bounds moves too slowly, use bisection + diff = xm + e = d + end if + + ! update last bound + a = b + fa = fb + + ! move the best guess + if (abs(d) > tol1) then + b = b + diff + else + b = b + sign(tol1, xm) + end if + + ! evaluate new trial root + if(present(use_lookup))then + fb = fun(b, vec, use_lookup, lookup_data, ixControlIndex) + else + fb = fun(b, vec) + end if + + end do + + ! case for non convergence + if (exitflag /= 1 ) then + write(*,*) 'Error (brent0.f90) : convergence was not attained' + write(*,*) 'Initial value:' + write(*,"(4F10.5)" ) x1, x2, fx1, fx2 + write(*,*) ' ' + write(*,*) 'final value:' + write(*,"('x = ' ,1F6.4, ': f(x1) = ' , 1F6.4 )" ) b, fb + err = 20;message = trim(message)//'convergence was not attained';return + else if( disp == 1) then + write(*,*) 'Brents method was converged.' + write(*,*) '' + end if + brent0 = b + return + + end function brent0 + +!---------------------------------------------------------------------- +! private subroutine: Find an initial guess of bracket and call brent0 +!---------------------------------------------------------------------- + subroutine brent (fun, x0, brent_out, LowerBound, UpperBound, vec, err, message, use_lookup, lookup_data, ixControlIndex) + ! + ! Inputs + ! fun: function to evaluate + ! x0: Initial guess + ! LowerBound, UpperBound : Lower and upper bound of the function + + implicit none + integer, parameter :: d = rkind + real(rkind), intent(in) :: x0, vec(9) + real(rkind), external :: fun + real(rkind), intent(out) :: brent_out + real(rkind), intent(in) :: LowerBound, UpperBound + logical(lgt), intent(in), optional :: use_lookup + type(zLookup),intent(in), optional :: lookup_data + integer(i4b), intent(in), optional :: ixControlIndex + integer(i4b),intent(out) :: err + character(*),intent(out) :: message + + real(rkind) :: a , b , olda, oldb, fa, fb, folda, foldb + real(rkind), parameter :: sqrt2 = sqrt(2.0_d)! change in dx + integer, parameter :: maxiter = 20, detail = 0 + real(rkind) :: dx ! change in bracket + integer :: iter, exitflag, disp, exita, exitb + real(rkind) :: sgn + real(rkind), parameter :: tol_x = 1.e-5_rkind, tol_f = 1.e0_rkind ! maybe these should be tied to the state variable tolerances + character(LEN=256):: cmessage ! error message of downwind routine + + ! initialize error control + err=0; message='brent/' + + a = x0 ! lower bracket + b = x0 ! upper bracket + exitflag = 0 ! flag to see we found the bracket + exita = 0 + exitb = 0 + + if(present(use_lookup))then + sgn = fun(x0, vec, use_lookup, lookup_data, ixControlIndex) ! sign of initial guess + else + sgn = fun(x0, vec) + endif + ! set disp variable + if (detail /= 0) then + disp = 1 + else + disp = 0 + end if + fa = sgn + fb = sgn + + if(abs(sgn) <= tol_f ) then ! if solution didn't change, initial guess is the solution + brent_out = x0; return + end if + + ! set initial change dx + if (abs(x0)<240._rkind) then ! a very cold temperature + dx = 2.0_rkind/50.0_rkind * Tfreeze + else + dx = 1.0_rkind/50.0_rkind * Tfreeze + end if + + if (disp == 1) then + write(*,*) 'Search for initial guess for Brents method' + write(*,*) 'find two points whose sign for f(x) is different ' + write(*,*) 'x1 searches downwards, x2 searches upwards with increasing increment' + write(*,*) ' ' + write(*,*) ' i x1 x2 f(x1) f(x2)' + write(*,"(1I4,4F17.6)") 0, a, b, fa, fb + end if + + ! main loop to extend a and b + do iter = 1, maxiter + ! update boundary, function is monotonically increasing + if (fa<=0) exita = 1 + if (fb<=0)then; a = b; fa = fb; exita = 1; endif + if (fb>=0) exitb = 1 + if (fa>=0)then; b = a; fb = fa; exitb = 1; endif + olda = a + oldb = b + folda = fa + foldb = fb + if (exita/= 1)then + a = a - dx + if (a < LowerBound ) a = LowerBound + endif + if (exitb/= 1)then + b = b + dx + if (b > UpperBound ) b = UpperBound + endif + dx = dx * sqrt2 + + if(present(use_lookup))then + if (exita/= 1) fa = fun(a, vec, use_lookup, lookup_data, ixControlIndex) + if (exitb/= 1) fb = fun(b, vec, use_lookup, lookup_data, ixControlIndex) + else + if (exita/= 1) fa = fun(a, vec) + if (exitb/= 1) fb = fun(b, vec) + end if + if (a==LowerBound) exita = 1 + if (b==UpperBound) exitb = 1 + + if (disp == 1) write(*,"(1I4,4F17.6)") iter, a, b, fa, fb + + ! check if sign of functions changed or not + if (( (sgn >= 0 ) .and. (fa <= 0) ) .or. & + ( (sgn <= 0 ) .and. (fa >= 0 ) ))then ! sign of a changed + ! use a and olda as bracket + b = olda + fb = folda + exitflag = 1 + exit + else if (( (sgn >= 0 ) .and. (fb <= 0 ) ) .or. & + ( (sgn <= 0 ) .and. (fb >= 0 ) )) then ! sign of b changed + a = oldb + fa = foldb + exitflag = 1 + exit + end if + + end do + + ! case for non convergence + if (exitflag /= 1 ) then + if (a==LowerBound .and. fa>0 .and. fb>0)then + brent_out = LowerBound; return ! if bracket is not found, use lower bound since true temperature and enthalpy is very low, LowerBound is close enough + elseif (b==UpperBound .and. fa<0 .and. fb<0)then ! fb will be a small negative value but should be zero to tolerances + brent_out = UpperBound; return ! if bracket is not found, use upper bound since true temperature is very close to upper bound, UpperBound is close enough + else + write(*,*) ' Error (temperature from enthalpy computation): Proper initial value for Brents method could not be found in between bounds' + write(*,*) ' i x1 x2 f(x1) f(x2)' + write(*,"(1I4,4F17.6)") iter, a, b, fa, fb + write(*,*) 'vec=',vec + err = 20;message = trim(message)//'proper initial value could not be found'; return + endif + else if (disp == 1) then + write(*,*) ' Initial guess was found.' + write(*,*) '' + end if + + ! call brent0 + if(present(use_lookup))then + brent_out = brent0(fun, a, b, fa, fb, tol_x, tol_f, detail, vec, err, cmessage, use_lookup, lookup_data, ixControlIndex) + else + brent_out = brent0(fun, a, b, fa, fb, tol_x, tol_f, detail, vec, err, cmessage) + end if + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + + end subroutine brent + + !---------------------------------------------------------------------- + ! private functions for temperature to enthalpy conversion for Brent's method + !---------------------------------------------------------------------- + function diff_H_veg ( scalarCanopyTemp, vec) + USE snow_utils_module,only:fracliquid ! compute volumetric fraction of liquid water + implicit none + real(rkind) :: diff_H_veg + real(rkind) , intent(IN) :: scalarCanopyTemp, vec(8) + real(rkind) :: scalarCanopyEnthalpy, scalarCanopyEnthTemp, scalarCanopyWat + real(rkind) :: canopyDepth, specificHeatVeg, maxMassVegetation, snowfrz_scale, fLiq + + scalarCanopyEnthalpy = vec(1) + canopyDepth = vec(2) + specificHeatVeg = vec(3) + maxMassVegetation = vec(4) + snowfrz_scale = vec(5) + scalarCanopyWat = vec(6) + + call T2enthTemp_veg(canopyDepth, specificHeatVeg, maxMassVegetation, snowfrz_scale, scalarCanopyTemp, & + scalarCanopyWat, scalarCanopyEnthTemp) + fLiq = fracliquid(scalarCanopyTemp, snowfrz_scale) + diff_H_veg = scalarCanopyEnthTemp - LH_fus * scalarCanopyWat* (1._rkind - fLiq)/ canopyDepth - scalarCanopyEnthalpy + + end function diff_H_veg + !---------------------------------------------------------------------- + function diff_H_snow ( mLayerTemp, vec) + USE snow_utils_module,only:fracliquid ! compute volumetric fraction of liquid water + implicit none + real(rkind) :: diff_H_snow + real(rkind) , intent(IN) :: mLayerTemp, vec(9) + real(rkind) :: mLayerEnthalpy, mLayerEnthTemp, mLayerVolFracWat, snowfrz_scale, fLiq + + mLayerEnthalpy = vec(1) + snowfrz_scale = vec(2) + mLayerVolFracWat = vec(3) + + call T2enthTemp_snow(snowfrz_scale, mLayerTemp, mLayerVolFracWat, mLayerEnthTemp) + fLiq = fracliquid(mLayerTemp, snowfrz_scale) + diff_H_snow = mLayerEnthTemp - iden_water * LH_fus * mLayerVolFracWat * (1._rkind - fLiq) - mLayerEnthalpy + + end function diff_H_snow + !---------------------------------------------------------------------- + function diff_H_soil ( mLayerTemp, vec, use_lookup, lookup_data, ixControlIndex) + USE soil_utils_module,only:volFracLiq ! compute volumetric fraction of liquid water based on matric head + implicit none + real(rkind) :: diff_H_soil + real(rkind) , intent(in) :: mLayerTemp, vec(9) + logical(lgt), intent(in) :: use_lookup + type(zLookup),intent(in) :: lookup_data + integer(i4b), intent(in) :: ixControlIndex + real(rkind) :: mLayerEnthalpy, mLayerEnthTemp, mLayerMatricHead, volFracWat, xConst, mLayerPsiLiq, fLiq + real(rkind) :: soil_dens_intr, vGn_alpha, vGn_n, theta_sat, theta_res, vGn_m, integral_frz_low + integer(i4b) :: err + character(LEN=256):: cmessage ! error message of downwind routine + + mLayerEnthalpy = vec(1) + soil_dens_intr = vec(2) + vGn_alpha = vec(3) + vGn_n = vec(4) + theta_sat = vec(5) + theta_res = vec(6) + vGn_m = vec(7) + integral_frz_low = vec(8) + mLayerMatricHead = vec(9) + + call T2enthTemp_soil(use_lookup, soil_dens_intr, vGn_alpha, vGn_n, theta_sat, theta_res, vGn_m, & + ixControlIndex, lookup_data, integral_frz_low, mLayerTemp, mLayerMatricHead, & + mLayerEnthTemp, err, cmessage) + if(err/=0) then; cmessage="diff_H_soil inside Brent solver"//trim(cmessage); print*, cmessage; stop; end if + volFracWat = volFracLiq(mLayerMatricHead,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) + xConst = LH_fus/(gravity*Tfreeze) ! m K-1 (NOTE: J = kg m2 s-2) + mLayerPsiLiq = xConst*(mLayerTemp - Tfreeze) ! liquid water matric potential from the Clapeyron eqution + fLiq = volFracLiq(mLayerPsiLiq,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) ! here fLiq is the total liquid fraction, not fraction of water fraction that is liquid + diff_H_soil = mLayerEnthTemp - iden_water * LH_fus * (volFracWat - fLiq) - mLayerEnthalpy + + end function diff_H_soil + + +end module enthalpyTemp_module \ No newline at end of file diff --git a/build/source/engine/eval8summa.f90 b/build/source/engine/eval8summa.f90 old mode 100755 new mode 100644 index 286cf5bdb..5d120fbdc --- a/build/source/engine/eval8summa.f90 +++ b/build/source/engine/eval8summa.f90 @@ -25,48 +25,30 @@ module eval8summa_module ! access missing values USE globalData,only:integerMissing ! missing integer -USE globalData,only:realMissing ! missing double precision number +USE globalData,only:realMissing ! missing real number USE globalData,only:quadMissing ! missing quadruple precision number -! access the global print flag -USE globalData,only:globalPrintFlag - -! define access to state variables to print -USE globalData,only: iJac1 ! first layer of the Jacobian to print -USE globalData,only: iJac2 ! last layer of the Jacobian to print - -! domain types -USE globalData,only:iname_veg ! named variables for vegetation -USE globalData,only:iname_snow ! named variables for snow -USE globalData,only:iname_soil ! named variables for soil - ! named variables to describe the state variable type -USE globalData,only:iname_nrgCanair ! named variable defining the energy of the canopy air space -USE globalData,only:iname_nrgCanopy ! named variable defining the energy of the vegetation canopy -USE globalData,only:iname_watCanopy ! named variable defining the mass of water on the vegetation canopy -USE globalData,only:iname_nrgLayer ! named variable defining the energy state variable for snow+soil layers USE globalData,only:iname_watLayer ! named variable defining the total water state variable for snow+soil layers USE globalData,only:iname_liqLayer ! named variable defining the liquid water state variable for snow+soil layers -USE globalData,only:iname_matLayer ! named variable defining the matric head state variable for soil layers -USE globalData,only:iname_lmpLayer ! named variable defining the liquid matric potential state variable for soil layers +USE globalData,only:iname_matLayer ! named variable defining the total water matric potential state variable for soil layers +USE globalData,only:iname_lmpLayer ! named variable defining the liquid water matric potential state variable for soil layers ! constants USE multiconst,only:& - Tfreeze, & ! temperature at freezing (K) - LH_fus, & ! latent heat of fusion (J kg-1) - LH_vap, & ! latent heat of vaporization (J kg-1) - LH_sub, & ! latent heat of sublimation (J kg-1) - Cp_air, & ! specific heat of air (J kg-1 K-1) - iden_air, & ! intrinsic density of air (kg m-3) - iden_ice, & ! intrinsic density of ice (kg m-3) - iden_water ! intrinsic density of liquid water (kg m-3) + LH_fus, & ! latent heat of fusion (J kg-1) + iden_water, & ! intrinsic density of liquid water (kg m-3) + gravity, & ! gravitational acceleration (m s-2) + Tfreeze ! freezing point of pure water (K) + ! provide access to the derived types to define the data structures USE data_types,only:& var_i, & ! data vector (i4b) - var_d, & ! data vector (dp) + var_d, & ! data vector (rkind) var_ilength, & ! data vector with variable length dimension (i4b) - var_dlength, & ! data vector with variable length dimension (dp) + var_dlength, & ! data vector with variable length dimension (rkind) + zLookup, & ! data vector with variable length dimension (rkind) model_options ! defines the model decisions ! indices that define elements of the data structures @@ -78,450 +60,1012 @@ module eval8summa_module USE var_lookup,only:iLookFLUX ! named variables for structure elements USE var_lookup,only:iLookDERIV ! named variables for structure elements -! look-up values for the choice of groundwater representation (local-column, or single-basin) +! look-up values for the choice of variable in energy equations (BE residual or IDA state variable) USE mDecisions_module,only: & - localColumn, & ! separate groundwater representation in each local soil column - singleBasin ! single groundwater store over the entire basin + closedForm, & ! use temperature with closed form heat capacity + enthalpyFormLU, & ! use enthalpy with soil temperature-enthalpy lookup tables + enthalpyForm ! use enthalpy with soil temperature-enthalpy analytical solution -! look-up values for the choice of groundwater parameterization +! look-up values for the numerical method USE mDecisions_module,only: & - qbaseTopmodel, & ! TOPMODEL-ish baseflow parameterization - bigBucket, & ! a big bucket (lumped aquifer model) - noExplicit ! no explicit groundwater parameterization - -! look-up values for the form of Richards' equation -USE mDecisions_module,only: & - moisture, & ! moisture-based form of Richards' equation - mixdform ! mixed form of Richards' equation + homegrown, & ! homegrown backward Euler solution based on concepts from numerical recipes + kinsol, & ! SUNDIALS backward Euler solution using Kinsol + ida ! SUNDIALS solution using IDA implicit none private public::eval8summa +#ifdef SUNDIALS_ACTIVE +public::eval8summa4kinsol +#endif +public::imposeConstraints contains - ! ********************************************************************************************************** - ! public subroutine eval8summa: compute the residual vector and the Jacobian matrix - ! ********************************************************************************************************** - subroutine eval8summa(& - ! input: model control - dt, & ! intent(in): length of the time step (seconds) - nSnow, & ! intent(in): number of snow layers - nSoil, & ! intent(in): number of soil layers - nLayers, & ! intent(in): total number of layers - nState, & ! intent(in): total number of state variables - firstSubStep, & ! intent(in): flag to indicate if we are processing the first sub-step - firstFluxCall, & ! intent(inout): flag to indicate if we are processing the first flux call - firstSplitOper, & ! intent(in): flag to indicate if we are processing the first flux call in a splitting operation - computeVegFlux, & ! intent(in): flag to indicate if we need to compute fluxes over vegetation - scalarSolution, & ! intent(in): flag to indicate the scalar solution - ! input: state vectors - stateVecTrial, & ! intent(in): model state vector - fScale, & ! intent(in): function scaling vector - sMul, & ! intent(in): state vector multiplier (used in the residual calculations) - ! input: data structures - model_decisions, & ! intent(in): model decisions - type_data, & ! intent(in): type of vegetation and soil - attr_data, & ! intent(in): spatial attributes - mpar_data, & ! intent(in): model parameters - forc_data, & ! intent(in): model forcing data - bvar_data, & ! intent(in): average model variables for the entire basin - prog_data, & ! intent(in): model prognostic variables for a local HRU - ! input-output: data structures - indx_data, & ! intent(inout): index data - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - flux_data, & ! intent(inout): model fluxes for a local HRU - deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables - ! input-output: baseflow - ixSaturation, & ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) - dBaseflow_dMatric, & ! intent(out): derivative in baseflow w.r.t. matric head (s-1) - ! output: flux and residual vectors - feasible, & ! intent(out): flag to denote the feasibility of the solution - fluxVec, & ! intent(out): flux vector - resSink, & ! intent(out): additional (sink) terms on the RHS of the state equation - resVec, & ! intent(out): residual vector - fEval, & ! intent(out): function evaluation - err,message) ! intent(out): error control - ! -------------------------------------------------------------------------------------------------------------------------------- - ! provide access to subroutines - USE getVectorz_module, only:varExtract ! extract variables from the state vector - USE updateVars_module, only:updateVars ! update prognostic variables - USE computFlux_module, only:soilCmpres ! compute soil compression - USE computFlux_module, only:computFlux ! compute fluxes given a state vector - USE computResid_module,only:computResid ! compute residuals given a state vector - implicit none - ! -------------------------------------------------------------------------------------------------------------------------------- - ! -------------------------------------------------------------------------------------------------------------------------------- - ! input: model control - real(rkind),intent(in) :: dt ! length of the time step (seconds) - integer(i4b),intent(in) :: nSnow ! number of snow layers - integer(i4b),intent(in) :: nSoil ! number of soil layers - integer(i4b),intent(in) :: nLayers ! total number of layers - integer(i4b),intent(in) :: nState ! total number of state variables - logical(lgt),intent(in) :: firstSubStep ! flag to indicate if we are processing the first sub-step - logical(lgt),intent(inout) :: firstFluxCall ! flag to indicate if we are processing the first flux call - logical(lgt),intent(in) :: firstSplitOper ! flag to indicate if we are processing the first flux call in a splitting operation - logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation - logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution - ! input: state vectors - real(rkind),intent(in) :: stateVecTrial(:) ! model state vector - real(rkind),intent(in) :: fScale(:) ! function scaling vector - real(rkind),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) - ! input: data structures - type(model_options),intent(in) :: model_decisions(:) ! model decisions - type(var_i), intent(in) :: type_data ! type of vegetation and soil - type(var_d), intent(in) :: attr_data ! spatial attributes - type(var_dlength), intent(in) :: mpar_data ! model parameters - type(var_d), intent(in) :: forc_data ! model forcing data - type(var_dlength), intent(in) :: bvar_data ! model variables for the local basin - type(var_dlength), intent(in) :: prog_data ! prognostic variables for a local HRU - ! output: data structures - type(var_ilength),intent(inout) :: indx_data ! indices defining model states and layers - type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU - type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU - type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables - ! input-output: baseflow - integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) - real(rkind),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) - ! output: flux and residual vectors - logical(lgt),intent(out) :: feasible ! flag to denote the feasibility of the solution - real(rkind),intent(out) :: fluxVec(:) ! flux vector - real(rkind),intent(out) :: resSink(:) ! sink terms on the RHS of the flux equation - real(rkind),intent(out) :: resVec(:) ! NOTE: qp ! residual vector - real(rkind),intent(out) :: fEval ! function evaluation - ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! -------------------------------------------------------------------------------------------------------------------------------- - ! local variables - ! -------------------------------------------------------------------------------------------------------------------------------- - ! state variables - real(rkind) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) - real(rkind) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) - real(rkind) :: scalarCanopyWatTrial ! trial value for liquid water storage in the canopy (kg m-2) - real(rkind),dimension(nLayers) :: mLayerTempTrial ! trial value for temperature of layers in the snow and soil domains (K) - real(rkind),dimension(nLayers) :: mLayerVolFracWatTrial ! trial value for volumetric fraction of total water (-) - real(rkind),dimension(nSoil) :: mLayerMatricHeadTrial ! trial value for total water matric potential (m) - real(rkind),dimension(nSoil) :: mLayerMatricHeadLiqTrial ! trial value for liquid water matric potential (m) - real(rkind) :: scalarAquiferStorageTrial ! trial value of storage of water in the aquifer (m) - ! diagnostic variables - real(rkind) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) - real(rkind) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) - real(rkind),dimension(nLayers) :: mLayerVolFracLiqTrial ! trial value for volumetric fraction of liquid water (-) - real(rkind),dimension(nLayers) :: mLayerVolFracIceTrial ! trial value for volumetric fraction of ice (-) - ! other local variables - integer(i4b) :: iLayer ! index of model layer in the snow+soil domain - integer(i4b) :: jState(1) ! index of model state for the scalar solution within the soil domain - integer(i4b) :: ixBeg,ixEnd ! index of indices for the soil compression routine - integer(i4b),parameter :: ixVegVolume=1 ! index of the desired vegetation control volumne (currently only one veg layer) - real(rkind) :: xMin,xMax ! minimum and maximum values for water content - real(rkind) :: scalarCanopyHydTrial ! trial value for mass of water on the vegetation canopy (kg m-2) - real(rkind),parameter :: canopyTempMax=500._rkind ! expected maximum value for the canopy temperature (K) - real(rkind),dimension(nLayers) :: mLayerVolFracHydTrial ! trial value for volumetric fraction of water (-), general vector merged from Wat and Liq - real(rkind),dimension(nState) :: rVecScaled ! scaled residual vector - character(LEN=256) :: cmessage ! error message of downwind routine - ! -------------------------------------------------------------------------------------------------------------------------------- - ! association to variables in the data structures - ! -------------------------------------------------------------------------------------------------------------------------------- - associate(& - ! model decisions - ixRichards => model_decisions(iLookDECISIONS%f_Richards)%iDecision ,& ! intent(in): [i4b] index of the form of Richards' equation - ! snow parameters - snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1) ,& ! intent(in): [dp] scaling parameter for the snow freezing curve (K-1) - ! soil parameters - theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat ,& ! intent(in): [dp(:)] soil porosity (-) - specificStorage => mpar_data%var(iLookPARAM%specificStorage)%dat(1) ,& ! intent(in): [dp] specific storage coefficient (m-1) - ! canopy and layer depth - canopyDepth => diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1) ,& ! intent(in): [dp ] canopy depth (m) - mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat ,& ! intent(in): [dp(:)] depth of each layer in the snow-soil sub-domain (m) - ! model state variables - scalarSfcMeltPond => prog_data%var(iLookPROG%scalarSfcMeltPond)%dat(1) ,& ! intent(in): [dp] ponded water caused by melt of the "snow without a layer" (kg m-2) - mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat ,& ! intent(in): [dp(:)] volumetric fraction of liquid water (-) - mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat ,& ! intent(in): [dp(:)] volumetric fraction of ice (-) - mLayerMatricHeadLiq => diag_data%var(iLookDIAG%mLayerMatricHeadLiq)%dat ,& ! intent(in): [dp(:)] liquid water matric potential (m) - ! model diagnostic variables - scalarFracLiqVeg => diag_data%var(iLookDIAG%scalarFracLiqVeg)%dat(1) ,& ! intent(in): [dp] fraction of liquid water on vegetation (-) - mLayerFracLiqSnow => diag_data%var(iLookDIAG%mLayerFracLiqSnow)%dat ,& ! intent(in): [dp(:)] fraction of liquid water in each snow layer (-) - ! soil compression - scalarSoilCompress => diag_data%var(iLookDIAG%scalarSoilCompress)%dat(1) ,& ! intent(in): [dp] total change in storage associated with compression of the soil matrix (kg m-2) - mLayerCompress => diag_data%var(iLookDIAG%mLayerCompress)%dat ,& ! intent(in): [dp(:)] change in storage associated with compression of the soil matrix (-) - ! derivatives - dVolTot_dPsi0 => deriv_data%var(iLookDERIV%dVolTot_dPsi0)%dat ,& ! intent(in): [dp(:)] derivative in total water content w.r.t. total water matric potential - dCompress_dPsi => deriv_data%var(iLookDERIV%dCompress_dPsi)%dat ,& ! intent(in): [dp(:)] derivative in compressibility w.r.t. matric head (m-1) - ! mapping - ixMapFull2Subset => indx_data%var(iLookINDEX%ixMapFull2Subset)%dat ,& ! intent(in): [i4b(:)] mapping of full state vector to the state subset - ixControlVolume => indx_data%var(iLookINDEX%ixControlVolume)%dat ,& ! intent(in): [i4b(:)] index of control volume for different domains (veg, snow, soil) - ! indices - ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy air space energy state variable (nrg) - ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable (nrg) - ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) - ixSnowOnlyNrg => indx_data%var(iLookINDEX%ixSnowOnlyNrg)%dat ,& ! intent(in): [i4b(:)] indices for energy states in the snow subdomain - ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in): [i4b(:)] indices for hydrology states in the snow+soil subdomain - ixStateType => indx_data%var(iLookINDEX%ixStateType)%dat ,& ! intent(in): [i4b(:)] indices defining the type of the state (iname_nrgLayer...) - ixHydCanopy => indx_data%var(iLookINDEX%ixHydCanopy)%dat ,& ! intent(in): [i4b(:)] index of the hydrology states in the canopy domain - ixHydType => indx_data%var(iLookINDEX%ixHydType)%dat ,& ! intent(in): [i4b(:)] index of the type of hydrology states in snow+soil domain - layerType => indx_data%var(iLookINDEX%layerType)%dat & ! intent(in): [i4b(:)] layer type (iname_soil or iname_snow) - ) ! association to variables in the data structures - ! -------------------------------------------------------------------------------------------------------------------------------- - ! initialize error control - err=0; message="eval8summa/" - - ! check the feasibility of the solution - feasible=.true. - - ! check that the canopy air space temperature is reasonable - if(ixCasNrg/=integerMissing)then - if(stateVecTrial(ixCasNrg) > canopyTempMax) feasible=.false. - endif - - ! check that the canopy air space temperature is reasonable - if(ixVegNrg/=integerMissing)then - if(stateVecTrial(ixVegNrg) > canopyTempMax) feasible=.false. - endif - - ! check canopy liquid water is not negative - if(ixVegHyd/=integerMissing)then - if(stateVecTrial(ixVegHyd) < 0._rkind) feasible=.false. - end if - - ! check snow temperature is below freezing - if(count(ixSnowOnlyNrg/=integerMissing)>0)then - if(any(stateVecTrial( pack(ixSnowOnlyNrg,ixSnowOnlyNrg/=integerMissing) ) > Tfreeze)) feasible=.false. - endif - - ! loop through non-missing hydrology state variables in the snow+soil domain - do concurrent (iLayer=1:nLayers,ixSnowSoilHyd(iLayer)/=integerMissing) - - ! check the minimum and maximum water constraints - if(ixHydType(iLayer)==iname_watLayer .or. ixHydType(iLayer)==iname_liqLayer)then - - ! --> minimum - if (layerType(iLayer) == iname_soil) then - xMin = theta_sat(iLayer-nSnow) - else - xMin = 0._rkind - endif - - ! --> maximum - select case( layerType(iLayer) ) - case(iname_snow); xMax = merge(iden_ice, 1._rkind - mLayerVolFracIce(iLayer), ixHydType(iLayer)==iname_watLayer) - case(iname_soil); xMax = merge(theta_sat(iLayer-nSnow), theta_sat(iLayer-nSnow) - mLayerVolFracIce(iLayer), ixHydType(iLayer)==iname_watLayer) - end select - - ! --> check - if(stateVecTrial( ixSnowSoilHyd(iLayer) ) < xMin .or. stateVecTrial( ixSnowSoilHyd(iLayer) ) > xMax) feasible=.false. - !if(.not.feasible) write(*,'(a,1x,i4,1x,L1,1x,10(f20.10,1x))') 'iLayer, feasible, stateVecTrial( ixSnowSoilHyd(iLayer) ), xMin, xMax = ', iLayer, feasible, stateVecTrial( ixSnowSoilHyd(iLayer) ), xMin, xMax - - endif ! if water states - - end do ! loop through non-missing hydrology state variables in the snow+soil domain - - ! early return for non-feasible solutions - if(.not.feasible)then - fluxVec(:) = realMissing - resVec(:) = quadMissing - fEval = realMissing - return - end if - - ! get the start and end indices for the soil compression calculations - if(scalarSolution)then - jState = pack(ixControlVolume, ixMapFull2Subset/=integerMissing) - ixBeg = jState(1) - ixEnd = jState(1) - else - ixBeg = 1 - ixEnd = nSoil - endif - - ! extract variables from the model state vector - call varExtract(& - ! input - stateVecTrial, & ! intent(in): model state vector (mixed units) - diag_data, & ! intent(in): model diagnostic variables for a local HRU - prog_data, & ! intent(in): model prognostic variables for a local HRU - indx_data, & ! intent(in): indices defining model states and layers - ! output: variables for the vegetation canopy - scalarCanairTempTrial, & ! intent(out): trial value of canopy air temperature (K) - scalarCanopyTempTrial, & ! intent(out): trial value of canopy temperature (K) - scalarCanopyWatTrial, & ! intent(out): trial value of canopy total water (kg m-2) - scalarCanopyLiqTrial, & ! intent(out): trial value of canopy liquid water (kg m-2) - scalarCanopyIceTrial, & ! intent(out): trial value of canopy ice content (kg m-2) - ! output: variables for the snow-soil domain - mLayerTempTrial, & ! intent(out): trial vector of layer temperature (K) - mLayerVolFracWatTrial, & ! intent(out): trial vector of volumetric total water content (-) - mLayerVolFracLiqTrial, & ! intent(out): trial vector of volumetric liquid water content (-) - mLayerVolFracIceTrial, & ! intent(out): trial vector of volumetric ice water content (-) - mLayerMatricHeadTrial, & ! intent(out): trial vector of total water matric potential (m) - mLayerMatricHeadLiqTrial, & ! intent(out): trial vector of liquid water matric potential (m) - ! output: variables for the aquifer - scalarAquiferStorageTrial,& ! intent(out): trial value of storage of water in the aquifer (m) - ! output: error control - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - - ! update diagnostic variables - call updateVars(& - ! input - .false., & ! intent(in): logical flag to adjust temperature to account for the energy used in melt+freeze - mpar_data, & ! intent(in): model parameters for a local HRU - indx_data, & ! intent(in): indices defining model states and layers - prog_data, & ! intent(in): model prognostic variables for a local HRU - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables - ! output: variables for the vegetation canopy - scalarCanopyTempTrial, & ! intent(inout): trial value of canopy temperature (K) - scalarCanopyWatTrial, & ! intent(inout): trial value of canopy total water (kg m-2) - scalarCanopyLiqTrial, & ! intent(inout): trial value of canopy liquid water (kg m-2) - scalarCanopyIceTrial, & ! intent(inout): trial value of canopy ice content (kg m-2) - ! output: variables for the snow-soil domain - mLayerTempTrial, & ! intent(inout): trial vector of layer temperature (K) - mLayerVolFracWatTrial, & ! intent(inout): trial vector of volumetric total water content (-) - mLayerVolFracLiqTrial, & ! intent(inout): trial vector of volumetric liquid water content (-) - mLayerVolFracIceTrial, & ! intent(inout): trial vector of volumetric ice water content (-) - mLayerMatricHeadTrial, & ! intent(inout): trial vector of total water matric potential (m) - mLayerMatricHeadLiqTrial, & ! intent(inout): trial vector of liquid water matric potential (m) - ! output: error control - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - - ! print the states in the canopy domain - !print*, 'dt = ', dt - !write(*,'(a,1x,10(f20.10,1x))') 'scalarCanopyTempTrial = ', scalarCanopyTempTrial - !write(*,'(a,1x,10(f20.10,1x))') 'scalarCanopyWatTrial = ', scalarCanopyWatTrial - !write(*,'(a,1x,10(f20.10,1x))') 'scalarCanopyLiqTrial = ', scalarCanopyLiqTrial - !write(*,'(a,1x,10(f20.10,1x))') 'scalarCanopyIceTrial = ', scalarCanopyIceTrial - - ! print the states in the snow+soil domain - !write(*,'(a,1x,10(f20.10,1x))') 'mLayerTempTrial = ', mLayerTempTrial(iJac1:min(nLayers,iJac2)) - !write(*,'(a,1x,10(f20.10,1x))') 'mLayerVolFracWatTrial = ', mLayerVolFracWatTrial(iJac1:min(nLayers,iJac2)) - !write(*,'(a,1x,10(f20.10,1x))') 'mLayerVolFracLiqTrial = ', mLayerVolFracLiqTrial(iJac1:min(nLayers,iJac2)) - !write(*,'(a,1x,10(f20.10,1x))') 'mLayerVolFracIceTrial = ', mLayerVolFracIceTrial(iJac1:min(nLayers,iJac2)) - !write(*,'(a,1x,10(f20.10,1x))') 'mLayerMatricHeadTrial = ', mLayerMatricHeadTrial(iJac1:min(nSoil,iJac2)) - !write(*,'(a,1x,10(f20.10,1x))') 'mLayerMatricHeadLiqTrial = ', mLayerMatricHeadLiqTrial(iJac1:min(nSoil,iJac2)) - - ! print the water content - if(globalPrintFlag)then - if(iJac1 mpar_data%var(iLookPARAM%theta_sat)%dat ,& ! intent(in): [dp(:)] soil porosity (-) + specificStorage => mpar_data%var(iLookPARAM%specificStorage)%dat(1) ,& ! intent(in): [dp] specific storage coefficient (m-1) + ! canopy and layer depth + canopyDepth => diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1) ,& ! intent(in): [dp ] canopy depth (m) + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat ,& ! intent(in): [dp(:)] depth of each layer in the snow-soil sub-domain (m) + ! model state variables from the previous solution + scalarCanairTemp => prog_data%var(iLookPROG%scalarCanairTemp)%dat(1) ,& ! intent(in): [dp] temperature of the canopy air space (K) + scalarCanopyTemp => prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1) ,& ! intent(in): [dp] temperature of the vegetation canopy (K) + scalarCanopyWat => prog_data%var(iLookPROG%scalarCanopyWat)%dat(1) ,& ! intent(in): [dp] mass of total water on the vegetation canopy (kg m-2) + mLayerTemp => prog_data%var(iLookPROG%mLayerTemp)%dat ,& ! intent(in): [dp(:)] temperature of each snow/soil layer (K) + mLayerVolFracWat => prog_data%var(iLookPROG%mLayerVolFracWat)%dat ,& ! intent(in): [dp(:)] volumetric fraction of total water (-) + mLayerMatricHead => prog_data%var(iLookPROG%mLayerMatricHead)%dat ,& ! intent(in): [dp(:)] total water matric potential (m) + mLayerMatricHeadLiq => diag_data%var(iLookDIAG%mLayerMatricHeadLiq)%dat ,& ! intent(in): [dp(:)] liquid water matric potential (m) + scalarAquiferStorage => prog_data%var(iLookPROG%scalarAquiferStorage)%dat(1) ,& ! intent(in): [dp] storage of water in the aquifer (m) + ! model diagnostic variables, will be updated before used + scalarCanopyLiq => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1) ,& ! intent(in): [dp(:)] mass of liquid water on the vegetation canopy (kg m-2) + scalarCanopyIce => prog_data%var(iLookPROG%scalarCanopyIce)%dat(1) ,& ! intent(in): [dp(:)] mass of ice on the vegetation canopy (kg m-2) + scalarFracLiqVeg => diag_data%var(iLookDIAG%scalarFracLiqVeg)%dat(1) ,& ! intent(in): [dp] fraction of liquid water on vegetation (-) + scalarSfcMeltPond => prog_data%var(iLookPROG%scalarSfcMeltPond)%dat(1) ,& ! intent(in): [dp] ponded water caused by melt of the "snow without a layer" (kg m-2) + mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat ,& ! intent(in): [dp(:)] volumetric fraction of liquid water (-) + mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat ,& ! intent(in): [dp(:)] volumetric fraction of ice (-) + mLayerFracLiqSnow => diag_data%var(iLookDIAG%mLayerFracLiqSnow)%dat ,& ! intent(in): [dp(:)] fraction of liquid water in each snow layer (-) + ! enthalpy from the previous solution + scalarCanairEnthalpy => prog_data%var(iLookPROG%scalarCanairEnthalpy)%dat(1) ,& ! intent(in): [dp] enthalpy of the canopy air space (J m-3) + scalarCanopyEnthTemp => diag_data%var(iLookDIAG%scalarCanopyEnthTemp)%dat(1) ,& ! intent(in): [dp] temperature component of enthalpy of the vegetation canopy (J m-3) + mLayerEnthTemp => diag_data%var(iLookDIAG%mLayerEnthTemp)%dat ,& ! intent(in): [dp(:)] temperature component of enthalpy of the snow+soil layers (J m-3) + ! soil compression + scalarSoilCompress => diag_data%var(iLookDIAG%scalarSoilCompress)%dat(1) ,& ! intent(in): [dp] total change in storage associated with compression of the soil matrix (kg m-2 s-1) + mLayerCompress => diag_data%var(iLookDIAG%mLayerCompress)%dat ,& ! intent(in): [dp(:)] change in volumetric water content due to compression of soil (s-1) + ! derivatives + dTheta_dTkCanopy => deriv_data%var(iLookDERIV%dTheta_dTkCanopy)%dat(1) ,& ! intent(in): [dp] derivative of volumetric liquid water content w.r.t. temperature + dVolTot_dPsi0 => deriv_data%var(iLookDERIV%dVolTot_dPsi0)%dat ,& ! intent(in): [dp(:)] derivative in total water content w.r.t. total water matric potential + dCompress_dPsi => deriv_data%var(iLookDERIV%dCompress_dPsi)%dat ,& ! intent(in): [dp(:)] derivative in compressibility w.r.t. matric head (m-1) + mLayerdTheta_dTk => deriv_data%var(iLookDERIV%mLayerdTheta_dTk)%dat ,& ! intent(in): [dp(:)] derivative of volumetric liquid water content w.r.t. temperature + dVolHtCapBulk_dPsi0 => deriv_data%var(iLookDERIV%dVolHtCapBulk_dPsi0)%dat ,& ! intent(out): [dp(:)] derivative in bulk heat capacity w.r.t. matric potential + dVolHtCapBulk_dTheta => deriv_data%var(iLookDERIV%dVolHtCapBulk_dTheta)%dat ,& ! intent(out): [dp(:)] derivative in bulk heat capacity w.r.t. volumetric water content + dVolHtCapBulk_dCanWat => deriv_data%var(iLookDERIV%dVolHtCapBulk_dCanWat)%dat(1) ,& ! intent(out): [dp] derivative in bulk heat capacity w.r.t. volumetric water content + dVolHtCapBulk_dTk => deriv_data%var(iLookDERIV%dVolHtCapBulk_dTk)%dat ,& ! intent(out): [dp(:)] derivative in bulk heat capacity w.r.t. temperature + dVolHtCapBulk_dTkCanopy => deriv_data%var(iLookDERIV%dVolHtCapBulk_dTkCanopy)%dat(1) ,& ! intent(out): [dp] derivative in bulk heat capacity w.r.t. temperature + dThermalC_dWatAbove => deriv_data%var(iLookDERIV%dThermalC_dWatAbove)%dat ,& ! intent(out): [dp(:)] derivative in the thermal conductivity w.r.t. water state in the layer above + dThermalC_dWatBelow => deriv_data%var(iLookDERIV%dThermalC_dWatBelow)%dat ,& ! intent(out): [dp(:)] derivative in the thermal conductivity w.r.t. water state in the layer above + dThermalC_dTempAbove => deriv_data%var(iLookDERIV%dThermalC_dTempAbove)%dat ,& ! intent(out): [dp(:)] derivative in the thermal conductivity w.r.t. energy state in the layer above + dThermalC_dTempBelow => deriv_data%var(iLookDERIV%dThermalC_dTempBelow)%dat ,& ! intent(out): [dp(:)] derivative in the thermal conductivity w.r.t. energy state in the layer above + dCm_dPsi0 => deriv_data%var(iLookDERIV%dCm_dPsi0)%dat ,& ! intent(out): [dp(:)] derivative in heat capacity w.r.t. matric potential (J kg-1) + dCm_dTk => deriv_data%var(iLookDERIV%dCm_dTk)%dat ,& ! intent(out): [dp(:)] derivative in heat capacity w.r.t. temperature (J kg-1 K-2) + dCm_dTkCanopy => deriv_data%var(iLookDERIV%dCm_dTkCanopy)%dat(1) ,& ! intent(out): [dp ] derivative in heat capacity w.r.t. canopy temperature (J kg-1 K-2) + ! mapping + ixMapFull2Subset => indx_data%var(iLookINDEX%ixMapFull2Subset)%dat ,& ! intent(in): [i4b(:)]mapping of full state vector to the state subset + ixControlVolume => indx_data%var(iLookINDEX%ixControlVolume)%dat ,& ! intent(in): [i4b(:)]index of control volume for different domains (veg, snow, soil) + ! heat capacity + heatCapVegTrial => diag_data%var(iLookDIAG%scalarBulkVolHeatCapVeg)%dat(1) ,& ! intent(out): [dp] volumetric heat capacity of vegetation canopy + mLayerHeatCapTrial => diag_data%var(iLookDIAG%mLayerVolHtCapBulk)%dat ,& ! intent(out): [dp(:)] heat capacity for snow and soil + ! Cm + scalarCanopyCmTrial => diag_data%var(iLookDIAG%scalarCanopyCm)%dat(1) ,& ! intent(out): [dp] Cm for vegetation canopy (J kg-1) + mLayerCmTrial => diag_data%var(iLookDIAG%mLayerCm)%dat & ! intent(out): [dp(:)] Cm for each layer (J m-3) + ) ! association to variables in the data structures + ! -------------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message="eval8summa/" + + ! check the feasibility of the solution always with BE homegrown but not inside Sundials solver + feasible=.true. + if (.not.insideSUN) then + call checkFeas(& + ! input + stateVec, & ! intent(in): model state vector (mixed units) + mpar_data, & ! intent(in): model parameters + prog_data, & ! intent(in): model prognostic variables for a local HRU + indx_data, & ! intent(in): indices defining model states and layers + .false., & ! intent(in): currently never using enthalpy as state vector in BE + ! output: feasibility + feasible, & ! intent(inout): flag to denote the feasibility of the solution + ! output: error control + err,cmessage) ! intent(out): error control + + ! early return for non-feasible solutions + if(.not.feasible)then + fluxVec(:) = realMissing + resVec(:) = quadMissing + fEval = realMissing + message=trim(message)//trim(cmessage)//'non-feasible' + return + end if + end if ! ( feasibility check ) + + if(ixNrgConserv == enthalpyForm .or. ixNrgConserv == enthalpyFormLU)then + ! use mixed form of energy equation, need these true to use for Jacobian + updateStateCp = .true. + updateFluxCp = .true. + needStateCm = .true. + else if(ixNrgConserv == closedForm)then ! have a choice, temperature the state variable + updateStateCp = updateCp_closedForm + updateFluxCp = updateCp_closedForm + needStateCm = needCm_closedForm + else + message=trim(message)//'unknown choice of variable in energy conservation backward Euler residual' + err=1; return + end if + + ! get the start and end indices for the soil compression calculations + if(scalarSolution)then + jState = pack(ixControlVolume, ixMapFull2Subset/=integerMissing) + ixBeg = jState(1) + ixEnd = jState(1) + else + ixBeg = 1 + ixEnd = nSoil + endif + + ! initialize to state variable from the last update incase splitting is used + scalarCanairTempTrial = scalarCanairTemp + scalarCanopyTempTrial = scalarCanopyTemp + scalarCanopyWatTrial = scalarCanopyWat + scalarCanopyLiqTrial = scalarCanopyLiq + scalarCanopyIceTrial = scalarCanopyIce + mLayerTempTrial = mLayerTemp + mLayerVolFracWatTrial = mLayerVolFracWat + mLayerVolFracLiqTrial = mLayerVolFracLiq + mLayerVolFracIceTrial = mLayerVolFracIce + mLayerMatricHeadTrial = mLayerMatricHead + mLayerMatricHeadLiqTrial = mLayerMatricHeadLiq + scalarAquiferStorageTrial = scalarAquiferStorage + scalarCanairEnthalpyTrial = scalarCanairEnthalpy + scalarCanopyEnthTempTrial = scalarCanopyEnthTemp + mLayerEnthTempTrial = mLayerEnthTemp + + ! extract variables from the model state vector + call varExtract(& + ! input + stateVec, & ! intent(in): model state vector (mixed units) + indx_data, & ! intent(in): indices defining model states and layers + ! output: variables for the vegetation canopy + scalarCanairTempTrial, & ! intent(inout): trial value of canopy air temperature (K) + scalarCanopyTempTrial, & ! intent(inout): trial value of canopy temperature (K) + scalarCanopyWatTrial, & ! intent(inout): trial value of canopy total water (kg m-2) + scalarCanopyLiqTrial, & ! intent(inout): trial value of canopy liquid water (kg m-2) + ! output: variables for the snow-soil domain + mLayerTempTrial, & ! intent(inout): trial vector of layer temperature (K) + mLayerVolFracWatTrial, & ! intent(inout): trial vector of volumetric total water content (-) + mLayerVolFracLiqTrial, & ! intent(inout): trial vector of volumetric liquid water content (-) + mLayerMatricHeadTrial, & ! intent(inout): trial vector of total water matric potential (m) + mLayerMatricHeadLiqTrial, & ! intent(inout): trial vector of liquid water matric potential (m) + ! output: variables for the aquifer + scalarAquiferStorageTrial, & ! intent(inout): trial value of storage of water in the aquifer (m) + ! output: error control + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) + + ! update diagnostic variables and derivatives + call updateVars(& + ! input + ixNrgConserv.ne.closedForm, & ! intent(in): flag if computing temperature compoment of enthalpy + ixNrgConserv==enthalpyFormLU, & ! intent(in): flag to use the lookup table for soil temperature-enthalpy + .false., & ! intent(in): logical flag to adjust temperature to account for the energy used in melt+freeze + mpar_data, & ! intent(in): model parameters for a local HRU + indx_data, & ! intent(in): indices defining model states and layers + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables + lookup_data, & ! intent(in): lookup table data structure + scalarCanairTempTrial, & ! intent(in): trial value of canopy air space temperature (K) + ! output: variables for the vegetation canopy + scalarCanopyTempTrial, & ! intent(inout): trial value for canopy temperature (K) + scalarCanopyWatTrial, & ! intent(inout): trial value for canopy total water (kg m-2) + scalarCanopyLiqTrial, & ! intent(inout): trial value for canopy liquid water (kg m-2) + scalarCanopyIceTrial, & ! intent(inout): trial value for canopy ice content (kg m-2) + ! output: variables for the snow-soil domain + mLayerTempTrial, & ! intent(inout): trial vector of layer temperature (K) + mLayerVolFracWatTrial, & ! intent(inout): trial vector of volumetric total water content (-) + mLayerVolFracLiqTrial, & ! intent(inout): trial vector of volumetric liquid water content (-) + mLayerVolFracIceTrial, & ! intent(inout): trial vector of volumetric ice water content (-) + mLayerMatricHeadTrial, & ! intent(inout): trial vector of total water matric potential (m) + mLayerMatricHeadLiqTrial, & ! intent(inout): trial vector of liquid water matric potential (m) + ! output: enthalpy state variables + scalarCanairEnthalpyTrial, & ! intent(inout): trial value for enthalpy of the canopy air space (J m-3) + scalarCanopyEnthTempTrial, & ! intent(inout): trial value for temperature component of enthalpy of the vegetation canopy (J m-3) + mLayerEnthTempTrial, & ! intent(inout): trial vector of temperature component of enthalpy of each snow+soil layer (J m-3) + ! output: error control + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) + + if(updateStateCp)then + ! *** compute volumetric heat capacity C_p + call computHeatCapAnalytic(& + ! input: state variables + canopyDepth, & ! intent(in): canopy depth (m) + scalarCanopyIceTrial, & ! intent(in): trial value for mass of ice on the vegetation canopy (kg m-2) + scalarCanopyLiqTrial, & ! intent(in): trial value for the liquid water on the vegetation canopy (kg m-2) + scalarCanopyTempTrial, & ! intent(in): trial value of canopy temperature (K) + mLayerVolFracIceTrial, & ! intent(in): volumetric fraction of ice at the start of the sub-step (-) + mLayerVolFracLiqTrial, & ! intent(in): fraction of liquid water at the start of the sub-step (-) + mLayerTempTrial, & ! intent(in): trial value of layer temperature (K) + mLayerMatricHeadTrial, & ! intent(in): trial total water matric potential (m) + ! input: pre-computed derivatives + dTheta_dTkCanopy, & ! intent(in): derivative in canopy volumetric liquid water content w.r.t. temperature (K-1) + scalarFracLiqVeg, & ! intent(in): fraction of canopy liquid water (-) + mLayerdTheta_dTk, & ! intent(in): derivative of volumetric liquid water content w.r.t. temperature (K-1) + mLayerFracLiqSnow, & ! intent(in): fraction of liquid water (-) + dVolTot_dPsi0, & ! intent(in): derivative in total water content w.r.t. total water matric potential (m-1) + ! input output data structures + mpar_data, & ! intent(in): model parameters + indx_data, & ! intent(in): model layer indices + ! output + heatCapVegTrial, & ! intent(inout): volumetric heat capacity of vegetation canopy + mLayerHeatCapTrial, & ! intent(inout): volumetric heat capacity of soil and snow + dVolHtCapBulk_dPsi0, & ! intent(inout): derivative in bulk heat capacity w.r.t. matric potential + dVolHtCapBulk_dTheta, & ! intent(inout): derivative in bulk heat capacity w.r.t. volumetric water content + dVolHtCapBulk_dCanWat, & ! intent(inout): derivative in bulk heat capacity w.r.t. volumetric water content + dVolHtCapBulk_dTk, & ! intent(inout): derivative in bulk heat capacity w.r.t. temperature + dVolHtCapBulk_dTkCanopy, & ! intent(inout): derivative in bulk heat capacity w.r.t. temperature + ! output: error control + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! compute multiplier of state vector + call computStatMult(& + ! input + heatCapVegTrial, & ! intent(in): volumetric heat capacity of vegetation canopy + mLayerHeatCapTrial, & ! intent(in): volumetric heat capacity of soil and snow + indx_data, & ! intent(in): indices defining model states and layers + ! output + sMul, & ! intent(out): multiplier for state vector (used in the residual calculations) + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (check for errors) + else + ! set state heat capacity derivatives to 0 for constant through step + dVolHtCapBulk_dPsi0 = 0._rkind + dVolHtCapBulk_dTheta = 0._rkind + dVolHtCapBulk_dCanWat = 0._rkind + dVolHtCapBulk_dTk = 0._rkind + dVolHtCapBulk_dTkCanopy = 0._rkind + endif ! updateStateCp + + if(updateFluxCp)then + ! update thermal conductivity + call computThermConduct(& + ! input: control variables + nLayers, & ! intent(in): total number of layers + ! input: state variables + mLayerTempTrial, & ! intent(in): trial temperature of layer temperature (K) + mLayerMatricHeadTrial, & ! intent(in): trial value for total water matric potential (m) + mLayerVolFracIceTrial, & ! intent(in): volumetric fraction of ice at the start of the sub-step (-) + mLayerVolFracLiqTrial, & ! intent(in): volumetric fraction of liquid water at the start of the sub-step (-) + ! input: pre-computed derivatives + mLayerdTheta_dTk, & ! intent(in): derivative in volumetric liquid water content w.r.t. temperature (K-1) + mLayerFracLiqSnow, & ! intent(in): fraction of liquid water (-) + ! input/output: data structures + mpar_data, & ! intent(in): model parameters + indx_data, & ! intent(in): model layer indices + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + ! output: derivatives + dThermalC_dWatAbove, & ! intent(out): derivative in the thermal conductivity w.r.t. water state in the layer above + dThermalC_dWatBelow, & ! intent(out): derivative in the thermal conductivity w.r.t. water state in the layer above + dThermalC_dTempAbove, & ! intent(out): derivative in the thermal conductivity w.r.t. energy state in the layer above + dThermalC_dTempBelow, & ! intent(out): derivative in the thermal conductivity w.r.t. energy state in the layer above + ! output: error control + err,cmessage) ! intent(out): error control + if(err/=0)then; err=55; message=trim(message)//trim(cmessage); return; end if + else + ! set flux heat capacity derivatives to 0 for constant through step + dThermalC_dWatAbove = 0._rkind + dThermalC_dWatBelow = 0._rkind + dThermalC_dTempAbove = 0._rkind + dThermalC_dTempBelow = 0._rkind + endif ! updateFluxCp + + if(needStateCm)then + ! compute C_m + call computCm(& ! input: state variables - scalarCanairTempTrial, & ! intent(in): trial value for the temperature of the canopy air space (K) - scalarCanopyTempTrial, & ! intent(in): trial value for the temperature of the vegetation canopy (K) - mLayerTempTrial, & ! intent(in): trial value for the temperature of each snow and soil layer (K) - mLayerMatricHeadLiqTrial, & ! intent(in): trial value for the liquid water matric potential in each soil layer (m) - scalarAquiferStorageTrial, & ! intent(in): trial value of storage of water in the aquifer (m) - ! input: diagnostic variables defining the liquid water and ice content - scalarCanopyLiqTrial, & ! intent(in): trial value for the liquid water on the vegetation canopy (kg m-2) - scalarCanopyIceTrial, & ! intent(in): trial value for the ice on the vegetation canopy (kg m-2) - mLayerVolFracLiqTrial, & ! intent(in): trial value for the volumetric liquid water content in each snow and soil layer (-) - mLayerVolFracIceTrial, & ! intent(in): trial value for the volumetric ice in each snow and soil layer (-) - ! input: data structures - model_decisions, & ! intent(in): model decisions - type_data, & ! intent(in): type of vegetation and soil - attr_data, & ! intent(in): spatial attributes + scalarCanopyTempTrial, & ! intent(in): trial value of canopy temperature (K) + mLayerTempTrial, & ! intent(in): trial value of layer temperature (K) + mLayerMatricHeadTrial, & ! intent(in): trial value for total water matric potential (-) + ! input data structures mpar_data, & ! intent(in): model parameters - forc_data, & ! intent(in): model forcing data - bvar_data, & ! intent(in): average model variables for the entire basin - prog_data, & ! intent(in): model prognostic variables for a local HRU - indx_data, & ! intent(in): index data - ! input-output: data structures - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - flux_data, & ! intent(inout): model fluxes for a local HRU - deriv_data, & ! intent(out): derivatives in model fluxes w.r.t. relevant state variables - ! input-output: flux vector and baseflow derivatives - ixSaturation, & ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) - dBaseflow_dMatric, & ! intent(out): derivative in baseflow w.r.t. matric head (s-1) - fluxVec, & ! intent(out): flux vector (mixed units) - ! output: error control - err,cmessage) ! intent(out): error code and error message - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - - ! compute soil compressibility (-) and its derivative w.r.t. matric head (m) - ! NOTE: we already extracted trial matrix head and volumetric liquid water as part of the flux calculations - call soilCmpres(& - ! input: - ixRichards, & ! intent(in): choice of option for Richards' equation - ixBeg,ixEnd, & ! intent(in): start and end indices defining desired layers - mLayerMatricHeadLiq(1:nSoil), & ! intent(in): matric head at the start of the time step (m) - mLayerMatricHeadLiqTrial(1:nSoil), & ! intent(in): trial value of matric head (m) - mLayerVolFracLiqTrial(nSnow+1:nLayers), & ! intent(in): trial value for the volumetric liquid water content in each soil layer (-) - mLayerVolFracIceTrial(nSnow+1:nLayers), & ! intent(in): trial value for the volumetric ice content in each soil layer (-) - specificStorage, & ! intent(in): specific storage coefficient (m-1) - theta_sat, & ! intent(in): soil porosity (-) - ! output: - mLayerCompress, & ! intent(inout): compressibility of the soil matrix (-) - dCompress_dPsi, & ! intent(inout): derivative in compressibility w.r.t. matric head (m-1) - err,cmessage) ! intent(out): error code and error message - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - - ! compute the total change in storage associated with compression of the soil matrix (kg m-2) - scalarSoilCompress = sum(mLayerCompress(1:nSoil)*mLayerDepth(nSnow+1:nLayers))*iden_water - - ! vegetation domain: get the correct water states (total water, or liquid water, depending on the state type) - if(computeVegFlux)then - scalarCanopyHydTrial = merge(scalarCanopyWatTrial, scalarCanopyLiqTrial, (ixStateType( ixHydCanopy(ixVegVolume) )==iname_watCanopy) ) - else - scalarCanopyHydTrial = realMissing - endif - - ! snow+soil domain: get the correct water states (total water, or liquid water, depending on the state type) - mLayerVolFracHydTrial = merge(mLayerVolFracWatTrial, mLayerVolFracLiqTrial, (ixHydType==iname_watLayer .or. ixHydType==iname_matLayer) ) - - ! compute the residual vector - call computResid(& - ! input: model control - dt, & ! intent(in): length of the time step (seconds) - nSnow, & ! intent(in): number of snow layers - nSoil, & ! intent(in): number of soil layers - nLayers, & ! intent(in): total number of layers - ! input: flux vectors - sMul, & ! intent(in): state vector multiplier (used in the residual calculations) - fluxVec, & ! intent(in): flux vector - ! input: state variables (already disaggregated into scalars and vectors) - scalarCanairTempTrial, & ! intent(in): trial value for the temperature of the canopy air space (K) - scalarCanopyTempTrial, & ! intent(in): trial value for the temperature of the vegetation canopy (K) - scalarCanopyHydTrial, & ! intent(in): trial value of canopy hydrology state variable (kg m-2) - mLayerTempTrial, & ! intent(in): trial value for the temperature of each snow and soil layer (K) - mLayerVolFracHydTrial, & ! intent(in): trial vector of volumetric water content (-) - scalarAquiferStorageTrial, & ! intent(in): trial value of storage of water in the aquifer (m) - ! input: diagnostic variables defining the liquid water and ice content (function of state variables) - scalarCanopyIceTrial, & ! intent(in): trial value for the ice on the vegetation canopy (kg m-2) - mLayerVolFracIceTrial, & ! intent(in): trial value for the volumetric ice in each snow and soil layer (-) - ! input: data structures - prog_data, & ! intent(in): model prognostic variables for a local HRU - diag_data, & ! intent(in): model diagnostic variables for a local HRU - flux_data, & ! intent(in): model fluxes for a local HRU - indx_data, & ! intent(in): index data - ! output - resSink, & ! intent(out): additional (sink) terms on the RHS of the state equation - resVec, & ! intent(out): residual vector - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - - ! compute the function evaluation - rVecScaled = fScale(:)*real(resVec(:), rkind) ! scale the residual vector (NOTE: residual vector is in quadruple precision) - fEval = 0.5_rkind*dot_product(rVecScaled,rVecScaled) - - ! end association with the information in the data structures - end associate - - end subroutine eval8summa + indx_data, & ! intent(in): model layer indices + ! output + scalarCanopyCmTrial, & ! intent(inout): Cm for vegetation canopy (J kg-1) + mLayerCmTrial, & ! intent(inout): Cm for each layer (J m-3) + dCm_dPsi0, & ! intent(inout): derivative in Cm w.r.t. matric potential (J kg) + dCm_dTk, & ! intent(inout): derivative in Cm w.r.t. temperature (J kg K-2) + dCm_dTkCanopy, & ! intent(inout): derivative in Cm w.r.t. temperature (J kg K-2) + err,cmessage) ! intent(inout): error control + else + scalarCanopyCmTrial = 0._rkind + mLayerCmTrial = 0._rkind + dCm_dPsi0 = 0._rkind + dCm_dTk = 0._rkind + dCm_dTkCanopy = 0._rkind + endif ! needStateCm + + ! save the number of flux calls per time step + indx_data%var(iLookINDEX%numberFluxCalc)%dat(1) = indx_data%var(iLookINDEX%numberFluxCalc)%dat(1) + 1 + + ! only need to check longwave balance with numerical recipes solver + checkLWBalance = .false. + if(ixNumericalMethod==homegrown) checkLWBalance = .true. + + ! compute the fluxes for a given state vector + call computFlux(& + ! input-output: model control + nSnow, & ! intent(in): number of snow layers + nSoil, & ! intent(in): number of soil layers + nLayers, & ! intent(in): total number of layers + firstSubStep, & ! intent(in): flag to indicate if we are processing the first sub-step + firstFluxCall, & ! intent(inout): flag to denote the first flux call + firstSplitOper, & ! intent(in): flag to indicate if we are processing the first flux call in a splitting operation + computeVegFlux, & ! intent(in): flag to indicate if we need to compute fluxes over vegetation + scalarSolution, & ! intent(in): flag to indicate the scalar solution + checkLWBalance, & ! intent(in): flag to check longwave balance + scalarSfcMeltPond/dt, & ! intent(in): drainage from the surface melt pond (kg m-2 s-1) + ! input: state variables + scalarCanairTempTrial, & ! intent(in): trial value for the temperature of the canopy air space (K) + scalarCanopyTempTrial, & ! intent(in): trial value for the temperature of the vegetation canopy (K) + mLayerTempTrial, & ! intent(in): trial value for the temperature of each snow and soil layer (K) + mLayerMatricHeadLiqTrial, & ! intent(in): trial value for the liquid water matric potential in each soil layer (m) + mLayerMatricHeadTrial, & ! intent(in): trial vector of total water matric potential (m) + scalarAquiferStorageTrial, & ! intent(in): trial value of storage of water in the aquifer (m) + ! input: diagnostic variables defining the liquid water and ice content + scalarCanopyLiqTrial, & ! intent(in): trial value for the liquid water on the vegetation canopy (kg m-2) + scalarCanopyIceTrial, & ! intent(in): trial value for the ice on the vegetation canopy (kg m-2) + mLayerVolFracLiqTrial, & ! intent(in): trial value for the volumetric liquid water content in each snow and soil layer (-) + mLayerVolFracIceTrial, & ! intent(in): trial value for the volumetric ice in each snow and soil layer (-) + ! input: data structures + model_decisions, & ! intent(in): model decisions + type_data, & ! intent(in): type of vegetation and soil + attr_data, & ! intent(in): spatial attributes + mpar_data, & ! intent(in): model parameters + forc_data, & ! intent(in): model forcing data + bvar_data, & ! intent(in): average model variables for the entire basin + prog_data, & ! intent(in): model prognostic variables for a local HRU + indx_data, & ! intent(in): index data + ! input-output: data structures + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + flux_data, & ! intent(inout): model fluxes for a local HRU + deriv_data, & ! intent(out): derivatives in model fluxes w.r.t. relevant state variables + ! input-output: flux vector and baseflow derivatives + ixSaturation, & ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) + dBaseflow_dMatric, & ! intent(out): derivative in baseflow w.r.t. matric head (s-1) + fluxVec, & ! intent(out): flux vector (mixed units) + ! output: error control + err,cmessage) ! intent(out): error code and error message + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) + + ! compute soil compressibility (-) and its derivative w.r.t. matric head (m) + ! NOTE: we already extracted trial matrix head and volumetric liquid water as part of the flux calculations + ! use non-prime version + call soilCmpres(& + ! input: + dt_cur, & ! intent(in): length of the time step (seconds) + ixRichards, & ! intent(in): choice of option for Richards' equation + ixBeg,ixEnd, & ! intent(in): start and end indices defining desired layers + mLayerMatricHead(1:nSoil), & ! intent(in): matric head at the start of the time step (m) + mLayerMatricHeadTrial(1:nSoil), & ! intent(in): trial value of matric head (m) + mLayerVolFracLiqTrial(nSnow+1:nLayers), & ! intent(in): trial value for the volumetric liquid water content in each soil layer (-) + mLayerVolFracIceTrial(nSnow+1:nLayers), & ! intent(in): trial value for the volumetric ice content in each soil layer (-) + specificStorage, & ! intent(in): specific storage coefficient (m-1) + theta_sat, & ! intent(in): soil porosity (-) + ! output: + mLayerCompress, & ! intent(inout): compressibility of the soil matrix (-) + dCompress_dPsi, & ! intent(inout): derivative in compressibility w.r.t. matric head (m-1) + err,cmessage) ! intent(out): error code and error message + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) + + ! compute the total change in storage associated with compression of the soil matrix (kg m-2 s-1) + scalarSoilCompress = sum(mLayerCompress(1:nSoil)*mLayerDepth(nSnow+1:nLayers))*iden_water + + ! compute the residual vector + call computResid(& + ! input: model control + dt_cur, & ! intent(in): length of the time step (seconds) + nSnow, & ! intent(in): number of snow layers + nSoil, & ! intent(in): number of soil layers + nLayers, & ! intent(in): total number of layers + ixNrgConserv.ne.closedForm, & ! intent(in): flag to use enthalpy form of residual + ! input: flux vectors + sMul, & ! intent(in): state vector multiplier (used in the residual calculations) + fluxVec, & ! intent(in): flux vector + ! input: state variables (already disaggregated into scalars and vectors) + scalarCanairTempTrial, & ! intent(in): trial value for the temperature of the canopy air space (K) + scalarCanopyTempTrial, & ! intent(in): trial value for the temperature of the vegetation canopy (K) + scalarCanopyWatTrial, & ! intent(in): trial value for the water on the vegetation canopy (kg m-2) + mLayerTempTrial, & ! intent(in): trial value for the temperature of each snow and soil layer (K) + scalarAquiferStorageTrial, & ! intent(in): trial value of storage of water in the aquifer (m) + ! input: diagnostic variables defining the liquid water and ice content (function of state variables) + scalarCanopyIceTrial, & ! intent(in): trial value for the ice on the vegetation canopy (kg m-2) + scalarCanopyLiqTrial, & ! intent(in): trial value for the liq on the vegetation canopy (kg m-2) + mLayerVolFracIceTrial, & ! intent(in): trial value for the volumetric ice in each snow and soil layer (-) + mLayerVolFracWatTrial, & ! intent(in): trial value for the volumetric water in each snow and soil layer (-) + mLayerVolFracLiqTrial, & ! intent(in): trial value for the volumetric liq in each snow and soil layer (-) + ! input: enthalpy terms + scalarCanopyCmTrial, & ! intent(in): Cm for vegetation canopy (J kg-1) + mLayerCmTrial, & ! intent(in): Cm for each layer (J m-3) + scalarCanairEnthalpyTrial, & ! intent(in): trial value for enthalpy of the canopy air space (J m-3) + scalarCanopyEnthTempTrial, & ! intent(in): trial value for temperature component of enthalpy of the vegetation canopy (J m-3) + mLayerEnthTempTrial, & ! intent(in): trial vector of temperature component of enthalpy of each snow+soil layer (J m-3) + ! input: data structures + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(in): model diagnostic variables for a local HRU + flux_data, & ! intent(in): model fluxes for a local HRU + indx_data, & ! intent(in): index data + ! output + resSink, & ! intent(out): additional (sink) terms on the RHS of the state equation + resVec, & ! intent(out): residual vector + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) + + ! compute the function evaluation + rVecScaled = fScale(:)*real(resVec(:), rkind) ! scale the residual vector (NOTE: residual vector is in quadruple precision) + fEval = 0.5_rkind*dot_product(rVecScaled,rVecScaled) + + ! end association with the information in the data structures + end associate + +end subroutine eval8summa + +#ifdef SUNDIALS_ACTIVE +! ********************************************************************************************************** +! public function eval8summa4kinsol: compute the residual vector F(t,y) required for KINSOL solver +! ********************************************************************************************************** +! Return values: +! 0 = success, +! 1 = recoverable error, +! -1 = non-recoverable error +! ---------------------------------------------------------------- +integer(c_int) function eval8summa4kinsol(sunvec_y, sunvec_r, user_data) & + result(ierr) bind(C,name='eval8summa4kinsol') + + !======= Inclusions =========== + use, intrinsic :: iso_c_binding + use fsundials_core_mod + use fnvector_serial_mod + use type4kinsol + + !======= Declarations ========= + implicit none + + ! calling variables + type(N_Vector) :: sunvec_y ! solution N_Vector y + type(N_Vector) :: sunvec_r ! residual N_Vector F(t,y) + type(c_ptr), value :: user_data ! user-defined data + + ! pointers to data in SUNDIALS vectors + type(data4kinsol), pointer :: eqns_data ! equations data + real(rkind), pointer :: stateVec(:) ! solution vector + real(rkind), pointer :: rVec(:) ! residual vector + logical(lgt) :: feasible ! feasibility of state vector + real(rkind) :: fNew ! function values, not needed here + integer(i4b) :: err ! error in imposeConstraints + character(len=256) :: message ! error message of downwind routine + !======= Internals ============ + + ! get equations data from user-defined data + call c_f_pointer(user_data, eqns_data) + + ! get data arrays from SUNDIALS vectors + stateVec(1:eqns_data%nState) => FN_VGetArrayPointer(sunvec_y) + rVec(1:eqns_data%nState) => FN_VGetArrayPointer(sunvec_r) + + ! increment the proposed iteration for simple error control if needed + if (eqns_data%firstStateiteration) then + eqns_data%firstStateIteration = .false. + else + call imposeConstraints(eqns_data%model_decisions,eqns_data%indx_data,eqns_data%prog_data,eqns_data%mpar_data,stateVec(:), & + eqns_data%stateVecPrev, eqns_data%nState, eqns_data%nSoil, eqns_data%nSnow, message, err) + if(err/=0)then; ierr=1; message="eval8summa4kinsol/"//trim(message); print*, message; return; end if ! (check for errors) + endif + eqns_data%stateVecPrev = stateVec(:) ! save the state vector for the next iteration + + ! compute the flux and the residual vector for a given state vector + call eval8summa(& + ! input: model control + eqns_data%dt_cur, & ! intent(in): current stepsize + eqns_data%dt, & ! intent(in): data step + eqns_data%nSnow, & ! intent(in): number of snow layers + eqns_data%nSoil, & ! intent(in): number of soil layers + eqns_data%nLayers, & ! intent(in): number of layers + eqns_data%nState, & ! intent(in): number of state variables in the current subset + .true., & ! intent(in): inside SUNDIALS solver + eqns_data%firstSubStep, & ! intent(in): flag to indicate if we are processing the first sub-step + eqns_data%firstFluxCall, & ! intent(inout): flag to indicate if we are processing the first flux call + eqns_data%firstSplitOper, & ! intent(in): flag to indicate if we are processing the first flux call in a splitting operation + eqns_data%computeVegFlux, & ! intent(in): flag to indicate if we need to compute fluxes over vegetation + eqns_data%scalarSolution, & ! intent(in): flag to indicate the scalar solution + ! input: state vectors + stateVec, & ! intent(in): model state vector + eqns_data%fScale, & ! intent(in): characteristic scale of the function evaluations + eqns_data%sMul, & ! intent(inout): state vector multiplier (used in the residual calculations) + ! input: data structures + eqns_data%model_decisions, & ! intent(in): model decisions + eqns_data%lookup_data, & ! intent(in): lookup data + eqns_data%type_data, & ! intent(in): type of vegetation and soil + eqns_data%attr_data, & ! intent(in): spatial attributes + eqns_data%mpar_data, & ! intent(in): model parameters + eqns_data%forc_data, & ! intent(in): model forcing data + eqns_data%bvar_data, & ! intent(in): average model variables for the entire basin + eqns_data%prog_data, & ! intent(in): model prognostic variables for a local HRU + ! input-output: data structures + eqns_data%indx_data, & ! intent(inout): index data + eqns_data%diag_data, & ! intent(inout): model diagnostic variables for a local HRU + eqns_data%flux_data, & ! intent(inout): model fluxes for a local HRU (initial flux structure) + eqns_data%deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables + ! input-output: baseflow + eqns_data%ixSaturation, & ! intent(inout): index of the lowest saturated layer + eqns_data%dBaseflow_dMatric, & ! intent(out): derivative in baseflow w.r.t. matric head (s-1) + ! output: flux and residual vectors + feasible, & ! intent(out): flag to denote the feasibility of the solution always true inside SUNDIALS + eqns_data%fluxVec, & ! intent(out): flux vector + eqns_data%resSink, & ! intent(out): additional (sink) terms on the RHS of the state equation + rVec, & ! intent(out): residual vector + fNew, & ! intent(out): new function evaluation + eqns_data%err,eqns_data%message) ! intent(out): error control + if(eqns_data%err > 0)then; eqns_data%message=trim(eqns_data%message); ierr=-1; return; endif + if(eqns_data%err < 0)then; eqns_data%message=trim(eqns_data%message); ierr=1; return; endif + + ! save residual and return success + eqns_data%resVec = rVec + ierr = 0 + return + +end function eval8summa4kinsol +#endif + +! *************************************************************************************************************************************** +! public subroutine imposeConstraints: impose solution constraints +! This is simple error control to reduce possible temperature increments, cross over freezing point events, and keep the state feasible +! Imposed after the internal call of KINSOL incrementing the linesearch +! *************************************************************************************************************************************** +subroutine imposeConstraints(model_decisions,indx_data, prog_data, mpar_data, stateVec, stateVecPrev,& + nState, nSoil, nSnow, message, err) + ! external functions + USE snow_utils_module,only:fracliquid ! compute the fraction of liquid water at a given temperature (snow) + USE soil_utils_module,only:crit_soilT ! compute the critical temperature below which ice exists + USE soil_utils_module,only:matricHead ! compute the matric head based on volumetric water content + USE soil_utils_module,only:volFracLiq ! compute volumetric fraction of liquid water + + implicit none + + type(model_options),intent(in) :: model_decisions(:) ! model decisions + type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers + type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU + type(var_dlength),intent(in) :: mpar_data ! model parameters + real(rkind), intent(inout) :: stateVec(:) ! state vector + real(rkind), intent(in) :: stateVecPrev(:) ! previous state vector + integer(i4b),intent(in) :: nState ! total number of state variables + integer(i4b),intent(in) :: nSoil ! number of soil layers + integer(i4b),intent(in) :: nSnow ! number of snow layers + integer(i4b),intent(out) :: err ! error code + character(len=256),intent(out) :: message ! error message + ! ----------------------------------------------------------------------------------------------------- + ! temporary variables for model constraints + real(qp),dimension(nState) :: xInc ! iteration increment + real(rkind) :: scalarTemp ! temperature of an individual snow layer (K) + real(rkind) :: scalarIce ! volumetric ice content of an individual layer (-) + real(rkind) :: scalarLiq ! volumetric liquid water content of an individual layer (-) + real(rkind) :: xPsi00 ! matric head after applying the iteration increment (m) + real(rkind) :: TcSoil ! critical point when soil begins to freeze (K) + real(rkind) :: critDiff ! temperature difference from critical (K) + real(rkind) :: epsT ! small interval above/below critical (K) + real(rkind) :: zMaxTempIncrement ! maximum temperature increment (K) + real(rkind) :: zMaxMatricIncrement ! maximum matric head increment (m) + real(rkind) :: xConst ! constant in the freezing curve function (m K-1) + real(rkind) :: mLayerPsiLiq ! liquid water matric potential (m) + real(rkind) :: vGn_m(nSoil) ! van Genutchen "m" parameter (-) + real(rkind) :: effSat ! effective saturation (-) + real(rkind) :: avPore ! available pore space (-) + ! indices of model state variables + integer(i4b) :: iState ! index of state within a specific variable type + integer(i4b) :: ixNrg,ixLiq ! index of energy and mass state variables in full state vector + ! indices of model layers + integer(i4b) :: iLayer ! index of model layer + ! choice of constraints to impose + logical(lgt) :: small_delTemp ! flag to constain temperature change to be less than zMaxTempIncrement + logical(lgt) :: small_delMatric ! flag to constain matric head change to be less than zMaxMatricIncrement + logical(lgt) :: detect_events ! flag to do freezing point event detection and cross-over with epsT + logical(lgt) :: water_bounds ! flag to force water to not go above or below physical bounds + + ! ----------------------------------------------------------------------------------------------------- + ! association to variables in the data structures + associate(& + ! model decisions + ixNumericalMethod => model_decisions(iLookDECISIONS%num_method)%iDecision ,& ! intent(in): [i4b] choice of numerical solver + ! indices of model state variables + ixNrgOnly => indx_data%var(iLookINDEX%ixNrgOnly)%dat ,& ! intent(in): [i4b(:)] list of indices in the state subset for energy states + ixHydOnly => indx_data%var(iLookINDEX%ixHydOnly)%dat ,& ! intent(in): [i4b(:)] list of indices in the state subset for hydrology states + ixMatOnly => indx_data%var(iLookINDEX%ixMatOnly)%dat ,& ! intent(in): [i4b(:)] list of indices in the state subset for matric head states + ixMassOnly => indx_data%var(iLookINDEX%ixMassOnly)%dat ,& ! intent(in): [i4b(:)] list of indices in the state subset for canopy storage states + ixHydType => indx_data%var(iLookINDEX%ixHydType)%dat ,& ! intent(in): [i4b(:)] index of the type of hydrology states in snow+soil domain + ixStateType_subset => indx_data%var(iLookINDEX%ixStateType_subset)%dat ,& ! intent(in): [i4b(:)] named variables defining the states in the subset + ! indices for specific state variables + ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy air space energy state variable + ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable + ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) + ixTopNrg => indx_data%var(iLookINDEX%ixTopNrg)%dat(1) ,& ! intent(in): [i4b] index of upper-most energy state in the snow-soil subdomain + ixTopHyd => indx_data%var(iLookINDEX%ixTopHyd)%dat(1) ,& ! intent(in): [i4b] index of upper-most hydrology state in the snow-soil subdomain + ! vector of energy indices for the snow and soil domains + ! NOTE: states not in the subset are equal to integerMissing + ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the snow+soil domain + ixSnowOnlyNrg => indx_data%var(iLookINDEX%ixSnowOnlyNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the snow domain + ixSoilOnlyNrg => indx_data%var(iLookINDEX%ixSoilOnlyNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the soil domain + ! vector of hydrology indices for the snow and soil domains + ! NOTE: states not in the subset are equal to integerMissing + ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the snow+soil domain + ixSnowOnlyHyd => indx_data%var(iLookINDEX%ixSnowOnlyHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the snow domain + ixSoilOnlyHyd => indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the soil domain + ! number of state variables of a specific type + nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg )%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow+soil domain + nSnowOnlyNrg => indx_data%var(iLookINDEX%nSnowOnlyNrg )%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow domain + nSoilOnlyNrg => indx_data%var(iLookINDEX%nSoilOnlyNrg )%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the soil domain + nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the snow+soil domain + nSnowOnlyHyd => indx_data%var(iLookINDEX%nSnowOnlyHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the snow domain + nSoilOnlyHyd => indx_data%var(iLookINDEX%nSoilOnlyHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the soil domain + ! snow parameters + snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1) ,& ! intent(in): [dp] scaling parameter for the snow freezing curve (K-1) + ! soil parameters + theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat ,& ! intent(in): [dp(:)] soil porosity (-) + theta_res => mpar_data%var(iLookPARAM%theta_res)%dat ,& ! intent(in): [dp(:)] residual volumetric water content (-) + vGn_n => mpar_data%var(iLookPARAM%vGn_n)%dat ,& ! intent(in): [dp(:)] van Genutchen "n" parameter (-) + vGn_alpha => mpar_data%var(iLookPARAM%vGn_alpha)%dat ,& ! intent(in): [dp(:)] van Genutchen "alpha" parameter (m-1) + ! state variables at the start of the time step + mLayerMatricHead => prog_data%var(iLookPROG%mLayerMatricHead)%dat ,& ! intent(in): [dp(:)] matric head (m) + mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat & ! intent(in): [dp(:)] volumetric fraction of ice (-) + ) ! associating variables with indices of model state variables + ! ----------------------------------------------------------------------------------------------------- + + ! initialize error control + err=0; message='imposeConstraints/' + + ! calculate proposed increment in state vector + xInc(1:nState) = stateVec(1:nState)*1._qp - stateVecPrev(1:nState)*1._qp + + ! identify which constraints to impose + select case(ixNumericalMethod) + case(ida); err=20; message=trim(message)//'should not be imposing constraints for IDA solver'; return + case(kinsol) + small_delTemp = .true. ! flag to constain temperature change to be less than zMaxTempIncrement + zMaxTempIncrement = 10._rkind ! maximum temperature increment (K) + small_delMatric = .true. ! flag to constain matric head change to be less than zMaxMatricIncrement + zMaxMatricIncrement = 10._rkind ! maximum matric head increment (m) + detect_events = .true. ! flag to do freezing point event detection and cross-over with epsT, works best if on + epsT = 1.e-7_rkind ! small interval above/below critical (K), works better if larger + water_bounds = .true. ! flag to force water bounds, works best if on + case(homegrown) + small_delTemp = .true. ! flag to constain temperature change to be less than zMaxTempIncrement + zMaxTempIncrement = 10._rkind ! maximum temperature increment (K) + small_delMatric = .true. ! flag to constain matric head change to be less than zMaxMatricIncrement + zMaxMatricIncrement = 10._rkind ! maximum matric head increment (m) + detect_events = .true. ! flag to do freezing point event detection and cross-over with epsT + epsT = 1.e-7_rkind ! small interval above/below critical (K) + water_bounds = .true. ! flag to force water bounds + case default; err=20; message=trim(message)//'expect num_method to be ida, kinsol, or homegrown (or itertive, which is homegrown)'; return + end select + + vGn_m = 1._rkind - 1._rkind/vGn_n + + ! ** limit temperature increment to zMaxTempIncrement + ! NOTE: this can cause problems especially from a cold start when far from the solution + if(small_delTemp)then + if(size(ixNrgOnly)>0)then + ! loop through snow+soil layers + do iState=1,size(ixNrgOnly) + ! define index of the energy state variable within the state subset + ixNrg = ixNrgOnly(iState) + ! place constraint for temperature + if(abs(xInc(ixNrg)) > zMaxTempIncrement) xInc(ixNrg) = sign(zMaxTempIncrement, xInc(ixNrg)) + end do ! (loop through snow+soil layers) + endif + endif ! (small temperature change) + + ! ** limit soil water (matric head) increment to zMaxMatricIncrement if starting positive + if(small_delMatric)then + if(size(ixMatOnly)>0)then + ! loop through soil layers + do iState=1,size(ixMatOnly) + ! define index of the hydrology state variable within the state subset + ixLiq = ixMatOnly(iState) + ! place constraint for matric head + if(xInc(ixLiq) > zMaxMatricIncrement .and. stateVecPrev(ixLiq) > 0._rkind) xInc(ixLiq) = zMaxMatricIncrement + end do ! (loop through soil layers) + endif + endif ! (small matric head change) + + ! ** stop just above or just below the freezing point if crossing + if(detect_events)then + + ! crossing freezing point event for vegetation + if(ixVegNrg/=integerMissing)then + ! initialize + critDiff = Tfreeze - stateVecPrev(ixVegNrg) + ! initially frozen (T < Tfreeze) + if(critDiff > 0._rkind)then ! (check crossing above zero) + if(xInc(ixVegNrg) > critDiff) xInc(ixVegNrg) = critDiff + epsT ! constrained temperature increment (K) + ! initially unfrozen (T > Tfreeze) + else ! (check crossing below zero) + if(xInc(ixVegNrg) < critDiff) xInc(ixVegNrg) = critDiff - epsT ! constrained temperature increment (K) + end if ! (switch between initially frozen and initially unfrozen) + endif ! if the state variable for canopy temperature is included within the state subset + + ! crossing freezing point event for snow, keep it below freezing + if(nSnowOnlyNrg > 0)then + do iLayer=1,nSnow + ! check if energy state is included + if(ixSnowOnlyNrg(iLayer)==integerMissing) cycle + ! check temperatures, and, if necessary, scale iteration increment + iState = ixSnowOnlyNrg(iLayer) + ! constrained temperature increment (K) -- simplified bi-section + if(stateVecPrev(iState) + xInc(iState) > Tfreeze) xInc(iState) = 0.5_rkind*(Tfreeze - stateVecPrev(iState) ) + end do ! (loop through snow layers) + endif ! (if there are state variables for energy in the snow domain) + + ! crossing freezing point event for soil + if(nSoilOnlyNrg>0)then + do iLayer=1,nSoil + ! check if energy state is included + if(ixSoilOnlyNrg(iLayer)==integerMissing) cycle + ! define index of the state variables within the state subset + ixNrg = ixSoilOnlyNrg(iLayer) + ixLiq = ixSoilOnlyHyd(iLayer) + ! get the matric potential of total water + if(ixLiq/=integerMissing)then + select case( ixStateType_subset( ixSoilOnlyHyd(iLayer) ) ) + case(iname_lmpLayer) + effSat = volFracLiq(stateVecPrev(ixLiq) + xInc(ixLiq),vGn_alpha(iLayer),0._rkind,1._rkind,vGn_n(iLayer),vGn_m(iLayer)) ! effective saturation + avPore = theta_sat(iLayer) - mLayerVolFracIce(iLayer+nSnow) - theta_res(iLayer) ! available pore space + scalarLiq = effSat*avPore + theta_res(iLayer) + xPsi00 = matricHead(scalarLiq + mLayerVolFracIce(iLayer+nSnow),vGn_alpha(iLayer),theta_res(iLayer),theta_sat(iLayer),vGn_n(iLayer),vGn_m(iLayer)) + case(iname_matLayer); xPsi00 = stateVecPrev(ixLiq) + xInc(ixLiq) ! only true if using iname_matLayer, otherwise may want to fix this + case(iname_watLayer); xPsi00 = matricHead(stateVecPrev(ixLiq) + xInc(ixLiq),vGn_alpha(iLayer),theta_res(iLayer),theta_sat(iLayer),vGn_n(iLayer),vGn_m(iLayer)) + case(iname_liqLayer) + xPsi00 = matricHead(mLayerVolFracIce(iLayer+nSnow) + stateVecPrev(ixLiq) + xInc(ixLiq),vGn_alpha(iLayer),theta_res(iLayer),theta_sat(iLayer),vGn_n(iLayer),vGn_m(iLayer)) + case default; err=20; message=trim(message)//'expect ixStateType_subset to be iname_matLayer, iname_lmpLayer, iname_watLayer, or iname_liqLayer for soil hydrology'; return + end select + else + xPsi00 = mLayerMatricHead(iLayer) + endif + ! identify the critical point when soil begins to freeze (TcSoil) + TcSoil = crit_soilT(xPsi00) + ! get the difference from the current state and the crossing point (K) + critDiff = TcSoil - stateVecPrev(ixNrg) + ! initially frozen (T < TcSoil) + if(critDiff > 0._rkind)then ! (check crossing above zero) + if(xInc(ixNrg) > critDiff) xInc(ixNrg) = critDiff + epsT ! set iteration increment to slightly above critical temperature + ! initially unfrozen (T > TcSoil) + else ! (check crossing below zero) + if(xInc(ixNrg) < critDiff) xInc(ixNrg) = critDiff - epsT ! set iteration increment to slightly below critical temperature + endif ! (switch between initially frozen and initially unfrozen) + end do ! (loop through soil layers) + endif ! (if there are both energy and liquid water state variables) + + endif ! (detect events) + + ! ** ensure water is within bounds + if(water_bounds)then + + ! impose positivity for canopy liquid water + if(ixVegHyd/=integerMissing)then + ! constrained iteration increment (K) -- simplified bi-section + if(stateVecPrev(ixVegHyd) + xInc(ixVegHyd) < 0._rkind) xInc(ixVegHyd) = -0.5_rkind*stateVecPrev(ixVegHyd) + endif ! (if the state variable for canopy water is included within the state subset) + + ! impose bounds for snow water, change in total water is only due to liquid flux + if(nSnowOnlyHyd>0)then + ! loop through snow layers + do iLayer=1,nSnow + ! check if the layer is included + if(ixSnowOnlyHyd(iLayer)==integerMissing) cycle + if(ixSnowOnlyNrg(iLayer)/=integerMissing)then + ! get the layer temperature (from stateVecPrev if ixSnowOnlyNrg(iLayer) is within the state vector + scalarTemp = stateVecPrev( ixSnowOnlyNrg(iLayer) ) + else ! get the layer temperature from the last update + scalarTemp = prog_data%var(iLookPROG%mLayerTemp)%dat(iLayer) + endif + ! get the volumetric fraction of liquid water and ice + select case( ixStateType_subset( ixSnowOnlyHyd(iLayer) ) ) + case(iname_watLayer); scalarLiq = fracliquid(scalarTemp,mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1)) * stateVecPrev(ixSnowOnlyHyd(iLayer)) + case(iname_liqLayer); scalarLiq = stateVecPrev(ixSnowOnlyHyd(iLayer)) + case default; err=20; message=trim(message)//'expect ixStateType_subset to be iname_watLayer or iname_liqLayer for snow hydrology'; return + end select + scalarIce = merge(stateVecPrev(ixSnowOnlyHyd(iLayer)) - scalarLiq,mLayerVolFracIce(iLayer), ixHydType(iLayer)==iname_watLayer) + ! checking if drain more than what is available or add more than possible, constrained iteration increment -- simplified bi-section + if(-xInc(ixSnowOnlyHyd(iLayer)) > scalarLiq) then + xInc(ixSnowOnlyHyd(iLayer)) = -0.5_rkind*scalarLiq + elseif(xInc(ixSnowOnlyHyd(iLayer)) > 1._rkind - scalarIce - scalarLiq)then + xInc(ixSnowOnlyHyd(iLayer)) = 0.5_rkind*(1._rkind - scalarIce - scalarLiq) + endif + end do ! (looping through snow layers) + endif ! (if there are state variables for liquid water in the snow domain) + + ! impose bounds for soil water, change in total water is only due to liquid flux + if(nSoilOnlyHyd>0)then + ! loop through soil layers + do iLayer=1,nSoil + ! check if the layer is included + if(ixSoilOnlyHyd(iLayer)==integerMissing) cycle + if(ixHydType(iLayer+nSnow)==iname_watLayer .or. ixHydType(iLayer+nSnow)==iname_liqLayer)then + ! get the volumetric fraction of liquid water and ice + select case( ixStateType_subset( ixSoilOnlyHyd(iLayer) ) ) + case(iname_watLayer) + xPsi00 = matricHead(stateVecPrev(ixSoilOnlyHyd(iLayer)),vGn_alpha(iLayer),theta_res(iLayer),theta_sat(iLayer),vGn_n(iLayer),vGn_m(iLayer)) + ! get the layer temperature + if(ixSoilOnlyNrg(iLayer)/=integerMissing)then + scalarTemp = stateVecPrev( ixSoilOnlyNrg(iLayer) ) + else + scalarTemp = prog_data%var(iLookPROG%mLayerTemp)%dat(iLayer+nSnow) + endif + ! identify the critical point when soil begins to freeze (TcSoil) + TcSoil = crit_soilT(xPsi00) + ! get the volumetric fraction of liquid water and ice + if(scalarTemp < TcSoil)then + xConst = LH_fus/(gravity*Tfreeze) + mLayerPsiLiq = xConst*(scalarTemp - Tfreeze) + scalarLiq = volFracLiq(mLayerPsiLiq,vGn_alpha(iLayer),theta_res(iLayer),theta_sat(iLayer),vGn_n(iLayer),vGn_m(iLayer)) + else + scalarLiq = stateVecPrev(ixSoilOnlyHyd(iLayer)) + end if ! (check if soil is partially frozen) + case(iname_liqLayer); scalarLiq = stateVecPrev(ixSoilOnlyHyd(iLayer)) + end select + scalarIce = merge(stateVecPrev(ixSoilOnlyHyd(iLayer)) - scalarLiq,mLayerVolFracIce(iLayer+nSnow), ixHydType(iLayer)==iname_watLayer) + ! checking if drain more than what is available or add more than possible, constrained iteration increment -- simplified bi-section + if(-xInc(ixSoilOnlyHyd(iLayer)) > scalarLiq - theta_res(iLayer))then + xInc(ixSoilOnlyHyd(iLayer)) = -0.5_rkind*(scalarLiq - theta_res(iLayer)) + elseif(xInc(ixSoilOnlyHyd(iLayer)) > theta_sat(iLayer) - scalarIce - scalarLiq)then + xInc(ixSoilOnlyHyd(iLayer)) = 0.5_rkind*(theta_sat(iLayer) - scalarIce - scalarLiq) + endif + endif ! (if the state variable is not matric head) + end do ! (looping through soil layers) + endif ! (if there are state variables for liquid water in the soil domain) + + endif ! (water bounds) + + ! Update the state vector with the modified iteration increment + stateVec(:) = stateVecPrev(:) + xInc(:) + + ! end association with variables with indices of model state variables + end associate + +end subroutine imposeConstraints + + end module eval8summa_module diff --git a/build/source/engine/eval8summaWithPrime.f90 b/build/source/engine/eval8summaWithPrime.f90 new file mode 100644 index 000000000..fd95387ea --- /dev/null +++ b/build/source/engine/eval8summaWithPrime.f90 @@ -0,0 +1,808 @@ + +module eval8summaWithPrime_module + +! data types +USE nrtype + +! access missing values +USE globalData,only:integerMissing ! missing integer +USE globalData,only:realMissing ! missing real number +USE globalData,only:quadMissing ! missing quadruple precision number + +! constants +USE multiconst,only:& + Tfreeze, & ! temperature at freezing (K) + iden_ice, & ! intrinsic density of ice (kg m-3) + iden_water ! intrinsic density of liquid water (kg m-3) + +! provide access to the derived types to define the data structures +USE data_types,only:& + var_i, & ! data vector (i4b) + var_d, & ! data vector (rkind) + var_ilength, & ! data vector with variable length dimension (i4b) + var_dlength, & ! data vector with variable length dimension (rkind) + zLookup, & ! lookup tables + model_options ! defines the model decisions + +! indices that define elements of the data structures +USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure +USE var_lookup,only:iLookPARAM ! named variables for structure elements +USE var_lookup,only:iLookPROG ! named variables for structure elements +USE var_lookup,only:iLookINDEX ! named variables for structure elements +USE var_lookup,only:iLookDIAG ! named variables for structure elements +USE var_lookup,only:iLookFLUX ! named variables for structure elements +USE var_lookup,only:iLookDERIV ! named variables for structure elements + +! look-up values for the choice of variable in energy equations (BE residual or IDA state variable) +USE mDecisions_module,only: & + closedForm, & ! use temperature with closed form heat capacity + enthalpyFormLU, & ! use enthalpy with soil temperature-enthalpy lookup tables + enthalpyForm ! use enthalpy with soil temperature-enthalpy analytical solution + +implicit none +private +public::eval8summaWithPrime +public::eval8summa4ida + + +contains + +! ********************************************************************************************************** +! public subroutine eval8summaWithPrime: compute the residual vector +! ********************************************************************************************************** +subroutine eval8summaWithPrime(& + ! input: model control + dt, & ! intent(in): entire time step for drainage pond rate + nSnow, & ! intent(in): number of snow layers + nSoil, & ! intent(in): number of soil layers + nLayers, & ! intent(in): total number of layers + insideSUN, & ! intent(in): flag to indicate if we are inside Sundials solver + firstSubStep, & ! intent(in): flag to indicate if we are processing the first sub-step + firstFluxCall, & ! intent(inout): flag to indicate if we are processing the first flux call + firstSplitOper, & ! intent(inout): flag to indicate if we are processing the first flux call in a splitting operation + computeVegFlux, & ! intent(in): flag to indicate if we need to compute fluxes over vegetation + scalarSolution, & ! intent(in): flag to indicate the scalar solution + ! input: state vectors + stateVec, & ! intent(in): model state vector + stateVecPrime, & ! intent(in): derivative of model state vector + sMul, & ! intent(inout): state vector multiplier (used in the residual calculations) + ! input: data structures + model_decisions, & ! intent(in): model decisions + lookup_data, & ! intent(in): lookup table data structure + type_data, & ! intent(in): type of vegetation and soil + attr_data, & ! intent(in): spatial attributes + mpar_data, & ! intent(in): model parameters + forc_data, & ! intent(in): model forcing data + bvar_data, & ! intent(in): average model variables for the entire basin + prog_data, & ! intent(in): model prognostic variables for a local HRU + ! input-output: data stuctures + indx_data, & ! intent(inout): index data + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + flux_data, & ! intent(inout): model fluxes for a local HRU + deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables + ! input-output: values needed in case canopy gets buried + scalarCanopyEnthalpyTrial, & ! intent(inout): trial value for enthalpy of the vegetation canopy (J m-3) + scalarCanopyTempTrial, & ! intent(inout): trial value for temperature of the vegetation canopy (K), also used to start enthalpy calculations + scalarCanopyWatTrial, & ! intent(inout): trial value for total water content of the vegetation canopy (kg m-2) + ! output: new values of variables needed in data window outside of internal IDA for rootfinding and to start enthalpy calculations + mLayerTempTrial, & ! intent(inout): trial vector of layer temperature (K) + mLayerMatricHeadTrial, & ! intent(out): trial value for total water matric potential (m) + ! output: new prime values of variables needed in data window outside of internal IDA for Jacobian + scalarCanopyTempPrime, & ! intent(out): prime value for temperature of the vegetation canopy (K s-1) + scalarCanopyWatPrime, & ! intent(out): prime value for total water content of the vegetation canopy (kg m-2 s-1) + mLayerTempPrime, & ! intent(out): prime vector of temperature of each snow and soil layer (K s-1) + mLayerMatricHeadPrime, & ! intent(out): prime vector of matric head of each snow and soil layer (m s-1) + mLayerVolFracWatPrime, & ! intent(out): prime vector of volumetric total water content of each snow and soil layer (s-1) + ! input-output: baseflow + ixSaturation, & ! intent(inout): index of the lowest saturated layer + dBaseflow_dMatric, & ! intent(out): derivative in baseflow w.r.t. matric head (s-1) + ! output: flux and residual vectors + feasible, & ! intent(out): flag to denote the feasibility of the solution + fluxVec, & ! intent(out): flux vector + resSink, & ! intent(out): sink terms on the RHS of the flux equation + resVec, & ! intent(out): residual vector + err,message) ! intent(out): error control + ! -------------------------------------------------------------------------------------------------------------------------------- + ! provide access to subroutines + USE getVectorz_module, only:varExtract ! extract variables from the state vector + USE getVectorz_module, only:checkFeas ! check feasibility of state vector + USE updateVarsWithPrime_module, only:updateVarsWithPrime ! update variables + USE computFlux_module, only:soilCmpresPrime ! compute soil compression + USE computFlux_module, only:computFlux ! compute fluxes given a state vector + USE computHeatCap_module,only:computHeatCapAnalytic ! recompute closed form heat capacity (Cp) and derivatives + USE computHeatCap_module,only:computCm ! compute Cm and derivatives + USE computHeatCap_module, only:computStatMult ! recompute state multiplier + USE computResidWithPrime_module,only:computResidWithPrime ! compute residuals given a state vector + USE computThermConduct_module,only:computThermConduct ! recompute thermal conductivity and derivatives + implicit none + ! -------------------------------------------------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------------------------------------------------- + ! input: model control + real(rkind),intent(in) :: dt ! entire time step for drainage pond rate + integer(i4b),intent(in) :: nSnow ! number of snow layers + integer(i4b),intent(in) :: nSoil ! number of soil layers + integer(i4b),intent(in) :: nLayers ! total number of layers + logical(lgt),intent(in) :: insideSUN ! flag to indicate if we are inside Sundials solver + logical(lgt),intent(in) :: firstSubStep ! flag to indicate if we are processing the first sub-step + logical(lgt),intent(inout) :: firstFluxCall ! flag to indicate if we are processing the first flux call + logical(lgt),intent(inout) :: firstSplitOper ! flag to indicate if we are processing the first flux call in a splitting operation + logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation + logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution + ! input: state vectors + real(rkind),intent(in) :: stateVec(:) ! model state vector + real(rkind),intent(in) :: stateVecPrime(:) ! model state vector + real(qp),intent(inout) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) + ! input: data structures + type(model_options),intent(in) :: model_decisions(:) ! model decisions + type(zLookup), intent(in) :: lookup_data ! lookup tables + type(var_i), intent(in) :: type_data ! type of vegetation and soil + type(var_d), intent(in) :: attr_data ! spatial attributes + type(var_dlength), intent(in) :: mpar_data ! model parameters + type(var_d), intent(in) :: forc_data ! model forcing data + type(var_dlength), intent(in) :: bvar_data ! model variables for the local basin + type(var_dlength), intent(in) :: prog_data ! prognostic variables for a local HRU + ! output: data structures + type(var_ilength),intent(inout) :: indx_data ! indices defining model states and layers + type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + ! input-output: values needed in case canopy gets buried + real(rkind),intent(inout) :: scalarCanopyEnthalpyTrial ! trial value for enthalpy of the vegetation canopy (J m-3) + real(rkind),intent(inout) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) + real(rkind),intent(inout) :: scalarCanopyWatTrial ! trial value for total water content of the vegetation canopy (kg m-2), also used to start enthalpy calculations + ! output: new values of variables needed in data window outside of internal IDA for rootfinding and to start enthalpy calculations + real(rkind),intent(inout) :: mLayerTempTrial(:) ! trial vector of layer temperature (K) + real(rkind),intent(out) :: mLayerMatricHeadTrial(:) ! trial vector for total water matric potential (m) + ! output: new prime values of variables needed in data window outside of internal IDA for Jacobian + real(rkind),intent(out) :: scalarCanopyTempPrime ! prime value for temperature of the vegetation canopy (K s-1) + real(rkind),intent(out) :: scalarCanopyWatPrime ! prime value for total water content of the vegetation canopy (kg m-2 s-1) + real(rkind),intent(out) :: mLayerTempPrime(:) ! prime vector of temperature of each snow and soil layer (K s-1) + real(rkind),intent(out) :: mLayerMatricHeadPrime(:) ! prime vector of matric head of each snow and soil layer (m s-1) + real(rkind),intent(out) :: mLayerVolFracWatPrime(:) ! prime vector of volumetric total water content of each snow and soil layer (s-1) + ! input-output: baseflow + integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer + real(rkind),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + ! output: flux and residual vectors + logical(lgt),intent(out) :: feasible ! flag to denote the feasibility of the solution + real(rkind),intent(out) :: fluxVec(:) ! flux vector + real(rkind),intent(out) :: resSink(:) ! sink terms on the RHS of the flux equation + real(qp),intent(out) :: resVec(:) ! NOTE: qp ! residual vector + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! -------------------------------------------------------------------------------------------------------------------------------- + ! local variables + ! -------------------------------------------------------------------------------------------------------------------------------- + real(rkind) :: dt1 ! residual step size + ! state variables + real(rkind) :: scalarCanairEnthalpyTrial ! trial value for enthalpy of the canopy air space (J m-3) + real(rkind) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) + real(rkind) :: scalarCanopyLiqTrial ! trial value for liquid water storage in the canopy (kg m-2) + real(rkind) :: scalarCanopyIceTrial ! trial value for ice storage in the canopy (kg m-2) + real(rkind),dimension(nSoil) :: mLayerMatricHeadLiqTrial ! trial value for liquid water matric potential (m) + real(rkind),dimension(nLayers) :: mLayerEnthalpyTrial ! trial vector of enthalpy of each snow and soil layer (J m-3) + real(rkind),dimension(nLayers) :: mLayerVolFracWatTrial ! trial vector of volumetric total water content (-) + real(rkind),dimension(nLayers) :: mLayerVolFracLiqTrial ! trial vector of volumetric liquid water content (-) + real(rkind),dimension(nLayers) :: mLayerVolFracIceTrial ! trial vector of volumetric fraction of ice (-) + real(rkind) :: scalarAquiferStorageTrial ! trial value for storage of water in the aquifer (m) + ! prime state variables + real(rkind) :: scalarCanairEnthalpyPrime ! prime value for enthalpy of the canopy air space (W m-3) + real(rkind) :: scalarCanairTempPrime ! prime value for temperature of the canopy air space (K s-1) + real(rkind) :: scalarCanopyEnthalpyPrime ! prime value for enthalpy of the vegetation canopy (W m-3) + real(rkind) :: scalarCanopyLiqPrime ! prime value for liquid water storage in the canopy (kg m-2 s-1) + real(rkind) :: scalarCanopyIcePrime ! prime value for mass of ice on the vegetation canopy (kg m-2 s-1) + real(rkind),dimension(nLayers) :: mLayerEnthalpyPrime ! prime vector of enthalpy of each snow and soil layer (W m-3) + real(rkind),dimension(nLayers) :: mLayerVolFracLiqPrime ! prime vector of volumetric liquid water content (s-1) + real(rkind),dimension(nLayers) :: mLayerVolFracIcePrime ! prime vector of volumetric fraction of ice (s-1) + real(rkind),dimension(nSoil) :: mLayerMatricHeadLiqPrime ! prime vector of liquid water matric potential (m s-1) + real(rkind) :: scalarAquiferStoragePrime ! prime value of storage of water in the aquifer (m s-1) + ! dummy state variables + real(rkind) :: scalarCanairNrgTrial ! trial value for energy of the canopy air space + real(rkind) :: scalarCanopyNrgTrial ! trial value for energy of the vegetation canopy + real(rkind),dimension(nLayers) :: mLayerNrgTrial ! trial vector of energy of each snow and soil layer + real(rkind) :: scalarCanairNrgPrime ! prime value for energy of the canopy air space + real(rkind) :: scalarCanopyNrgPrime ! prime value for energy of the vegetation canopy + real(rkind),dimension(nLayers) :: mLayerNrgPrime ! prime vector of energy of each snow and soil layer + ! other local variables + integer(i4b) :: jState(1) ! index of model state for the scalar solution within the soil domain + integer(i4b) :: ixBeg,ixEnd ! index of indices for the soil compression routine + character(LEN=256) :: cmessage ! error message of downwind routine + logical(lgt) :: updateStateCp ! flag to indicate if we update Cp at each step for LHS, set with nrgConserv choice and updateCp_closedForm flag + logical(lgt) :: updateFluxCp ! flag to indicate if we update Cp at each step for RHS, set with nrgConserv choice and updateCp_closedForm flag + logical(lgt) :: needStateCm ! flag to indicate if the energy equation contains LHS Cm = dH_T/dTheta_m,, set with nrgConserv choice and needStateCm_closedForm flag + logical(lgt),parameter :: updateCp_closedForm=.true. ! nrgConserv = closedForm flag to indicate if we update Cp at each step + logical(lgt),parameter :: needCm_closedForm=.true. ! nrgConserv = closedForm flag to indicate if the energy equation contains Cm = dH_T/dTheta_m + + ! -------------------------------------------------------------------------------------------------------------------------------- + ! association to variables in the data structures + ! -------------------------------------------------------------------------------------------------------------------------------- + associate(& + ! model decisions + ixNrgConserv => model_decisions(iLookDECISIONS%nrgConserv)%iDecision ,& ! intent(in): [i4b] choice of variable in either energy backward Euler residual or IDA state variable + ixRichards => model_decisions(iLookDECISIONS%f_Richards)%iDecision ,& ! intent(in): [i4b] index of the form of Richards' equation + ! snow parameters + snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1) ,& ! intent(in): [dp] scaling parameter for the snow freezing curve (K-1) + ! soil parameters + theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat ,& ! intent(in): [dp(:)] soil porosity (-) + specificStorage => mpar_data%var(iLookPARAM%specificStorage)%dat(1) ,& ! intent(in): [dp] specific storage coefficient (m-1) + ! canopy and layer depth + canopyDepth => diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1) ,& ! intent(in): [dp ] canopy depth (m) + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat ,& ! intent(in): [dp(:)] depth of each layer in the snow-soil sub-domain (m) + ! model diagnostic variables, will be updated before used + scalarFracLiqVeg => diag_data%var(iLookDIAG%scalarFracLiqVeg)%dat(1) ,& ! intent(in): [dp] fraction of liquid water on vegetation (-) + scalarSfcMeltPond => prog_data%var(iLookPROG%scalarSfcMeltPond)%dat(1) ,& ! intent(in): [dp] ponded water caused by melt of the "snow without a layer" (kg m-2) + mLayerFracLiqSnow => diag_data%var(iLookDIAG%mLayerFracLiqSnow)%dat ,& ! intent(in): [dp(:)] fraction of liquid water in each snow layer (-) + ! soil compression + scalarSoilCompress => diag_data%var(iLookDIAG%scalarSoilCompress)%dat(1) ,& ! intent(in): [dp] total change in storage associated with compression of the soil matrix (kg m-2 s-1) + mLayerCompress => diag_data%var(iLookDIAG%mLayerCompress)%dat ,& ! intent(in): [dp(:)] change in volumetric water content due to compression of soil (s-1) + ! derivatives + dTheta_dTkCanopy => deriv_data%var(iLookDERIV%dTheta_dTkCanopy)%dat(1) ,& ! intent(in): [dp] derivative of volumetric liquid water content w.r.t. temperature + dVolTot_dPsi0 => deriv_data%var(iLookDERIV%dVolTot_dPsi0)%dat ,& ! intent(in): [dp(:)] derivative in total water content w.r.t. total water matric potential + dCompress_dPsi => deriv_data%var(iLookDERIV%dCompress_dPsi)%dat ,& ! intent(in): [dp(:)] derivative in compressibility w.r.t. matric head (m-1) + mLayerdTheta_dTk => deriv_data%var(iLookDERIV%mLayerdTheta_dTk)%dat ,& ! intent(in): [dp(:)] derivative of volumetric liquid water content w.r.t. temperature + dVolHtCapBulk_dPsi0 => deriv_data%var(iLookDERIV%dVolHtCapBulk_dPsi0)%dat ,& ! intent(out): [dp(:)] derivative in bulk heat capacity w.r.t. matric potential + dVolHtCapBulk_dTheta => deriv_data%var(iLookDERIV%dVolHtCapBulk_dTheta)%dat ,& ! intent(out): [dp(:)] derivative in bulk heat capacity w.r.t. volumetric water content + dVolHtCapBulk_dCanWat => deriv_data%var(iLookDERIV%dVolHtCapBulk_dCanWat)%dat(1) ,& ! intent(out): [dp] derivative in bulk heat capacity w.r.t. volumetric water content + dVolHtCapBulk_dTk => deriv_data%var(iLookDERIV%dVolHtCapBulk_dTk)%dat ,& ! intent(out): [dp(:)] derivative in bulk heat capacity w.r.t. temperature + dVolHtCapBulk_dTkCanopy => deriv_data%var(iLookDERIV%dVolHtCapBulk_dTkCanopy)%dat(1) ,& ! intent(out): [dp] derivative in bulk heat capacity w.r.t. temperature + dThermalC_dWatAbove => deriv_data%var(iLookDERIV%dThermalC_dWatAbove)%dat ,& ! intent(out): [dp(:)] derivative in the thermal conductivity w.r.t. water state in the layer above + dThermalC_dWatBelow => deriv_data%var(iLookDERIV%dThermalC_dWatBelow)%dat ,& ! intent(out): [dp(:)] derivative in the thermal conductivity w.r.t. water state in the layer above + dThermalC_dTempAbove => deriv_data%var(iLookDERIV%dThermalC_dTempAbove)%dat ,& ! intent(out): [dp(:)] derivative in the thermal conductivity w.r.t. energy state in the layer above + dThermalC_dTempBelow => deriv_data%var(iLookDERIV%dThermalC_dTempBelow)%dat ,& ! intent(out): [dp(:)] derivative in the thermal conductivity w.r.t. energy state in the layer above + dCm_dPsi0 => deriv_data%var(iLookDERIV%dCm_dPsi0)%dat ,& ! intent(out): [dp(:)] derivative in heat capacity w.r.t. matric potential (J kg-1 K-1) + dCm_dTk => deriv_data%var(iLookDERIV%dCm_dTk)%dat ,& ! intent(out): [dp(:)] derivative in heat capacity w.r.t. temperature (J kg-1 K-2) + dCm_dTkCanopy => deriv_data%var(iLookDERIV%dCm_dTkCanopy)%dat(1) ,& ! intent(out): [dp ] derivative in heat capacity w.r.t. canopy temperature (J kg-1 K-2) + ! mapping + ixMapFull2Subset => indx_data%var(iLookINDEX%ixMapFull2Subset)%dat ,& ! intent(in): [i4b(:)] mapping of full state vector to the state subset + ixControlVolume => indx_data%var(iLookINDEX%ixControlVolume)%dat ,& ! intent(in): [i4b(:)] index of control volume for different domains (veg, snow, soil) + ! heat capacity + heatCapVegTrial => diag_data%var(iLookDIAG%scalarBulkVolHeatCapVeg)%dat(1) ,& ! intent(out): [dp] volumetric heat capacity of vegetation canopy + mLayerHeatCapTrial => diag_data%var(iLookDIAG%mLayerVolHtCapBulk)%dat ,& ! intent(out): [dp(:)] heat capacity for snow and soil + ! Cm + scalarCanopyCmTrial => diag_data%var(iLookDIAG%scalarCanopyCm)%dat(1) ,& ! intent(out): [dp] Cm for vegetation canopy (J kg-1) + mLayerCmTrial => diag_data%var(iLookDIAG%mLayerCm)%dat & ! intent(out): [dp(:)] Cm for each layer (J m-3) + ) ! association to variables in the data structures + ! -------------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message="eval8summaWithPrime/" + + ! check the feasibility of the solution only if not inside Sundials solver + feasible=.true. + if (.not.insideSUN) then + call checkFeas(& + ! input + stateVec, & ! intent(in): model state vector (mixed units) + mpar_data, & ! intent(in): model parameters + prog_data, & ! intent(in): model prognostic variables for a local HRU + indx_data, & ! intent(in): indices defining model states and layers + ixNrgConserv.ne.closedForm, & ! intent(in): flag to indicate if we are using enthalpy as state variable + ! output: feasibility + feasible, & ! intent(inout): flag to denote the feasibility of the solution + ! output: error control + err,cmessage) ! intent(out): error control + + ! early return for non-feasible solutions + if(.not.feasible)then + fluxVec(:) = realMissing + resVec(:) = quadMissing + message=trim(message)//trim(cmessage)//'non-feasible' + return + end if + end if ! ( feasibility check ) + + if(ixNrgConserv == enthalpyForm .or. ixNrgConserv == enthalpyFormLU)then ! use enthalpy as state variable, do not need state terms but do need flux term + updateStateCp = .false. + updateFluxCp = .true. + needStateCm = .false. + else if(ixNrgConserv == closedForm)then ! have a choice, temperature the state variable + updateStateCp = updateCp_closedForm + updateFluxCp = updateCp_closedForm + needStateCm = needCm_closedForm + else + message=trim(message)//'unknown choice of variable in energy conservation backward Euler residual' + err=1; return + end if + + ! get the start and end indices for the soil compression calculations + if(scalarSolution)then + jState = pack(ixControlVolume, ixMapFull2Subset/=integerMissing) + ixBeg = jState(1) + ixEnd = jState(1) + else + ixBeg = 1 + ixEnd = nSoil + endif + + ! Canopy layer can disappear even without splitting (snow burial), so need to take last values + if(ixNrgConserv== enthalpyForm .or. ixNrgConserv == enthalpyFormLU)then ! use state variable as enthalpy, need to compute temperature + scalarCanopyNrgTrial = scalarCanopyEnthalpyTrial + else ! use state variable as temperature + scalarCanopyNrgTrial = scalarCanopyTempTrial + endif !(choice of how conservation of energy is implemented) + + ! Placeholder: if we decide to use splitting, we need to pass all the previous values of the state variables + scalarCanairNrgTrial = realMissing + scalarCanopyLiqTrial = realMissing + scalarCanopyIceTrial = realMissing + mLayerNrgTrial = realMissing + mLayerVolFracWatTrial = realMissing + mLayerVolFracLiqTrial = realMissing + mLayerVolFracIceTrial = realMissing + mLayerMatricHeadTrial = realMissing + mLayerMatricHeadLiqTrial = realMissing + scalarAquiferStorageTrial = realMissing + + ! extract states from the state vector + call varExtract(& + ! input + stateVec, & ! intent(in): model state vector (mixed units) + indx_data, & ! intent(in): indices defining model states and layers + ! output: variables for the vegetation canopy + scalarCanairNrgTrial, & ! intent(inout): trial value of energy of the canopy air space, temperature (K) or enthalpy (J m-3) + scalarCanopyNrgTrial, & ! intent(inout): trial value of energy of the vegetation canopy, temperature (K) or enthalpy (J m-3) + scalarCanopyWatTrial, & ! intent(inout): trial value of canopy total water (kg m-2) + scalarCanopyLiqTrial, & ! intent(inout): trial value of canopy liquid water (kg m-2) + ! output: variables for the snow-soil domain + mLayerNrgTrial, & ! intent(inout): trial vector of energy, temperature (K) or enthalpy (J m-3) + mLayerVolFracWatTrial, & ! intent(inout): trial vector of volumetric total water content (-) + mLayerVolFracLiqTrial, & ! intent(inout): trial vector of volumetric liquid water content (-) + mLayerMatricHeadTrial, & ! intent(inout): trial vector of total water matric potential (m) + mLayerMatricHeadLiqTrial, & ! intent(inout): trial vector of liquid water matric potential (m) + ! output: variables for the aquifer + scalarAquiferStorageTrial, & ! intent(inout): trial value of storage of water in the aquifer (m) + ! output: error control + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) + + ! Placeholder: if we decide to use splitting, we need to pass all the previous values of the state variables + scalarCanairNrgPrime = realMissing + scalarCanopyNrgPrime = realMissing + scalarCanopyWatPrime = realMissing + scalarCanopyLiqPrime = realMissing + scalarCanopyIcePrime = realMissing + mLayerNrgPrime = realMissing + mLayerVolFracWatPrime = realMissing + mLayerVolFracLiqPrime = realMissing + mLayerVolFracIcePrime = realMissing + mLayerMatricHeadPrime = realMissing + mLayerMatricHeadLiqPrime = realMissing + scalarAquiferStoragePrime = realMissing + + call varExtract(& + ! input + stateVecPrime, & ! intent(in): derivative of model state vector (mixed units) + indx_data, & ! intent(in): indices defining model states and layers + ! output: variables for the vegetation canopy + scalarCanairNrgPrime, & ! intent(inout): derivative of energy of the canopy air space, temperature (K s-1) or enthalpy (W m-3) + scalarCanopyNrgPrime, & ! intent(inout): derivative of energy of the vegetation canopy, temperature (K s-1) or enthalpy (W m-3) + scalarCanopyWatPrime, & ! intent(inout): derivative of canopy total water (kg m-2 s-1) + scalarCanopyLiqPrime, & ! intent(inout): derivative of canopy liquid water (kg m-2 s-1) + ! output: variables for the snow-soil domain + mLayerNrgPrime, & ! intent(inout): derivative of energy of each snow and soil layer, temperature (K s-1) or enthalpy (W m-3) + mLayerVolFracWatPrime, & ! intent(inout): derivative of volumetric total water content (s-1) + mLayerVolFracLiqPrime, & ! intent(inout): derivative of volumetric liquid water content (s-1) + mLayerMatricHeadPrime, & ! intent(inout): derivative of total water matric potential (m s-1) + mLayerMatricHeadLiqPrime, & ! intent(inout): derivative of liquid water matric potential (m s-1) + ! output: variables for the aquifer + scalarAquiferStoragePrime, & ! intent(inout): derivative of storage of water in the aquifer (m s-1) + ! output: error control + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) + + if(ixNrgConserv== enthalpyForm .or. ixNrgConserv == enthalpyFormLU)then ! use state variable as enthalpy, need to compute temperature + scalarCanairEnthalpyTrial = scalarCanairNrgTrial + scalarCanopyEnthalpyTrial = scalarCanopyNrgTrial + mLayerEnthalpyTrial = mLayerNrgTrial + scalarCanairEnthalpyPrime = scalarCanairNrgPrime + scalarCanopyEnthalpyPrime = scalarCanopyNrgPrime + mLayerEnthalpyPrime = mLayerNrgPrime + ! do not use these variables + scalarCanairTempPrime = realMissing + scalarCanopyTempPrime = realMissing + mLayerTempPrime = realMissing + else ! use state variable as temperature + scalarCanairTempTrial = scalarCanairNrgTrial + scalarCanopyTempTrial = scalarCanopyNrgTrial + mLayerTempTrial = mLayerNrgTrial + scalarCanairTempPrime = scalarCanairNrgPrime + scalarCanopyTempPrime = scalarCanopyNrgPrime + mLayerTempPrime = mLayerNrgPrime + ! do not use these variables + scalarCanairEnthalpyTrial = realMissing + scalarCanopyEnthalpyTrial = realMissing + mLayerEnthalpyTrial = realMissing + scalarCanairEnthalpyPrime = realMissing + scalarCanopyEnthalpyPrime = realMissing + mLayerEnthalpyPrime = realMissing + endif !(choice of how conservation of energy is implemented) + + ! update diagnostic variables and derivatives + ! NOTE: if we are using enthalpy as a state variable, currently all *TempPrime, *IcePrime, and *LiqPrime are set to realMissing + ! This possibly could cause problems (?) if we use splitting, but we are not using splitting at the moment + call updateVarsWithPrime(& + ! input + ixNrgConserv.ne.closedForm, & ! intent(in): flag if need to update temperature from enthalpy + ixNrgConserv==enthalpyFormLU, & ! intent(in): flag to use the lookup table for soil temperature-enthalpy + .true., & ! intent(in): flag if computing for Jacobian update + .false., & ! intent(in): flag to adjust temperature to account for the energy + mpar_data, & ! intent(in): model parameters for a local HRU + indx_data, & ! intent(in): indices defining model states and layers + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables + lookup_data, & ! intent(in): lookup table data structure + ! input: enthalpy state variables + scalarCanairEnthalpyTrial, & ! intent(in): trial value for enthalpy of the canopy air space (J m-3) + scalarCanopyEnthalpyTrial, & ! intent(in): trial value for enthalpy of the vegetation canopy (J m-3) + mLayerEnthalpyTrial, & ! intent(in): trial vector of enthalpy of each snow+soil layer (J m-3) + ! output: variables for the vegetation canopy + scalarCanairTempTrial, & ! intent(inout): trial value of canopy air space temperature (K) + scalarCanopyTempTrial, & ! intent(inout): trial value of canopy temperature (K) + scalarCanopyWatTrial, & ! intent(inout): trial value of canopy total water (kg m-2) + scalarCanopyLiqTrial, & ! intent(inout): trial value of canopy liquid water (kg m-2) + scalarCanopyIceTrial, & ! intent(inout): trial value of canopy ice content (kg m-2) + scalarCanopyTempPrime, & ! intent(inout): trial value of time derivative canopy temperature (K s-1) + scalarCanopyWatPrime, & ! intent(inout): trial value of time derivative canopy total water (kg m-2 s-1) + scalarCanopyLiqPrime, & ! intent(inout): trial value of time derivative canopy liquid water (kg m-2 s-1) + scalarCanopyIcePrime, & ! intent(inout): trial value of time derivative canopy ice content (kg m-2 s-1) + ! output: variables for th snow-soil domain + mLayerTempTrial, & ! intent(inout): trial vector of layer temperature (K) + mLayerVolFracWatTrial, & ! intent(inout): trial vector of volumetric total water content (-) + mLayerVolFracLiqTrial, & ! intent(inout): trial vector of volumetric liquid water content (-) + mLayerVolFracIceTrial, & ! intent(inout): trial vector of volumetric ice water content (-) + mLayerMatricHeadTrial, & ! intent(inout): trial vector of total water matric potential (m) + mLayerMatricHeadLiqTrial, & ! intent(inout): trial vector of liquid water matric potential (m) + mLayerTempPrime, & ! intent(inout): trial vector of time derivative layer temperature (K s-1) + mLayerVolFracWatPrime, & ! intent(inout): trial vector of time derivative volumetric total water content (s-1) + mLayerVolFracLiqPrime, & ! intent(inout): trial vector of time derivative volumetric liquid water content (s-1) + mLayerVolFracIcePrime, & ! intent(inout): trial vector of time derivative volumetric ice water content (s-1) + mLayerMatricHeadPrime, & ! intent(inout): trial vector of time derivative total water matric potential (m s-1) + mLayerMatricHeadLiqPrime, & ! intent(inout): trial vector of time derivative liquid water matric potential (m s-1) + ! output: error control + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) + + if(updateStateCp)then + ! *** compute volumetric heat capacity C_p + call computHeatCapAnalytic(& + ! input: state variables + canopyDepth, & ! intent(in): canopy depth (m) + scalarCanopyIceTrial, & ! intent(in): trial value for mass of ice on the vegetation canopy (kg m-2) + scalarCanopyLiqTrial, & ! intent(in): trial value for the liquid water on the vegetation canopy (kg m-2) + scalarCanopyTempTrial, & ! intent(in): trial value of canopy temperature (K) + mLayerVolFracIceTrial, & ! intent(in): volumetric fraction of ice at the start of the sub-step (-) + mLayerVolFracLiqTrial, & ! intent(in): fraction of liquid water at the start of the sub-step (-) + mLayerTempTrial, & ! intent(in): trial value of layer temperature (K) + mLayerMatricHeadTrial, & ! intent(in): trial total water matric potential (m) + ! input: pre-computed derivatives + dTheta_dTkCanopy, & ! intent(in): derivative in canopy volumetric liquid water content w.r.t. temperature (K-1) + scalarFracLiqVeg, & ! intent(in): fraction of canopy liquid water (-) + mLayerdTheta_dTk, & ! intent(in): derivative of volumetric liquid water content w.r.t. temperature (K-1) + mLayerFracLiqSnow, & ! intent(in): fraction of liquid water (-) + dVolTot_dPsi0, & ! intent(in): derivative in total water content w.r.t. total water matric potential (m-1) + ! input output data structures + mpar_data, & ! intent(in): model parameters + indx_data, & ! intent(in): model layer indices + ! output + heatCapVegTrial, & ! intent(inout): volumetric heat capacity of vegetation canopy + mLayerHeatCapTrial, & ! intent(inout): volumetric heat capacity of soil and snow + dVolHtCapBulk_dPsi0, & ! intent(inout): derivative in bulk heat capacity w.r.t. matric potential + dVolHtCapBulk_dTheta, & ! intent(inout): derivative in bulk heat capacity w.r.t. volumetric water content + dVolHtCapBulk_dCanWat, & ! intent(inout): derivative in bulk heat capacity w.r.t. volumetric water content + dVolHtCapBulk_dTk, & ! intent(inout): derivative in bulk heat capacity w.r.t. temperature + dVolHtCapBulk_dTkCanopy, & ! intent(inout): derivative in bulk heat capacity w.r.t. temperature + ! output: error control + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! compute multiplier of state vector + call computStatMult(& + ! input + heatCapVegTrial, & ! intent(in): volumetric heat capacity of vegetation canopy + mLayerHeatCapTrial, & ! intent(in): volumetric heat capacity of soil and snow + indx_data, & ! intent(in): indices defining model states and layers + ! output + sMul, & ! intent(out): multiplier for state vector (used in the residual calculations) + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (check for errors) + else + ! set state heat capacity derivatives to 0 for constant through step + dVolHtCapBulk_dPsi0 = 0._rkind + dVolHtCapBulk_dTheta = 0._rkind + dVolHtCapBulk_dCanWat = 0._rkind + dVolHtCapBulk_dTk = 0._rkind + dVolHtCapBulk_dTkCanopy = 0._rkind + endif ! updateStateCp + + if(updateFluxCp)then + ! update thermal conductivity + call computThermConduct(& + ! input: control variables + nLayers, & ! intent(in): total number of layers + ! input: state variables + mLayerTempTrial, & ! intent(in): trial temperature of layer temperature (K) + mLayerMatricHeadTrial, & ! intent(in): trial value for total water matric potential (m) + mLayerVolFracIceTrial, & ! intent(in): volumetric fraction of ice at the start of the sub-step (-) + mLayerVolFracLiqTrial, & ! intent(in): volumetric fraction of liquid water at the start of the sub-step (-) + ! input: pre-computed derivatives + mLayerdTheta_dTk, & ! intent(in): derivative in volumetric liquid water content w.r.t. temperature (K-1) + mLayerFracLiqSnow, & ! intent(in): fraction of liquid water (-) + ! input/output: data structures + mpar_data, & ! intent(in): model parameters + indx_data, & ! intent(in): model layer indices + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + ! output: derivative + dThermalC_dWatAbove, & ! intent(out): derivative in the thermal conductivity w.r.t. water state in the layer above + dThermalC_dWatBelow, & ! intent(out): derivative in the thermal conductivity w.r.t. water state in the layer above + dThermalC_dTempAbove, & ! intent(out): derivative in the thermal conductivity w.r.t. energy state in the layer above + dThermalC_dTempBelow, & ! intent(out): derivative in the thermal conductivity w.r.t. energy state in the layer above + ! output: error control + ! output: error control + err,cmessage) ! intent(out): error control + if(err/=0)then; err=55; message=trim(message)//trim(cmessage); return; end if + else + ! set flux heat capacity derivatives to 0 for constant through step + dThermalC_dWatAbove = 0._rkind + dThermalC_dWatBelow = 0._rkind + dThermalC_dTempAbove = 0._rkind + dThermalC_dTempBelow = 0._rkind + endif ! updateFluxCp + + if(needStateCm)then + ! compute C_m + call computCm(& + ! input: state variables + scalarCanopyTempTrial, & ! intent(in): trial value of canopy temperature (K) + mLayerTempTrial, & ! intent(in): trial value of layer temperature (K) + mLayerMatricHeadTrial, & ! intent(in): trial value for total water matric potential (-) + ! input data structures + mpar_data, & ! intent(in): model parameters + indx_data, & ! intent(in): model layer indices + ! output + scalarCanopyCmTrial, & ! intent(inout): Cm for vegetation canopy (J kg-1) + mLayerCmTrial, & ! intent(inout): Cm for each layer (J m-3) + dCm_dPsi0, & ! intent(inout): derivative in Cm w.r.t. matric potential (J kg) + dCm_dTk, & ! intent(inout): derivative in Cm w.r.t. temperature (J kg K-2) + dCm_dTkCanopy, & ! intent(inout): derivative in Cm w.r.t. temperature (J kg K-2) + err,cmessage) ! intent(inout): error control + else + scalarCanopyCmTrial = 0._rkind + mLayerCmTrial = 0._rkind + dCm_dPsi0 = 0._rkind + dCm_dTk = 0._rkind + dCm_dTkCanopy = 0._rkind + endif ! needStateCm + + ! save the number of flux calls per time step + indx_data%var(iLookINDEX%numberFluxCalc)%dat(1) = indx_data%var(iLookINDEX%numberFluxCalc)%dat(1) + 1 + + ! compute the fluxes for a given state vector + call computFlux(& + ! input-output: model control + nSnow, & ! intent(in): number of snow layers + nSoil, & ! intent(in): number of soil layers + nLayers, & ! intent(in): total number of layers + firstSubStep, & ! intent(in): flag to indicate if we are processing the first sub-step + firstFluxCall, & ! intent(inout): flag to denote the first flux call + firstSplitOper, & ! intent(in): flag to indicate if we are processing the first flux call in a splitting operation + computeVegFlux, & ! intent(in): flag to indicate if we need to compute fluxes over vegetation + scalarSolution, & ! intent(in): flag to indicate the scalar solution + .false., & ! intent(in): do not check longwave balance + scalarSfcMeltPond/dt, & ! intent(in): drainage from the surface melt pond (kg m-2 s-1) + ! input: state variables + scalarCanairTempTrial, & ! intent(in): trial value for the temperature of the canopy air space (K) + scalarCanopyTempTrial, & ! intent(in): trial value for the temperature of the vegetation canopy (K) + mLayerTempTrial, & ! intent(in): trial value for the temperature of each snow and soil layer (K) + mLayerMatricHeadLiqTrial, & ! intent(in): trial value for the liquid water matric potential in each soil layer (m) + mLayerMatricHeadTrial, & ! intent(in): trial vector of total water matric potential (m) + scalarAquiferStorageTrial, & ! intent(in): trial value of storage of water in the aquifer (m) + ! input: diagnostic variables defining the liquid water and ice content + scalarCanopyLiqTrial, & ! intent(in): trial value for the liquid water on the vegetation canopy (kg m-2) + scalarCanopyIceTrial, & ! intent(in): trial value for the ice on the vegetation canopy (kg m-2) + mLayerVolFracLiqTrial, & ! intent(in): trial value for the volumetric liquid water content in each snow and soil layer (-) + mLayerVolFracIceTrial, & ! intent(in): trial value for the volumetric ice in each snow and soil layer (-) + ! input: data structures + model_decisions, & ! intent(in): model decisions + type_data, & ! intent(in): type of vegetation and soil + attr_data, & ! intent(in): spatial attributes + mpar_data, & ! intent(in): model parameters + forc_data, & ! intent(in): model forcing data + bvar_data, & ! intent(in): average model variables for the entire basin + prog_data, & ! intent(in): model prognostic variables for a local HRU + indx_data, & ! intent(in): index data + ! input-output: data structures + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + flux_data, & ! intent(inout): model fluxes for a local HRU + deriv_data, & ! intent(out): derivatives in model fluxes w.r.t. relevant state variables + ! input-output: flux vector and baseflow derivatives + ixSaturation, & ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) + dBaseflow_dMatric, & ! intent(out): derivative in baseflow w.r.t. matric head (s-1), we will use it later in computJacobWithPrime + fluxVec, & ! intent(out): flux vector (mixed units) + ! output: error control + err,cmessage) ! intent(out): error code and error message + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) + + firstSplitOper = .false. ! after call computFlux once in dt, no longer firstSplitOper + + ! compute soil compressibility (-) and its derivative w.r.t. matric head (m) + ! NOTE: we already extracted trial matrix head and volumetric liquid water as part of the flux calculations + call soilCmpresPrime(& + ! input: + ixRichards, & ! intent(in): choice of option for Richards' equation + ixBeg,ixEnd, & ! intent(in): start and end indices defining desired layers + mLayerMatricHeadPrime(1:nSoil), & ! intent(in): matric head at the start of the time step (m s-1) + mLayerVolFracLiqTrial(nSnow+1:nLayers), & ! intent(in): trial value for the volumetric liquid water content in each soil layer (-) + mLayerVolFracIceTrial(nSnow+1:nLayers), & ! intent(in): trial value for the volumetric ice content in each soil layer (-) + specificStorage, & ! intent(in): specific storage coefficient (m-1) + theta_sat, & ! intent(in): soil porosity (-) + ! output: + mLayerCompress, & ! intent(inout): compressibility of the soil matrix (-) + dCompress_dPsi, & ! intent(inout): derivative in compressibility w.r.t. matric head (m-1) + err,cmessage) ! intent(out): error code and error message + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) + + ! compute the total change in storage associated with compression of the soil matrix (kg m-2 s-1) + scalarSoilCompress = sum(mLayerCompress(1:nSoil)*mLayerDepth(nSnow+1:nLayers))*iden_water + + ! compute the residual vector + if (insideSUN)then + dt1 = 1._qp ! always 1 for IDA since using Prime derivatives + + call computResidWithPrime(& + ! input: model control + dt1, & ! intent(in): length of the residual time step (seconds) + nSnow, & ! intent(in): number of snow layers + nSoil, & ! intent(in): number of soil layers + nLayers, & ! intent(in): total number of layers + ixNrgConserv.ne.closedForm, & ! intent(in): flag if enthalpy is state variable + ! input: flux vectors + sMul, & ! intent(in): state vector multiplier (used in the residual calculations) + fluxVec, & ! intent(in): flux vector + ! input: state variables (already disaggregated into scalars and vectors) + scalarCanairTempPrime, & ! intent(in): prime value for the temperature of the canopy air space (K s-1) + scalarCanopyTempPrime, & ! intent(in): prime value for the temperature of the vegetation canopy (K s-1) + scalarCanopyWatPrime, & ! intent(in): prime value for the water on the vegetation canopy (kg m-2 s-1) + mLayerTempPrime, & ! intent(in): prime vector of the temperature of each snow and soil layer (K s-1) + scalarAquiferStoragePrime, & ! intent(in): prime value for storage of water in the aquifer (m s-1) + ! input: diagnostic variables defining the liquid water and ice content (function of state variables) + scalarCanopyIcePrime, & ! intent(in): prime value for the ice on the vegetation canopy (kg m-2 s-1) + scalarCanopyLiqPrime, & ! intent(in): prime value for the liq on the vegetation canopy (kg m-2 s-1) + mLayerVolFracIcePrime, & ! intent(in): prime vector of the volumetric ice in each snow and soil layer (s-1) + mLayerVolFracWatPrime, & ! intent(in): prime vector of the volumetric water in each snow and soil layer (s-1) + mLayerVolFracLiqPrime, & ! intent(in): prime vector of the volumetric liq in each snow and soil layer (s-1) + ! input: enthalpy terms + scalarCanopyCmTrial, & ! intent(in): Cm for vegetation canopy (J kg-1) + mLayerCmTrial, & ! intent(in): Cm for each layer (J m-3) + scalarCanairEnthalpyPrime, & ! intent(in): prime value for the enthalpy of the canopy air space (W m-3) + scalarCanopyEnthalpyPrime, & ! intent(in): prime value for the of enthalpy of the vegetation canopy (W m-3) + mLayerEnthalpyPrime, & ! intent(in): prime vector of the of enthalpy of each snow and soil layer (W m-3) + ! input: data structures + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(in): model diagnostic variables for a local HRU + flux_data, & ! intent(in): model fluxes for a local HRU + indx_data, & ! intent(in): index data + ! output + resSink, & ! intent(out): additional (sink) terms on the RHS of the state equation + resVec, & ! intent(out): residual vector + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) + + else ! currently not using residuals outside Sundials! + dt1 = 1._qp + endif + + ! end association with the information in the data structures + end associate + +end subroutine eval8summaWithPrime + + +! ********************************************************************************************************** +! public function eval8summa4ida: compute the residual vector F(t,y,y') required for IDA solver +! ********************************************************************************************************** +! Return values: +! 0 = success, +! 1 = recoverable error, +! -1 = non-recoverable error +! ---------------------------------------------------------------- +integer(c_int) function eval8summa4ida(tres, sunvec_y, sunvec_yp, sunvec_r, user_data) & + result(ierr) bind(C,name='eval8summa4ida') + + !======= Inclusions =========== + use, intrinsic :: iso_c_binding + use fsundials_core_mod + use fnvector_serial_mod + use type4ida + + !======= Declarations ========= + implicit none + + ! calling variables + real(rkind), value :: tres ! current time t + type(N_Vector) :: sunvec_y ! solution N_Vector y + type(N_Vector) :: sunvec_yp ! derivative N_Vector y' + type(N_Vector) :: sunvec_r ! residual N_Vector F(t,y,y') + type(c_ptr), value :: user_data ! user-defined data + + ! pointers to data in SUNDIALS vectors + type(data4ida), pointer :: eqns_data ! equations data + real(rkind), pointer :: stateVec(:) ! solution vector + real(rkind), pointer :: stateVecPrime(:) ! derivative vector + real(rkind), pointer :: rVec(:) ! residual vector + logical(lgt) :: feasible ! feasibility of state vector + !======= Internals ============ + + ! get equations data from user-defined data + call c_f_pointer(user_data, eqns_data) + + ! get data arrays from SUNDIALS vectors + stateVec(1:eqns_data%nState) => FN_VGetArrayPointer(sunvec_y) + stateVecPrime(1:eqns_data%nState) => FN_VGetArrayPointer(sunvec_yp) + rVec(1:eqns_data%nState) => FN_VGetArrayPointer(sunvec_r) + + ! compute the flux and the residual vector for a given state vector + call eval8summaWithPrime(& + ! input: model control + eqns_data%dt, & ! intent(in): data step + eqns_data%nSnow, & ! intent(in): number of snow layers + eqns_data%nSoil, & ! intent(in): number of soil layers + eqns_data%nLayers, & ! intent(in): number of layers + .true., & ! intent(in): inside SUNDIALS solver + eqns_data%firstSubStep, & ! intent(in): flag to indicate if we are processing the first sub-step + eqns_data%firstFluxCall, & ! intent(inout): flag to indicate if we are processing the first flux call + eqns_data%firstSplitOper, & ! intent(inout): flag to indicate if we are processing the first flux call in a splitting operation + eqns_data%computeVegFlux, & ! intent(in): flag to indicate if we need to compute fluxes over vegetation + eqns_data%scalarSolution, & ! intent(in): flag to indicate the scalar solution + ! input: state vectors + stateVec, & ! intent(in): model state vector + stateVecPrime, & ! intent(in): model state vector + eqns_data%sMul, & ! intent(inout): state vector multiplier (used in the residual calculations) + ! input: data structures + eqns_data%model_decisions, & ! intent(in): model decisions + eqns_data%lookup_data, & ! intent(in): lookup data + eqns_data%type_data, & ! intent(in): type of vegetation and soil + eqns_data%attr_data, & ! intent(in): spatial attributes + eqns_data%mpar_data, & ! intent(in): model parameters + eqns_data%forc_data, & ! intent(in): model forcing data + eqns_data%bvar_data, & ! intent(in): average model variables for the entire basin + eqns_data%prog_data, & ! intent(in): model prognostic variables for a local HRU + ! input-output: data structures + eqns_data%indx_data, & ! intent(inout): index data + eqns_data%diag_data, & ! intent(inout): model diagnostic variables for a local HRU + eqns_data%flux_data, & ! intent(inout): model fluxes for a local HRU (initial flux structure) + eqns_data%deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables + ! input-output: values needed in case canopy gets buried + eqns_data%scalarCanopyEnthalpyTrial, & ! intent(inout): trial value for enthalpy of the vegetation canopy (J m-3) + eqns_data%scalarCanopyTempTrial, & ! intent(inout): trial value for temperature of the vegetation canopy (K), also used to start enthalpy calculations + eqns_data%scalarCanopyWatTrial, & ! intent(inout): trial value for total water content of the vegetation canopy (kg m-2) + ! output: new values of variables needed in data window outside of internal IDA for rootfinding and to start enthalpy calculations + eqns_data%mLayerTempTrial, & ! intent(inout): trial vector of layer temperature (K) + eqns_data%mLayerMatricHeadTrial, & ! intent(out): trial value for total water matric potential (m) + ! output: new prime values of variables needed in data window outside of internal IDA + eqns_data%scalarCanopyTempPrime, & ! intent(out): prime value for temperature of the vegetation canopy (K s-1) + eqns_data%scalarCanopyWatPrime, & ! intent(out): prime value for total water content of the vegetation canopy (kg m-2 s-1) + eqns_data%mLayerTempPrime, & ! intent(out): prime vector of temperature of each snow and soil layer (K s-1) + eqns_data%mLayerMatricHeadPrime, & ! intent(out): prime vector of matric head of each snow and soil layer (m s-1) + eqns_data%mLayerVolFracWatPrime, & ! intent(out): prime vector of volumetric total water content of each snow and soil layer (s-1) + ! input-output: baseflow + eqns_data%ixSaturation, & ! intent(inout): index of the lowest saturated layer + eqns_data%dBaseflow_dMatric, & ! intent(out): derivative in baseflow w.r.t. matric head (s-1) + ! output: flux and residual vectors + feasible, & ! intent(out): flag to denote the feasibility of the solution always true inside SUNDIALS + eqns_data%fluxVec, & ! intent(out): flux vector + eqns_data%resSink, & ! intent(out): additional (sink) terms on the RHS of the state equation + rVec, & ! intent(out): residual vector + eqns_data%err,eqns_data%message) ! intent(out): error control + if(eqns_data%err > 0)then; eqns_data%message=trim(eqns_data%message); ierr=-1; return; endif + if(eqns_data%err < 0)then; eqns_data%message=trim(eqns_data%message); ierr=1; return; endif + + ! save residual and return success + eqns_data%resVec = rVec + ierr = 0 + return + +end function eval8summa4ida + + +end module eval8summaWithPrime_module diff --git a/build/source/engine/expIntegral.f90 b/build/source/engine/expIntegral.f90 old mode 100755 new mode 100644 index 6061643b9..28f9fa3c8 --- a/build/source/engine/expIntegral.f90 +++ b/build/source/engine/expIntegral.f90 @@ -5,7 +5,7 @@ module expIntegral_module public::expint contains - ! Numerical recipes routines removed; use code from UEB-Veg + ! Homegrown routines removed; use code from UEB-Veg ! ****************** EXPONENTIAL INTEGRAL FUNCTION ***************************************** ! From UEB-Veg @@ -14,8 +14,7 @@ FUNCTION EXPINT (LAI) real(rkind) LAI real(rkind) EXPINT real(rkind) a0,a1,a2,a3,a4,a5,b1,b2,b3,b4 - real(rkind),parameter :: verySmall=tiny(1.0_rkind) ! a very small number - IF (LAI < verySmall)THEN + IF (LAI < tiny(1._rkind))THEN EXPINT=1._rkind ELSEIF (LAI.LE.1.0) THEN diff --git a/build/source/engine/f2008funcs.f90 b/build/source/engine/f2008funcs.f90 old mode 100755 new mode 100644 diff --git a/build/source/engine/ffile_info.f90 b/build/source/engine/ffile_info.f90 old mode 100755 new mode 100644 index eb1938f92..2d0988261 --- a/build/source/engine/ffile_info.f90 +++ b/build/source/engine/ffile_info.f90 @@ -22,7 +22,6 @@ module ffile_info_module USE nrtype USE netcdf USE globalData,only:integerMissing -USE globalData,only:ixHRUfile_min,ixHRUfile_max implicit none private public::ffile_info @@ -43,39 +42,41 @@ subroutine ffile_info(nGRU,err,message) USE summaFileManager,only:FORCING_FILELIST ! list of model forcing files USE globalData,only:forcFileInfo,data_step ! info on model forcing file USE globalData,only:forc_meta ! forcing metadata - USE get_ixname_module,only:get_ixtime,get_ixforce ! identify index of named variable + USE get_ixname_module,only:get_ixTime,get_ixForce ! identify index of named variable USE ascii_util_module,only:get_vlines ! get a vector of non-comment lines USE ascii_util_module,only:split_line ! split a line into words USE globalData,only:gru_struc ! gru-hru mapping structure implicit none ! define input & output - integer(i4b),intent(in) :: nGRU ! number of grouped response units - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + integer(i4b),intent(in) :: nGRU ! number of grouped response units + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message ! define local variables ! netcdf file i/o related - integer(i4b) :: ncid ! netcdf file id - integer(i4b) :: mode ! netCDF file open mode - integer(i4b) :: varid ! netcdf variable id - integer(i4b) :: dimId ! netcdf dimension id - character(LEN=nf90_max_name) :: varName ! character array of netcdf variable name - integer(i4b) :: iNC ! index of a variable in netcdf file - integer(i4b) :: nvar ! number of variables in netcdf local attribute file + integer(i4b) :: ncid ! netcdf file id + integer(i4b) :: mode ! netCDF file open mode + integer(i4b) :: varid ! netcdf variable id + integer(i4b) :: dimId ! netcdf dimension id + character(LEN=nf90_max_name) :: varName ! character array of netcdf variable name + integer(i4b) :: iNC ! index of a variable in netcdf file + integer(i4b) :: nvar ! number of variables in netcdf local attribute file ! the rest - character(LEN=linewidth),allocatable :: dataLines(:) ! vector of lines of information (non-comment lines) - character(len=256) :: cmessage ! error message for downwind routine - character(LEN=256) :: infile ! input filename - integer(i4b) :: unt ! file unit (free unit output from file_open) - character(LEN=256) :: filenameData ! name of forcing datafile - integer(i4b) :: ivar ! index of model variable - integer(i4b) :: iFile ! counter for forcing files - integer(i4b) :: nFile ! number of forcing files in forcing file list - integer(i4b) :: file_nHRU ! number of HRUs in current forcing file - integer(i4b) :: nForcing ! number of forcing variables - integer(i4b) :: iGRU,localHRU_ix ! index of GRU and HRU - integer(8) :: ncHruId(1) ! hruID from the forcing files - real(rkind) :: dataStep_iFile ! data step for a given forcing data file - logical(lgt) :: xist ! .TRUE. if the file exists + character(LEN=linewidth),allocatable :: dataLines(:) ! vector of lines of information (non-comment lines) + character(len=256) :: cmessage ! error message for downwind routine + character(LEN=256) :: infile ! input filename + integer(i4b) :: unt ! file unit (free unit output from file_open) + character(LEN=256) :: filenameData ! name of forcing datafile + integer(i4b) :: ivar ! index of model variable + integer(i4b) :: iFile ! counter for forcing files + integer(i4b) :: nFile ! number of forcing files in forcing file list + integer(i4b) :: file_nHRU ! number of HRUs in current forcing file + integer(i4b) :: nForcing ! number of forcing variables + integer(i4b) :: iGRU,localHRU_ix ! index of GRU and HRU + integer(i8b) :: ncHruId(1) ! hruID from the forcing files + real(rkind) :: dataStep_iFile ! data step for a given forcing data file + logical(lgt) :: xist ! .TRUE. if the file exists + logical(lgt) :: completed_data_step ! .TRUE. if data step variable is present + logical(lgt) :: completed_hruId ! .TRUE. if hruId ! Start procedure here err=0; message="ffile_info/" @@ -172,6 +173,8 @@ subroutine ffile_info(nGRU,err,message) err = nf90_inquire_dimension(ncid,dimId,len=forcFileInfo(iFile)%nTimeSteps); if(err/=0)then; message=trim(message)//'cannot read dimension time'; return; end if ! loop through all variables in netcdf file, check to see if everything needed to run the model exists and data_step is correct + completed_data_step = .false. + completed_hruId = .false. do iNC=1,nVar ! inquire about current variable name, type, number of dimensions @@ -185,7 +188,7 @@ subroutine ffile_info(nGRU,err,message) case('time','pptrate','SWRadAtm','LWRadAtm','airtemp','windspd','airpres','spechum') ! get variable index - ivar = get_ixforce(trim(varname)) + ivar = get_ixForce(trim(varname)) if(ivar < 0)then; err=40; message=trim(message)//"variableNotFound[var="//trim(varname)//"]"; return; end if if(ivar>size(forcFileInfo(iFile)%data_id))then; err=35; message=trim(message)//"indexOutOfRange[var="//trim(varname)//"]"; return; end if @@ -204,12 +207,15 @@ subroutine ffile_info(nGRU,err,message) if(err/=0)then; message=trim(message)//'problem reading first Julian day'; return; end if end if ! if the variable name is time - ! data step + ! data step -- required case('data_step' ) ! read data_step from netcdf file err = nf90_inq_varid(ncid, "data_step", varId); if(err/=0)then; message=trim(message)//'cannot find data_step'; return; end if err = nf90_get_var(ncid,varid,dataStep_iFile); if(err/=0)then; message=trim(message)//'cannot read data_step'; return; end if + if (dataStep_iFile <= 0)then + message=trim(message)//'data_step must be greater than zero'; err=30; return + end if ! check data_step is the same for all forcing files if(iFile == 1)then @@ -220,6 +226,7 @@ subroutine ffile_info(nGRU,err,message) err=20; return end if end if + completed_data_step = .true. ! HRU id -- required case('hruId') @@ -242,12 +249,17 @@ subroutine ffile_info(nGRU,err,message) endif end do end do + completed_hruId = .true. ! OK to have additional variables in the forcing file that are not used case default; cycle end select ! select variable name end do ! (end of netcdf file variable loop) + ! check to see if data_step and hruId are present + if(.not.completed_data_step)then; message=trim(message)//"data_step variable not found in forcing file "//trim(infile); err=40; return; end if + if(.not.completed_hruId)then; message=trim(message)//"hruId variable not found in forcing file "//trim(infile);err=40; return; endif + ! check to see if any forcing variables are missed if(any(forcFileInfo(iFile)%data_id(:)==integerMissing))then do iVar=1,size(forcFileInfo(iFile)%data_id) diff --git a/build/source/engine/getVectorz.f90 b/build/source/engine/getVectorz.f90 old mode 100755 new mode 100644 index a25d5090a..dc98ddd0e --- a/build/source/engine/getVectorz.f90 +++ b/build/source/engine/getVectorz.f90 @@ -27,9 +27,6 @@ module getVectorz_module USE globalData,only:integerMissing ! missing integer USE globalData,only:realMissing ! missing real number -! access the global print flag -USE globalData,only:globalPrintFlag - ! domain types USE globalData,only:iname_cas ! named variables for canopy air space USE globalData,only:iname_veg ! named variables for vegetation canopy @@ -53,20 +50,17 @@ module getVectorz_module ! constants USE multiconst,only:& - gravity, & ! acceleration of gravity (m s-2) Tfreeze, & ! temperature at freezing (K) Cp_air, & ! specific heat of air (J kg-1 K-1) - LH_fus, & ! latent heat of fusion (J kg-1) iden_air, & ! intrinsic density of air (kg m-3) - iden_ice, & ! intrinsic density of ice (kg m-3) iden_water ! intrinsic density of liquid water (kg m-3) ! provide access to the derived types to define the data structures USE data_types,only:& var_i, & ! data vector (i4b) - var_d, & ! data vector (dp) + var_d, & ! data vector (rkind) var_ilength, & ! data vector with variable length dimension (i4b) - var_dlength ! data vector with variable length dimension (dp) + var_dlength ! data vector with variable length dimension (rkind) ! provide access to indices that define elements of the data structures USE var_lookup,only:iLookDIAG ! named variables for structure elements @@ -75,10 +69,6 @@ module getVectorz_module USE var_lookup,only:iLookPARAM ! named variables for structure elements USE var_lookup,only:iLookINDEX ! named variables for structure elements -! provide access to routines to update states -USE updatState_module,only:updateSnow ! update snow states -USE updatState_module,only:updateSoil ! update soil states - ! provide access to functions for the constitutive functions and derivatives USE snow_utils_module,only:fracliquid ! compute the fraction of liquid water (snow) USE snow_utils_module,only:dFracLiq_dTk ! differentiate the freezing curve w.r.t. temperature (snow) @@ -87,483 +77,593 @@ module getVectorz_module USE soil_utils_module,only:dPsi_dTheta ! derivative in the soil water characteristic (soil) USE soil_utils_module,only:matricHead ! compute the matric head based on volumetric water content USE soil_utils_module,only:volFracLiq ! compute volumetric fraction of liquid water -USE soil_utils_module,only:crit_soilT ! compute critical temperature below which ice exists -USE soil_utils_module,only:liquidHead ! compute the liquid water matric potential implicit none private public::popStateVec public::getScaling public::varExtract - -! common variables -real(rkind),parameter :: valueMissing=-9999._rkind ! missing value - +public::checkFeas contains - ! ********************************************************************************************************** - ! public subroutine popStateVec: populate model state vectors - ! ********************************************************************************************************** - subroutine popStateVec(& + +! ********************************************************************************************************** +! public subroutine popStateVec: populate model state vectors +! ********************************************************************************************************** +subroutine popStateVec(& ! input: data structures - nState, & ! intent(in): number of desired state variables - prog_data, & ! intent(in): model prognostic variables for a local HRU - diag_data, & ! intent(in): model diagnostic variables for a local HRU - indx_data, & ! intent(in): indices defining model states and layers + nState, & ! intent(in): number of desired state variables + enthalpyStateVec, & ! intent(in): flag if enthalpy is state variable + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(in): model diagnostic variables for a local HRU + indx_data, & ! intent(in): indices defining model states and layers ! output - stateVec, & ! intent(out): model state vector - err,message) ! intent(out): error control - ! -------------------------------------------------------------------------------------------------------------------------------- - ! input: data structures - integer(i4b),intent(in) :: nState ! number of desired state variables - type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU - type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU - type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers - ! output - real(rkind),intent(out) :: stateVec(:) ! model state vector (mixed units) - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! -------------------------------------------------------------------------------------------------------------------------------- - ! local variables - ! -------------------------------------------------------------------------------------------------------------------------------- - ! state subsets - integer(i4b) :: iState ! index of state within the snow+soil domain - integer(i4b) :: iLayer ! index of layer within the snow+soil domain - integer(i4b) :: ixStateSubset ! index within the state subset - logical(lgt),dimension(nState) :: stateFlag ! flag to denote that the state is populated - ! -------------------------------------------------------------------------------------------------------------------------------- - ! -------------------------------------------------------------------------------------------------------------------------------- - ! make association with variables in the data structures - fixedLength: associate(& - ! model states for the vegetation canopy - scalarCanairTemp => prog_data%var(iLookPROG%scalarCanairTemp)%dat(1) ,& ! intent(in) : [dp] temperature of the canopy air space (K) - scalarCanopyTemp => prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1) ,& ! intent(in) : [dp] temperature of the vegetation canopy (K) - scalarCanopyWat => prog_data%var(iLookPROG%scalarCanopyWat)%dat(1) ,& ! intent(in) : [dp] mass of total water on the vegetation canopy (kg m-2) - scalarCanopyLiq => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1) ,& ! intent(in) : [dp] mass of liquid water on the vegetation canopy (kg m-2) - ! model state variable vectors for the snow-soil layers - mLayerTemp => prog_data%var(iLookPROG%mLayerTemp)%dat ,& ! intent(in) : [dp(:)] temperature of each snow/soil layer (K) - mLayerVolFracWat => prog_data%var(iLookPROG%mLayerVolFracWat)%dat ,& ! intent(in) : [dp(:)] volumetric fraction of total water (-) - mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat ,& ! intent(in) : [dp(:)] volumetric fraction of liquid water (-) - mLayerMatricHead => prog_data%var(iLookPROG%mLayerMatricHead)%dat ,& ! intent(in) : [dp(:)] matric head (m) - mLayerMatricHeadLiq => diag_data%var(iLookDIAG%mLayerMatricHeadLiq)%dat ,& ! intent(in) : [dp(:)] matric potential of liquid water (m) - ! model state variables for the aquifer - scalarAquiferStorage=> prog_data%var(iLookPROG%scalarAquiferStorage)%dat(1) ,& ! intent(in) : [dp] storage of water in the aquifer (m) - ! indices defining specific model states - ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat ,& ! intent(in) : [i4b(:)] [length=1] index of canopy air space energy state variable - ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat ,& ! intent(in) : [i4b(:)] [length=1] index of canopy energy state variable - ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat ,& ! intent(in) : [i4b(:)] [length=1] index of canopy hydrology state variable (mass) - ixAqWat => indx_data%var(iLookINDEX%ixAqWat)%dat ,& ! intent(in) : [i4b(:)] [length=1] index of aquifer storage state variable - ! vector of energy and hydrology indices for the snow and soil domains - ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in) : [i4b(:)] index in the state subset for energy state variables in the snow+soil domain - ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in) : [i4b(:)] index in the state subset for hydrology state variables in the snow+soil domain - nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg )%dat(1) ,& ! intent(in) : [i4b] number of energy state variables in the snow+soil domain - nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd )%dat(1) ,& ! intent(in) : [i4b] number of hydrology state variables in the snow+soil domain - ! type of model state variabless - ixStateType_subset => indx_data%var(iLookINDEX%ixStateType_subset)%dat ,& ! intent(in) : [i4b(:)] [state subset] type of desired model state variables - ixHydType => indx_data%var(iLookINDEX%ixHydType)%dat ,& ! intent(in) : [i4b(:)] index of the type of hydrology states in snow+soil domain - ! number of layers - nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in) : [i4b] number of snow layers - nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1) ,& ! intent(in) : [i4b] number of soil layers - nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1) & ! intent(in) : [i4b] total number of layers - ) ! end association with variables in the data structures - ! -------------------------------------------------------------------------------------------------------------------------------- - ! initialize error control - err=0; message='popStateVec/' - - ! ----- - ! * initialize state vectors... - ! ----------------------------- - - ! initialize flags - stateFlag(:) = .false. - - ! build the state vector for the temperature of the canopy air space - ! NOTE: currently vector length=1, and use "do concurrent" to generalize to a multi-layer canopy - do concurrent (iState=1:size(ixCasNrg),ixCasNrg(iState)/=integerMissing) - stateVec( ixCasNrg(iState) ) = scalarCanairTemp ! transfer canopy air temperature to the state vector - stateFlag( ixCasNrg(iState) ) = .true. ! flag to denote that the state is populated - end do - - ! build the state vector for the temperature of the vegetation canopy - ! NOTE: currently vector length=1, and use "do concurrent" to generalize to a multi-layer canopy - do concurrent (iState=1:size(ixVegNrg),ixVegNrg(iState)/=integerMissing) - stateVec( ixVegNrg(iState) ) = scalarCanopyTemp ! transfer vegetation temperature to the state vector - stateFlag( ixVegNrg(iState) ) = .true. ! flag to denote that the state is populated - end do - - ! build the state vector for the water in the vegetation canopy - ! NOTE: currently vector length=1, and use "do concurrent" to generalize to a multi-layer canopy - do concurrent (iState=1:size(ixVegHyd),ixVegHyd(iState)/=integerMissing) - stateFlag( ixVegHyd(iState) ) = .true. ! flag to denote that the state is populated - select case(ixStateType_subset( ixVegHyd(iState) )) - case(iname_watCanopy); stateVec( ixVegHyd(iState) ) = scalarCanopyWat ! transfer total canopy water to the state vector - case(iname_liqCanopy); stateVec( ixVegHyd(iState) ) = scalarCanopyLiq ! transfer liquid canopy water to the state vector - case default; stateFlag( ixVegHyd(iState) ) = .false. ! flag to denote that the state is populated - end select - end do - - ! build the energy state vector for the snow and soil domain - if(nSnowSoilNrg>0)then - do concurrent (iLayer=1:nLayers,ixSnowSoilNrg(iLayer)/=integerMissing) ! (loop through non-missing energy state variables in the snow+soil domain) - ixStateSubset = ixSnowSoilNrg(iLayer) ! index within the state vector - stateVec(ixStateSubset) = mLayerTemp(iLayer) ! transfer temperature from a layer to the state vector - stateFlag(ixStateSubset) = .true. ! flag to denote that the state is populated - end do ! looping through non-missing energy state variables in the snow+soil domain - endif - - ! build the hydrology state vector for the snow+soil domains - ! NOTE: ixVolFracWat and ixVolFracLiq can also include states in the soil domain, hence enable primary variable switching - if(nSnowSoilHyd>0)then - do concurrent (iLayer=1:nLayers,ixSnowSoilHyd(iLayer)/=integerMissing) ! (loop through non-missing hydrology state variables in the snow+soil domain) - ixStateSubset = ixSnowSoilHyd(iLayer) ! index within the state vector - stateFlag(ixStateSubset) = .true. ! flag to denote that the state is populated - select case( ixHydType(iLayer) ) - case(iname_watLayer); stateVec(ixStateSubset) = mLayerVolFracWat(iLayer) ! total water state variable for snow+soil layers - case(iname_liqLayer); stateVec(ixStateSubset) = mLayerVolFracLiq(iLayer) ! liquid water state variable for snow+soil layers - case(iname_matLayer); stateVec(ixStateSubset) = mLayerMatricHead(iLayer-nSnow) ! total water matric potential variable for soil layers - case(iname_lmpLayer); stateVec(ixStateSubset) = mLayerMatricHeadLiq(iLayer-nSnow) ! liquid matric potential state variable for soil layers - case default; stateFlag(ixStateSubset) = .false. ! flag to denote that the state is populated - end select - end do ! looping through non-missing energy state variables in the snow+soil domain - endif - - ! build the state vector for the aquifer storage - ! NOTE: currently vector length=1, and use "do concurrent" to generalize to a multi-layer aquifer - do concurrent (iState=1:size(ixAqWat),ixAqWat(iState)/=integerMissing) - stateVec( ixAqWat(iState) ) = scalarAquiferStorage ! transfer aquifer storage to the state vector - stateFlag( ixAqWat(iState) ) = .true. ! flag to denote that the state is populated - end do - - ! check that we populated all state variables - if(count(stateFlag)/=nState)then - print*, 'stateFlag = ', stateFlag - message=trim(message)//'some state variables unpopulated' - err=20; return - endif - - end associate fixedLength ! end association to variables in the data structure where vector length does not change - end subroutine popStateVec - - - ! ********************************************************************************************************** - ! public subroutine getScaling: get scale factors - ! ********************************************************************************************************** - subroutine getScaling(& - ! input: data structures - diag_data, & ! intent(in): model diagnostic variables for a local HRU - indx_data, & ! intent(in): indices defining model states and layers - ! output - fScale, & ! intent(out): function scaling vector (mixed units) - xScale, & ! intent(out): variable scaling vector (mixed units) - sMul, & ! intent(out): multiplier for state vector (used in the residual calculations) - dMat, & ! intent(out): diagonal of the Jacobian matrix (excludes fluxes) - err,message) ! intent(out): error control - ! -------------------------------------------------------------------------------------------------------------------------------- - USE nr_utility_module,only:arth ! get a sequence of numbers arth(start, incr, count) - USE f2008funcs_module,only:findIndex ! finds the index of the first value within a vector - ! -------------------------------------------------------------------------------------------------------------------------------- - ! input: data structures - type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU - type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers - ! output: state vectors - real(rkind),intent(out) :: fScale(:) ! function scaling vector (mixed units) - real(rkind),intent(out) :: xScale(:) ! variable scaling vector (mixed units) - real(rkind),intent(out) :: sMul(:) ! NOTE: qp ! multiplier for state vector (used in the residual calculations) - real(rkind),intent(out) :: dMat(:) ! diagonal of the Jacobian matrix (excludes fluxes) - ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! -------------------------------------------------------------------------------------------------------------------------------- - ! local variables - ! -------------------------------------------------------------------------------------------------------------------------------- - ! scaling parameters - real(rkind),parameter :: fScaleLiq=0.01_rkind ! func eval: characteristic scale for volumetric liquid water content (-) - real(rkind),parameter :: fScaleMat=10._rkind ! func eval: characteristic scale for matric head (m) - real(rkind),parameter :: fScaleNrg=1000000._rkind ! func eval: characteristic scale for energy (J m-3) - real(rkind),parameter :: xScaleLiq=0.1_rkind ! state var: characteristic scale for volumetric liquid water content (-) - real(rkind),parameter :: xScaleMat=10._rkind ! state var: characteristic scale for matric head (m) - real(rkind),parameter :: xScaleTemp=1._rkind ! state var: characteristic scale for temperature (K) - ! state subsets - integer(i4b) :: iLayer ! index of layer within the snow+soil domain - integer(i4b) :: ixStateSubset ! index within the state subset - ! -------------------------------------------------------------------------------------------------------------------------------- - ! -------------------------------------------------------------------------------------------------------------------------------- - ! make association with variables in the data structures - fixedLength: associate(& - ! model diagnostic variables - canopyDepth => diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1) ,& ! intent(in): [dp] canopy depth (m) - volHeatCapVeg => diag_data%var(iLookDIAG%scalarBulkVolHeatCapVeg)%dat(1),& ! intent(in) : [dp] bulk volumetric heat capacity of vegetation (J m-3 K-1) - mLayerVolHeatCap => diag_data%var(iLookDIAG%mLayerVolHtCapBulk)%dat ,& ! intent(in) : [dp(:)] bulk volumetric heat capacity in each snow and soil layer (J m-3 K-1) - ! indices defining specific model states - ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat ,& ! intent(in) : [i4b(:)] [length=1] index of canopy air space energy state variable - ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat ,& ! intent(in) : [i4b(:)] [length=1] index of canopy energy state variable - ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat ,& ! intent(in) : [i4b(:)] [length=1] index of canopy hydrology state variable (mass) - ! vector of energy and hydrology indices for the snow and soil domains - ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in) : [i4b(:)] index in the state subset for energy state variables in the snow+soil domain - ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in) : [i4b(:)] index in the state subset for hydrology state variables in the snow+soil domain - nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg )%dat(1) ,& ! intent(in) : [i4b] number of energy state variables in the snow+soil domain - nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd )%dat(1) ,& ! intent(in) : [i4b] number of hydrology state variables in the snow+soil domain - ! type of model state variabless - ixStateType_subset => indx_data%var(iLookINDEX%ixStateType_subset)%dat ,& ! intent(in) : [i4b(:)] [state subset] type of desired model state variables - ! number of layers - nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in) : [i4b] number of snow layers - nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1) ,& ! intent(in) : [i4b] number of soil layers - nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1) & ! intent(in) : [i4b] total number of layers - ) ! end association with variables in the data structures - ! -------------------------------------------------------------------------------------------------------------------------------- - ! initialize error control - err=0; message='getScaling/' - - ! ----- - ! * define scaling vectors... - ! --------------------------- - - ! define the function and variable scaling factors for energy - where(ixStateType_subset==iname_nrgCanair .or. ixStateType_subset==iname_nrgCanopy .or. ixStateType_subset==iname_nrgLayer) - fScale = 1._rkind / fScaleNrg ! 1/(J m-3) - xScale = 1._rkind ! K - endwhere - - ! define the function and variable scaling factors for water on the vegetation canopy - where(ixStateType_subset==iname_watCanopy .or. ixStateType_subset==iname_liqCanopy) - fScale = 1._rkind / (fScaleLiq*canopyDepth*iden_water) ! 1/(kg m-2) - xScale = 1._rkind ! (kg m-2) - endwhere - - ! define the function and variable scaling factors for water in the snow+soil domain - where(ixStateType_subset==iname_watLayer .or. ixStateType_subset==iname_liqLayer) - fScale = 1._rkind / fScaleLiq ! (-) - xScale = 1._rkind ! (-) - end where - - ! define the function and variable scaling factors for water in the snow+soil domain - where(ixStateType_subset==iname_matLayer .or. ixStateType_subset==iname_lmpLayer) - fScale = 1._rkind / fScaleLiq ! (-) - xScale = 1._rkind ! (m) - end where - - ! define the function and variable scaling factors for water storage in the aquifer - where(ixStateType_subset==iname_watAquifer) - fScale = 1._rkind - xScale = 1._rkind - endwhere - - ! ----- - ! * define components of derivative matrices that are constant over a time step (substep)... - ! ------------------------------------------------------------------------------------------ - - ! define the multiplier for the state vector for residual calculations (vegetation canopy) - ! NOTE: Use the "where" statement to generalize to multiple canopy layers (currently one canopy layer) - - where(ixStateType_subset==iname_nrgCanair) sMul = Cp_air*iden_air ! volumetric heat capacity of air (J m-3 K-1) - where(ixStateType_subset==iname_nrgCanopy) sMul = volHeatCapVeg ! volumetric heat capacity of the vegetation (J m-3 K-1) - where(ixStateType_subset==iname_watCanopy) sMul = 1._rkind ! nothing else on the left hand side - where(ixStateType_subset==iname_liqCanopy) sMul = 1._rkind ! nothing else on the left hand side - - ! compute terms in the Jacobian for vegetation (excluding fluxes) - ! NOTE: This is computed outside the iteration loop because it does not depend on state variables - ! NOTE: Energy for vegetation is computed *within* the iteration loop as it includes phase change - ! NOTE: Use the "where" statement to generalize to multiple canopy layers (currently one canopy layer) - where(ixStateType_subset==iname_nrgCanair) dMat = Cp_air*iden_air ! volumetric heat capacity of air (J m-3 K-1) - where(ixStateType_subset==iname_nrgCanopy) dMat = realMissing ! populated within the iteration loop - where(ixStateType_subset==iname_watCanopy) dMat = 1._rkind ! nothing else on the left hand side - where(ixStateType_subset==iname_liqCanopy) dMat = 1._rkind ! nothing else on the left hand side - - ! define the energy multiplier and diagonal elements for the state vector for residual calculations (snow-soil domain) - if(nSnowSoilNrg>0)then - do concurrent (iLayer=1:nLayers,ixSnowSoilNrg(iLayer)/=integerMissing) ! (loop through non-missing energy state variables in the snow+soil domain) - ixStateSubset = ixSnowSoilNrg(iLayer) ! index within the state vector - sMul(ixStateSubset) = mLayerVolHeatCap(iLayer) ! transfer volumetric heat capacity to the state multiplier - dMat(ixStateSubset) = realMissing ! diagonal element populated within the iteration loop - end do ! looping through non-missing energy state variables in the snow+soil domain - endif - - ! define the hydrology multiplier and diagonal elements for the state vector for residual calculations (snow-soil domain) - if(nSnowSoilHyd>0)then - do concurrent (iLayer=1:nLayers,ixSnowSoilHyd(iLayer)/=integerMissing) ! (loop through non-missing energy state variables in the snow+soil domain) - ixStateSubset = ixSnowSoilHyd(iLayer) ! index within the state vector - sMul(ixStateSubset) = 1._rkind ! state multiplier = 1 (nothing else on the left-hand-side) - dMat(ixStateSubset) = 1._rkind ! diagonal element = 1 (nothing else on the left-hand-side) - end do ! looping through non-missing energy state variables in the snow+soil domain - endif - - ! define the scaling factor and diagonal elements for the aquifer - where(ixStateType_subset==iname_watAquifer) - sMul = 1._rkind - dMat = 1._rkind - endwhere - - ! ------------------------------------------------------------------------------------------ - ! ------------------------------------------------------------------------------------------ - - end associate fixedLength ! end association to variables in the data structure where vector length does not change - end subroutine getScaling - - - - ! ********************************************************************************************************** - ! public subroutine varExtract: extract variables from the state vector and compute diagnostic variables - ! ********************************************************************************************************** - subroutine varExtract(& + stateVec, & ! intent(out): model state vector + err,message) ! intent(out): error control + ! -------------------------------------------------------------------------------------------------------------------------------- + ! input: data structures + integer(i4b),intent(in) :: nState ! number of desired state variables + logical(lgt),intent(in) :: enthalpyStateVec ! flag if enthalpy is state variable + type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU + type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU + type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers + ! output + real(rkind),intent(out) :: stateVec(:) ! model state vector (mixed units) + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! -------------------------------------------------------------------------------------------------------------------------------- + ! local variables + ! -------------------------------------------------------------------------------------------------------------------------------- + ! state subsets + integer(i4b) :: iState ! index of state within the snow+soil domain + integer(i4b) :: iLayer ! index of layer within the snow+soil domain + integer(i4b) :: ixStateSubset ! index within the state subset + logical(lgt),dimension(nState) :: stateFlag ! flag to denote that the state is populated + ! -------------------------------------------------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------------------------------------------------- + ! make association with variables in the data structures + fixedLength: associate(& + ! model states for the vegetation canopy + scalarCanairTemp => prog_data%var(iLookPROG%scalarCanairTemp)%dat(1) ,& ! intent(in) : [dp] temperature of the canopy air space (K) + scalarCanairEnthalpy => prog_data%var(iLookPROG%scalarCanairEnthalpy)%dat(1) ,& ! intent(in) : [dp] enthalpy of the canopy air space (J m-3) + scalarCanopyTemp => prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1) ,& ! intent(in) : [dp] temperature of the vegetation canopy (K) + scalarCanopyEnthalpy => prog_data%var(iLookPROG%scalarCanopyEnthalpy)%dat(1) ,& ! intent(in) : [dp] enthalpy of the vegetation canopy (J m-3) + scalarCanopyWat => prog_data%var(iLookPROG%scalarCanopyWat)%dat(1) ,& ! intent(in) : [dp] mass of total water on the vegetation canopy (kg m-2) + scalarCanopyLiq => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1) ,& ! intent(in) : [dp] mass of liquid water on the vegetation canopy (kg m-2) + ! model state variable vectors for the snow-soil layers + mLayerTemp => prog_data%var(iLookPROG%mLayerTemp)%dat ,& ! intent(in) : [dp(:)] temperature of each snow/soil layer (K) + mLayerEnthalpy => prog_data%var(iLookPROG%mLayerEnthalpy)%dat ,& ! intent(in) : [dp(:)] enthalpy of each snow+soil layer (J m-3) + mLayerVolFracWat => prog_data%var(iLookPROG%mLayerVolFracWat)%dat ,& ! intent(in) : [dp(:)] volumetric fraction of total water (-) + mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat ,& ! intent(in) : [dp(:)] volumetric fraction of liquid water (-) + mLayerMatricHead => prog_data%var(iLookPROG%mLayerMatricHead)%dat ,& ! intent(in) : [dp(:)] matric head (m) + mLayerMatricHeadLiq => diag_data%var(iLookDIAG%mLayerMatricHeadLiq)%dat ,& ! intent(in) : [dp(:)] matric potential of liquid water (m) + ! model state variables for the aquifer + scalarAquiferStorage => prog_data%var(iLookPROG%scalarAquiferStorage)%dat(1) ,& ! intent(in) : [dp] storage of water in the aquifer (m) + ! indices defining specific model states + ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat ,& ! intent(in) : [i4b(:)] [length=1] index of canopy air space energy state variable + ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat ,& ! intent(in) : [i4b(:)] [length=1] index of canopy energy state variable + ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat ,& ! intent(in) : [i4b(:)] [length=1] index of canopy hydrology state variable (mass) + ixAqWat => indx_data%var(iLookINDEX%ixAqWat)%dat ,& ! intent(in) : [i4b(:)] [length=1] index of aquifer storage state variable + ! vector of energy and hydrology indices for the snow and soil domains + ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in) : [i4b(:)] index in the state subset for energy state variables in the snow+soil domain + ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in) : [i4b(:)] index in the state subset for hydrology state variables in the snow+soil domain + nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg )%dat(1) ,& ! intent(in) : [i4b] number of energy state variables in the snow+soil domain + nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd )%dat(1) ,& ! intent(in) : [i4b] number of hydrology state variables in the snow+soil domain + ! type of model state variabless + ixStateType_subset => indx_data%var(iLookINDEX%ixStateType_subset)%dat ,& ! intent(in) : [i4b(:)] [state subset] type of desired model state variables + ixHydType => indx_data%var(iLookINDEX%ixHydType)%dat ,& ! intent(in) : [i4b(:)] index of the type of hydrology states in snow+soil domain + ! number of layers + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in) : [i4b] number of snow layers + nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1) ,& ! intent(in) : [i4b] number of soil layers + nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1) & ! intent(in) : [i4b] total number of layers + ) ! end association with variables in the data structures + ! -------------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message='popStateVec/' + + ! ----- + ! * initialize state vectors... + ! ----------------------------- + + ! initialize flags + stateFlag(:) = .false. + + ! build the state vector for the temperature of the canopy air space + ! NOTE: currently vector length=1, and use "do concurrent" to generalize to a multi-layer canopy + do concurrent (iState=1:size(ixCasNrg),ixCasNrg(iState)/=integerMissing) + if(enthalpyStateVec)then + stateVec( ixCasNrg(iState) ) = scalarCanairEnthalpy ! transfer canopy air enthalpy to the state vector + else + stateVec( ixCasNrg(iState) ) = scalarCanairTemp ! transfer canopy air temperature to the state vector + endif + stateFlag( ixCasNrg(iState) ) = .true. ! flag to denote that the state is populated + end do + + ! build the state vector for the temperature of the vegetation canopy + ! NOTE: currently vector length=1, and use "do concurrent" to generalize to a multi-layer canopy + do concurrent (iState=1:size(ixVegNrg),ixVegNrg(iState)/=integerMissing) + if(enthalpyStateVec)then + stateVec( ixVegNrg(iState) ) = scalarCanopyEnthalpy ! transfer vegetation enthalpy to the state vector + else + stateVec( ixVegNrg(iState) ) = scalarCanopyTemp ! transfer vegetation temperature to the state vector + endif + stateFlag( ixVegNrg(iState) ) = .true. ! flag to denote that the state is populated + end do + + ! build the state vector for the water in the vegetation canopy + ! NOTE: currently vector length=1, and use "do concurrent" to generalize to a multi-layer canopy + do concurrent (iState=1:size(ixVegHyd),ixVegHyd(iState)/=integerMissing) + stateFlag( ixVegHyd(iState) ) = .true. ! flag to denote that the state is populated + select case(ixStateType_subset( ixVegHyd(iState) )) + case(iname_watCanopy); stateVec( ixVegHyd(iState) ) = scalarCanopyWat ! transfer total canopy water to the state vector + case(iname_liqCanopy); stateVec( ixVegHyd(iState) ) = scalarCanopyLiq ! transfer liquid canopy water to the state vector + case default; stateFlag( ixVegHyd(iState) ) = .false. ! flag to denote that the state is populated + end select + end do + + ! build the energy state vector for the snow and soil domain + if(nSnowSoilNrg>0)then + do concurrent (iLayer=1:nLayers,ixSnowSoilNrg(iLayer)/=integerMissing) ! (loop through non-missing energy state variables in the snow+soil domain) + ixStateSubset = ixSnowSoilNrg(iLayer) ! index within the state vector + if(enthalpyStateVec)then + stateVec(ixStateSubset) = mLayerEnthalpy(iLayer) ! transfer enthalpy from a layer to the state vector + else + stateVec(ixStateSubset) = mLayerTemp(iLayer) ! transfer temperature from a layer to the state vector + endif + stateFlag(ixStateSubset) = .true. ! flag to denote that the state is populated + end do ! looping through non-missing energy state variables in the snow+soil domain + endif + + ! build the hydrology state vector for the snow+soil domains + ! NOTE: ixVolFracWat and ixVolFracLiq can also include states in the soil domain, hence enable primary variable switching + if(nSnowSoilHyd>0)then + do concurrent (iLayer=1:nLayers,ixSnowSoilHyd(iLayer)/=integerMissing) ! (loop through non-missing hydrology state variables in the snow+soil domain) + ixStateSubset = ixSnowSoilHyd(iLayer) ! index within the state vector + stateFlag(ixStateSubset) = .true. ! flag to denote that the state is populated + select case( ixHydType(iLayer) ) + case(iname_watLayer); stateVec(ixStateSubset) = mLayerVolFracWat(iLayer) ! total water state variable for snow+soil layers + case(iname_liqLayer); stateVec(ixStateSubset) = mLayerVolFracLiq(iLayer) ! liquid water state variable for snow+soil layers + case(iname_matLayer); stateVec(ixStateSubset) = mLayerMatricHead(iLayer-nSnow) ! total water matric potential variable for soil layers + case(iname_lmpLayer); stateVec(ixStateSubset) = mLayerMatricHeadLiq(iLayer-nSnow) ! liquid matric potential state variable for soil layers + case default; stateFlag(ixStateSubset) = .false. ! flag to denote that the state is populated + end select + end do ! looping through non-missing energy state variables in the snow+soil domain + endif + + ! build the state vector for the aquifer storage + ! NOTE: currently vector length=1, and use "do concurrent" to generalize to a multi-layer aquifer + do concurrent (iState=1:size(ixAqWat),ixAqWat(iState)/=integerMissing) + stateVec( ixAqWat(iState) ) = scalarAquiferStorage ! transfer aquifer storage to the state vector + stateFlag( ixAqWat(iState) ) = .true. ! flag to denote that the state is populated + end do + + ! check that we populated all state variables + if(count(stateFlag)/=nState)then + print*, 'stateFlag = ', stateFlag + message=trim(message)//'some state variables unpopulated' + err=20; return + endif + + end associate fixedLength ! end association to variables in the data structure where vector length does not change +end subroutine popStateVec + + +! ********************************************************************************************************** +! public subroutine getScaling: get scale factors +! ********************************************************************************************************** +subroutine getScaling(& + ! input: data structures + diag_data, & ! intent(in): model diagnostic variables for a local HRU + indx_data, & ! intent(in): indices defining model states and layers + ! output + fScale, & ! intent(out): characteristic scale of the function evaluations (mixed units) + xScale, & ! intent(out): variable scaling vector (mixed units) + sMul, & ! intent(out): multiplier for state vector (used in the residual calculations) + dMat, & ! intent(out): diagonal of the Jacobian matrix excluding fluxes, not depending on the state vector + err,message) ! intent(out): error control + ! -------------------------------------------------------------------------------------------------------------------------------- + USE nr_utility_module,only:arth ! get a sequence of numbers arth(start, incr, count) + USE f2008funcs_module,only:findIndex ! finds the index of the first value within a vector + ! -------------------------------------------------------------------------------------------------------------------------------- + ! input: data structures + type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU + type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers + ! output: state vectors + real(rkind),intent(out) :: fScale(:) ! characteristic scale of the function evaluations (mixed units) + real(rkind),intent(out) :: xScale(:) ! variable scaling vector (mixed units) + real(qp),intent(out) :: sMul(:) ! NOTE: qp ! multiplier for state vector (used in the residual calculations) + real(rkind),intent(out) :: dMat(:) ! diagonal of the Jacobian matrix excluding fluxes, not depending on the state vector + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! -------------------------------------------------------------------------------------------------------------------------------- + ! local variables + ! -------------------------------------------------------------------------------------------------------------------------------- + ! scaling parameters + real(rkind),parameter :: fScaleLiq=0.01_rkind ! func eval: characteristic scale for volumetric liquid water content (-) + real(rkind),parameter :: fScaleMat=10._rkind ! func eval: characteristic scale for matric head (m) + real(rkind),parameter :: fScaleNrg=1000000._rkind ! func eval: characteristic scale for energy (J m-3) + real(rkind),parameter :: xScaleLiq=0.1_rkind ! state var: characteristic scale for volumetric liquid water content (-) + real(rkind),parameter :: xScaleMat=10._rkind ! state var: characteristic scale for matric head (m) + real(rkind),parameter :: xScaleTemp=1._rkind ! state var: characteristic scale for temperature (K) + ! state subsets + integer(i4b) :: iLayer ! index of layer within the snow+soil domain + integer(i4b) :: ixStateSubset ! index within the state subset + ! -------------------------------------------------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------------------------------------------------- + ! make association with variables in the data structures + fixedLength: associate(& + ! model diagnostic variables + canopyDepth => diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1) ,& ! intent(in): [dp] canopy depth (m) + volHeatCapVeg => diag_data%var(iLookDIAG%scalarBulkVolHeatCapVeg)%dat(1),& ! intent(in) : [dp] bulk volumetric heat capacity of vegetation (J m-3 K-1) + mLayerVolHeatCap => diag_data%var(iLookDIAG%mLayerVolHtCapBulk)%dat ,& ! intent(in) : [dp(:)] bulk volumetric heat capacity in each snow and soil layer (J m-3 K-1) + ! indices defining specific model states + ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat ,& ! intent(in) : [i4b(:)] [length=1] index of canopy air space energy state variable + ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat ,& ! intent(in) : [i4b(:)] [length=1] index of canopy energy state variable + ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat ,& ! intent(in) : [i4b(:)] [length=1] index of canopy hydrology state variable (mass) + ! vector of energy and hydrology indices for the snow and soil domains + ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in) : [i4b(:)] index in the state subset for energy state variables in the snow+soil domain + ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in) : [i4b(:)] index in the state subset for hydrology state variables in the snow+soil domain + nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg )%dat(1) ,& ! intent(in) : [i4b] number of energy state variables in the snow+soil domain + nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd )%dat(1) ,& ! intent(in) : [i4b] number of hydrology state variables in the snow+soil domain + ! type of model state variabless + ixStateType_subset => indx_data%var(iLookINDEX%ixStateType_subset)%dat ,& ! intent(in) : [i4b(:)] [state subset] type of desired model state variables + ! number of layers + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in) : [i4b] number of snow layers + nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1) ,& ! intent(in) : [i4b] number of soil layers + nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1) & ! intent(in) : [i4b] total number of layers + ) ! end association with variables in the data structures + ! -------------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message='getScaling/' + + ! ----- + ! * define scaling vectors... + ! --------------------------- + + ! define the function and variable scaling factors for energy + where(ixStateType_subset==iname_nrgCanair .or. ixStateType_subset==iname_nrgCanopy .or. ixStateType_subset==iname_nrgLayer) + fScale = 1._rkind / fScaleNrg ! 1/(J m-3) + xScale = 1._rkind ! K + endwhere + + ! define the function and variable scaling factors for water on the vegetation canopy + where(ixStateType_subset==iname_watCanopy .or. ixStateType_subset==iname_liqCanopy) + fScale = 1._rkind / (fScaleLiq*canopyDepth*iden_water) ! 1/(kg m-2) + xScale = 1._rkind ! (kg m-2) + endwhere + + ! define the function and variable scaling factors for water in the snow+soil domain + where(ixStateType_subset==iname_watLayer .or. ixStateType_subset==iname_liqLayer) + fScale = 1._rkind / fScaleLiq ! (-) + xScale = 1._rkind ! (-) + end where + + ! define the function and variable scaling factors for water in the snow+soil domain + where(ixStateType_subset==iname_matLayer .or. ixStateType_subset==iname_lmpLayer) + fScale = 1._rkind / fScaleLiq ! (-) + xScale = 1._rkind ! (m) + end where + + ! define the function and variable scaling factors for water storage in the aquifer + where(ixStateType_subset==iname_watAquifer) + fScale = 1._rkind + xScale = 1._rkind + endwhere + + ! ----- + ! * define components of derivative matrices at start of time step (substep)... + ! ------------------------------------------------------------------------------------------ + + ! define the multiplier for the state vector for residual calculations (vegetation canopy) + ! NOTE: Use the "where" statement to generalize to multiple canopy layers (currently one canopy layer) + where(ixStateType_subset==iname_nrgCanair) sMul = Cp_air*iden_air ! volumetric heat capacity of air (J m-3 K-1) + where(ixStateType_subset==iname_nrgCanopy) sMul = volHeatCapVeg ! volumetric heat capacity of the vegetation (J m-3 K-1) + where(ixStateType_subset==iname_watCanopy) sMul = 1._rkind ! nothing else on the left hand side + where(ixStateType_subset==iname_liqCanopy) sMul = 1._rkind ! nothing else on the left hand side + + ! compute terms in the Jacobian for vegetation (excluding fluxes) + ! NOTE: This is computed outside the iteration loop because it does not depend on state variables + ! NOTE: Energy for vegetation is computed *within* the iteration loop as it includes phase change + ! NOTE: Use the "where" statement to generalize to multiple canopy layers (currently one canopy layer) + where(ixStateType_subset==iname_nrgCanair) dMat = Cp_air*iden_air ! volumetric heat capacity of air (J m-3 K-1) + where(ixStateType_subset==iname_nrgCanopy) dMat = realMissing ! populated within the iteration loop + where(ixStateType_subset==iname_watCanopy) dMat = 1._rkind ! nothing else on the left hand side + where(ixStateType_subset==iname_liqCanopy) dMat = 1._rkind ! nothing else on the left hand side + + ! define the energy multiplier and diagonal elements for the state vector for residual calculations (snow-soil domain) + if(nSnowSoilNrg>0)then + do concurrent (iLayer=1:nLayers,ixSnowSoilNrg(iLayer)/=integerMissing) ! (loop through non-missing energy state variables in the snow+soil domain) + ixStateSubset = ixSnowSoilNrg(iLayer) ! index within the state vector + sMul(ixStateSubset) = mLayerVolHeatCap(iLayer) ! transfer volumetric heat capacity to the state multiplier + dMat(ixStateSubset) = realMissing ! diagonal element populated within the iteration loop + end do ! looping through non-missing energy state variables in the snow+soil domain + endif + + ! define the hydrology multiplier and diagonal elements for the state vector for residual calculations (snow-soil domain) + if(nSnowSoilHyd>0)then + do concurrent (iLayer=1:nLayers,ixSnowSoilHyd(iLayer)/=integerMissing) ! (loop through non-missing energy state variables in the snow+soil domain) + ixStateSubset = ixSnowSoilHyd(iLayer) ! index within the state vector + sMul(ixStateSubset) = 1._rkind ! state multiplier = 1 (nothing else on the left-hand-side) + dMat(ixStateSubset) = 1._rkind ! diagonal element = 1 (nothing else on the left-hand-side) + end do ! looping through non-missing energy state variables in the snow+soil domain + endif + + ! define the scaling factor and diagonal elements for the aquifer + where(ixStateType_subset==iname_watAquifer) + sMul = 1._rkind + dMat = 1._rkind + endwhere + + end associate fixedLength ! end association to variables in the data structure where vector length does not change +end subroutine getScaling + + +! ********************************************************************************************************** +! public subroutine checkFeas: check feasibility of the state vector +! ********************************************************************************************************** +subroutine checkFeas(& + ! input + stateVec, & ! intent(in): model state vector (mixed units) + mpar_data, & ! intent(in): model parameters + prog_data, & ! intent(in): model prognostic variables for a local HRU + indx_data, & ! intent(in): indices defining model states and layers + enthalpyStateVec, & ! intent(in): flag if enthalpy is state variable + ! output: feasibility + feasible, & ! intent(inout): flag to denote the feasibility of the solution + ! output: error control + err,message) ! intent(out): error control + ! -------------------------------------------------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------------------------------------------------- + implicit none + ! input + real(rkind),intent(in) :: stateVec(:) ! model state vector (mixed units) + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU + type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers + logical(lgt),intent(in) :: enthalpyStateVec ! flag if enthalpy is state variable + ! output: feasibility + logical(lgt),intent(inout) :: feasible ! flag to denote the feasibility of the solution + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! -------------------------------------------------------------------------------------------------------------------------------- + ! local variables + integer(i4b) :: iLayer ! index of layer within the snow+soil domain + real(rkind) :: xMin,xMax ! minimum and maximum values for water content + real(rkind),parameter :: canopyTempMax=500._rkind ! expected maximum value for the canopy temperature (K) + logical(lgt),parameter :: printFlag=.false. ! flag to denote if we print infeasibilities + ! -------------------------------------------------------------------------------------------------------------------------------- + ! make association with variables in the data structures + associate(& + ! soil parameters + theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat ,& ! intent(in): [dp(:)] soil porosity (-) + theta_res => mpar_data%var(iLookPARAM%theta_res)%dat ,& ! intent(in): [dp(:)] residual volumetric water content (-) + ! model diagnostic variables from the previous solution + mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat ,& ! intent(in): [dp(:)] volumetric fraction of ice (-) + ! number of model layers, and layer type + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in): [i4b] total number of snow layers + nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1) ,& ! intent(in): [i4b] total number of soil layers + nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1) ,& ! intent(in): [i4b] total number of snow and soil layers + ! indices defining model states and layers + ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy air space energy state variable + ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable + ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) + ixSnowOnlyNrg => indx_data%var(iLookINDEX%ixSnowOnlyNrg)%dat ,& ! intent(in): [i4b(:)] indices for energy states in the snow subdomain + ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in): [i4b(:)] indices for hydrology states in the snow+soil subdomain + ixStateType => indx_data%var(iLookINDEX%ixStateType)%dat ,& ! intent(in): [i4b(:)] indices defining the type of the state (iname_nrgLayer...) + ixHydCanopy => indx_data%var(iLookINDEX%ixHydCanopy)%dat ,& ! intent(in): [i4b(:)] index of the hydrology states in the canopy domain + ixHydType => indx_data%var(iLookINDEX%ixHydType)%dat ,& ! intent(in): [i4b(:)] index of the type of hydrology states in snow+soil domain + layerType => indx_data%var(iLookINDEX%layerType)%dat & ! intent(in): [i4b(:)] layer type (iname_soil or iname_snow) + )! association with variables in the data structures + ! -------------------------------------------------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------------------------------------------------- + + ! initialize error control + err=0; message="checkFeas/" + + ! NOTE: we will not print infeasibilities since it does not indicate a failure, just a need to iterate until maxiter + feasible=.true. + ! check that the canopy air space temperature is reasonable + if(ixCasNrg/=integerMissing)then + if(stateVec(ixCasNrg) > canopyTempMax .and. .not.enthalpyStateVec)then + feasible=.false. + message=trim(message)//'canopy air space temp high/' + if(printFlag) write(*,'(a,1x,L1,1x,10(f20.10,1x))') 'feasible, max, stateVec( ixCasNrg )', feasible, canopyTempMax, stateVec(ixCasNrg) + endif + endif + + ! check that the canopy air space temperature is reasonable + if(ixVegNrg/=integerMissing)then + if(stateVec(ixVegNrg) > canopyTempMax .and. .not.enthalpyStateVec)then + feasible=.false. + message=trim(message)//'canopy temp high/' + if(printFlag) write(*,'(a,1x,L1,1x,10(f20.10,1x))') 'feasible, max, stateVec( ixVegNrg )', feasible, canopyTempMax, stateVec(ixVegNrg) + endif + endif + + ! check canopy liquid water is not negative + if(ixVegHyd/=integerMissing)then + if(stateVec(ixVegHyd) < 0._rkind)then + feasible=.false. + message=trim(message)//'canopy liq water neg/' + if(printFlag) write(*,'(a,1x,L1,1x,10(f20.10,1x))') 'feasible, min, stateVec( ixVegHyd )', feasible, 0._rkind, stateVec(ixVegHyd) + endif + endif + + ! check snow temperature is below freezing + if(count(ixSnowOnlyNrg/=integerMissing)>0)then + if(any(stateVec( pack(ixSnowOnlyNrg,ixSnowOnlyNrg/=integerMissing) ) > Tfreeze) .and. .not.enthalpyStateVec)then + feasible=.false. + message=trim(message)//'snow temp high/' + if(printFlag)then + do iLayer=1,nSnow + if(stateVec(ixSnowOnlyNrg(iLayer)) > Tfreeze) write(*,'(a,1x,i4,1x,L1,1x,10(f20.10,1x))') 'iLayer, feasible, max, stateVec( ixSnowOnlyNrg(iLayer) )', iLayer, feasible, Tfreeze, stateVec( ixSnowOnlyNrg(iLayer) ) + enddo + endif + endif + endif + + ! loop through non-missing hydrology state variables in the snow+soil domain + do concurrent (iLayer=1:nLayers,ixSnowSoilHyd(iLayer)/=integerMissing) + + ! check the minimum and maximum water constraints + if(ixHydType(iLayer)==iname_watLayer .or. ixHydType(iLayer)==iname_liqLayer)then + + ! --> minimum + if (layerType(iLayer) == iname_soil) then + xMin = theta_res(iLayer-nSnow) + else + xMin = 0._rkind + endif + + ! --> maximum + select case( layerType(iLayer) ) + case(iname_snow); xMax = merge(1._rkind, 1._rkind - mLayerVolFracIce(iLayer), ixHydType(iLayer)==iname_watLayer) + case(iname_soil); xMax = merge(theta_sat(iLayer-nSnow), theta_sat(iLayer-nSnow) - mLayerVolFracIce(iLayer), ixHydType(iLayer)==iname_watLayer) + end select + + ! --> check + if(stateVec( ixSnowSoilHyd(iLayer) ) < xMin .or. stateVec( ixSnowSoilHyd(iLayer) ) > xMax)then + feasible=.false. + message=trim(message)//'layer water out of bounds/' + if(printFlag)then + if(stateVec( ixSnowSoilHyd(iLayer) ) < xMin .or. stateVec( ixSnowSoilHyd(iLayer) ) > xMax) & + write(*,'(a,1x,i4,1x,L1,1x,10(f20.10,1x))') 'iLayer, feasible, stateVec( ixSnowSoilHyd(iLayer) ), xMin, xMax = ', iLayer, feasible, stateVec( ixSnowSoilHyd(iLayer) ), xMin, xMax + endif + endif + endif ! if water states + + end do ! loop through non-missing hydrology state variables in the snow+soil domain + + end associate ! end association to variables in the data structure +end subroutine checkFeas + + +! ********************************************************************************************************** +! public subroutine varExtract: extract variables from the state vector and compute diagnostic variables +! This routine does not initialize any of the variables +! ********************************************************************************************************** +subroutine varExtract(& ! input stateVec, & ! intent(in): model state vector (mixed units) - diag_data, & ! intent(in): model diagnostic variables for a local HRU - prog_data, & ! intent(in): model prognostic variables for a local HRU indx_data, & ! intent(in): indices defining model states and layers ! output: variables for the vegetation canopy - scalarCanairTempTrial, & ! intent(out): trial value of canopy air temperature (K) - scalarCanopyTempTrial, & ! intent(out): trial value of canopy temperature (K) - scalarCanopyWatTrial, & ! intent(out): trial value of canopy total water (kg m-2) - scalarCanopyLiqTrial, & ! intent(out): trial value of canopy liquid water (kg m-2) - scalarCanopyIceTrial, & ! intent(out): trial value of canopy ice content (kg m-2) + scalarCanairNrgTrial, & ! intent(inout): trial value of canopy air energy, temperature (K) or enthalpy (J m-3) + scalarCanopyNrgTrial, & ! intent(inout): trial value of canopy energy, temperature (K) or enthalpy (J m-3) + scalarCanopyWatTrial, & ! intent(inout): trial value of canopy total water (kg m-2) + scalarCanopyLiqTrial, & ! intent(inout): trial value of canopy liquid water (kg m-2) ! output: variables for the snow-soil domain - mLayerTempTrial, & ! intent(out): trial vector of layer temperature (K) - mLayerVolFracWatTrial, & ! intent(out): trial vector of volumetric total water content (-) - mLayerVolFracLiqTrial, & ! intent(out): trial vector of volumetric liquid water content (-) - mLayerVolFracIceTrial, & ! intent(out): trial vector of volumetric ice water content (-) - mLayerMatricHeadTrial, & ! intent(out): trial vector of total water matric potential (m) - mLayerMatricHeadLiqTrial, & ! intent(out): trial vector of liquid water matric potential (m) + mLayerNrgTrial, & ! intent(inout): trial vector of layer energy, temperature (K) or enthalpy (J m-3) + mLayerVolFracWatTrial, & ! intent(inout): trial vector of volumetric total water content (-) + mLayerVolFracLiqTrial, & ! intent(inout): trial vector of volumetric liquid water content (-) + mLayerMatricHeadTrial, & ! intent(inout): trial vector of total water matric potential (m) + mLayerMatricHeadLiqTrial, & ! intent(inout): trial vector of liquid water matric potential (m) ! output: variables for the aquifer scalarAquiferStorageTrial, & ! intent(out): trial value of storage of water in the aquifer (m) ! output: error control err,message) ! intent(out): error control - ! -------------------------------------------------------------------------------------------------------------------------------- - ! -------------------------------------------------------------------------------------------------------------------------------- - implicit none - ! input - real(rkind),intent(in) :: stateVec(:) ! model state vector (mixed units) - type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU - type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU - type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers - ! output: variables for the vegetation canopy - real(rkind),intent(out) :: scalarCanairTempTrial ! trial value of canopy air temperature (K) - real(rkind),intent(out) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) - real(rkind),intent(out) :: scalarCanopyWatTrial ! trial value of canopy total water (kg m-2) - real(rkind),intent(out) :: scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) - real(rkind),intent(out) :: scalarCanopyIceTrial ! trial value of canopy ice content (kg m-2) - ! output: variables for the snow-soil domain - real(rkind),intent(out) :: mLayerTempTrial(:) ! trial vector of layer temperature (K) - real(rkind),intent(out) :: mLayerVolFracWatTrial(:) ! trial vector of volumetric total water content (-) - real(rkind),intent(out) :: mLayerVolFracLiqTrial(:) ! trial vector of volumetric liquid water content (-) - real(rkind),intent(out) :: mLayerVolFracIceTrial(:) ! trial vector of volumetric ice water content (-) - real(rkind),intent(out) :: mLayerMatricHeadTrial(:) ! trial vector of total water matric potential (m) - real(rkind),intent(out) :: mLayerMatricHeadLiqTrial(:) ! trial vector of liquid water matric potential (m) - ! output: variables for the aquifer - real(rkind),intent(out) :: scalarAquiferStorageTrial ! trial value of storage of water in the aquifer (m) - ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! -------------------------------------------------------------------------------------------------------------------------------- - ! local variables - integer(i4b) :: iLayer ! index of layer within the snow+soil domain - ! -------------------------------------------------------------------------------------------------------------------------------- - ! make association with variables in the data structures - associate(& - ! number of model layers, and layer type - nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in): [i4b] total number of snow layers - nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1) ,& ! intent(in): [i4b] total number of soil layers - nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1) ,& ! intent(in): [i4b] total number of snow and soil layers - ! indices defining model states and layers - ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy air space energy state variable - ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable - ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) - ixAqWat => indx_data%var(iLookINDEX%ixAqWat)%dat(1) ,& ! intent(in): [i4b] index of the squifer storage state variable - ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in): [i4b(:)] indices IN THE STATE SUBSET for energy states in the snow+soil subdomain - ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in): [i4b(:)] indices IN THE STATE SUBSET for hydrology states in the snow+soil subdomain - nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg )%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow+soil domain - nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the snow+soil domain - ! indices defining type of model state variables - ixStateType_subset => indx_data%var(iLookINDEX%ixStateType_subset)%dat ,& ! intent(in): [i4b(:)] [state subset] type of desired model state variables - ixHydType => indx_data%var(iLookINDEX%ixHydType)%dat ,& ! intent(in): [i4b(:)] index of the type of hydrology states in snow+soil domain - ! model states for the vegetation canopy - scalarCanairTemp => prog_data%var(iLookPROG%scalarCanairTemp)%dat(1) ,& ! intent(in): [dp] temperature of the canopy air space (K) - scalarCanopyTemp => prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1) ,& ! intent(in): [dp] temperature of the vegetation canopy (K) - scalarCanopyWat => prog_data%var(iLookPROG%scalarCanopyWat)%dat(1) ,& ! intent(in): [dp] mass of total water on the vegetation canopy (kg m-2) - ! model state variable vectors for the snow-soil layers - mLayerTemp => prog_data%var(iLookPROG%mLayerTemp)%dat ,& ! intent(in): [dp(:)] temperature of each snow/soil layer (K) - mLayerVolFracWat => prog_data%var(iLookPROG%mLayerVolFracWat)%dat ,& ! intent(in): [dp(:)] volumetric fraction of total water (-) - mLayerMatricHead => prog_data%var(iLookPROG%mLayerMatricHead)%dat ,& ! intent(in): [dp(:)] total water matric potential (m) - mLayerMatricHeadLiq => diag_data%var(iLookDIAG%mLayerMatricHeadLiq)%dat ,& ! intent(in): [dp(:)] liquid water matric potential (m) - ! model state variables for the aquifer - scalarAquiferStorage => prog_data%var(iLookPROG%scalarAquiferStorage)%dat(1) ,& ! intent(in): [dp] storage of water in the aquifer (m) - ! model diagnostic variables from a previous solution - scalarCanopyLiq => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1) ,& ! intent(in): [dp(:)] mass of liquid water on the vegetation canopy (kg m-2) - scalarCanopyIce => prog_data%var(iLookPROG%scalarCanopyIce)%dat(1) ,& ! intent(in): [dp(:)] mass of ice on the vegetation canopy (kg m-2) - mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat ,& ! intent(in): [dp(:)] volumetric fraction of liquid water (-) - mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat & ! intent(in): [dp(:)] volumetric fraction of ice (-) - ) ! association with variables in the data structures - - ! -------------------------------------------------------------------------------------------------------------------------------- - ! -------------------------------------------------------------------------------------------------------------------------------- - - ! initialize error control - err=0; message='varExtract/' - - ! *** extract state variables for the vegetation canopy - - ! initialize to state variable from the last update - scalarCanairTempTrial = scalarCanairTemp - scalarCanopyTempTrial = scalarCanopyTemp - scalarCanopyWatTrial = scalarCanopyWat - scalarCanopyLiqTrial = scalarCanopyLiq - scalarCanopyIceTrial = scalarCanopyIce - - ! check if computing the vegetation flux - if(ixCasNrg/=integerMissing .or. ixVegNrg/=integerMissing .or. ixVegHyd/=integerMissing)then - - ! extract temperature of the canopy air space - if(ixCasNrg/=integerMissing) scalarCanairTempTrial = stateVec(ixCasNrg) - - ! extract canopy temperature - if(ixVegNrg/=integerMissing) scalarCanopyTempTrial = stateVec(ixVegNrg) - - ! extract intercepted water - if(ixVegHyd/=integerMissing)then - select case( ixStateType_subset(ixVegHyd) ) - case(iname_liqCanopy); scalarCanopyLiqTrial = stateVec(ixVegHyd) - case(iname_watCanopy); scalarCanopyWatTrial = stateVec(ixVegHyd) - case default; err=20; message=trim(message)//'case not found: expect iname_liqCanopy or iname_watCanopy'; return - end select - endif - - endif ! not computing the vegetation flux - - ! *** extract state variables from the snow+soil sub-domain - - ! initialize to the state variable from the last update - mLayerTempTrial = mLayerTemp - mLayerVolFracWatTrial = mLayerVolFracWat - mLayerVolFracLiqTrial = mLayerVolFracLiq - mLayerVolFracIceTrial = mLayerVolFracIce - mLayerMatricHeadTrial = mLayerMatricHead ! total water matric potential - mLayerMatricHeadLiqTrial = mLayerMatricHeadLiq ! liquid water matric potential - scalarAquiferStorageTrial = scalarAquiferStorage - - ! overwrite with the energy values from the state vector - if(nSnowSoilNrg>0)then - do concurrent (iLayer=1:nLayers,ixSnowSoilNrg(iLayer)/=integerMissing) ! (loop through non-missing energy state variables in the snow+soil domain) - mLayerTempTrial(iLayer) = stateVec( ixSnowSoilNrg(iLayer) ) - end do ! looping through non-missing energy state variables in the snow+soil domain - endif - - ! overwrite with the hydrology values from the state vector - if(nSnowSoilHyd>0)then - do concurrent (iLayer=1:nLayers,ixSnowSoilHyd(iLayer)/=integerMissing) ! (loop through non-missing hydrology state variables in the snow+soil domain) - select case( ixHydType(iLayer) ) - case(iname_watLayer); mLayerVolFracWatTrial(iLayer) = stateVec( ixSnowSoilHyd(iLayer) ) ! total water state variable for snow+soil layers - case(iname_liqLayer); mLayerVolFracLiqTrial(iLayer) = stateVec( ixSnowSoilHyd(iLayer) ) ! liquid water state variable for snow+soil layers - case(iname_matLayer); mLayerMatricHeadTrial(iLayer-nSnow) = stateVec( ixSnowSoilHyd(iLayer) ) ! total water matric potential variable for soil layers - case(iname_lmpLayer); mLayerMatricHeadLiqTrial(iLayer-nSnow) = stateVec( ixSnowSoilHyd(iLayer) ) ! liquid matric potential state variable for soil layers - case default ! do nothing - end select - end do ! looping through non-missing energy state variables in the snow+soil domain - endif - - ! extract temperature of the canopy air space - if(ixAqWat/=integerMissing) scalarAquiferStorageTrial = stateVec(ixAqWat) - - end associate - - end subroutine varExtract + ! -------------------------------------------------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------------------------------------------------- + implicit none + ! input + real(rkind),intent(in) :: stateVec(:) ! model state vector (mixed units) + type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers + ! output: variables for the vegetation canopy + real(rkind),intent(inout) :: scalarCanairNrgTrial ! trial value of canopy air energy, temperature (K) or enthalpy (J m-3) + real(rkind),intent(inout) :: scalarCanopyNrgTrial ! trial value of canopy energy, temperature (K) or enthalpy (J m-3) + real(rkind),intent(inout) :: scalarCanopyWatTrial ! trial value of canopy total water (kg m-2) + real(rkind),intent(inout) :: scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) + ! output: variables for the snow-soil domain + real(rkind),intent(inout) :: mLayerNrgTrial(:) ! trial vector of layer energy, temperature (K) or enthalpy (J m-3) + real(rkind),intent(inout) :: mLayerVolFracWatTrial(:) ! trial vector of volumetric total water content (-) + real(rkind),intent(inout) :: mLayerVolFracLiqTrial(:) ! trial vector of volumetric liquid water content (-) + real(rkind),intent(inout) :: mLayerMatricHeadTrial(:) ! trial vector of total water matric potential (m) + real(rkind),intent(inout) :: mLayerMatricHeadLiqTrial(:) ! trial vector of liquid water matric potential (m) + ! output: variables for the aquifer + real(rkind),intent(inout) :: scalarAquiferStorageTrial ! trial value of storage of water in the aquifer (m) + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! -------------------------------------------------------------------------------------------------------------------------------- + ! local variables + integer(i4b) :: iLayer ! index of layer within the snow+soil domain + ! -------------------------------------------------------------------------------------------------------------------------------- + ! make association with variables in the data structures + associate(& + ! number of model layers, and layer type + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in): [i4b] total number of snow layers + nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1) ,& ! intent(in): [i4b] total number of soil layers + nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1) ,& ! intent(in): [i4b] total number of snow and soil layers + ! indices defining model states and layers + ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy air space energy state variable + ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable + ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) + ixAqWat => indx_data%var(iLookINDEX%ixAqWat)%dat(1) ,& ! intent(in): [i4b] index of the squifer storage state variable + ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in): [i4b(:)] indices IN THE STATE SUBSET for energy states in the snow+soil subdomain + ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in): [i4b(:)] indices IN THE STATE SUBSET for hydrology states in the snow+soil subdomain + nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg )%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow+soil domain + nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the snow+soil domain + ! indices defining type of model state variables + ixStateType_subset => indx_data%var(iLookINDEX%ixStateType_subset)%dat ,& ! intent(in): [i4b(:)] [state subset] type of desired model state variables + ixHydType => indx_data%var(iLookINDEX%ixHydType)%dat & ! intent(in): [i4b(:)] index of the type of hydrology states in snow+soil domain + )! association with variables in the data structures + + ! -------------------------------------------------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------------------------------------------------- + + ! initialize error control + err=0; message='varExtract/' + + ! *** extract state variables for the vegetation canopy + + ! check if computing the vegetation flux + if(ixCasNrg/=integerMissing .or. ixVegNrg/=integerMissing .or. ixVegHyd/=integerMissing)then + + ! extract temperature of the canopy air space + if(ixCasNrg/=integerMissing) scalarCanairNrgTrial = stateVec(ixCasNrg) + + ! extract canopy temperature + if(ixVegNrg/=integerMissing) scalarCanopyNrgTrial = stateVec(ixVegNrg) + + ! extract intercepted water + if(ixVegHyd/=integerMissing)then + select case( ixStateType_subset(ixVegHyd) ) + case(iname_liqCanopy); scalarCanopyLiqTrial = stateVec(ixVegHyd) + case(iname_watCanopy); scalarCanopyWatTrial = stateVec(ixVegHyd) + case default; err=20; message=trim(message)//'case not found: expect iname_liqCanopy or iname_watCanopy'; return + end select + endif + + endif ! not computing the vegetation flux + + ! *** extract state variables from the snow+soil sub-domain + + + ! overwrite with the energy values from the state vector + if(nSnowSoilNrg>0)then + do concurrent (iLayer=1:nLayers,ixSnowSoilNrg(iLayer)/=integerMissing) ! (loop through non-missing energy state variables in the snow+soil domain) + mLayerNrgTrial(iLayer) = stateVec( ixSnowSoilNrg(iLayer) ) + end do ! looping through non-missing energy state variables in the snow+soil domain + endif + + ! overwrite with the hydrology values from the state vector + if(nSnowSoilHyd>0)then + do concurrent (iLayer=1:nLayers,ixSnowSoilHyd(iLayer)/=integerMissing) ! (loop through non-missing hydrology state variables in the snow+soil domain) + select case( ixHydType(iLayer) ) + case(iname_watLayer); mLayerVolFracWatTrial(iLayer) = stateVec( ixSnowSoilHyd(iLayer) ) ! total water state variable for snow+soil layers + case(iname_liqLayer); mLayerVolFracLiqTrial(iLayer) = stateVec( ixSnowSoilHyd(iLayer) ) ! liquid water state variable for snow+soil layers + case(iname_matLayer); mLayerMatricHeadTrial(iLayer-nSnow) = stateVec( ixSnowSoilHyd(iLayer) ) ! total water matric potential variable for soil layers + case(iname_lmpLayer); mLayerMatricHeadLiqTrial(iLayer-nSnow) = stateVec( ixSnowSoilHyd(iLayer) ) ! liquid matric potential state variable for soil layers + case default ! do nothing + end select + end do ! looping through non-missing energy state variables in the snow+soil domain + endif + + ! extract temperature of the canopy air space + if(ixAqWat/=integerMissing) scalarAquiferStorageTrial = stateVec(ixAqWat) + + end associate +end subroutine varExtract end module getVectorz_module diff --git a/build/source/engine/groundwatr.f90 b/build/source/engine/groundwatr.f90 old mode 100755 new mode 100644 index d4b5a12a1..90c90659f --- a/build/source/engine/groundwatr.f90 +++ b/build/source/engine/groundwatr.f90 @@ -24,12 +24,15 @@ module groundwatr_module USE nrtype ! model constants -USE multiconst,only:iden_water ! density of water (kg m-3) +USE multiconst,only:iden_water ! density of water (kg m-3) ! derived types to define the data structures USE data_types,only:& - var_d, & ! data vector (dp) - var_dlength ! data vector with variable length dimension (dp) + var_d, & ! data vector (rkind) + var_dlength, & ! data vector with variable length dimension (rkind) + in_type_groundwatr, & ! intent(in) arguments for groundwatr call + io_type_groundwatr, & ! intent(inout) arguments for groundwatr call + out_type_groundwatr ! intent(out) arguments for groundwatr call ! named variables defining elements in the data structures USE var_lookup,only:iLookATTR ! named variables for structure elements @@ -40,496 +43,366 @@ module groundwatr_module ! look-up values for the choice of groundwater parameterization USE mDecisions_module,only: & - qbaseTopmodel, & ! TOPMODEL-ish baseflow parameterization - bigBucket, & ! a big bucket (lumped aquifer model) - noExplicit ! no explicit groundwater parameterization + qbaseTopmodel, & ! TOPMODEL-ish baseflow parameterization + bigBucket, & ! a big bucket (lumped aquifer model) + noExplicit ! no explicit groundwater parameterization ! privacy implicit none -! constant parameters -real(rkind),parameter :: valueMissing=-9999._rkind ! missing value parameter -real(rkind),parameter :: verySmall=epsilon(1.0_rkind) ! a very small number (used to avoid divide by zero) -real(rkind),parameter :: dx=1.e-8_rkind ! finite difference increment private -public::groundwatr +public :: groundwatr contains - - ! ************************************************************************************************ - ! public subroutine groundwatr: compute the groundwater sink term in Richards' equation - ! ************************************************************************************************ - ! - ! Method - ! ------ - ! - ! Here we assume that water avaialble for shallow groundwater flow includes is all water above - ! "field capacity" below the depth zCrit, where zCrit is defined as the lowest point in the soil - ! profile where the volumetric liquid water content is less than field capacity. - ! - ! We further assume that transmssivity (m2 s-1) for each layer is defined asuming that the water - ! available for saturated flow is located at the bottom of the soil profile. Specifically: - ! trTotal(iLayer) = tran0*(zActive(iLayer)/soilDepth)**zScale_TOPMODEL - ! trSoil(iLayer) = trTotal(iLayer) - trTotal(iLayer+1) - ! where zActive(iLayer) is the effective water table thickness for all layers up to and including - ! the current layer (working from the bottom to the top). - ! - ! The outflow from each layer is then (m3 s-1) - ! mLayerOutflow(iLayer) = trSoil(iLayer)*tan_slope*contourLength - ! where contourLength is the width of a hillslope (m) parallel to a stream - ! - ! ************************************************************************************************ - subroutine groundwatr(& - - ! input: model control - nSnow, & ! intent(in): number of snow layers - nSoil, & ! intent(in): number of soil layers - nLayers, & ! intent(in): total number of layers - getSatDepth, & ! intent(in): logical flag to compute index of the lowest saturated layer - - ! input: state and diagnostic variables - mLayerdTheta_dPsi, & ! intent(in): derivative in the soil water characteristic w.r.t. matric head in each layer (m-1) - mLayerMatricHeadLiq, & ! intent(in): liquid water matric potential (m) - mLayerVolFracLiq, & ! intent(in): volumetric fraction of liquid water (-) - mLayerVolFracIce, & ! intent(in): volumetric fraction of ice (-) - - ! input/output: data structures - attr_data, & ! intent(in): spatial attributes - mpar_data, & ! intent(in): model parameters - prog_data, & ! intent(in): model prognostic variables for a local HRU - diag_data, & ! intent(in): model diagnostic variables for a local HRU - flux_data, & ! intent(inout): model fluxes for a local HRU - - ! output: baseflow - ixSaturation, & ! intent(inout) index of lowest saturated layer (NOTE: only computed on the first iteration) - mLayerBaseflow, & ! intent(out): baseflow from each soil layer (m s-1) - dBaseflow_dMatric, & ! intent(out): derivative in baseflow w.r.t. matric head (s-1) - - ! output: error control - err,message) ! intent(out): error control - ! --------------------------------------------------------------------------------------- - ! utility modules - USE soil_utils_module,only:volFracLiq ! compute volumetric fraction of liquid water as a function of matric head - USE soil_utils_module,only:hydCond_psi ! compute hydraulic conductivity as a function of matric head - implicit none - ! --------------------------------------------------------------------------------------- - ! * dummy variables - ! --------------------------------------------------------------------------------------- - ! input: model control - integer(i4b),intent(in) :: nSnow ! number of snow layers - integer(i4b),intent(in) :: nSoil ! number of soil layers - integer(i4b),intent(in) :: nLayers ! total number of layers - logical(lgt),intent(in) :: getSatDepth ! logical flag to compute index of the lowest saturated layer - ! input: state and diagnostic variables - real(rkind),intent(in) :: mLayerdTheta_dPsi(:) ! derivative in the soil water characteristic w.r.t. matric head in each layer (m-1) - real(rkind),intent(in) :: mLayerMatricHeadLiq(:) ! matric head in each layer at the current iteration (m) - real(rkind),intent(in) :: mLayerVolFracLiq(:) ! volumetric fraction of liquid water (-) - real(rkind),intent(in) :: mLayerVolFracIce(:) ! volumetric fraction of ice (-) - ! input/output: data structures - type(var_d),intent(in) :: attr_data ! spatial attributes - type(var_dlength),intent(in) :: mpar_data ! model parameters - type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU - type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU - type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU - ! output: baseflow - integer(i4b),intent(inout) :: ixSaturation ! index of lowest saturated layer (NOTE: only computed on the first iteration) - real(rkind),intent(out) :: mLayerBaseflow(:) ! baseflow from each soil layer (m s-1) - real(rkind),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) - ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! --------------------------------------------------------------------------------------- - ! * local variables - ! --------------------------------------------------------------------------------------- - ! general local variables - integer(i4b) :: iLayer ! index of soil layer - real(rkind),dimension(nSoil,nSoil) :: dBaseflow_dVolLiq ! derivative in the baseflow flux w.r.t. volumetric liquid water content (m s-1) - ! local variables to compute the numerical Jacobian - logical(lgt),parameter :: doNumericalJacobian=.false. ! flag to compute the numerical Jacobian - real(rkind),dimension(nSoil) :: mLayerMatricHeadPerturbed ! perturbed matric head (m) - real(rkind),dimension(nSoil) :: mLayerVolFracLiqPerturbed ! perturbed volumetric fraction of liquid water (-) - real(rkind),dimension(nSoil) :: mLayerBaseflowPerturbed ! perturbed baseflow (m s-1) - real(rkind),dimension(nSoil,nSoil) :: nJac ! numerical Jacobian (s-1) - ! *************************************************************************************** - ! *************************************************************************************** - ! initialize error control - err=0; message='groundwatr/' - ! --------------------------------------------------------------------------------------- - ! --------------------------------------------------------------------------------------- - ! associate variables in data structures - associate(& - - ! input: baseflow parameters - fieldCapacity => mpar_data%var(iLookPARAM%fieldCapacity)%dat(1), & ! intent(in): [dp] field capacity (-) - theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat, & ! intent(in): [dp] soil porosity (-) - theta_res => mpar_data%var(iLookPARAM%theta_res)%dat, & ! intent(in): [dp] residual volumetric water content (-) - - ! input: van Genuchten soil parametrers - vGn_alpha => mpar_data%var(iLookPARAM%vGn_alpha)%dat, & ! intent(in): [dp] van Genutchen "alpha" parameter (m-1) - vGn_n => mpar_data%var(iLookPARAM%vGn_n)%dat, & ! intent(in): [dp] van Genutchen "n" parameter (-) - vGn_m => diag_data%var(iLookDIAG%scalarVGn_m)%dat, & ! intent(in): [dp] van Genutchen "m" parameter (-) - - ! output: diagnostic variables - scalarExfiltration => flux_data%var(iLookFLUX%scalarExfiltration)%dat(1), & ! intent(out):[dp] exfiltration from the soil profile (m s-1) - mLayerColumnOutflow => flux_data%var(iLookFLUX%mLayerColumnOutflow)%dat & ! intent(out):[dp(:)] column outflow from each soil layer (m3 s-1) - - ) ! end association to variables in data structures - - ! ************************************************************************************************ - ! (1) compute the "active" portion of the soil profile - ! ************************************************************************************************ - - ! get index of the lowest saturated layer - if(getSatDepth)then ! NOTE: only compute for the first flux call - ixSaturation = nSoil+1 ! unsaturated profile when ixSaturation>nSoil - do iLayer=nSoil,1,-1 ! start at the lowest soil layer and work upwards to the top layer - if(mLayerVolFracLiq(iLayer) > fieldCapacity)then; ixSaturation = iLayer ! index of saturated layer -- keeps getting over-written as move upwards - else; exit; end if ! (only consider saturated layer at the bottom of the soil profile) - end do ! (looping through soil layers) - end if - - ! check for an early return (no layers are "active") - if(ixSaturation > nSoil)then - scalarExfiltration = 0._rkind ! exfiltration from the soil profile (m s-1) - mLayerColumnOutflow(:) = 0._rkind ! column outflow from each soil layer (m3 s-1) - mLayerBaseflow(:) = 0._rkind ! baseflow from each soil layer (m s-1) - dBaseflow_dMatric(:,:) = 0._rkind ! derivative in baseflow w.r.t. matric head (s-1) - return - end if ! if some layers are saturated - - ! ************************************************************************************************ - ! (2) compute the baseflow flux and its derivative w.r.t volumetric liquid water content - ! ************************************************************************************************ - - ! use private subroutine to compute baseflow (for multiple calls for numerical Jacobian) - call computeBaseflow(& - ! input: control and state variables - nSnow, & ! intent(in): number of snow layers - nSoil, & ! intent(in): number of soil layers - nLayers, & ! intent(in): total number of layers - .true., & ! intent(in): .true. if analytical derivatives are desired - ixSaturation, & ! intent(in): index of upper-most "saturated" layer - mLayerVolFracLiq, & ! intent(in): volumetric fraction of liquid water in each soil layer (-) - mLayerVolFracIce, & ! intent(in): volumetric fraction of ice in each soil layer (-) +! ************************************************************************************************ +! public subroutine groundwatr: compute the groundwater sink term in Richards' equation +! ************************************************************************************************ +! +! Method +! ------ +! +! Here we assume that water available for shallow groundwater flow includes is all water above +! "field capacity" below the depth zCrit, where zCrit is defined as the lowest point in the soil +! profile where the volumetric liquid water content is less than field capacity. +! +! We further assume that transmssivity (m2 s-1) for each layer is defined assuming that the water +! available for saturated flow is located at the bottom of the soil profile. Specifically: +! trTotal(iLayer) = tran0*(zActive(iLayer)/soilDepth)**zScale_TOPMODEL +! trSoil(iLayer) = trTotal(iLayer) - trTotal(iLayer+1) +! where zActive(iLayer) is the effective water table thickness for all layers up to and including +! the current layer (working from the bottom to the top). +! +! The outflow from each layer is then (m3 s-1) +! mLayerOutflow(iLayer) = trSoil(iLayer)*tan_slope*contourLength +! where contourLength is the width of a hillslope (m) parallel to a stream +! +! ************************************************************************************************ +subroutine groundwatr(& + ! input: model control, state variables, and diagnostic variables + in_groundwatr, & ! intent(in): model control, state variables, and diagnostic variables ! input/output: data structures - attr_data, & ! intent(in): spatial attributes - mpar_data, & ! intent(in): model parameters - prog_data, & ! intent(in): model prognostic variables for a local HRU - flux_data, & ! intent(inout): model fluxes for a local HRU - ! output: fluxes and derivatives - mLayerBaseflow, & ! intent(out): baseflow flux in each soil layer (m s-1) - dBaseflow_dVolLiq) ! intent(out): derivative in baseflow w.r.t. volumetric liquid water content (s-1) - - ! use the chain rule to compute the baseflow derivative w.r.t. matric head (s-1) - do iLayer=1,nSoil - dBaseflow_dMatric(1:iLayer,iLayer) = dBaseflow_dVolLiq(1:iLayer,iLayer)*mLayerdTheta_dPsi(iLayer) - if(iLayer prog_data%var(iLookPROG%iLayerHeight)%dat(nLayers), & ! intent(in): [dp] total soil depth (m) - mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat(nSnow+1:nLayers),& ! intent(in): [dp(:)] depth of each soil layer (m) - - ! input: diagnostic variables - surfaceHydCond => flux_data%var(iLookFLUX%mLayerSatHydCondMP)%dat(1), & ! intent(in): [dp] saturated hydraulic conductivity at the surface (m s-1) - mLayerColumnInflow => flux_data%var(iLookFLUX%mLayerColumnInflow)%dat, & ! intent(in): [dp(:)] inflow into each soil layer (m3/s) - - ! input: local attributes - HRUarea => attr_data%var(iLookATTR%HRUarea), & ! intent(in): [dp] HRU area (m2) - tan_slope => attr_data%var(iLookATTR%tan_slope), & ! intent(in): [dp] tan water table slope, taken as tan local ground surface slope (-) - contourLength => attr_data%var(iLookATTR%contourLength), & ! intent(in): [dp] length of contour at downslope edge of HRU (m) - - ! input: baseflow parameters - zScale_TOPMODEL => mpar_data%var(iLookPARAM%zScale_TOPMODEL)%dat(1), & ! intent(in): [dp] TOPMODEL exponent (-) - kAnisotropic => mpar_data%var(iLookPARAM%kAnisotropic)%dat(1), & ! intent(in): [dp] anisotropy factor for lateral hydraulic conductivity (- - fieldCapacity => mpar_data%var(iLookPARAM%fieldCapacity)%dat(1), & ! intent(in): [dp] field capacity (-) - theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat, & ! intent(in): [dp(:)] soil porosity (-) - - ! output: diagnostic variables - scalarExfiltration => flux_data%var(iLookFLUX%scalarExfiltration)%dat(1), & ! intent(out):[dp] exfiltration from the soil profile (m s-1) - mLayerColumnOutflow => flux_data%var(iLookFLUX%mLayerColumnOutflow)%dat & ! intent(out):[dp(:)] column outflow from each soil layer (m3 s-1) - - ) ! end association to variables in data structures - ! *********************************************************************************************************************** - ! *********************************************************************************************************************** - ! start routine here - - ! *********************************************************************************************************************** - ! (1) compute the baseflow flux in each soil layer - ! *********************************************************************************************************************** - - ! compute the maximum transmissivity - ! NOTE: this can be done as a pre-processing step - tran0 = kAnisotropic*surfaceHydCond*soilDepth/zScale_TOPMODEL ! maximum transmissivity (m2 s-1) - - ! compute the water table thickness (m) and transmissivity in each layer (m2 s-1) - do iLayer=nSoil,ixSaturation,-1 ! loop through "active" soil layers, from lowest to highest - ! define drainable water in each layer (m) - activePorosity = theta_sat(iLayer) - fieldCapacity ! "active" porosity (-) - drainableWater = mLayerDepth(iLayer)*(max(0._rkind,mLayerVolFracLiq(iLayer) - fieldCapacity))/activePorosity - ! compute layer transmissivity - if(iLayer==nSoil)then - zActive(iLayer) = drainableWater ! water table thickness associated with storage in a given layer (m) - trTotal(iLayer) = tran0*(zActive(iLayer)/soilDepth)**zScale_TOPMODEL ! total transmissivity for total depth zActive (m2 s-1) - trSoil(iLayer) = trTotal(iLayer) ! transmissivity of water in a given layer (m2 s-1) - else - zActive(iLayer) = zActive(iLayer+1) + drainableWater - trTotal(iLayer) = tran0*(zActive(iLayer)/soilDepth)**zScale_TOPMODEL - trSoil(iLayer) = trTotal(iLayer) - trTotal(iLayer+1) - end if - !write(*,'(a,1x,i4,1x,10(f20.15,1x))') 'iLayer, mLayerMatricHeadLiq(iLayer), mLayerVolFracLiq(iLayer), zActive(iLayer), trTotal(iLayer), trSoil(iLayer) = ', & - ! iLayer, mLayerMatricHeadLiq(iLayer), mLayerVolFracLiq(iLayer), zActive(iLayer), trTotal(iLayer), trSoil(iLayer) - end do ! looping through soil layers - - ! set un-used portions of the vectors to zero - if(ixSaturation>1)then - zActive(1:ixSaturation-1) = 0._rkind - trTotal(1:ixSaturation-1) = 0._rkind - trSoil(1:ixSaturation-1) = 0._rkind - end if - - ! compute the outflow from each layer (m3 s-1) - mLayerColumnOutflow(1:nSoil) = trSoil(1:nSoil)*tan_slope*contourLength - - ! compute total column inflow and total column outflow (m s-1) - totalColumnInflow = sum(mLayerColumnInflow(1:nSoil))/HRUarea - totalColumnOutflow = sum(mLayerColumnOutflow(1:nSoil))/HRUarea - - ! compute the available storage (m) - availStorage = sum(mLayerDepth(1:nSoil)*(theta_sat - (mLayerVolFracLiq(1:nSoil)+mLayerVolFracIce(1:nSoil))) ) - - ! compute the smoothing function (-) - if(availStorage < xMinEval)then - ! (compute the logistic function) - expF = exp((availStorage - xCenter)/xWidth) - logF = 1._rkind / (1._rkind + expF) - ! (compute the derivative in the logistic function w.r.t. volumetric liquid water content in each soil layer) - dLogFunc_dLiq(1:nSoil) = mLayerDepth(1:nSoil)*(expF/xWidth)/(1._rkind + expF)**2._rkind - else - logF = 0._rkind - dLogFunc_dLiq(:) = 0._rkind - end if - - ! compute the exfiltartion (m s-1) - if(totalColumnInflow > totalColumnOutflow .and. logF > tiny(1._rkind))then - scalarExfiltration = logF*(totalColumnInflow - totalColumnOutflow) ! m s-1 - !write(*,'(a,1x,10(f30.20,1x))') 'scalarExfiltration = ', scalarExfiltration - else - scalarExfiltration = 0._rkind - end if - - ! check - !write(*,'(a,1x,10(f30.20,1x))') 'zActive(1), soilDepth, availStorage, logF, scalarExfiltration = ', & - ! zActive(1), soilDepth, availStorage, logF, scalarExfiltration - !if(scalarExfiltration > tiny(1.0_rkind)) pause 'exfiltrating' - - ! compute the baseflow in each layer (m s-1) - mLayerBaseflow(1:nSoil) = (mLayerColumnOutflow(1:nSoil) - mLayerColumnInflow(1:nSoil))/HRUarea - - ! compute the total baseflow - qbTotal = sum(mLayerBaseflow) - - ! add exfiltration to the baseflow flux at the top layer - mLayerBaseflow(1) = mLayerBaseflow(1) + scalarExfiltration - mLayerColumnOutflow(1) = mLayerColumnOutflow(1) + scalarExfiltration*HRUarea - - ! test - if(printFlag)then - xDepth = sum(mLayerDepth(ixSaturation:nSoil)*(mLayerVolFracLiq(ixSaturation:nSoil) - fieldCapacity))/sum(theta_sat(ixSaturation:nSoil) - fieldCapacity) ! "effective" water table thickness (m) - xTran = tran0*(xDepth/soilDepth)**zScale_TOPMODEL ! transmissivity for the entire aquifer (m2 s-1) - xFlow = xTran*tan_slope*contourLength/HRUarea ! total column outflow (m s-1) - print*, 'ixSaturation = ', ixSaturation - write(*,'(a,1x,5(f30.20,1x))') 'tran0, soilDepth = ', tran0, soilDepth - write(*,'(a,1x,5(f30.20,1x))') 'surfaceHydCond, zScale_TOPMODEL = ', surfaceHydCond, zScale_TOPMODEL - write(*,'(a,1x,5(f30.20,1x))') 'xDepth, zActive(ixSaturation) = ', xDepth, zActive(ixSaturation) - write(*,'(a,1x,5(f30.20,1x))') 'xTran, trTotal(ixSaturation) = ', xTran, trTotal(ixSaturation) - write(*,'(a,1x,5(f30.20,1x))') 'xFlow, totalColumnOutflow = ', xFlow, sum(mLayerColumnOutflow(:))/HRUarea - !pause 'check groundwater' - end if - - ! *********************************************************************************************************************** - ! (2) compute the derivative in the baseflow flux w.r.t. volumetric liquid water content (m s-1) - ! *********************************************************************************************************************** - - ! initialize the derivative matrix - dBaseflow_dVolLiq(:,:) = 0._rkind - - ! check if derivatives are actually required - if(.not.derivDesired) return - - ! compute ratio of hillslope width to hillslope area (m m-2) - length2area = tan_slope*contourLength/HRUarea - - ! compute the ratio of layer depth to maximum water holding capacity (-) - depth2capacity(1:nSoil) = mLayerDepth(1:nSoil)/sum( (theta_sat(1:nSoil) - fieldCapacity)*mLayerDepth(1:nSoil) ) - - ! compute the change in dimensionless flux w.r.t. change in dimensionless storage (-) - dXdS(1:nSoil) = zScale_TOPMODEL*(zActive(1:nSoil)/SoilDepth)**(zScale_TOPMODEL - 1._rkind) - - ! loop through soil layers - do iLayer=1,nSoil - ! compute diagonal terms (s-1) - dBaseflow_dVolLiq(iLayer,iLayer) = tran0*dXdS(iLayer)*depth2capacity(iLayer)*length2area - ! compute off-diagonal terms - do jLayer=iLayer+1,nSoil ! (only dependent on layers below) - dBaseflow_dVolLiq(iLayer,jLayer) = tran0*(dXdS(iLayer) - dXdS(iLayer+1))*depth2capacity(jLayer)*length2area - end do ! looping through soil layers - end do ! looping through soil layers - - ! compute the derivative in the exfiltration flux w.r.t. volumetric liquid water content (m s-1) - if(qbTotal < 0._rkind)then - do iLayer=1,nSoil - dExfiltrate_dVolLiq(iLayer) = dBaseflow_dVolLiq(iLayer,iLayer)*logF + dLogFunc_dLiq(iLayer)*qbTotal - end do ! looping through soil layers - dBaseflow_dVolLiq(1,1:nSoil) = dBaseflow_dVolLiq(1,1:nSoil) - dExfiltrate_dVolLiq(1:nSoil) - end if - - ! end association to data in structures - end associate - - end subroutine computeBaseflow - + attr_data, & ! intent(in): spatial attributes + mpar_data, & ! intent(in): model parameters + prog_data, & ! intent(in): model prognostic variables for a local HRU + flux_data, & ! intent(inout): model fluxes for a local HRU + ! input-output: baseflow + io_groundwatr, & ! intent(inout): index of lowest saturated layer (NOTE: only computed on the first iteration) + ! output: baseflow and error control + out_groundwatr) ! intent(out): baseflow and error control + ! --------------------------------------------------------------------------------------- + ! utility modules + USE soil_utils_module,only:volFracLiq ! compute volumetric fraction of liquid water as a function of matric head + USE soil_utils_module,only:hydCond_psi ! compute hydraulic conductivity as a function of matric head + implicit none + ! --------------------------------------------------------------------------------------- + ! * dummy variables + ! --------------------------------------------------------------------------------------- + ! input: model control, state variables, and diagnostic variables + type(in_type_groundwatr),intent(in) :: in_groundwatr ! model control, state variables, and diagnostic variables + ! input-output: data structures + type(var_d),intent(in) :: attr_data ! spatial attributes + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU + type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU + ! input-output: baseflow + type(io_type_groundwatr),intent(inout) :: io_groundwatr ! index of lowest saturated layer (NOTE: only computed on the first iteration) + ! output: baseflow and error control + type(out_type_groundwatr),intent(out) :: out_groundwatr ! baseflow and error control + ! --------------------------------------------------------------------------------------- + ! * local variables + ! --------------------------------------------------------------------------------------- + ! general local variables + integer(i4b) :: iLayer ! index of soil layer + real(rkind),dimension(in_groundwatr%nSoil,in_groundwatr%nSoil) :: dBaseflow_dVolLiq ! derivative in the baseflow flux w.r.t. volumetric liquid water content (m s-1) + ! *************************************************************************************** + ! *************************************************************************************** + ! associate variables in data structures + allocate(out_groundwatr % mLayerBaseflow(in_groundwatr%nSoil),out_groundwatr % dBaseflow_dMatric(in_groundwatr%nSoil,in_groundwatr%nSoil)) ! allocate intent(out) data structure components + associate(& + ! input: model control + nSnow => in_groundwatr % nSnow, & ! intent(in): [i4b] number of snow layers + nSoil => in_groundwatr % nSoil, & ! intent(in): [i4b] number of soil layers + nLayers => in_groundwatr % nLayers, & ! intent(in): [i4b] total number of layers + getSatDepth => in_groundwatr % firstFluxCall, & ! intent(in): [lgt] logical flag to compute index of the lowest saturated layer + ! input: state and diagnostic variables + mLayerdTheta_dPsi => in_groundwatr % mLayerdTheta_dPsi, & ! intent(in): [dp] derivative in the soil water characteristic w.r.t. matric head in each layer (m-1) + mLayerVolFracLiq => in_groundwatr % mLayerVolFracLiqTrial, & ! intent(in): [dp] volumetric fraction of liquid water (-) + mLayerVolFracIce => in_groundwatr % mLayerVolFracIceTrial, & ! intent(in): [dp] volumetric fraction of ice (-) + ! input: baseflow parameters + fieldCapacity => mpar_data%var(iLookPARAM%fieldCapacity)%dat(1), & ! intent(in): [dp] field capacity (-) + theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat, & ! intent(in): [dp] soil porosity (-) + ! input-output: baseflow + ixSaturation => io_groundwatr % ixSaturation, & ! intent(inout): [i4b] index of lowest saturated layer (NOTE: only computed on the first iteration) + ! output: diagnostic variables + scalarExfiltration => flux_data%var(iLookFLUX%scalarExfiltration)%dat(1), & ! intent(out): [dp] exfiltration from the soil profile (m s-1) + mLayerColumnOutflow => flux_data%var(iLookFLUX%mLayerColumnOutflow)%dat, & ! intent(out): [dp(:)] column outflow from each soil layer (m3 s-1) + ! output: baseflow + mLayerBaseflow => out_groundwatr % mLayerBaseflow, & ! intent(out): [dp(:)] baseflow from each soil layer (m s-1) + dBaseflow_dMatric => out_groundwatr % dBaseflow_dMatric, & ! intent(out): [dp(:,:)] derivative in baseflow w.r.t. matric head (s-1) + ! output: error control + err => out_groundwatr % err, & ! intent(out): [i4b] error code + message => out_groundwatr % cmessage & ! intent(out): [character] error message + ) ! end association to variables in data structures + ! initialize error control + err=0; message='groundwatr/' + + ! ************************************************************************************************ + ! (1) compute the "active" portion of the soil profile + ! ************************************************************************************************ + + ! get index of the lowest saturated layer + if (getSatDepth) then ! NOTE: only compute for the first flux call + ixSaturation = nSoil+1 ! unsaturated profile when ixSaturation>nSoil + do iLayer=nSoil,1,-1 ! start at the lowest soil layer and work upwards to the top layer + if (mLayerVolFracLiq(iLayer) > fieldCapacity) then; ixSaturation = iLayer ! index of saturated layer -- keeps getting over-written as move upwards + else; exit; end if ! only consider saturated layer at the bottom of the soil profile + end do ! end looping through soil layers + end if + + ! check for an early return (no layers are "active") + if (ixSaturation > nSoil) then + scalarExfiltration = 0._rkind ! exfiltration from the soil profile (m s-1) + mLayerColumnOutflow(:) = 0._rkind ! column outflow from each soil layer (m3 s-1) + mLayerBaseflow(:) = 0._rkind ! baseflow from each soil layer (m s-1) + dBaseflow_dMatric(:,:) = 0._rkind ! derivative in baseflow w.r.t. matric head (s-1) + return + end if ! if some layers are saturated + + ! ************************************************************************************************ + ! (2) compute the baseflow flux and its derivative w.r.t volumetric liquid water content + ! ************************************************************************************************ + + ! use private subroutine to compute baseflow (for multiple calls for numerical Jacobian) + call computeBaseflow(& + ! input: control and state variables + nSnow, & ! intent(in): number of snow layers + nSoil, & ! intent(in): number of soil layers + nLayers, & ! intent(in): total number of layers + .true., & ! intent(in): .true. if analytical derivatives are desired + ixSaturation, & ! intent(in): index of upper-most "saturated" layer + mLayerVolFracLiq, & ! intent(in): volumetric fraction of liquid water in each soil layer (-) + mLayerVolFracIce, & ! intent(in): volumetric fraction of ice in each soil layer (-) + ! input/output: data structures + attr_data, & ! intent(in): spatial attributes + mpar_data, & ! intent(in): model parameters + prog_data, & ! intent(in): model prognostic variables for a local HRU + flux_data, & ! intent(inout): model fluxes for a local HRU + ! output: fluxes and derivatives + mLayerBaseflow, & ! intent(out): baseflow flux in each soil layer (m s-1) + dBaseflow_dVolLiq) ! intent(out): derivative in baseflow w.r.t. volumetric liquid water content (s-1) + + ! use the chain rule to compute the baseflow derivative w.r.t. matric head (s-1) + do iLayer=1,nSoil + dBaseflow_dMatric(1:iLayer,iLayer) = dBaseflow_dVolLiq(1:iLayer,iLayer)*mLayerdTheta_dPsi(iLayer) + if (iLayer prog_data%var(iLookPROG%iLayerHeight)%dat(nLayers), & ! intent(in): [dp] total soil depth (m) + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat(nSnow+1:nLayers),& ! intent(in): [dp(:)] depth of each soil layer (m) + ! input: diagnostic variables + surfaceHydCond => flux_data%var(iLookFLUX%mLayerSatHydCondMP)%dat(1), & ! intent(in): [dp] saturated hydraulic conductivity at the surface (m s-1) + mLayerColumnInflow => flux_data%var(iLookFLUX%mLayerColumnInflow)%dat, & ! intent(in): [dp(:)] inflow into each soil layer (m3/s) + ! input: local attributes + HRUarea => attr_data%var(iLookATTR%HRUarea), & ! intent(in): [dp] HRU area (m2) + tan_slope => attr_data%var(iLookATTR%tan_slope), & ! intent(in): [dp] tan water table slope, taken as tan local ground surface slope (-) + contourLength => attr_data%var(iLookATTR%contourLength), & ! intent(in): [dp] length of contour at downslope edge of HRU (m) + ! input: baseflow parameters + zScale_TOPMODEL => mpar_data%var(iLookPARAM%zScale_TOPMODEL)%dat(1), & ! intent(in): [dp] TOPMODEL exponent (-) + kAnisotropic => mpar_data%var(iLookPARAM%kAnisotropic)%dat(1), & ! intent(in): [dp] anisotropy factor for lateral hydraulic conductivity (- + fieldCapacity => mpar_data%var(iLookPARAM%fieldCapacity)%dat(1), & ! intent(in): [dp] field capacity (-) + theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat, & ! intent(in): [dp(:)] soil porosity (-) + ! output: diagnostic variables + scalarExfiltration => flux_data%var(iLookFLUX%scalarExfiltration)%dat(1), & ! intent(out): [dp] exfiltration from the soil profile (m s-1) + mLayerColumnOutflow => flux_data%var(iLookFLUX%mLayerColumnOutflow)%dat & ! intent(out): [dp(:)] column outflow from each soil layer (m3 s-1) + ) ! end association to variables in data structures + + ! *********************************************************************************************************************** + ! (1) compute the baseflow flux in each soil layer + ! *********************************************************************************************************************** + + ! compute the maximum transmissivity + ! NOTE: this can be done as a pre-processing step + tran0 = kAnisotropic*surfaceHydCond*soilDepth/zScale_TOPMODEL ! maximum transmissivity (m2 s-1) + + ! compute the water table thickness (m) and transmissivity in each layer (m2 s-1) + do iLayer=nSoil,ixSaturation,-1 ! loop through "active" soil layers, from lowest to highest + ! define drainable water in each layer (m) + activePorosity = theta_sat(iLayer) - fieldCapacity ! "active" porosity (-) + drainableWater = mLayerDepth(iLayer)*(max(0._rkind,mLayerVolFracLiq(iLayer) - fieldCapacity))/activePorosity + ! compute layer transmissivity + if (iLayer==nSoil) then + zActive(iLayer) = drainableWater ! water table thickness associated with storage in a given layer (m) + trTotal(iLayer) = tran0*(zActive(iLayer)/soilDepth)**zScale_TOPMODEL ! total transmissivity for total depth zActive (m2 s-1) + trSoil(iLayer) = trTotal(iLayer) ! transmissivity of water in a given layer (m2 s-1) + else + zActive(iLayer) = zActive(iLayer+1) + drainableWater + trTotal(iLayer) = tran0*(zActive(iLayer)/soilDepth)**zScale_TOPMODEL + trSoil(iLayer) = trTotal(iLayer) - trTotal(iLayer+1) + end if + end do ! end looping through soil layers + + ! set un-used portions of the vectors to zero + if (ixSaturation>1) then + zActive(1:ixSaturation-1) = 0._rkind + trTotal(1:ixSaturation-1) = 0._rkind + trSoil(1:ixSaturation-1) = 0._rkind + end if + + ! compute the outflow from each layer (m3 s-1) + mLayerColumnOutflow(1:nSoil) = trSoil(1:nSoil)*tan_slope*contourLength + + ! compute total column inflow and total column outflow (m s-1) + totalColumnInflow = sum(mLayerColumnInflow(1:nSoil))/HRUarea + totalColumnOutflow = sum(mLayerColumnOutflow(1:nSoil))/HRUarea + + ! compute the available storage (m) + availStorage = sum(mLayerDepth(1:nSoil)*(theta_sat(1:nSoil) - (mLayerVolFracLiq(1:nSoil)+mLayerVolFracIce(1:nSoil)))) + + ! compute the smoothing function (-) + if (availStorage < xMinEval) then + ! compute the logistic function + expF = exp((availStorage - xCenter)/xWidth) + logF = 1._rkind / (1._rkind + expF) + ! compute the derivative in the logistic function w.r.t. volumetric liquid water content in each soil layer + dLogFunc_dLiq(1:nSoil) = mLayerDepth(1:nSoil)*(expF/xWidth)/(1._rkind + expF)**2_i4b + else + logF = 0._rkind + dLogFunc_dLiq(:) = 0._rkind + end if + + ! compute the exfiltration (m s-1) + if (totalColumnInflow > totalColumnOutflow .and. logF > tiny(1._rkind)) then + scalarExfiltration = logF*(totalColumnInflow - totalColumnOutflow) ! m s-1 + else + scalarExfiltration = 0._rkind + end if + + ! compute the baseflow in each layer (m s-1) + mLayerBaseflow(1:nSoil) = (mLayerColumnOutflow(1:nSoil) - mLayerColumnInflow(1:nSoil))/HRUarea + + ! compute the total baseflow + qbTotal = sum(mLayerBaseflow) + + ! add exfiltration to the baseflow flux at the top layer + mLayerBaseflow(1) = mLayerBaseflow(1) + scalarExfiltration + mLayerColumnOutflow(1) = mLayerColumnOutflow(1) + scalarExfiltration*HRUarea + + ! *********************************************************************************************************************** + ! (2) compute the derivative in the baseflow flux w.r.t. volumetric liquid water content (m s-1) + ! *********************************************************************************************************************** + + ! initialize the derivative matrix + dBaseflow_dVolLiq(:,:) = 0._rkind + + ! check if derivatives are actually required + if (.not.derivDesired) return + + ! compute ratio of hillslope width to hillslope area (m m-2) + length2area = tan_slope*contourLength/HRUarea + + ! compute the ratio of layer depth to maximum water holding capacity (-) + depth2capacity(1:nSoil) = mLayerDepth(1:nSoil)/sum( (theta_sat(1:nSoil) - fieldCapacity)*mLayerDepth(1:nSoil) ) + + ! compute the change in dimensionless flux w.r.t. change in dimensionless storage (-) + dXdS(1:nSoil) = zScale_TOPMODEL*(zActive(1:nSoil)/SoilDepth)**(zScale_TOPMODEL - 1._rkind) + + ! loop through soil layers + do iLayer=1,nSoil + ! compute diagonal terms (s-1) + dBaseflow_dVolLiq(iLayer,iLayer) = tran0*dXdS(iLayer)*depth2capacity(iLayer)*length2area + ! compute off-diagonal terms + do jLayer=iLayer+1,nSoil ! only dependent on layers below + dBaseflow_dVolLiq(iLayer,jLayer) = tran0*(dXdS(iLayer) - dXdS(iLayer+1))*depth2capacity(jLayer)*length2area + end do ! end looping through soil layers + end do ! end looping through soil layers + + ! compute the derivative in the exfiltration flux w.r.t. volumetric liquid water content (m s-1) + if (qbTotal < 0._rkind) then + do iLayer=1,nSoil + dExfiltrate_dVolLiq(iLayer) = dBaseflow_dVolLiq(iLayer,iLayer)*logF + dLogFunc_dLiq(iLayer)*qbTotal + end do ! end looping through soil layers + dBaseflow_dVolLiq(1,1:nSoil) = dBaseflow_dVolLiq(1,1:nSoil) - dExfiltrate_dVolLiq(1:nSoil) + end if + + end associate ! end association to data in structures + +end subroutine computeBaseflow end module groundwatr_module diff --git a/build/source/engine/hyp_2F1.f90 b/build/source/engine/hyp_2F1.f90 new file mode 100644 index 000000000..33382a634 --- /dev/null +++ b/build/source/engine/hyp_2F1.f90 @@ -0,0 +1,1873 @@ +module hyp_2F1_module + +! data types +USE nrtype + +! privacy +implicit none + +private::INF_NORM +private::TANZ +private::LOG1P +private::EXPM1 +private::GAMMA_INV +private::GAMMA_RATIO_DIFF_SMALL_EPS +private::GAMMA_INV_DIFF_EPS +private::A_SUM_INIT +private::LOG_A_SUM_INIT +private::B_SUM_INIT_PS_ONE +private::B_SUM_INIT_PS_INFINITY +private::CV_POLY_DER_CALC +private::MIN_N_CALC +private::HYP_PS_ZERO +private::HYP_PS_ONE +private::HYP_PS_INFINITY +private::HYP_PS_COMPLEX_PLANE_REST +private::TEST_2F1 +public::HYP_2F1 + +! constant parameters +real(rkind),parameter :: EPS15=1.e-15_rkind +real(rkind),parameter :: ZERO=0._rkind,ONE=1._rkind,TWO=2._rkind,HALF=0.5_rkind +real(rkind),parameter :: M_PI=3.14159265358979323846_rkind +real(rkind),parameter :: M_PI_2=1.57079632679489661923_rkind +real(rkind),parameter :: M_1_PI=0.31830988618379067154_rkind + +contains + + !============== START HYP_2F1 FILE ==================================== + ! + ! Gamma_inv denotes the entire inverse of the Gamma function. + ! F(z) means 2F1(a,b,c,z) with the a, b, c and z given as inputs + ! in the routine. + ! + ! Elementary functions and standard constants + ! are defined in the module. + ! See N.J.~Higham, ``Accuracy and Stability of Numerical Algorithms'', + ! SIAM, Philadelphia, 1996 for expm1 implementation. + ! log1p follows instantly. + ! + ! 19/04/2012 Modifications by Daniel Sabanes Bove: + ! - renamed LOG_GAMMA to LOG_GAMMA_FUN to avoid name + ! clash with intrinsic function + ! 11/01/2024 Modifications by Ashley Van Beusekom: + ! - made one module and removed functions as variable declarations + ! - made precision rkind dependent + ! - lowercase for readability + !---------------------------------------------------------------------- + ! + function INF_NORM(Z) + complex(rkind),intent(in) :: Z + real(rkind) :: INF_NORM + INF_NORM=MAX(ABS(REAL(Z,rkind)),ABS(AIMAG(Z))) + return + end function INF_NORM + ! + function TANZ(Z) + complex(rkind),intent(in) :: Z + complex(rkind) :: TANZ + TANZ=SIN(Z)/COS(Z) + return + end function TANZ + ! + function LOG1P(Z) + complex(rkind),intent(in) :: Z + real(rkind) :: X,XP1,LOG1P_X + real(rkind) :: Y,YX,YX2,YX2P1,LOG1P_YX2 + real(rkind) :: RE_LOG1P,IM_LOG1P + complex(rkind) :: LOG1P + if(INF_NORM(Z).lt.ONE) then + X = REAL(Z,rkind); XP1 = X+ONE + if(XP1.eq.ONE) then + LOG1P_X = X + else + LOG1P_X = LOG(XP1)*X/(XP1-ONE) + endif + Y = AIMAG(Z) + YX = Y/XP1; YX2 = YX*YX; YX2P1 = YX2+ONE + if(YX2P1.eq.ONE) then + LOG1P_YX2 = YX2 + else + LOG1P_YX2 = LOG(YX2P1)*YX2/(YX2P1-ONE) + endif + RE_LOG1P = LOG1P_X + HALF*LOG1P_YX2 + IM_LOG1P = ATAN2(Y,XP1) + LOG1P = CMPLX(RE_LOG1P,IM_LOG1P,rkind) + return + else + LOG1P=LOG(ONE+Z) + return + endif + end function LOG1P + ! + function EXPM1(Z) + complex(rkind),intent(in) :: Z + real(rkind) :: X,EXPM1_X,EXP_X,Y,SIN_HALF_Y + real(rkind) :: RE_EXPM1,IM_EXPM1 + complex(rkind) :: EXPM1 + if(INF_NORM(Z).lt.ONE) then + X = real(Z,rkind); EXP_X = EXP(X) + Y = AIMAG(Z); SIN_HALF_Y=SIN(HALF*Y) + if(EXP_X.eq.ONE) then + EXPM1_X = X + else + EXPM1_X = (EXP_X-ONE)*X/LOG(EXP_X) + endif + RE_EXPM1 = EXPM1_X-TWO*EXP_X*SIN_HALF_Y*SIN_HALF_Y + IM_EXPM1 = EXP_X*SIN(Y) + EXPM1 = CMPLX(RE_EXPM1,IM_EXPM1,rkind) + return + else + EXPM1=EXP(Z)-ONE + return + endif + end function EXPM1 + ! + !---------------------------------------------------------------------- + recursive function LOG_GAMMA_FUN(Z) result(RES) + !---------------------------------------------------------------------- + ! Logarithm of Gamma[z] and Gamma inverse function + ! ------------------------------------------------ + ! + ! For log[Gamma[z]],if z is not finite + ! or is a negative integer, the program + ! returns an error message and stops. + ! The Lanczos method is used. Precision : ~ 1E-15 + ! The method works for Re[z]>0.5 . + ! If Re[z]<=0.5, one uses the formula Gamma[z].Gamma[1-z]=Pi/sin(Pi.z) + ! log[sin(Pi.z)] is calculated with the Kolbig method + ! (K.S. Kolbig, Comp. Phys. Comm., Vol. 4, p.221(1972)): + ! If z=x+iy and y>=0, log[sin(Pi.z)]=log[sin(Pi.eps)]-i.Pi.n, + ! with z=n+eps so 0<=Re[eps]< 1 and n integer. + ! If y>110, log[sin(Pi.z)]=-i.Pi.z+log[0.5]+i.Pi/2 + ! numerically so that no overflow can occur. + ! If z=x+iy and y< 0, log[Gamma(z)]=[log[Gamma(z*)]]*, + ! so that one can use the previous formula with z*. + ! + ! For Gamma inverse, Lanczos method is also used + ! with Euler reflection formula. + ! sin (Pi.z) is calculated as sin (Pi.(z-n)) + ! to avoid inaccuracy with z = n + eps + ! with n integer and |eps| as small as possible. + ! + ! + ! Variables: + ! ---------- + ! x,y: Re[z], Im[z] + ! log_sqrt_2Pi,log_Pi : log[sqrt(2.Pi)], log(Pi). + ! sum : Rational function in the Lanczos method + ! log_Gamma_z : log[Gamma(z)] value. + ! c : table containing the fifteen coefficients in the expansion + ! used in the Lanczos method. + ! eps,n : z=n+eps so 0<=Re[eps]< 1 and n integer for Log[Gamma]. + ! z=n+eps and n integer + ! so |eps| is as small as possible for Gamma_inv. + ! log_const : log[0.5]+i.Pi/2 + ! g : coefficient used in the Lanczos formula. It is here 607/128. + ! z,z_m_0p5,z_p_g_m0p5,zm1 : argument of the Gamma function, + ! z-0.5, z-0.5+g, z-1 + ! res: returned value + !---------------------------------------------------------------------- + implicit none + complex(rkind),intent(in) :: Z + integer(i4b) :: N,I + real(rkind) :: X,Y,LOG_SQRT_2PI,G,LOG_PI,M_LN2,C(0:14) + complex(rkind) :: GAMMA_SUM,Z_M_0P5,Z_P_G_M0P5,ZM1 + complex(rkind) :: LOG_CONST,I_PI,EPS,LOG_SIN_PI_Z,RES + ! + M_LN2=0.69314718055994530942_rkind; X=REAL(Z,rkind); Y=AIMAG(Z) + if((Z.eq.NINT(X)).and.(X.le.ZERO)) & + print*,'Z IS NEGATIVE integer IN LOG_GAMMA_FUN' + if(X.ge.HALF) then + LOG_SQRT_2PI=0.91893853320467274177_rkind; G=4.7421875_rkind + Z_M_0P5=Z-HALF; Z_P_G_M0P5=Z_M_0P5+G; ZM1=Z-ONE + C=(/ 0.99999999999999709182_rkind , 57.156235665862923517_rkind, & + -59.597960355475491248_rkind , 14.136097974741747174_rkind, & + -0.49191381609762019978_rkind , 0.33994649984811888699e-4_rkind, & + 0.46523628927048575665e-4_rkind, -0.98374475304879564677e-4_rkind, & + 0.15808870322491248884e-3_rkind, -0.21026444172410488319e-3_rkind, & + 0.21743961811521264320e-3_rkind, -0.16431810653676389022e-3_rkind, & + 0.84418223983852743293e-4_rkind, -0.26190838401581408670e-4_rkind, & + 0.36899182659531622704e-5_rkind /) + + GAMMA_SUM=C(0) + do I=1,14 + GAMMA_SUM=GAMMA_SUM+C(I)/(ZM1+I) + enddo + RES=LOG_SQRT_2PI+LOG(GAMMA_SUM)+Z_M_0P5*LOG(Z_P_G_M0P5) & + -Z_P_G_M0P5 + return + else if(Y.ge.ZERO) then + if(X.lt.NINT(X)) then + N=NINT(X)-1 + else + N=NINT(X) + endif + LOG_PI=1.1447298858494002_rkind + LOG_CONST=CMPLX(-M_LN2,M_PI_2,rkind); I_PI=CMPLX(ZERO,M_PI,rkind) + EPS=Z-N + if(Y.gt.110._rkind) then + LOG_SIN_PI_Z=-I_PI*Z+LOG_CONST + else + LOG_SIN_PI_Z=LOG(SIN(M_PI*EPS))-I_PI*N + endif + RES=LOG_PI-LOG_SIN_PI_Z-LOG_GAMMA_FUN(ONE-Z); + return + else + RES=CONJG(LOG_GAMMA_FUN(CONJG(Z))) + return + endif + end function LOG_GAMMA_FUN + ! + !---------------------------------------------------------------------- + ! Inverse of the Gamma function [1/Gamma](z) + ! ------------------------------------------ + ! It is calculated with the Lanczos method for Re[z] >= 0.5 + ! and is precise up to 10^{-15}. + ! If Re[z] <= 0.5, one uses the formula + ! Gamma[z].Gamma[1-z] = Pi/sin (Pi.z). + ! sin (Pi.z) is calculated as sin (Pi.(z-n)) to avoid inaccuracy, + ! with z = n + eps with n integer and |eps| as small as possible. + ! + ! Variables + ! --------- + ! z : argument of the function + ! x: Re[z] + ! eps,n : z = n + eps with n integer and |eps| as small as possible. + ! res: returned value + !---------------------------------------------------------------------- + recursive function GAMMA_INV(Z) result(RES) + !-------------------------------------------------------------------- + implicit none + complex(rkind),intent(in) :: Z + integer(i4b) :: N,I + real(rkind) :: X,LOG_SQRT_2PI,G,C(0:14) + complex(rkind) :: RES,GAMMA_SUM,Z_M_0P5,Z_P_G_M0P5,ZM1,EPS + ! + X=REAL(Z,rkind) + if(X.ge.HALF) then + LOG_SQRT_2PI=0.91893853320467274177_rkind; G=4.7421875_rkind + Z_M_0P5=Z-HALF; Z_P_G_M0P5=Z_M_0P5+G; ZM1=Z-ONE + C=(/ 0.99999999999999709182_rkind , 57.156235665862923517_rkind, & + -59.597960355475491248_rkind , 14.136097974741747174_rkind, & + -0.49191381609762019978_rkind , 0.33994649984811888699e-4_rkind, & + 0.46523628927048575665e-4_rkind, -0.98374475304879564677e-4_rkind, & + 0.15808870322491248884e-3_rkind, -0.21026444172410488319e-3_rkind, & + 0.21743961811521264320e-3_rkind, -0.16431810653676389022e-3_rkind, & + 0.84418223983852743293e-4_rkind, -0.26190838401581408670e-4_rkind, & + 0.36899182659531622704e-5_rkind /) + + GAMMA_SUM=C(0) + do I=1,14 + GAMMA_SUM=GAMMA_SUM+C(I)/(ZM1+I); + enddo + RES=EXP(Z_P_G_M0P5-Z_M_0P5*LOG(Z_P_G_M0P5)-LOG_SQRT_2PI) & + /GAMMA_SUM + return + else + X=REAL(Z,rkind); N=NINT(X) + EPS=Z-N + if(MOD(N,2).eq.0) then + RES=SIN(M_PI*EPS)*M_1_PI/GAMMA_INV(ONE-Z) + return + else + RES=-SIN(M_PI*EPS)*M_1_PI/GAMMA_INV(ONE-Z) + return + endif + endif + end function GAMMA_INV + !---------------------------------------------------------------------- + ! + ! Calculation of H(z,eps) = [Gamma(z+eps)/Gamma(z) - 1]/eps, with e and + ! --------------------------------------------------------------------- + ! z complex so z,z+eps are not negative integers and 0 <= |eps|oo < 0.1 + ! --------------------------------------------------------------------- + ! The function H(z,eps) = [Gamma(z+eps)/Gamma(z) - 1]/e is calculated + ! here with the Lanczos method. + ! For the Lanczos method, the gamma parameter, denoted as g, + ! is 4.7421875 and one uses a sum of 15 numbers with the table c[15], + ! so that it is precise up to machine accuracy. + ! The H(z,eps) function is used in formulas occuring in1-z and 1/z + ! transformations (see Comp. Phys. Comm. paper). + ! + ! One must have z and z+eps not negative integers as otherwise + ! it is clearly not defined. + ! As this function is meant to be precise for small |eps|oo, + ! one has to have 0 <= |eps|oo < 0.1 . + ! Indeed, a direct implementation of H(z,eps) with Gamma_inv or + ! log_Gamma for |eps|oo >= 0.1 is numerically stable. + ! The returned function has full numerical accuracy + ! even if |eps|oo is very small. + ! + ! eps not equal to zero + ! --------------------- + ! If Re(z) >= 0.5 or Re(z+eps) >= 0.5, one clearly has Re(z) > 0.4 + ! and Re(z+eps) > 0.4, + ! so that the Lanczos summation can be used for both Gamma(z) + ! and Gamma(z+eps). + ! One then has: + ! log[Gamma(z+eps)/Gamma(z)] = + ! (z-0.5) log1p[eps/(z+g-0.5)] + eps log(z+g-0.5+eps) - eps + ! + log1p[-eps \sum_{i=1}^{14} c[i]/((z-1+i)(z-1+i+eps)) + ! / (c[0] + \sum_{i=1}^{14} c[i]/(z-1+i))] + ! H(z,eps) = expm1[log[Gamma(z+eps)/Gamma(z)]]/eps . + ! + ! If Re(z) < 0.5 and Re(z+eps) < 0.5, + ! Euler reflection formula is used for both Gamma(z) and Gamma(z+eps). + ! One then has: + ! H(z+eps,-eps) = [cos(pi.eps) + sin(pi.eps)/tan(pi(z-n))].H(1-z,-eps) + ! + (2/eps).sin^2(eps.pi/2) - sin(pi.eps)/(eps.tan(pi.(z-n))) + ! H(1-z,-eps) is calculated with the Lanczos summation + ! as Re(1-z) >= 0.5 and Re(1-z-eps) >= 0.5 . + ! z-n is used in tan(pi.z) instead of z to avoid inaccuracies + ! due the finite number of digits of pi. + ! H(z,eps) = H(z+eps,-eps)/(1 - eps.H(z+eps,-eps)) + ! provides the final result. + ! + ! eps equal to zero + ! ----------------- + ! It is obtained with the previous case and eps -> 0 : + ! If Re(z) >= 0.5, one has: + ! H(z,eps) = (z-0.5)/(z+g-0.5) + log(z+g-0.5) - 1 - + ! \sum_{i=1}^{14} c[i]/((z-1+i)^2)/(c[0]+\sum_{i=1}^{14} c[i]/(z-1+i)) + ! + ! If Re(z) < 0.5, one has: + ! H(z,0) = H(1-z,0) - pi/tan(pi.(z-n)) + ! + ! Variables + ! --------- + ! z,eps: input variables of the function H(z,eps) + ! g,c[15]: double and table of 15 doubles defining the Lanczos sum + ! so that it provides the Gamma function + ! precise up to machine accuracy. + ! eps_pz,z_m_0p5,z_pg_m0p5,eps_pz_pg_m0p5,zm1,zm1_p_eps: + ! z+eps,z-0.5,z+g-0.5,z+eps+g-0.5,z-1,z-1+eps + ! x,eps_px: real parts of z and z+eps. + ! n,m: closest integer ot the real part of z, same for z+eps. + ! sum_num,sum_den: \sum_{i=1}^{14} c[i]/((z-1+i)(z-1+i+eps)) + ! and (c[0] + \sum_{i=1}^{14} c[i]/(z-1+i)). + ! They appear respectively as numerator and denominator in formulas. + ! Pi_eps,term,T1_eps_z: pi.eps, sin (pi.eps)/tan(pi.(z-n)), + ! [cos(pi.eps) + sin(pi.eps)/tan(pi(z-n))].H(1-z,-eps) + ! sin_Pi_2_eps,T2_eps_z,T_eps_z: sin^2(eps.pi/2), + ! (2/eps).sin^2(eps.pi/2) - sin(pi.eps)/(eps.tan(pi.(z-n))), + ! H(z+eps,-eps) + ! res: returned value + !---------------------------------------------------------------------- + recursive function GAMMA_RATIO_DIFF_SMALL_EPS(Z,EPS) result(RES) + !-------------------------------------------------------------------- + implicit none + complex(rkind),intent(in) :: Z,EPS + integer(i4b) :: N,M,I + real(rkind) :: G,X,EPS_PX,C(0:14) + complex(rkind) :: RES,SUM_NUM,SUM_DEN + complex(rkind) :: EPS_PZ,Z_M_0P5,Z_PG_M0P5,EPS_PZ_PG_M0P5,ZM1 + complex(rkind) :: CI_ZM1_PI_INV,PI_EPS,TT,T1_EPS_Z,SIN_PI_2_EPS + complex(rkind) :: ZM1_P_EPS,T2_EPS_Z,T_EPS_Z + ! + G=4.74218750_rkind + if(INF_NORM(EPS).gt.0.1_rkind) & + print*,'ONE MUST HAVE |EPS|< 0.1 IN GAMMA_RATIO_DIFF_SMALL_EPS' + EPS_PZ=Z+EPS; Z_M_0P5=Z-HALF; Z_PG_M0P5=Z_M_0P5+G + EPS_PZ_PG_M0P5=Z_PG_M0P5+EPS; ZM1=Z-ONE; ZM1_P_EPS=ZM1+EPS + X=REAL(Z,rkind); EPS_PX=REAL(EPS_PZ,rkind); N=NINT(X); M=NINT(EPS_PX) + if((Z.eq.N).and.(N.le.0)) then + print*,'Z IS NEGATIVE integer IN GAMMA_RATIO_DIFF_SMALL_EPS' + endif + if((EPS_PZ.eq.M).and.(M.le.0)) then + print*,'Z+EPS IS NEGATIVE integer IN GAMMA_RATIO_DIFF_SMALL_EPS' + endif + C=(/ 0.99999999999999709182_rkind , 57.156235665862923517_rkind, & + -59.597960355475491248_rkind , 14.136097974741747174_rkind, & + -0.49191381609762019978_rkind , 0.33994649984811888699e-4_rkind, & + 0.46523628927048575665e-4_rkind, -0.98374475304879564677e-4_rkind, & + 0.15808870322491248884e-3_rkind, -0.21026444172410488319e-3_rkind, & + 0.21743961811521264320e-3_rkind, -0.16431810653676389022e-3_rkind, & + 0.84418223983852743293e-4_rkind, -0.26190838401581408670e-4_rkind, & + 0.36899182659531622704e-5_rkind /) + if((X.ge.HALF).or.(EPS_PX.ge.HALF)) then + SUM_NUM=ZERO;SUM_DEN=C(0) + do I=1,14 + CI_ZM1_PI_INV=C(I)/(ZM1+I) + SUM_NUM=SUM_NUM+CI_ZM1_PI_INV/(ZM1_P_EPS+I) + SUM_DEN=SUM_DEN+CI_ZM1_PI_INV + enddo + if(EPS.ne.ZERO) then + RES=EXPM1(Z_M_0P5*LOG1P(EPS/Z_PG_M0P5) & + +EPS*LOG(EPS_PZ_PG_M0P5)-EPS+LOG1P(-EPS*SUM_NUM/SUM_DEN))& + /EPS + return + else + RES=Z_M_0P5/Z_PG_M0P5 & + +LOG(EPS_PZ_PG_M0P5)-ONE-SUM_NUM/SUM_DEN + return + endif + else + if(EPS.ne.ZERO) then + PI_EPS=M_PI*EPS + TT=SIN(PI_EPS)/TANZ(M_PI*(Z-N)) + T1_EPS_Z=(COS(PI_EPS)+TT)*& + GAMMA_RATIO_DIFF_SMALL_EPS(ONE-Z,-EPS) + SIN_PI_2_EPS=SIN(M_PI_2*EPS) + T2_EPS_Z=(TWO*SIN_PI_2_EPS*SIN_PI_2_EPS-TT)/EPS + T_EPS_Z=T1_EPS_Z+T2_EPS_Z + RES=(T_EPS_Z/(ONE-EPS*T_EPS_Z)) + return + else + RES=GAMMA_RATIO_DIFF_SMALL_EPS(ONE-Z,-EPS) & + -M_PI/TANZ(M_PI*(Z-N)) + return + endif + endif + end function GAMMA_RATIO_DIFF_SMALL_EPS + ! + !---------------------------------------------------------------------- + ! Calculation of G(z,eps) = [Gamma_inv(z) - Gamma_inv(z+eps)]/eps + ! --------------------------------------------------------------- + ! with e and z complex + !--------------------- + ! The G(z,eps) function is used in formulas occuring in 1-z + ! and 1/z transformations (see Comp. Phys. Comm. paper). + ! Several case have to be considered for its evaluation. + ! eps is considered equal to zero + ! if z+eps and z are equal numerically. + ! + ! |eps|oo > 0.1 + ! ------------- + ! A direct evaluation with the values Gamma_inv(z) + ! and Gamma_inv(z+eps) is stable and returned. + ! + ! |eps|oo <= 0.1 with z+eps and z numerically different + ! ----------------------------------------------------- + ! If z is a negative integer, z+eps is not, + ! so that G(z,eps) = -Gamma_inv(z+eps)/eps, + ! for which a direct evaluation is precise and returned. + ! If z+eps is a negative integer, z is not, + ! so that G(z,eps) = Gamma_inv(z)/eps, + ! for which a direct evaluation is precise and returned. + ! If both of them are not negative integers, + ! one looks for the one of z and z+eps + ! which is the closest to a negative integer. + ! If it is z, one returns H(z,eps).Gamma_inv(z+eps). + ! If it is z+eps, one returns H(z+eps,-eps).Gamma_inv(z). + ! Both values are equal, so that one chooses the one + ! which makes the Gamma ratio Gamma(z+eps)/Gamma(z) + ! in H(z,eps) the smallest in modulus. + ! + ! z+eps and z numerically equal + ! ----------------------------- + ! If z is negative integer, G(z,0) = (-1)^(n+1) n!, + ! where z = -n, n integer, which is returned. + ! If z is not negative integer, one returns H(z,eps).Gamma_inv(z+eps) + ! + ! Variables + ! --------- + ! z,eps: input variables of the function G(z,eps) + ! eps_pz,x,eps_px: z+eps,real parts of z and z+eps. + ! n,m: closest integer ot the real part of z, same for z+eps. + ! fact,k: (-1)^(n+1) n!, returned when z = -n, n integer + ! and z and z+eps identical numerically (eps ~ 0). + ! It is calculated with integer index k. + ! is_z_negative_integer,is_eps_pz_negative_integer: + ! true if z is a negative integer, false if not, same for z+eps. + ! z_neg_int_distance, eps_pz_neg_int_distance: + ! |z + |n||oo, |z + eps + |m||oo. + ! If |z + |n||oo < |z + eps + |m||oo, + ! z is closer to the set of negative integers than z+eps. + ! Gamma_inv(z+eps) is then of moderate modulus + ! if Gamma_inv(z) is very small. + ! If z ~ n, H(z,eps) ~ -1/eps, + ! that so returning + ! G(z,eps) = H(z,eps).Gamma_inv(z+eps) here is preferred. + ! Same for |z + |n||oo > |z + eps + |m||oo with z <-> z+eps. + ! + !---------------------------------------------------------------------- + function GAMMA_INV_DIFF_EPS(Z,EPS) + !-------------------------------------------------------------------- + implicit none + complex(rkind),intent(in) :: Z,EPS + integer(i4b) :: M,N,K + real(rkind) :: X,EPS_PX,FACT + real(rkind) :: Z_NEG_INT_DISTANCE + real(rkind) :: EPS_PZ_NEG_INT_DISTANCE + complex(rkind) :: GAMMA_INV_DIFF_EPS,EPS_PZ + logical(lgt) :: IS_Z_NEG_INT,IS_EPS_PZ_NEG_INT + + EPS_PZ=Z+EPS; X=REAL(Z,rkind); EPS_PX=REAL(EPS_PZ,rkind) + N=NINT(X); M=NINT(EPS_PX) + IS_Z_NEG_INT=(Z.eq.N).and.(N.le.0) + IS_EPS_PZ_NEG_INT=(EPS_PZ.eq.M).and.(M.le.0) + if(INF_NORM(EPS).gt.0.10_rkind) then + GAMMA_INV_DIFF_EPS = (GAMMA_INV(Z) - GAMMA_INV(EPS_PZ))/EPS + return + else if(EPS_PZ.ne.Z) then + if(IS_Z_NEG_INT) then + GAMMA_INV_DIFF_EPS = (-GAMMA_INV(EPS_PZ)/EPS) + return + else if(IS_EPS_PZ_NEG_INT) then + GAMMA_INV_DIFF_EPS = (GAMMA_INV(Z)/EPS) + return + else + Z_NEG_INT_DISTANCE = INF_NORM (Z + ABS (N)) + EPS_PZ_NEG_INT_DISTANCE = INF_NORM (EPS_PZ + ABS (M)) + if(Z_NEG_INT_DISTANCE.lt.EPS_PZ_NEG_INT_DISTANCE) then + GAMMA_INV_DIFF_EPS= & + GAMMA_RATIO_DIFF_SMALL_EPS(Z,EPS)*GAMMA_INV(EPS_PZ) + return + else + GAMMA_INV_DIFF_EPS= & + GAMMA_RATIO_DIFF_SMALL_EPS(EPS_PZ,-EPS)*GAMMA_INV(Z) + return + endif + endif + else if(IS_Z_NEG_INT.and.IS_EPS_PZ_NEG_INT) then + FACT = -ONE;K=-1 + do while (K.ge.N) + FACT=FACT*K + K=K-1 + enddo + GAMMA_INV_DIFF_EPS = FACT + return + else + GAMMA_INV_DIFF_EPS = & + GAMMA_RATIO_DIFF_SMALL_EPS(Z,EPS)*GAMMA_INV(EPS_PZ) + return + endif + end function GAMMA_INV_DIFF_EPS + !---------------------------------------------------------------------- + ! + ! Calculation of Gamma_inv(1-m-eps)/eps of the A(z) polynomial in 1-z + ! ------------------------------------------------------------------- + ! and 1/z transformations + ! ----------------------- + ! This value occurs in A(z) in 1-z and 1/z transformations + ! (see Comp. Phys. Comm. paper) for m > 0. + ! Both cases of 1-m-eps numerically negative integer + ! or not have to be considered + ! + ! 1-eps-m and 1-m numerically different + ! ------------------------------------- + ! One returns Gamma_inv(1-m-eps)/eps directly + ! as its value is accurate. + ! To calculate Gamma_inv(1-m-eps), + ! one uses the value Gamma_inv(1-eps), + ! needed in considered transformations, + ! and one uses the equality + ! Gamma_inv(1-m-eps) = Gamma_inv(1-eps) \prod_{i=1}^{m} (1-eps-i) + ! for m > 0. + ! It is trivially demonstrated + ! from the equality Gamma(x+1) = x.Gamma(x). + ! One Gamma function evaluation is removed this way + ! from the calculation. + ! + ! 1-eps-m and 1-m numerically equal + ! --------------------------------- + ! This implies that 1-m-eps is negative integer numerically. + ! Here, eps~0, so that one returns the limit of Gamma_inv(1-m-eps)/eps + ! for eps -> 0, which is (-1)^m (m-1)! + ! + ! Variables + ! --------- + ! m,eps: variable inputs of the function + ! (m,eps) -> Gamma_inv(1-m-eps)/eps + ! Gamma_inv_one_meps: Gamma_inv(1-eps), + ! previously calculated and here recycled + ! to quickly calculate Gamma_inv(1-m-eps). + ! one_meps: 1-eps + !---------------------------------------------------------------------- + function A_SUM_INIT(M,EPS,GAMMA_INV_ONE_MEPS) + !-------------------------------------------------------------------- + implicit none + integer(i4b),intent(in) :: M + complex(rkind),intent(in) :: EPS,GAMMA_INV_ONE_MEPS + integer(i4b) :: N,I + real(rkind) :: FACT + complex(rkind) :: A_SUM_INIT,ONE_MEPS + complex(rkind) :: GAMMA_INV_ONE_MEPS_MM + ! + ONE_MEPS = ONE - EPS + if(ONE_MEPS-M.ne.1-M) then + GAMMA_INV_ONE_MEPS_MM = GAMMA_INV_ONE_MEPS + do I=1,M + GAMMA_INV_ONE_MEPS_MM = GAMMA_INV_ONE_MEPS_MM*(ONE_MEPS-I) + enddo + A_SUM_INIT=GAMMA_INV_ONE_MEPS_MM/EPS + return + else + FACT=ONE + do N=2,M-1 + FACT=FACT*N + enddo + if(MOD(M,2).eq.0) then + A_SUM_INIT=FACT + else + A_SUM_INIT=-FACT + endif + return + endif + end function A_SUM_INIT + ! + !---------------------------------------------------------------------- + ! Calculation of the log of Gamma_inv(1-m-eps)/eps + ! ------------------------------------------------ + ! See previous function. + ! It is used in case Gamma_inv(1-m-eps)/eps might overflow. + ! + ! Variables + ! --------- + ! m,eps: variable inputs of the function + ! (m,eps) -> log[Gamma_inv(1-m-eps)/eps] + ! one_meps_mm: 1-eps-m + ! i_Pi: i.Pi + ! log_fact: logarithm of (-1)^m (m-1)!, + ! here defined as log((m-1)!) + i.Pi if m is odd. + !---------------------------------------------------------------------- + function LOG_A_SUM_INIT(M,EPS) + !-------------------------------------------------------------------- + implicit none + integer(i4b),intent(in) :: M + complex(rkind),intent(in) :: EPS + integer(i4b) :: N + real(rkind) :: LOG_FACT + complex(rkind) :: ONE_MEPS_MM,LOG_A_SUM_INIT + ! + ONE_MEPS_MM=ONE-EPS-M + if(ONE_MEPS_MM.ne.1-M) then + LOG_A_SUM_INIT=(-LOG_GAMMA_FUN(ONE_MEPS_MM) - LOG(EPS)) + return + else + LOG_FACT=ZERO + do N=2,M-1 + LOG_FACT=LOG_FACT + LOG(DBLE(N)) + enddo + if(MOD(M,2).eq.0) then + LOG_A_SUM_INIT=LOG_FACT + else + LOG_A_SUM_INIT=CMPLX(LOG_FACT,M_PI,rkind) + endif + return + endif + end function LOG_A_SUM_INIT + !---------------------------------------------------------------------- + ! Calculation of the first term of the B(z) power series + ! ------------------------------------------------------ + ! in the 1-z transformation, divided by (1-z)^m + ! ---------------------------------------------- + ! In the 1-z transformation, + ! the power series B(z) = \sum_{n=0}^{+oo} \beta_n (1-z)^n occurs + ! (see Comp. Phys. Comm. paper). + ! The first term \beta_0, divided by (1-z)^m, is calculated here. + ! m is the closest integer to Re(c-a-b) >= 0 and eps = c-a-b-m. + ! + ! One has to consider |eps|oo > 0.1 and |eps|oo <= 0.1, + ! where 1-m-eps and 1-m can be different or equal numerically, + ! leading to some changes in this last case. + ! + ! |eps|oo > 0.1 + ! ------------- + ! One has \beta_0/(1-z)^m = [(a)_m (b)_m Gamma_inv(1-eps) + ! Gamma_inv(a+m+eps) Gamma_inv(b+m+eps) Gamma_inv(m+1) + ! - (1-z)^eps Gamma_inv(a) Gamma_inv(b) Gamma_inv(1+m+eps)] + ! [Gamma(c)/eps], stable in this regime for a direct evaluation. + ! + ! The values of Gamma(c), Gamma_inv(a+m+eps) + ! and Gamma_inv(b+m+eps) were already calculated and recycled here. + ! Gamma_inv(m+1) is calculated as 1/(m!). + ! + ! Gamma_inv(1+m+eps) is calculated from Gamma_inv(1-eps), + ! using the equalities: + ! Gamma_inv(1-m-eps) = Gamma_inv(1-eps) \prod_{i=1}^{m} (1-eps-i), + ! where the product is 1 by definition if m = 0, + ! Gamma_inv(1+m+eps) = (-1)^m sin (pi.eps) + ! /[pi.(eps+m).Gamma_inv(1-m-eps)] + ! from Euler reflection formula, Gamma(x+1) = x.Gamma(x) equality, + ! and m+eps no zero. + ! This scheme is much faster than + ! to recalculate Gamma_inv(1+m+eps) directly. + ! + ! |eps|oo <= 0.1 + ! -------------- + ! The \beta_0/(1-z)^m expression is rewritten + ! so that it contains no instabilities: + ! \beta_0/(1-z)^m = Gamma_inv(a+m+eps) Gamma_inv(b+m+eps) + ! [(G(1,-eps) Gamma_inv(m+1) + G(m+1,eps)) + ! - Gamma_inv(1+m+eps) (G(a+m,eps) Gamma_inv(b+m+eps) + ! + G(b+m,eps) Gamma_inv(a+m)) + ! - E(log(1-z),eps) Gamma_inv(a+m) Gamma_inv(b+m) Gamma_inv(1+m+eps)] + ! (a)_m (b)_m Gamma(c) + ! + ! E(log(1-z),eps) is [(1-z)^eps - 1]/eps + ! if 1-m-eps and 1-m are different numerically, + ! and log(1-z) otherwise (eps ~ 0). + ! If 1-m-eps and 1-m are equal numerically, + ! Gamma_inv(1+m+eps) is numerically equal to Gamma_inv(1+m), + ! already calculated as 1/(m!). + ! See |eps|oo > 0.1 case for data recycling of other values + ! or for 1-m-eps and 1-m different numerically. + ! + !---------------------------------------------------------------------- + ! Variables + ! --------- + ! a,b,c,one_minus_z: a,b,c and 1-z parameters and arguments + ! of the 2F1(a,b,c,z) function. + ! m,eps: closest integer to c-a-b, with Re(c-a-b) >= 0 + ! and eps = c-a-b-m + ! Gamma_c,Gamma_inv_one_meps,Gamma_inv_eps_pa_pm, Gamma_inv_eps_pb_pm: + ! recycled values of Gamma(c), Gamma_inv(1-eps), + ! Gamma_inv(a+m+eps) and Gamma_inv(b+m+eps). + ! inf_norm_eps,phase,a_pm,b_pm,one_meps,Pi_eps,Pi_eps_pm: + ! |eps|oo,(-1)^m,a+m,b+m,1-eps,pi.eps,pi.(eps+m) + ! Gamma_inv_one_meps_mm,Gamma_inv_eps_pm_p1: + ! Gamma_inv(1-m-eps) and Gamma_inv(1+m+eps) + ! calculated with the recycling scheme. + ! prod1: (a)_m (b)_m Gamma_inv(1-eps) Gamma_inv(a+m+eps) + ! x Gamma_inv(b+m+eps) Gamma_inv(m+1) in |eps|oo > 0.1 case. + ! prod2: (1-z)^eps Gamma_inv(a) Gamma_inv(b) Gamma_inv(1+m+eps) + ! in |eps|oo > 0.1 case. + ! Gamma_inv_mp1,prod_ab: Gamma_inv(m+1) calculated as 1/(m!) + ! and (a)_m (b)_m in |eps|oo <= 0.1 case. + ! is_eps_non_zero: true if 1-m-eps and 1-m are different numerically, + ! false if not. + ! Gamma_inv_a_pm,Gamma_inv_b_pm,z_term: Gamma_inv(a+m),Gamma_inv(b+m), + ! E(eps,log(1-z)) + ! prod1: Gamma_inv(a+m+eps) Gamma_inv(b+m+eps) + ! x [(G(1,-eps) Gamma_inv(m+1) + G(m+1,eps)) in |eps|oo <= 0.1 case. + ! prod2: Gamma_inv(1+m+eps) (G(a+m,eps) Gamma_inv(b+m+eps) + ! + G(b+m,eps) Gamma_inv(a+m)) + ! prod3: E(eps,log(1-z)) Gamma_inv(a+m) Gamma_inv(b+m) + ! Gamma_inv(1+m+eps) + ! res: returned \beta_0/(1-z)^m value in all cases. + !---------------------------------------------------------------------- + function B_SUM_INIT_PS_ONE(A,B,GAMMA_C,GAMMA_INV_ONE_MEPS, & + GAMMA_INV_EPS_PA_PM,GAMMA_INV_EPS_PB_PM,MZP1,M,EPS) + !-------------------------------------------------------------------- + implicit none + integer(i4b),intent(in) :: M + complex(rkind),intent(in) :: A,B,GAMMA_C,GAMMA_INV_ONE_MEPS + complex(rkind),intent(in) :: GAMMA_INV_EPS_PA_PM,GAMMA_INV_EPS_PB_PM,MZP1,EPS + integer(i4b) :: M_M1,N,I,PHASE + real(rkind) :: INF_NORM_EPS,GAMMA_INV_MP1 + complex(rkind) :: A_PM,B_SUM_INIT_PS_ONE,PI_EPS,GAMMA_INV_ONE_MEPS_MM + complex(rkind) :: B_PM,TMP1,TMP2 + complex(rkind) :: Z_TERM,PROD1,PROD2,PROD3,ONE_MEPS,PI_EPS_PM + complex(rkind) :: GAMMA_INV_A_PM,PROD_AB,GAMMA_INV_B_PM + complex(rkind) :: GAMMA_INV_EPS_PM_P1 + ! + INF_NORM_EPS=INF_NORM(EPS); M_M1=M-1; A_PM=A+M; B_PM=B+M + ONE_MEPS=ONE-EPS; PI_EPS=M_PI*EPS; PI_EPS_PM = M_PI*(EPS+M) + if(MOD(M,2).eq.0) then + PHASE = 1 + else + PHASE = -1 + endif + GAMMA_INV_ONE_MEPS_MM = GAMMA_INV_ONE_MEPS + do I=1,M + GAMMA_INV_ONE_MEPS_MM = GAMMA_INV_ONE_MEPS_MM*(ONE_MEPS - I) + enddo + if(INF_NORM_EPS.gt.0.10_rkind) then + GAMMA_INV_EPS_PM_P1 = PHASE*SIN(PI_EPS) & + /(PI_EPS_PM*GAMMA_INV_ONE_MEPS_MM) + PROD1=GAMMA_INV_ONE_MEPS*GAMMA_INV_EPS_PA_PM*GAMMA_INV_EPS_PB_PM + do N=0,M_M1 + PROD1=PROD1*(A+N)*(B+N)/(N+ONE) + enddo + PROD2=GAMMA_INV(A)*GAMMA_INV(B)*GAMMA_INV_EPS_PM_P1*(MZP1**EPS) + B_SUM_INIT_PS_ONE=GAMMA_C*(PROD1-PROD2)/EPS + return + else + GAMMA_INV_MP1=ONE;PROD_AB=ONE + do N=0,M_M1 + GAMMA_INV_MP1 = GAMMA_INV_MP1/(N+ONE) + PROD_AB = PROD_AB*(A+N)*(B+N) + enddo + if(ONE_MEPS-M.ne.1-M) then + Z_TERM=EXPM1(EPS*LOG(MZP1))/EPS + GAMMA_INV_EPS_PM_P1 = PHASE*SIN(PI_EPS) & + /(PI_EPS_PM*GAMMA_INV_ONE_MEPS_MM) + else + Z_TERM=LOG(MZP1) + GAMMA_INV_EPS_PM_P1 = GAMMA_INV_MP1 + endif + GAMMA_INV_A_PM=GAMMA_INV(A_PM);GAMMA_INV_B_PM=GAMMA_INV(B_PM) + TMP1=ONE; TMP2=M+1; + PROD1 = GAMMA_INV_EPS_PA_PM*GAMMA_INV_EPS_PB_PM & + *(GAMMA_INV_MP1*GAMMA_INV_DIFF_EPS(TMP1,-EPS) & + +GAMMA_INV_DIFF_EPS(TMP2,EPS)) + PROD2 = GAMMA_INV_EPS_PM_P1 & + *(GAMMA_INV_EPS_PB_PM*GAMMA_INV_DIFF_EPS(A_PM,EPS) & + +GAMMA_INV_A_PM*GAMMA_INV_DIFF_EPS(B_PM,EPS)) + PROD3 = GAMMA_INV_A_PM*GAMMA_INV_B_PM*GAMMA_INV_EPS_PM_P1*Z_TERM + B_SUM_INIT_PS_ONE=GAMMA_C*PROD_AB*(PROD1-PROD2-PROD3) + return + endif + end function B_SUM_INIT_PS_ONE + ! + !---------------------------------------------------------------------- + ! Calculation of the first term of the B(z) power series + ! ------------------------------------------------------ + ! in the 1/z transformation, divided by z^{-m} + !--------------------------------------------- + ! In the 1/z transformation, the power series + ! B(z) = \sum_{n=0}^{+oo} \beta_n z^{-n} occurs + ! (see Comp. Phys. Comm. paper). + ! The first term \beta_0, divided by z^{-m}, is calculated here. + ! m is the closest integer to Re(b-a) >= 0 and eps = b-a-m. + ! + ! One has to consider |eps|oo > 0.1 and |eps|oo <= 0.1, + ! where 1-m-eps and 1-m can be different or equal numerically, + ! leading to some changes in this last case. + ! + ! |eps|oo > 0.1 + ! ------------- + ! One has \beta_0/z^{-m} = [(a)_m (1-c+a)_m Gamma_inv(1-eps) + ! Gamma_inv(a+m+eps) Gamma_inv(c-a) Gamma_inv(m+1) + ! - (-z)^{-eps} (1-c+a+eps)_m Gamma_inv(a) Gamma_inv(c-a-eps) + ! Gamma_inv(1+m+eps)].[Gamma(c)/eps], + ! stable in this regime for a direct evaluation. + ! + ! The values of Gamma(c), Gamma_inv(c-a) and Gamma_inv(a+m+eps) + ! were already calculated and recycled here. + ! Gamma_inv(m+1) is calculated as 1/(m!). + ! Gamma_inv(1+m+eps) is calculated from Gamma_inv(1-eps) + ! as in the 1-z transformation routine. + ! + ! |eps|oo <= 0.1 + ! -------------- + ! The \beta_0/z^{-m} expression is rewritten + ! so that it contains no instabilities: + ! \beta_0/z^{-m} = [((1-c+a+eps)_m G(1,-eps) - P(m,eps,1-c+a) + ! Gamma_inv(1-eps)) Gamma_inv(c-a) Gamma_inv(a+m+eps) Gamma_inv(m+1) + ! + (1-c+a+eps)_m [G(m+1,eps) Gamma_inv(c-a) Gamma_inv(a+m+eps) + ! - G(a+m,eps) Gamma_inv(c-a) Gamma_inv(m+1+eps)] + ! - (G(c-a,-eps) - E(log(-z),-eps)) Gamma_inv(m+1+eps) + ! Gamma_inv(a+m)]] (a)_m Gamma(c) + ! + ! Definitions and method are the same + ! as in the 1-z transformation routine, except for P(m,eps,1-c+a). + ! P(m,eps,s) = [(s+eps)_m - (s)_m]/eps + ! for eps non zero and has a limit for eps -> 0. + ! Let n0 be the closest integer to -Re(s) for s complex. + ! A stable formula available for eps -> 0 for P(m,eps,s) is: + ! P(m,eps,s) = (s)_m E(\sum_{n=0}^{m-1} L(1/(s+n),eps),eps) + ! if n0 is not in [0:m-1], + ! P(m,eps,s) = \prod_{n=0, n not equal to n0}^{m-1} (s+eps+n) + ! + (s)_m E(\sum_{n=0, n not equal to n0}^{m-1} L(1/(s+n),eps),eps) + ! if n0 is in [0:m-1]. + ! L(s,eps) is log1p(s eps)/eps if eps is not zero, + ! and L(s,0) = s. + ! This expression is used in the code. + ! + ! Variables + ! --------- + ! a,b,c,z: a,b,c and z parameters + ! and arguments of the 2F1(a,b,c,z) function. + ! m,eps: closest integer to b-a, with Re(b-a) >= 0 and eps = b-a-m. + ! Gamma_c,Gamma_inv_cma,Gamma_inv_one_meps,Gamma_inv_eps_pa_pm: + ! recycled values of Gamma(c), Gamma_inv(c-a), Gamma_inv(1-eps) + ! and Gamma_inv(a+m+eps). + ! inf_norm_eps,phase,cma,a_mc_p1,a_mc_p1_pm,cma_eps,eps_pa_mc_p1,a_pm: + ! |eps|oo,(-1)^m,c-a,1-c+a+m,c-a-eps,1-c+a+eps,a+m + ! Gamma_inv_cma_meps,one_meps,Pi_eps,Pi_eps_pm: + ! Gamma_inv(c-a-eps),1-eps,pi.eps,pi.(eps+m) + ! Gamma_inv_one_meps_mm,Gamma_inv_eps_pm_p1: Gamma_inv(1-m-eps) + ! and Gamma_inv(1+m+eps) calculated with the recycling scheme. + ! prod1: (a)_m (1-c+a)_m Gamma_inv(1-eps) Gamma_inv(a+m+eps) + ! x Gamma_inv(c-a) Gamma_inv(m+1) in |eps|oo > 0.1 case. + ! prod2: (-z)^{-eps} (1-c+a+eps)_m Gamma_inv(a) + ! x Gamma_inv(c-a-eps) Gamma_inv(1+m+eps) in |eps|oo > 0.1 case. + ! n0: closest integer to -Re(1-c+a) + ! is_n0_here: true is n0 belongs to [0:m-1], false if not. + ! is_eps_non_zero: true if 1-m-eps and 1-m are different numerically, + ! false if not. + ! Gamma_inv_mp1,prod_a,prod_a_mc_p1: + ! Gamma_inv(m+1) calculated as 1/(m!), + ! (a)_m and (1-c+a)_m in |eps|oo <= 0.1 case. + ! prod_eps_pa_mc_p1_n0: + ! \prod_{n=0, n not equal to n0}^{m-1} (1-c+a+eps+n) + ! if n0 belongs to [0:m-1], 0.0 if not, in |eps|oo <= 0.1 case. + ! prod_eps_pa_mc_p1: (1-c+a+eps)_m in |eps|oo <= 0.1 case. + ! sum: \sum_{n=0, n not equal to n0}^{m-1} L(1/(s+n),eps) if 1-m-eps + ! and 1-m are different numerically, + ! \sum_{n=0, n not equal to n0}^{m-1} 1/(s+n) if not. + ! a_pn,a_mc_p1_pn,eps_pa_mc_p1_pn: a+n,1-c+a+n,1-c+a+eps+n values + ! used in (a)_m, (1-c+a)_m and (1-c+a+eps)_m evaluations. + ! sum_term,prod_diff_eps,z_term: + ! E(\sum_{n=0, n not equal to n0}^{m-1} L(1/(s+n),eps),eps), + ! P(m,eps,1-c+a), -E(-eps,log(-z)) + ! Gamma_inv_a_pm,Gamma_prod1: Gamma_inv(a+m), + ! Gamma_inv(c-a).Gamma_inv(a+m+eps) + ! prod1: ((1-c+a+eps)_m G(1,-eps) + ! - P(m,eps,1-c+a) Gamma_inv(1-eps)) Gamma_inv(c-a) + ! x Gamma_inv(a+m+eps) Gamma_inv(m+1) + ! prod_2a: Gamma_inv(c-a).Gamma_inv(a+m+eps).G(m+1,eps) + ! prod_2b: G(a+m,eps) Gamma_inv(c-a) Gamma_inv(m+1+eps) + ! prod_2c: (G(c-a,-eps) + ! - E(log(-z),-eps)) Gamma_inv(m+1+eps) Gamma_inv(a+m) + ! prod2: (1-c+a+eps)_m [G(m+1,eps) Gamma_inv(c-a) Gamma_inv(a+m+eps) + ! - G(a+m,eps) Gamma_inv(c-a) Gamma_inv(m+1+eps)] + ! - (G(c-a,-eps) - E(log(-z),-eps)) + ! x Gamma_inv(m+1+eps) Gamma_inv(a+m)]] + ! res: returned \beta_0/z^{-m} value in all cases. + !---------------------------------------------------------------------- + function B_SUM_INIT_PS_INFINITY(A,C,GAMMA_C,GAMMA_INV_CMA, & + GAMMA_INV_ONE_MEPS,GAMMA_INV_EPS_PA_PM,Z,M,EPS) + !-------------------------------------------------------------------- + implicit none + integer(i4b),intent(in) :: M + complex(rkind),intent(in) :: A,C,GAMMA_C,GAMMA_INV_CMA,Z,EPS + complex(rkind),intent(in) :: GAMMA_INV_ONE_MEPS,GAMMA_INV_EPS_PA_PM + integer(i4b) :: M_M1,I,N,N0,PHASE + logical(lgt) :: IS_N0_HERE,IS_EPS_NON_ZERO + real(rkind) :: INF_NORM_EPS,NP1,GAMMA_INV_MP1 + complex(rkind) :: B_SUM_INIT_PS_INFINITY,TMP1 + complex(rkind) :: CMA,A_MC_P1,A_MC_P1_PM,CMA_MEPS,EPS_PA_MC_P1,A_PM + complex(rkind) :: GAMMA_INV_EPS_PM_P1,GAMMA_INV_CMA_MEPS,PI_EPS + complex(rkind) :: PROD1,PROD2,A_PN,A_MC_P1_PN,ONE_MEPS + complex(rkind) :: PROD_A,PROD_A_MC_P1,PROD_EPS_PA_MC_P1_N0,PI_EPS_PM + complex(rkind) :: PROD_EPS_PA_MC_P1,SUM_N0,Z_TERM,SUM_TERM + complex(rkind) :: PROD_DIFF_EPS,GAMMA_INV_A_PM,GAMMA_PROD1 + complex(rkind) :: PROD_2A,PROD_2B,PROD_2C + complex(rkind) :: EPS_PA_MC_P1_PN,GAMMA_INV_ONE_MEPS_MM + ! + INF_NORM_EPS=INF_NORM(EPS); CMA=C-A; A_MC_P1=A-C+ONE + A_MC_P1_PM=A_MC_P1+M; CMA_MEPS=CMA-EPS; EPS_PA_MC_P1=EPS+A_MC_P1 + A_PM=A+M; M_M1=M-1; ONE_MEPS=ONE-EPS; PI_EPS=M_PI*EPS + PI_EPS_PM=M_PI*(EPS+M); GAMMA_INV_CMA_MEPS=GAMMA_INV(CMA_MEPS) + if(MOD(M,2).eq.0) then + PHASE = 1 + else + PHASE = -1 + endif + GAMMA_INV_ONE_MEPS_MM = GAMMA_INV_ONE_MEPS + do I=1,M + GAMMA_INV_ONE_MEPS_MM = GAMMA_INV_ONE_MEPS_MM*(ONE_MEPS - I) + enddo + if(INF_NORM_EPS.gt.0.1_rkind) then + GAMMA_INV_EPS_PM_P1 = PHASE*SIN(PI_EPS) & + /(PI_EPS_PM*GAMMA_INV_ONE_MEPS_MM) + PROD1 = GAMMA_INV_CMA*GAMMA_INV_EPS_PA_PM*GAMMA_INV_ONE_MEPS + PROD2 = GAMMA_INV(A)*GAMMA_INV_CMA_MEPS*GAMMA_INV_EPS_PM_P1 & + *((-Z)**(-EPS)) + do N=0,M_M1 + A_PN=A+N; A_MC_P1_PN=A_MC_P1+N + EPS_PA_MC_P1_PN=EPS+A_MC_P1_PN;NP1=N+ONE + PROD1 = PROD1*A_PN*A_MC_P1_PN/NP1 + PROD2 = PROD2*EPS_PA_MC_P1_PN + enddo + B_SUM_INIT_PS_INFINITY = GAMMA_C*(PROD1-PROD2)/EPS + return + else + N0=-NINT(REAL(A_MC_P1,rkind)) + IS_EPS_NON_ZERO=ONE_MEPS-M.ne.1-M + IS_N0_HERE=(N0.ge.0).and.(N0.lt.M) + GAMMA_INV_MP1=ONE; PROD_A=ONE; PROD_A_MC_P1=ONE + PROD_EPS_PA_MC_P1=ONE; SUM_N0=ZERO + if(IS_N0_HERE) then + PROD_EPS_PA_MC_P1_N0 = ONE + else + PROD_EPS_PA_MC_P1_N0 = ZERO + endif + do N=0,M_M1 + A_PN=A+N; A_MC_P1_PN=A_MC_P1+N + EPS_PA_MC_P1_PN=EPS+A_MC_P1_PN; NP1=N+ONE + PROD_A = PROD_A*A_PN + PROD_A_MC_P1 = PROD_A_MC_P1*A_MC_P1_PN + PROD_EPS_PA_MC_P1 = PROD_EPS_PA_MC_P1*EPS_PA_MC_P1_PN + GAMMA_INV_MP1 = GAMMA_INV_MP1/NP1 + if(N.ne.N0) then + if(IS_N0_HERE) then + PROD_EPS_PA_MC_P1_N0=PROD_EPS_PA_MC_P1_N0 & + *EPS_PA_MC_P1_PN + endif + if(IS_EPS_NON_ZERO) then + SUM_N0 = SUM_N0 + LOG1P(EPS/A_MC_P1_PN) + else + SUM_N0 = SUM_N0 + ONE/A_MC_P1_PN + endif + endif + enddo + if(IS_EPS_NON_ZERO) then + GAMMA_INV_EPS_PM_P1 = PHASE*SIN(PI_EPS) & + /(PI_EPS_PM*GAMMA_INV_ONE_MEPS_MM) + SUM_TERM = EXPM1(SUM_N0)/EPS + Z_TERM = EXPM1(-EPS*LOG(-Z))/EPS + else + GAMMA_INV_EPS_PM_P1 = GAMMA_INV_MP1 + SUM_TERM = SUM_N0 + Z_TERM = -LOG(-Z) + endif + PROD_DIFF_EPS = PROD_EPS_PA_MC_P1_N0 + PROD_A_MC_P1*SUM_TERM + GAMMA_INV_A_PM = GAMMA_INV(A_PM) + GAMMA_PROD1=GAMMA_INV_CMA*GAMMA_INV_EPS_PA_PM + TMP1=ONE + PROD1 = GAMMA_PROD1*GAMMA_INV_MP1*(GAMMA_INV_DIFF_EPS(TMP1,-EPS) & + *PROD_EPS_PA_MC_P1 - GAMMA_INV_ONE_MEPS*PROD_DIFF_EPS) + TMP1=M+1 + PROD_2A = GAMMA_PROD1*GAMMA_INV_DIFF_EPS(TMP1,EPS) + PROD_2B = GAMMA_INV_CMA*GAMMA_INV_EPS_PM_P1 & + *GAMMA_INV_DIFF_EPS(A_PM,EPS) + PROD_2C = GAMMA_INV_EPS_PM_P1*GAMMA_INV_A_PM & + *(GAMMA_INV_DIFF_EPS(CMA,-EPS) + GAMMA_INV_CMA_MEPS*Z_TERM) + PROD2 = PROD_EPS_PA_MC_P1*(PROD_2A - PROD_2B - PROD_2C) + B_SUM_INIT_PS_INFINITY = GAMMA_C*PROD_A*(PROD1+PROD2) + return + endif + end function B_SUM_INIT_PS_INFINITY + ! + !---------------------------------------------------------------------- + ! Calculation of the derivative of the polynomial P(X) + ! ---------------------------------------------------- + ! testing power series convergence + ! -------------------------------- + ! P(X) = |z(a+X)(b+X)|^2 - |(c+X)(X+1)|^2 + ! = \sum_{i=0}^{4} c[i] X^{i}, for |z| < 1. + ! It is positive when the power series term modulus increases + ! and negative when it decreases, + ! so that its derivative provides information on its convergence + ! (see Comp. Phys. Comm. paper). + ! Its derivative components cv_poly_der_tab[i] = (i+1) c[i+1] + ! for i in [0:3] + ! so that P'(X) = \sum_{i=0}^{3} cv_poly_der_tab[i] X^{i} + ! are calculated. + ! + ! Variables: + ! ---------- + ! a,b,c,z: a,b,c and z parameters and arguments + ! of the 2F1(a,b,c,z) function. + ! cv_poly_der_tab[3]: table of four doubles + ! containing the P'(X) components. + ! mod_a2,mod_b2,mod_c2,mod_z2,R_a,Re_b,Re_c: |a|^2, |b|^2, |c|^2, + ! |z|^2, Re(a), Re(b), Re(c), with which P(X) can be expressed. + !---------------------------------------------------------------------- + subroutine CV_POLY_DER_TAB_CALC(A,B,C,Z,CV_POLY_DER_TAB) + !-------------------------------------------------------------------- + implicit none + complex(rkind),intent(in) :: A,B,C,Z + real(rkind),intent(out) :: CV_POLY_DER_TAB(0:3) + real(rkind) :: MOD_A2,MOD_B2,MOD_C2,MOD_Z2 + real(rkind) :: RE_A,RE_B,RE_C,IM_A,IM_B,IM_C,RE_Z,IM_Z + ! + RE_A=REAL(A,rkind); IM_A=AIMAG(A); MOD_A2=RE_A*RE_A+IM_A*IM_A + RE_B=REAL(B,rkind); IM_B=AIMAG(B); MOD_B2=RE_B*RE_B+IM_B*IM_B + RE_C=REAL(C,rkind); IM_C=AIMAG(C); MOD_C2=RE_C*RE_C+IM_C*IM_C + RE_Z=REAL(Z,rkind); IM_Z=AIMAG(Z); MOD_Z2=RE_Z*RE_Z+IM_Z*IM_Z + CV_POLY_DER_TAB(0)=TWO*((RE_A*MOD_B2+RE_B*MOD_A2)*MOD_Z2-RE_C-MOD_C2) + CV_POLY_DER_TAB(1)=TWO*((MOD_A2+MOD_B2+4._rkind*RE_A*RE_B)*MOD_Z2 & + -ONE-4._rkind*RE_C-MOD_C2) + CV_POLY_DER_TAB(2)=6._rkind*((RE_A+RE_B)*MOD_Z2-RE_C-ONE) + CV_POLY_DER_TAB(3)=4._rkind*(MOD_Z2-ONE) + end subroutine CV_POLY_DER_TAB_CALC + ! + !---------------------------------------------------------------------- + ! Calculation of the derivative of the polynomial P(X) + ! ---------------------------------------------------- + ! testing power series convergence at one x value + ! ----------------------------------------------- + ! P'(x) is calculated for a real x. + ! See P'(X) components calculation routine for definitions. + !---------------------------------------------------------------------- + function CV_POLY_DER_CALC(CV_POLY_DER_TAB,X) + !-------------------------------------------------------------------- + implicit none + real(rkind),intent(in) :: X + real(rkind),intent(in) :: CV_POLY_DER_TAB(0:3) + real(rkind) :: CV_POLY_DER_CALC + ! + CV_POLY_DER_CALC=CV_POLY_DER_TAB(0)+X*(CV_POLY_DER_TAB(1) & + +X*(CV_POLY_DER_TAB(2)+X*CV_POLY_DER_TAB(3))) + return + end function CV_POLY_DER_CALC + ! + !---------------------------------------------------------------------- + ! Calculation of an integer after which false convergence cannot occur + ! -------------------------------------------------------------------- + ! See cv_poly_der_tab_calc routine for definitions. + ! If P'(x) < 0 and P''(x) < 0 for x > xc, it will be so for all x > xc + ! as P(x) -> -oo for x -> +oo + ! and P(x) can have at most one maximum for x > xc. + ! It means that the 2F1 power series term modulus will increase + ! or decrease to 0 for n > nc, + ! with nc the smallest positive integer larger than xc. + ! + ! If P'(X) = C0 + C1.X + C2.X^2 + C3.X^3, + ! the discriminant of P''(X) is Delta = C2^2 - 3 C1 C3. + ! + ! If Delta > 0, P''(X) has two different real roots + ! and its largest root is -(C2 + sqrt(Delta))/(3 C3), + ! because C3 = 4(|z|^2 - 1) < 0. + ! One can take xc = -(C2 + sqrt(Delta))/(3 C3) + ! and one returns its associated nc integer. + ! + ! If Delta <= 0, P''(X) has at most one real root, + ! so that P'(X) has only one root and then P(X) only one maximum. + ! In this case, one can choose xc = nc = 0, which is returned. + ! + ! Variables + ! --------- + ! cv_poly_der_tab: table of four doubles + ! containing the P'(X) coefficients + ! C1,C2,three_C3: cv_poly_der_tab[1], cv_poly_der_tab[2] + ! and 3.0*cv_poly_der_tab[3], so that P''(X) = C1 + 2.C2.x + three_C3.x^2 + ! Delta: discriminant of P''(X), equal to C2^2 - 3 C1 C3. + ! largest_root: if Delta > 0, + ! P''(X) largest real root equal to -(C2 + sqrt(Delta))/(3 C3). + !---------------------------------------------------------------------- + function MIN_N_CALC(CV_POLY_DER_TAB) + !-------------------------------------------------------------------- + implicit none + real(rkind),intent(in) :: CV_POLY_DER_TAB(0:3) + integer(i4b) :: MIN_N_CALC + real(rkind) :: C1,C2,THREE_C3,DELTA,LARGEST_ROOT + ! + C1=CV_POLY_DER_TAB(1); C2=CV_POLY_DER_TAB(2) + THREE_C3=3._rkind*CV_POLY_DER_TAB(3); DELTA = C2*C2 - THREE_C3*C1 + if(DELTA.le.ZERO) then + MIN_N_CALC = 0 + return + else + LARGEST_ROOT = -(C2 + SQRT (DELTA))/THREE_C3 + MIN_N_CALC = MAX(CEILING(LARGEST_ROOT),0) + return + endif + end function MIN_N_CALC + ! + !---------------------------------------------------------------------- + ! Calculation of the 2F1 power series converging for |z| < 1 + ! ---------------------------------------------------------- + ! One has 2F1(a,b,c,z) + ! = \sum_{n = 0}^{+oo} (a)_n (b)_n / ((c)_n n!) z^n, + ! so that 2F1(a,b,c,z) = \sum_{n = 0}^{+oo} t[n] z^n, + ! with t[0] = 1 and t[n+1] = (a+n)(b+n)/((c+n)(n+1)) t[n] for n >= 0. + ! If a or b are negative integers, + ! F(z) is a polynomial of degree -a or -b, evaluated directly. + ! If not, one uses the test of convergence |t[n] z^n|oo < 1E-15 + ! to truncate the series after it was checked + ! that false convergence cannot occur. + ! Variables: + ! ---------- + ! a,b,c,z: a,b,c and z parameters and arguments + ! of the 2F1(a,b,c,z) function. One must have here |z| < 1. + ! term,sum: term of the 2F1 power series equal to t[n] z^n, + ! truncated sum at given n of the 2F1 power series. + ! na,nb: absolute values of the closest integers to Re(a) and Re(b). + ! a = -na or b = -nb means one is in the polynomial case. + ! cv_poly_der_tab: coefficients of the derivative + ! of the polynomial P(X) = |z(a+X)(b+X)|^2 - |(c+X)(X+1)|^2 + ! min_n: smallest integer after which false convergence cannot occur. + ! It is calculated in min_n_calc. + ! possible_false_cv: always true if n < min_n. + ! If n >= min_n, it is true if P'(n) > 0. + ! If n >= min_n and P'(n) < 0, + ! it becomes false and remains as such for the rest of the calculation. + ! One can then check if |t[n] z^n|oo < 1E-15 to truncate the series. + !---------------------------------------------------------------------- + function HYP_PS_ZERO(A,B,C,Z) + !-------------------------------------------------------------------- + implicit none + complex(rkind),intent(in) :: A,B,C,Z + integer(i4b) :: N,NA,NB,MIN_N + complex(rkind) :: HYP_PS_ZERO,TERM + logical(lgt) :: POSSIBLE_FALSE_CV + real(rkind) :: CV_POLY_DER_TAB(0:3) + ! + NA = ABS(NINT(REAL(A,rkind))) + NB = ABS(NINT(REAL(B,rkind))) + TERM=ONE; HYP_PS_ZERO=ONE + if(A.eq.(-NA)) then + do N=0,NA-1 + TERM = TERM*Z*(A+N)*(B+N)/((N+ONE)*(C+N)) + HYP_PS_ZERO = HYP_PS_ZERO + TERM + enddo + return + else if(B.eq.(-NB)) then + do N=0,NB-1 + TERM = TERM*Z*(A+N)*(B+N)/((N+ONE)*(C+N)) + HYP_PS_ZERO = HYP_PS_ZERO + TERM + enddo + return + else + call CV_POLY_DER_TAB_CALC(A,B,C,Z,CV_POLY_DER_TAB) + POSSIBLE_FALSE_CV=.TRUE. + MIN_N=MIN_N_CALC(CV_POLY_DER_TAB);N=0 + do while(POSSIBLE_FALSE_CV.or.(INF_NORM(TERM).gt.EPS15)) + TERM = TERM*Z*(A+N)*(B+N)/((N+ONE)*(C+N)) + HYP_PS_ZERO = HYP_PS_ZERO + TERM + if(POSSIBLE_FALSE_CV.and.(N.gt.MIN_N)) then + POSSIBLE_FALSE_CV = & + (CV_POLY_DER_CALC(CV_POLY_DER_TAB,DBLE(N)).gt.ZERO) + endif + N=N+1 + enddo + return + endif + end function HYP_PS_ZERO + ! + !---------------------------------------------------------------------- + ! Calculation of the 2F1 power series + ! ----------------------------------- + ! converging with the 1-z transformation + ! -------------------------------------- + ! The formula for F(z) in the 1-z transformation holds: + ! F(z) = (-1)^m (pi.eps)/sin (pi.eps) [A(z) + B(z)] + ! for eps not equal to zero, F(z) = (-1)^m [A(z) + B(z)] for eps = 0 + ! where m = |Re(c-a-b)], eps = c-a-b-m, + ! A(z) = \sum_{n=0}^{m-1} alpha[n] (1-z)^n, + ! B(z) = \sum_{n=0}^{+oo} beta[n] (1-z)^n, and: + ! + ! alpha[0] = [Gamma_inv(1-m-eps)/eps] Gamma_inv(a+m+eps) + ! x Gamma_inv(b+m+eps) Gamma(c) + ! [Gamma_inv(1-m-eps)/eps] is calculated in A_sum_init. + ! alpha[0] is calculated with log[Gamma] + ! if the previous expression might overflow, + ! and its imaginary part removed if a, b and c are real. + ! alpha[n+1] = (a+n)(b+n)/[(n+1)(1-m-eps+n)] alpha[n], n in [0:m-2]. + ! + ! beta[0] is defined in B_sum_init_PS_one function comments. + ! gamma[0] = Gamma(c) (a)_m (b)_m (1-z)^m Gamma_inv(a+m+eps) + ! x Gamma_inv(b+m+eps) Gamma_inv(m+1) Gamma_inv(1-eps) + ! + ! beta[n+1] = (a+m+n+eps)(b+m+n+eps)/[(m+n+1+eps)(n+1)] beta[n] + ! + [(a+m+n)(b+m+n)/(m+n+1) - (a+m+n) - (b+m+n) - eps + ! + (a+m+n+eps)(b+m+n+eps)/(n+1)] + ! x gamma[n]/[(n+m+1+eps)(n+1+eps)], n >= 0. + ! gamma[n+1] = (a+m+n)(b+m+n)/[(m+n+1)(n+1-eps)] gamma[n], n >= 0. + ! + ! B(z) converges <=> |1-z| < 1 + ! The test of convergence is |beta[n] (1-z)^n|oo < 1E-15 |beta[0]|oo + ! for n large enough so that false convergence cannot occur. + ! + ! Variables + ! --------- + ! a,b,c,one_minus_z: a,b,c parameters + ! and 1-z from z argument of 2F1(a,b,c,z) + ! m,phase,m_p1,eps,eps_pm,eps_pm_p1, + ! a_pm,b_pm,one_meps,one_meps_pm: + ! |Re(c-a-b)], (-1)^m, m+1, c-a-b-m, + ! eps+m, eps+m+1, a+m, b+m, 1-eps, 1-eps-m + ! eps_pa,eps_pb,eps_pa_pm,eps_pb_pm,Pi_eps,Gamma_c: + ! eps+a, eps+b, eps+a+m, eps+b+m, pi.eps, Gamma(c) + ! Gamma_inv_eps_pa_pm,Gamma_inv_eps_pb_pm,Gamma_prod: + ! Gamma_inv(eps+a+m), Gamma_inv(eps+b+m), + ! Gamma(c).Gamma_inv(eps+a+m).Gamma_inv(eps+b+m) + ! Gamma_inv_one_meps,A_first_term,A_sum,A_term: + ! Gamma_inv(1-eps), alpha[0], A(z), alpha[n] (1-z)^n + ! pow_mzp1_m,B_first_term,prod_B,ratio: (1-z)^m, beta[0], + ! (a)_m (b)_m (1-z)^m, (a+n)(b+n)/(n+1) for n in [0:m-2]. + ! B_extra_term,B_term,B_sum,B_prec: + ! gamma[n], beta[n] (1-z)^n, B(z), 1E-15 |beta[0|oo + ! cv_poly1_der_tab,cv_poly2_der_tab: P1'(X) and P2'(X) coefficients + ! of the potentials derivatives of P1(X) and P2(X) + ! defined in cv_poly_der_tab_calc with parameters + ! a1 = a, b1 = b, c1 = 1-m-eps, z1 = 1-z + ! and a2 = eps+b+m, b2 = eps+a+m,c2 = eps+m+1, z2 = 1-z. + ! min_n: smallest integer after which false convergence cannot occur. + ! It is calculated in min_n_calc with both P1'(X) and P2'(X), + ! so one takes the largest integer coming from both calculations. + ! possible_false_cv: always true if n < min_n. + ! If n >= min_n, it is true if P1'(n) > 0 or P2'(n) > 0. + ! If n >= min_n and P1'(n) < 0 and P2'(n) < 0, + ! it becomes false and remains as such for the rest of the calculation. + ! One can then check if |beta[n] z^n|oo < 1E-15 to truncate the series. + ! n,n_pm_p1,n_p1,a_pm_pn,b_pm_pn,eps_pm_p1_pn,n_p1_meps,eps_pa_pm_pn, + ! eps_pb_pm_pn,eps_pm_pn: index of power series, n+m+1, n+1, + ! a+m+n, b+m+n, eps+m+n+1, n+1-eps, eps+a+m+n, eps+b+m+n, eps+m+n, + ! prod1,prod2,prod3: (eps+a+m+n)(eps+b+m+n), + ! (eps+m+1+n)(n+1), (a+m+n)(b+m+n) + !---------------------------------------------------------------------- + function HYP_PS_ONE(A,B,C,MZP1) + !-------------------------------------------------------------------- + implicit none + complex(rkind),intent(in) :: A,B,C,MZP1 + integer(i4b) :: N,M,PHASE,M_M2,MIN_N,M_P1 + real(rkind) :: B_PREC,N_P1,N_PM_P1 + complex(rkind) :: HYP_PS_ONE,EPS,EPS_PM,EPS_PM_P1,A_PM + complex(rkind) :: B_PM,ONE_MEPS_MM,EPS_PA,EPS_PB,PI_EPS,GAMMA_PROD + complex(rkind) :: EPS_PA_PM,EPS_PB_PM, A_SUM,A_TERM,ONE_MEPS + complex(rkind) :: B_EXTRA_TERM,B_TERM,B_SUM,GAMMA_C,RATIO + complex(rkind) :: A_PM_PN,B_PM_PN,EPS_PM_P1_PN,N_P1_MEPS + complex(rkind) :: PROD1,PROD2,PROD3 + complex(rkind) :: EPS_PA_PM_PN,EPS_PB_PM_PN,EPS_PM_PN,PROD_B,POW_MZP1_M + complex(rkind) :: GAMMA_INV_EPS_PA_PM,GAMMA_INV_EPS_PB_PM + complex(rkind) :: GAMMA_INV_ONE_MEPS + logical(lgt) :: POSSIBLE_FALSE_CV + real(rkind) :: CV_POLY1_DER_TAB(0:3),CV_POLY2_DER_TAB(0:3) + ! + M=NINT(REAL(C-A-B,rkind)); M_M2=M-2; M_P1=M+1 + if(MOD(M,2).eq.0) then + PHASE=1 + else + PHASE=-1 + endif + EPS=C-A-B-M; EPS_PM=EPS+M; EPS_PM_P1=EPS_PM+ONE; A_PM=A+M;B_PM=B+M + ONE_MEPS=ONE-EPS; ONE_MEPS_MM=ONE_MEPS-M; EPS_PA=EPS+A; EPS_PB=EPS+B + PI_EPS=M_PI*EPS; EPS_PA_PM=EPS_PA+M; EPS_PB_PM=EPS_PB+M + GAMMA_C=ONE/GAMMA_INV(C) + GAMMA_INV_EPS_PA_PM=GAMMA_INV(EPS_PA_PM) + GAMMA_INV_EPS_PB_PM=GAMMA_INV(EPS_PB_PM) + GAMMA_PROD=GAMMA_C*GAMMA_INV_EPS_PA_PM*GAMMA_INV_EPS_PB_PM + GAMMA_INV_ONE_MEPS=GAMMA_INV(ONE_MEPS) + if(M.eq.0) then + A_TERM=ZERO + else if(INF_NORM(ONE_MEPS_MM & + *(LOG(ONE + ABS(ONE_MEPS_MM))-ONE)).lt.300.0d0) then + A_TERM=GAMMA_PROD*A_SUM_INIT(M,EPS,GAMMA_INV_ONE_MEPS) + else + A_TERM=EXP(LOG_GAMMA_FUN(C)-LOG_GAMMA_FUN(EPS_PA_PM)& + -LOG_GAMMA_FUN(EPS_PB_PM)+LOG_A_SUM_INIT(M,EPS)) + if((AIMAG(A).eq.ZERO).and.(AIMAG(B).eq.ZERO)& + .and.(AIMAG(C).eq.ZERO)) then + A_TERM=REAL(A_TERM,rkind) + endif + endif + A_SUM=A_TERM + POW_MZP1_M = MZP1**M + B_TERM=B_SUM_INIT_PS_ONE(A,B,GAMMA_C,GAMMA_INV_ONE_MEPS, & + GAMMA_INV_EPS_PA_PM,GAMMA_INV_EPS_PB_PM,MZP1,M,EPS)*POW_MZP1_M + PROD_B=POW_MZP1_M + do N=0,M_M2 + RATIO=(A+N)*(B+N)/(N+ONE) + A_TERM=A_TERM*MZP1*RATIO/(N+ONE_MEPS_MM) + A_SUM=A_SUM+A_TERM + PROD_B = PROD_B*RATIO + enddo + if(M.gt.0) then + PROD_B = PROD_B*(A+M-ONE)*(B+M-ONE)/DBLE(M) + endif + B_EXTRA_TERM = PROD_B*GAMMA_PROD*GAMMA_INV_ONE_MEPS; B_SUM=B_TERM + B_PREC=EPS15*INF_NORM(B_TERM) + call CV_POLY_DER_TAB_CALC(A,B,ONE_MEPS_MM,MZP1,CV_POLY1_DER_TAB) + call CV_POLY_DER_TAB_CALC(EPS_PB_PM,EPS_PA_PM,EPS_PM_P1,MZP1, & + CV_POLY2_DER_TAB) + MIN_N=MAX(MIN_N_CALC(CV_POLY1_DER_TAB),MIN_N_CALC(CV_POLY2_DER_TAB)) + POSSIBLE_FALSE_CV=.TRUE.; N=0 + do while(POSSIBLE_FALSE_CV.or.(INF_NORM(B_TERM).gt.B_PREC)) + N_PM_P1=N+M_P1; N_P1=N+ONE; A_PM_PN=A_PM+N; B_PM_PN=B_PM+N + EPS_PM_P1_PN=EPS_PM_P1+N; N_P1_MEPS=ONE_MEPS+N + EPS_PM_PN=EPS_PM+N; EPS_PA_PM_PN=EPS_PA_PM+N + EPS_PB_PM_PN=EPS_PB_PM+N + PROD1=EPS_PA_PM_PN*EPS_PB_PM_PN + PROD2=EPS_PM_P1_PN*N_P1 + PROD3=A_PM_PN*B_PM_PN + B_TERM = MZP1*(B_TERM*PROD1/PROD2+B_EXTRA_TERM*(PROD3/N_PM_P1 & + -A_PM_PN-B_PM_PN-EPS+PROD1/N_P1)/(EPS_PM_P1_PN*N_P1_MEPS)) + B_SUM=B_SUM+B_TERM + B_EXTRA_TERM=B_EXTRA_TERM*MZP1*PROD3/(N_PM_P1*N_P1_MEPS) + if(POSSIBLE_FALSE_CV.and.(N.gt.MIN_N)) then + POSSIBLE_FALSE_CV = & + (CV_POLY_DER_CALC(CV_POLY1_DER_TAB,DBLE(N)).gt.ZERO).or. & + (CV_POLY_DER_CALC(CV_POLY2_DER_TAB,DBLE(N)).gt.ZERO) + endif + N=N+1 + enddo + if(EPS.eq.ZERO) then + HYP_PS_ONE=PHASE*(A_SUM+B_SUM) + return + else + HYP_PS_ONE=PHASE*(A_SUM+B_SUM)*PI_EPS/SIN(PI_EPS) + return + endif + end function HYP_PS_ONE + ! + !---------------------------------------------------------------------- + ! Calculation of the 2F1 power series + ! ----------------------------------- + ! converging with the 1/z transformation + ! -------------------------------------- + ! The formula for F(z) in the 1/z transformation holds: + ! F(z) = (-1)^m (pi.eps)/sin (pi.eps) [A(z) + B(z)] + ! for eps not equal to zero, + ! F(z) = (-1)^m [A(z) + B(z)] for eps = 0 + ! where m = |Re(b-a)], eps = b-a-m, + ! A(z) = \sum_{n=0}^{m-1} alpha[n] z^{-n}, + ! B(z) = \sum_{n=0}^{+oo} beta[n] z^{-n}, and: + ! + ! alpha[0] = [Gamma_inv(1-m-eps)/eps] Gamma_inv(c-a) + ! x Gamma_inv(a+m+eps) Gamma(c) + ! [Gamma_inv(1-m-eps)/eps] is calculated in A_sum_init. + ! alpha[0] is calculated with log[Gamma] + ! if the previous expression might overflow, + ! and its imaginary part removed if a, b and c are real. + ! alpha[n+1] = (a+n)(1-c+a+n)/[(n+1)(1-m-eps+n)] alpha[n], + ! n in [0:m-2]. + ! + ! beta[0] is defined in B_sum_init_PS_infinity function comments. + ! gamma[0] = Gamma(c) (a)_m (1-c+a)_m z^{-m} Gamma_inv(a+m+eps) + ! x Gamma_inv(c-a) Gamma_inv(m+1) Gamma_inv(1-eps) + ! + ! beta[n+1] = (a+m+n+eps)(1-c+a+m+n+eps)/[(m+n+1+eps)(n+1)] beta[n] + ! + [(a+m+n)(1-c+a+m+n)/(m+n+1) - (a+m+n) - (1-c+a+m+n) + ! - eps + (a+m+n+eps)(1-c+a+m+n+eps)/(n+1)] + ! x gamma[n]/[(n+m+1+eps)(n+1+eps)], n >= 0. + ! gamma[n+1] = (a+m+n)(b+m+n)/[(m+n+1)(n+1-eps)] gamma[n], n >= 0. + ! + ! B(z) converges <=> |z| > 1 + ! The test of convergence is |beta[n] z^{-n}|oo < 1E-15 |beta[0]|oo + ! for n large enough so that false convergence cannot occur. + ! + ! Variables + ! --------- + ! a,b,c,z: a,b,c parameters and z argument of 2F1(a,b,c,z) + ! m,phase,m_p1,eps,a_mc_p1,one_meps, + ! one_meps_pm,a_pm,a_mc_p1_pm,cma: |Re(b-a)], (-1)^m, m+1, b-a-m, + ! 1-c+a, 1-eps, 1-eps-m, a+m, 1-c+a+m, c-a + ! eps_pa,eps_pm_p1,eps_pa_mc_p1_pm,Pi_eps,eps_pa_pm,eps_pm,Gamma_c: + ! eps+a, eps+m+1, eps+1-c+a+m, pi.eps, eps+a+m, eps+m, Gamma(c) + ! Gamma_inv_eps_pa_pm,Gamma_inv_cma,z_inv,pow_mz_ma, + ! Gamma_inv_one_meps,Gamma_prod: Gamma_inv(eps+a+m), Gamma_inv(c-a), + ! 1/z, (-z)^(-a), Gamma_inv(1-eps), + ! Gamma(c) Gamma_inv(c-a) Gamma_inv(eps+a+m) + ! A_first_term,A_sum,A_term: alpha[0], A(z), alpha[n] z^{-n} + ! pow_z_inv_m,B_first_term,prod_B,ratio: z^{-m}, beta[0], + ! (a)_m (1-c+a)_m z^{-m}, (a+n)(1-c+a+n)/(n+1) for n in [0:m-2]. + ! B_extra_term,B_term,B_sum,B_prec: + ! gamma[n], beta[n] z^{-n}, B(z), 1E-15 |beta[0|oo + ! cv_poly1_der_tab,cv_poly2_der_tab: P1'(X) and P2'(X) coefficients + ! of the potentials derivatives of P1(X) and P2(X) + ! defined in cv_poly_der_tab_calc + ! with parameters a1 = a, b1 = 1-c+a, c1 = 1-m-eps, z1 = 1/z + ! and a2 = b, b2 = eps+1-c+a+m,c2 = eps+m+1, z2 = 1/z. + ! min_n: smallest integer after which false convergence cannot occur. + ! It is calculated in min_n_calc with both P1'(X) and P2'(X), + ! so one takes the largest integer coming from both calculations. + ! possible_false_cv: always true if n < min_n. If n >= min_n, + ! it is true if P1'(n) > 0 or P2'(n) > 0. + ! If n >= min_n and P1'(n) < 0 and P2'(n) < 0, + ! it becomes false and remains as such for the rest of the calculation. + ! One can then check if |beta[n] z^n|oo < 1E-15 to truncate the series. + ! n,n_pm_p1,n_p1,a_pm_pn,a_mc_p1_pm_pn,eps_pm_p1_pn,n_p1_meps, + ! eps_pa_pm_pn,eps_pa_mc_p1_pm_pn,eps_pm_pn: + ! index of power series, n+m+1, n+1, a+m+n, 1-c+a+m+n, eps+m+n+1, + ! n+1-eps, eps+a+m+n, eps+1-c+a+m+n, eps+m+n, + ! prod1,prod2,prod3: (eps+a+m+n)(eps+1-c+a+m+n), + ! (eps+m+1+n)(n+1), (a+m+n)(1-c+a+m+n) + !---------------------------------------------------------------------- + function HYP_PS_INFINITY(A,B,C,Z) + !-------------------------------------------------------------------- + implicit none + complex(rkind),intent(in) :: A,B,C,Z + integer(i4b) :: N,M,PHASE,M_M2,MIN_N,M_P1 + real(rkind) :: B_PREC,N_P1,N_PM_P1 + complex(rkind) :: POW_Z_INV_M,HYP_PS_INFINITY,Z_INV,RATIO + complex(rkind) :: EPS,A_MC_P1,ONE_MEPS,ONE_MEPS_MM,A_PM,A_MC_P1_PM + complex(rkind) :: CMA,EPS_PA,EPS_PM_P1,EPS_PA_MC_P1_PM,PI_EPS + complex(rkind) :: EPS_PA_PM,EPS_PM,GAMMA_C,GAMMA_INV_CMA,POW_MZ_MA + complex(rkind) :: A_SUM,A_TERM + complex(rkind) :: GAMMA_INV_EPS_PA_PM,GAMMA_INV_ONE_MEPS + complex(rkind) :: PROD_B,B_EXTRA_TERM,B_TERM,B_SUM,PROD1 + complex(rkind) :: A_PM_PN,A_MC_P1_PM_PN,EPS_PM_P1_PN,N_P1_MEPS + complex(rkind) :: PROD2,PROD3,GAMMA_PROD + complex(rkind) :: EPS_PA_PM_PN,EPS_PA_MC_P1_PM_PN,EPS_PM_PN + logical(lgt) :: POSSIBLE_FALSE_CV + real(rkind) :: CV_POLY1_DER_TAB(0:3),CV_POLY2_DER_TAB(0:3) + ! + M=NINT(REAL(B-A,rkind)); M_M2=M-2;M_P1=M+1 + if(MOD(M,2).eq.0) then + PHASE=1 + else + PHASE=-1 + endif + EPS=B-A-M; A_MC_P1=ONE-C+A; ONE_MEPS=ONE-EPS; ONE_MEPS_MM=ONE_MEPS-M + A_PM=A+M; A_MC_P1_PM=A_MC_P1+M; CMA=C-A; EPS_PA=EPS+A + EPS_PM=EPS+M; EPS_PM_P1=EPS_PM+ONE; EPS_PA_MC_P1_PM=EPS+A_MC_P1_PM + PI_EPS=M_PI*EPS; EPS_PA_PM=EPS_PA+M + GAMMA_C=ONE/GAMMA_INV(C); GAMMA_INV_EPS_PA_PM = GAMMA_INV(EPS_PA_PM) + GAMMA_INV_ONE_MEPS = GAMMA_INV(ONE_MEPS) + GAMMA_INV_CMA=GAMMA_INV(CMA); Z_INV=ONE/Z;POW_MZ_MA=(-Z)**(-A) + GAMMA_PROD=GAMMA_C*GAMMA_INV_CMA*GAMMA_INV_EPS_PA_PM + if(M.eq.0) then + A_TERM=ZERO + else if(INF_NORM(ONE_MEPS_MM & + *(LOG(ONE + ABS(ONE_MEPS_MM))-ONE)).lt.300._rkind) then + A_TERM=GAMMA_PROD*A_SUM_INIT(M,EPS,GAMMA_INV_ONE_MEPS) + else + A_TERM=EXP(LOG_GAMMA_FUN(C)-LOG_GAMMA_FUN(CMA)-LOG_GAMMA_FUN(B) & + + LOG_A_SUM_INIT(M,EPS)) + if((AIMAG(A).eq.ZERO).and.(AIMAG(B).eq.ZERO).and. & + (AIMAG(C).eq.ZERO)) then + A_TERM=REAL(A_TERM,rkind) + endif + endif + A_SUM=A_TERM + POW_Z_INV_M=Z_INV**M + B_TERM=B_SUM_INIT_PS_INFINITY(A,C,GAMMA_C,GAMMA_INV_CMA, & + GAMMA_INV_ONE_MEPS,GAMMA_INV_EPS_PA_PM,Z,M,EPS)*POW_Z_INV_M + PROD_B=POW_Z_INV_M + do N=0,M_M2 + RATIO=(A+N)*(A_MC_P1+N)/(N+ONE) + A_TERM = A_TERM*Z_INV*RATIO/(N+ONE_MEPS_MM) + A_SUM = A_SUM+A_TERM + PROD_B = PROD_B*RATIO + enddo + if (M.gt.0) then + PROD_B=PROD_B*(A+M-ONE)*(A_MC_P1+M-ONE)/DBLE(M) + endif + B_EXTRA_TERM = PROD_B*GAMMA_PROD*GAMMA_INV_ONE_MEPS + B_SUM=B_TERM + B_PREC=EPS15*INF_NORM(B_TERM) + call CV_POLY_DER_TAB_CALC(A,A_MC_P1,ONE_MEPS_MM,Z_INV, & + CV_POLY1_DER_TAB) + call CV_POLY_DER_TAB_CALC(B,EPS_PA_MC_P1_PM,EPS_PM_P1, & + Z_INV,CV_POLY2_DER_TAB) + MIN_N=MAX(MIN_N_CALC(CV_POLY1_DER_TAB),MIN_N_CALC(CV_POLY2_DER_TAB)) + POSSIBLE_FALSE_CV=.TRUE.; N=0 + do while(POSSIBLE_FALSE_CV.or.(INF_NORM(B_TERM).gt.B_PREC)) + N_PM_P1=N+M_P1; N_P1=N+ONE; A_PM_PN=A_PM+N + A_MC_P1_PM_PN=A_MC_P1_PM+N; EPS_PM_P1_PN=EPS_PM_P1+N + N_P1_MEPS=N_P1-EPS; EPS_PA_PM_PN=EPS_PA_PM+N + EPS_PA_MC_P1_PM_PN=EPS_PA_MC_P1_PM+N; EPS_PM_PN=EPS_PM+N + PROD1=EPS_PA_PM_PN*EPS_PA_MC_P1_PM_PN; PROD2=EPS_PM_P1_PN*N_P1 + PROD3=A_PM_PN*A_MC_P1_PM_PN + B_TERM = Z_INV*(B_TERM*PROD1/PROD2+B_EXTRA_TERM*(PROD3/N_PM_P1 & + -A_PM_PN-A_MC_P1_PM_PN-EPS+PROD1/N_P1) & + /(EPS_PM_P1_PN*N_P1_MEPS)) + B_SUM=B_SUM+B_TERM + B_EXTRA_TERM=B_EXTRA_TERM*Z_INV*PROD3/(N_PM_P1*N_P1_MEPS) + if(POSSIBLE_FALSE_CV.and.(N.gt.MIN_N)) then + POSSIBLE_FALSE_CV = (CV_POLY_DER_CALC( & + CV_POLY1_DER_TAB,DBLE(N)).gt.ZERO).or.(& + CV_POLY_DER_CALC(CV_POLY2_DER_TAB,DBLE(N)).gt.ZERO) + endif + N=N+1 + enddo + if(EPS.eq.ZERO) then + HYP_PS_INFINITY=PHASE*POW_MZ_MA*(A_SUM+B_SUM) + return + else + HYP_PS_INFINITY=PHASE*POW_MZ_MA*(A_SUM+B_SUM)*PI_EPS & + /SIN(PI_EPS) + return + endif + end function HYP_PS_INFINITY + ! + !---------------------------------------------------------------------- + ! Calculation of F(z) in transformation theory missing zones + ! ---------------------------------------------------------- + ! of the complex plane with a Taylor series + ! ----------------------------------------- + ! If z is close to exp(+/- i.pi/3), no transformation in 1-z, z, + ! z/(z-1) or combination of them can transform z in a complex number + ! of modulus smaller than a given Rmax < 1 . + ! Rmax is a radius for which one considers power series summation + ! for |z| > Rmax is too slow to be processed. One takes Rmax = 0.9 . + ! Nevertheless, for Rmax = 0.9, + ! these zones are small enough to be handled + ! with a Taylor series expansion around a point z0 close to z + ! where transformation theory can be used to calculate F(z). + ! One then chooses z0 to be 0.9 z/|z| if |z| < 1, and 1.1 z/|z| + ! if |z| > 1, + ! so that hyp_PS_zero or hyp_PS_infinity can be used + ! (see comments of these functions above). + ! For this z0, F(z) = \sum_{n=0}^{+oo} q[n] (z-z0)^n, with: + ! q[0] = F(z0), q[1] = F'(z0) = (a b/c) 2F1(a+1,b+1,c+1,z0) + ! q[n+2] = [q[n+1] (n (2 z0 - 1) - c + (a+b+c+1) z0) + ! + q[n] (a+n)(b+n)/(n+1)]/(z0(1-z0)(n+2)) + ! As |z-z0| < 0.1, it converges with around 15 terms, + ! so that no instability can occur for moderate a, b and c. + ! Convergence is tested + ! with |q[n] (z-z0)^n|oo + |q[n+1] (z-z0)^{n+1}|oo. + ! Series is truncated when this test is smaller + ! than 1E-15 (|q[0]|oo + |q[1] (z-z0)|oo). + ! No false convergence can happen here + ! as q[n] behaves smoothly for n -> +oo. + ! + ! Variables + ! --------- + ! a,b,c,z: a,b,c parameters and z argument of 2F1(a,b,c,z) + ! abs_z,is_abs_z_small: |z|, true if |z| < 1 and false if not. + ! z0,zc_z0_ratio,z0_term1,z0_term2: 0.9 z/|z| if |z| < 1, + ! and 1.1 z/|z| if |z| > 1, (z-z0)/(z0 (1-z0)), + ! 2 z0 - 1, c - (a+b+c+1) z0 + ! hyp_PS_z0,dhyp_PS_z0,prec: F(z0), F'(z0) calculated with 2F1 + ! as F'(z0) = (a b/c) 2F1(a+1,b+1,c+1,z0), + ! precision demanded for series truncation + ! equal to 1E-15 (|q[0]|oo + |q[1] (z-z0)|oo). + ! n,an,anp1,anp2,sum: index of the series, q[n] (z-z0)^n, + ! q[n+1] (z-z0)^{n+1}, q[n+2] (z-z0)^{n+2}, + ! truncated sum of the power series. + !---------------------------------------------------------------------- + function HYP_PS_COMPLEX_PLANE_REST(A,B,C,Z) + !-------------------------------------------------------------------- + implicit none + complex(rkind),intent(in) :: A,B,C,Z + integer(i4b) :: N + real(rkind) :: ABS_Z,PREC + complex(rkind) :: HYP_PS_COMPLEX_PLANE_REST + complex(rkind) :: Z0,ZC,ZC_Z0_RATIO,Z0_TERM1,Z0_TERM2 + complex(rkind) :: HYP_PS_Z0,DHYP_PS_Z0,AN,ANP1,ANP2 + ! + ABS_Z=ABS(Z) + if(ABS_Z.lt.ONE) then + Z0=0.9_rkind*Z/ABS_Z; ZC=Z-Z0; ZC_Z0_RATIO=ZC/(Z0*(ONE-Z0)) + Z0_TERM1=TWO*Z0 - ONE; Z0_TERM2=C-(A+B+ONE)*Z0 + HYP_PS_Z0=HYP_PS_ZERO(A,B,C,Z0) + DHYP_PS_Z0=HYP_PS_ZERO(A+ONE,B+ONE,C+ONE,Z0)*A*B/C + else + Z0=1.1_rkind*Z/ABS_Z; ZC=Z-Z0; ZC_Z0_RATIO=ZC/(Z0*(ONE-Z0)) + Z0_TERM1=TWO*Z0 - ONE; Z0_TERM2=C-(A+B+ONE)*Z0 + HYP_PS_Z0=HYP_PS_INFINITY(A,B,C,Z0) + DHYP_PS_Z0=HYP_PS_INFINITY(A+ONE,B+ONE,C+ONE,Z0)*A*B/C + endif + AN=HYP_PS_Z0;ANP1=ZC*DHYP_PS_Z0;HYP_PS_COMPLEX_PLANE_REST=AN+ANP1 + PREC=EPS15*(INF_NORM(AN)+INF_NORM(ANP1)); N=0 + do while(INF_NORM(AN).gt.PREC) + ANP2=ZC_Z0_RATIO*(ANP1*(N*Z0_TERM1-Z0_TERM2)+AN*ZC*(A+N)*(B+N) & + /(N+ONE))/(N+TWO) + HYP_PS_COMPLEX_PLANE_REST = HYP_PS_COMPLEX_PLANE_REST + ANP2 + N=N+1 + AN=ANP1 + ANP1=ANP2 + enddo + return + end function HYP_PS_COMPLEX_PLANE_REST + ! + !---------------------------------------------------------------------- + ! Calculation of F(z) for arbitrary z using previous routines + ! ----------------------------------------------------------- + ! Firstly, it is checked if a,b and c are negative integers. + ! If neither a nor b is negative integer but c is, + ! F(z) is undefined so that the program stops with an error message. + ! If a and c are negative integers with c < a, + ! or b and c are negative integers with b < a, + ! or c is not negative integer integer but a or b is, + ! one is in the polynomial case. + ! In this case, if |z| < |z/(z-1)| or z = 1, + ! hyp_PS_zero is used directly, as then |z| <= 2 + ! and no instability arises with hyp_PS_zero + ! as long the degree of the polynomial is small (<= 10 typically). + ! If not, one uses the transformation + ! F(z) = (1-z)^{-a} 2F1(a,c-b,c,z/(z-1)) if a is negative integer + ! or F(z) = (1-z)^{-b} 2F1(b,c-a,c,z/(z-1)) if b is negative integer + ! along with hyp_PS_zero. + ! Indeed, 2F1(a,c-b,c,X) is a polynomial if a is negative integer, + ! and so is 2F1(b,c-a,c,X) if b is negative integer, + ! so that one has here |z/(z-1)| <= 2 + ! and the stability of the method is the same + ! as for the |z| < |z/(z-1)| case. + ! If one is in the non-polynomial case, one checks if z >= 1. + ! If it is, one is the cut of F(z) + ! so that z is replaced by z - 10^{-307}i. + ! Then, using F(z) = 2F1(b,a,c,z) + ! and F(z) = (1-z)^{c-a-b} 2F1(c-a,c-b,c,z), + ! one replaces a,b,c parameters by combinations of them + ! so that Re(b-a) >= 0 and Re(c-a-b) >= 0. + ! Exchanging a and b does not change convergence properties, + ! while having Re(c-a-b) >= 0 accelerates it + ! (In hyp_PS_zero, t[n] z^n ~ z^n/(n^{c-a-b}) for n -> +oo). + ! If |1-z| < 1E-5, one uses hyp_PS_one + ! as the vicinity of the singular point z = 1 is treated properly. + ! After that, one compares |z| and |z/(z-1)| + ! to R in {0.5,0.6,0.7,0.8,0.9}. + ! If one of them is smaller than R, + ! one uses hyp_PS_zero without transformation + ! or with the transformation F(z) = (1-z)^{-a} 2F1(a,c-b,c,z/(z-1)). + ! Then, if both of them are larger than 0.9, + ! one compares |1/z|, |(z-1)/z|, |1-z| and |1/(1-z)| + ! to R in {0.5,0.6,0.7,0.8,0.9}. + ! If one of them is found smaller than R, + ! with the condition that |c-b|oo < 5 for (z-1)/z transformation, + ! |a,b,c|oo < 5 for |1-z| transformation + ! and |a,c-b,c|oo < 5 for |1/(1-z)| transformation, + ! the corresponding transformation is used. + ! If none of them was smaller than 0.9, + ! one is in the missing zones of transformation theory + ! so that the Taylor series of hyp_PS_complex_plane_rest is used. + ! + ! Variables + ! --------- + ! a,b,c,z: a,b,c parameters and z argument of 2F1(a,b,c,z) + ! Re_a,Re_b,Re_c,na,nb,nc,is_a_neg_int,is_b_neg_int,is_c_neg_int: + ! real parts of a,b,c, closest integers to a,b,c, + ! true if a,b,c is negative integers and false if not. + ! zm1,z_over_zm1,z_shift: z-1, z/(z-1), z - 10^{-307}i in case z >= 1. + ! ab_condition, cab_condition: true if Re(b-a) >= 0 and false if not, + ! true if Re(c-a-b) >= 0 and false if not. + ! abs_zm1,abz_z,abs_z_inv,abs_z_over_zm1,abs_zm1_inv,abs_zm1_over_z: + ! |z-1|, |z|, |1/z|, |z/(z-1)|, |1/(z-1)|, |(z-1)/z| + ! are_ac_small: true if |a|oo < 5 and |c|oo < 5, false if not. + ! is_cmb_small: true if |c-b|oo < 5, false if not. + ! are_abc_small: true if |a|oo < 5, |b|oo < 5 and |c|oo < 5, + ! false if not. + ! are_a_cmb_c_small: true if |a|oo < 5, |c-b|oo < 5 and |c|oo < 5, + ! false if not. + ! R_tab,R: table of radii {0.5,0.6,0.7,0.8,0.9}, one of these radii. + ! res: returned result + !---------------------------------------------------------------------- + recursive function HYP_2F1(A,B,C,Z) result(RES) + !-------------------------------------------------------------------- + implicit none + complex(rkind),intent(in) :: A,B,C,Z + integer(i4b) :: NA,NB,NC,I + real(rkind) :: RE_A,RE_B,RE_C,ABS_Z,ABS_ZM1,ABS_Z_OVER_ZM1 + real(rkind) :: ABS_ZM1_OVER_Z,ABS_ZM1_INV,R_TABLE(1:5),R,ABS_Z_INV + complex(rkind) :: RES,Z_SHIFT,Z_OVER_ZM1,ZM1 + logical(lgt) :: IS_A_NEG_INT,IS_B_NEG_INT,IS_C_NEG_INT + logical(lgt) :: AB_CONDITION,CAB_CONDITION,ARE_A_CMB_C_SMALL + logical(lgt) :: IS_CMB_SMALL,ARE_AC_SMALL,ARE_ABC_SMALL + ! + RE_A=REAL(A,rkind); RE_B=REAL(B,rkind); RE_C=REAL(C,rkind); + NA=NINT(RE_A); NB=NINT(RE_B); NC=NINT(RE_C); + IS_A_NEG_INT=A.eq.NA.and.NA.le.0 + IS_B_NEG_INT=B.eq.NB.and.NB.le.0 + IS_C_NEG_INT=C.eq.NC.and.NC.le.0 + ZM1=Z-ONE + if(IS_C_NEG_INT) then + ABS_Z=ABS(Z); Z_OVER_ZM1 = Z/ZM1 + ABS_Z_OVER_ZM1=ABS(Z_OVER_ZM1) + if(IS_A_NEG_INT.and.(NC.lt.NA)) then + if((Z.eq.ONE).or.(ABS_Z.lt.ABS_Z_OVER_ZM1)) then + RES=HYP_PS_ZERO(A,B,C,Z) + return + else + RES=((-ZM1)**(-A))*HYP_PS_ZERO(A,C-B,C,Z_OVER_ZM1) + return + endif + else if(IS_B_NEG_INT.and.(NC.lt.NB)) then + if((Z.eq.ONE).or.(ABS_Z.lt.ABS_Z_OVER_ZM1)) then + RES=HYP_PS_ZERO(A,B,C,Z) + return + else + RES=((-ZM1)**(-B))*HYP_PS_ZERO(B,C-A,C,Z_OVER_ZM1) + return + endif + else + print*,'2F1 UNDEFINED' + endif + endif + if(IS_A_NEG_INT) then + ABS_Z=ABS(Z); Z_OVER_ZM1 = Z/ZM1 + ABS_Z_OVER_ZM1=ABS(Z_OVER_ZM1) + if((Z.eq.ONE).or.(ABS_Z.lt.ABS_Z_OVER_ZM1)) then + RES=HYP_PS_ZERO(A,B,C,Z) + return + else + RES=((-ZM1)**(-A))*HYP_PS_ZERO(A,C-B,C,Z_OVER_ZM1) + return + endif + else if(IS_B_NEG_INT) then + ABS_Z=ABS(Z); Z_OVER_ZM1 = Z/ZM1 + ABS_Z_OVER_ZM1=ABS(Z_OVER_ZM1) + if((Z.eq.ONE).or.(ABS_Z.lt.ABS_Z_OVER_ZM1)) then + RES=HYP_PS_ZERO(A,B,C,Z) + return + else + RES=((-ZM1)**(-B))*HYP_PS_ZERO(B,C-A,C,Z_OVER_ZM1) + return + endif + endif + if((REAL(Z,rkind).ge.ONE).and.(AIMAG(Z).eq.ZERO)) then + Z_SHIFT=CMPLX(REAL(Z,rkind),-1.e-307_rkind,rkind) + RES=HYP_2F1(A,B,C,Z_SHIFT) + return + endif + AB_CONDITION = (RE_B.ge.RE_A) + CAB_CONDITION = (RE_C.ge.RE_A + RE_B) + if ((.NOT.AB_CONDITION).or.(.NOT.CAB_CONDITION)) then + if ((.NOT.AB_CONDITION).and.(CAB_CONDITION)) then + RES=HYP_2F1(B,A,C,Z) + return + else if((.NOT.CAB_CONDITION).and.(AB_CONDITION)) then + RES=((-ZM1)**(C-A-B))*HYP_2F1(C-B,C-A,C,Z) + return + else + RES=((-ZM1)**(C-A-B))*HYP_2F1(C-A,C-B,C,Z) + return + endif + endif + ABS_ZM1=ABS(ZM1) + if(ABS_ZM1.lt.1.e-5_rkind) then + RES=HYP_PS_ONE(A,B,C,-ZM1) + return + endif + ABS_Z=ABS(Z); ABS_Z_OVER_ZM1=ABS_Z/ABS_ZM1; ABS_Z_INV=ONE/ABS_Z + ABS_ZM1_OVER_Z=ONE/ABS_Z_OVER_ZM1; ABS_ZM1_INV=ONE/ABS_ZM1 + IS_CMB_SMALL = INF_NORM(C-B).lt.5._rkind; + ARE_AC_SMALL = (INF_NORM(A).lt.5._rkind).and.(INF_NORM(C).lt.5._rkind) + ARE_ABC_SMALL = ARE_AC_SMALL.and.(INF_NORM(B).lt.5._rkind) + ARE_A_CMB_C_SMALL = ARE_AC_SMALL.and.IS_CMB_SMALL + R_TABLE=(/0.5_rkind,0.6_rkind,0.7_rkind,0.8_rkind,0.9_rkind/) + do I=1,5 + R=R_TABLE(I) + if(ABS_Z.le.R) then + RES=HYP_PS_ZERO(A,B,C,Z) + return + endif + if(IS_CMB_SMALL.and.(ABS_Z_OVER_ZM1.le.R)) then + RES=((-ZM1)**(-A))*HYP_PS_ZERO(A,C-B,C,Z/ZM1) + return + endif + enddo + do I=1,5 + R=R_TABLE(I) + if(ABS_Z_INV.le.R) then + RES=HYP_PS_INFINITY(A,B,C,Z) + return + endif + if(IS_CMB_SMALL.and.(ABS_ZM1_OVER_Z.le.R)) then + RES=((-ZM1)**(-A))*HYP_PS_INFINITY(A,C-B,C,Z/ZM1) + return + endif + if(ARE_ABC_SMALL.and.(ABS_ZM1.le.R)) then + RES=HYP_PS_ONE(A,B,C,-ZM1) + return + endif + if(ARE_A_CMB_C_SMALL.and.(ABS_ZM1_INV.le.R)) then + RES=((-ZM1)**(-A))*HYP_PS_ONE(A,C-B,C,-ONE/ZM1) + return + endif + enddo + RES=HYP_PS_COMPLEX_PLANE_REST(A,B,C,Z) + return + end function HYP_2F1 + ! + !---------------------------------------------------------------------- + ! Test of 2F1 numerical accuracy + ! ------------------------------ + ! using hypergeometric differential equation + ! ------------------------------------------ + ! If z = 0, F(z) = 1 so that this value is trivially tested. + ! To test otherwise if the value of F(z) is accurate, + ! one uses the fact that + ! z(z-1) F''(z) + (c - (a+b+1) z) F'(z) - a b F(z) = 0. + ! If z is not equal to one, a relative precision test is provided + ! by |F''(z) + [(c - (a+b+1) z) F'(z) - a b F(z)]/[z(z-1)]|oo + ! /(|F(z)|oo + F'(z)|oo + |F''(z)|oo). + ! If z is equal to one, one uses |(c - (a+b+1)) F'(z) - a b F(z)|oo + ! /(|F(z)|oo + F'(z)|oo + 1E-307). + ! F'(z) and F''(z) are calculated using equalities + ! F'(z) = (a b/c) 2F1(a+1,b+1,c+1,z) + ! and F'(z) = ((a+1)(b+1)/(c+1)) (a b/c) 2F1(a+2,b+2,c+2,z). + ! + ! Variables + ! --------- + ! a,b,c,z: a,b,c parameters and z argument of 2F1(a,b,c,z) + ! F,dF,d2F: F(z), F'(z) and F''(z) calculated with hyp_2F1 + ! using F'(z) = (a b/c) 2F1(a+1,b+1,c+1,z) + ! and F'(z) = ((a+1)(b+1)/(c+1)) (a b/c) 2F1(a+2,b+2,c+2,z). + !---------------------------------------------------------------------- + function TEST_2F1(A,B,C,Z,F) + !-------------------------------------------------------------------- + implicit none + complex(rkind),intent(in) :: A,B,C,Z + real(rkind) :: TEST_2F1 + complex(rkind) :: F,DF,D2F + ! + if(Z.eq.ZERO) then + TEST_2F1=INF_NORM(F-ONE) + return + else if(Z.eq.ONE) then + DF = HYP_2F1(A+ONE,B+ONE,C+ONE,Z)*A*B/C + TEST_2F1=INF_NORM((C-(A+B+ONE))*DF-A*B*F) & + /(INF_NORM (F)+INF_NORM(DF)+1.e-307_rkind) + return + else + DF = HYP_2F1(A+ONE,B+ONE,C+ONE,Z)*A*B/C + D2F = HYP_2F1(A+TWO,B+TWO,C+TWO,Z)*A*(A+ONE)*B*(B+ONE) & + /(C*(C+ONE)) + TEST_2F1=INF_NORM(D2F+((C-(A+B+ONE)*Z)*DF-A*B*F)/(Z*(ONE-Z))) & + /(INF_NORM(F)+INF_NORM(DF)+INF_NORM(D2F)) + return + endif + end function TEST_2F1 + !============== END HYP_2F1 FILE ====================================== + +end module hyp_2F1_module diff --git a/build/source/engine/indexState.f90 b/build/source/engine/indexState.f90 old mode 100755 new mode 100644 index 9c87d9833..d1eb29366 --- a/build/source/engine/indexState.f90 +++ b/build/source/engine/indexState.f90 @@ -24,7 +24,8 @@ module indexState_module USE nrtype ! derived types to define the data structures -USE data_types,only:var_ilength ! data vector with variable length dimension (i4b) +USE data_types,only:var_ilength ! data vector with variable length dimension (i4b) +USE data_types,only:in_type_indexSplit,out_type_indexSplit ! classes for indexSplit subroutine arguments ! missing data USE globalData,only:integerMissing ! missing integer @@ -258,11 +259,6 @@ subroutine indexState(computeVegFlux, & ! intent(in): flag to denote ! define the index for the control volumes in the aquifer if(includeAquifer) ixControlVolume( ixWatAquifer(1) ) = 1 - !print*, 'ixControlVolume = ', ixControlVolume - !print*, 'ixDomainType = ', ixDomainType - !print*, 'ixStateType = ', ixStateType - !print*, 'PAUSE: '; read(*,*) - ! end association to the ALLOCATABLE variables in the data structures end associate @@ -276,89 +272,95 @@ end subroutine indexState ! ********************************************************************************************************** ! public subroutine indexSplit: define list of indices for each state variable ! ********************************************************************************************************** - subroutine indexSplit(stateSubsetMask, & ! intent(in) : logical vector (.true. if state is in the subset) - nSnow,nSoil,nLayers,nSubset, & ! intent(in) : number of snow and soil layers, and total number of layers + subroutine indexSplit(in_indexSplit, & ! intent(in) : number of model layers and states in a subset + stateSubsetMask, & ! intent(in) : logical vector (.true. if state is in the subset) indx_data, & ! intent(inout) : index data structure - err,message) ! intent(out) : error control + out_indexSplit) ! intent(out) : error control ! external modules USE f2008funcs_module,only:findIndex ! finds the index of the first value within a vector USE nr_utility_module,only:arth ! creates a sequence of numbers (start, incr, n) implicit none ! -------------------------------------------------------------------------------------------------------------------------------- ! input - logical(lgt),intent(in) :: stateSubsetMask(:) ! logical vector (.true. if state is in the subset) - integer(i4b),intent(in) :: nSnow,nSoil,nLayers,nSubset ! number of snow and soil layers, total number of layers, and number of states in the subset - type(var_ilength),intent(inout) :: indx_data ! indices defining model states and layers + type(in_type_indexSplit),intent(in) :: in_indexSplit ! number of model layers and states in a subset + logical(lgt),intent(in) :: stateSubsetMask(:) ! logical vector (.true. if state is in the subset) + type(var_ilength),intent(inout) :: indx_data ! indices defining model states and layers ! output - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + type(out_type_indexSplit),intent(out) :: out_indexSplit ! error control ! -------------------------------------------------------------------------------------------------------------------------------- ! local variables - integer(i4b) :: iVar ! variable index - integer(i4b) :: ixVegWat ! index of total water in the vegetation canopy - integer(i4b) :: ixVegLiq ! index of liquid water in the vegetation canopy - integer(i4b) :: ixTopWat ! index of upper-most total water state in the snow-soil subdomain - integer(i4b) :: ixTopLiq ! index of upper-most liquid water state in the snow-soil subdomain - integer(i4b) :: ixTopMat ! index of upper-most total water matric potential state in the soil subdomain - integer(i4b) :: ixTopLMP ! index of upper-most liquid water matric potential state in the soil subdomain - integer(i4b),dimension(nSubset) :: ixSequence ! sequential index in model state vector - logical(lgt),dimension(nSubset) :: stateTypeMask ! mask of state vector for specific state subsets - logical(lgt),dimension(nLayers) :: volFracWat_mask ! mask of layers within the snow+soil domain - logical(lgt),dimension(nSoil) :: matricHead_mask ! mask of layers within the soil domain - character(len=256) :: cmessage ! error message of downwind routine + integer(i4b) :: iVar ! variable index + integer(i4b) :: ixVegWat ! index of total water in the vegetation canopy + integer(i4b) :: ixVegLiq ! index of liquid water in the vegetation canopy + integer(i4b) :: ixTopWat ! index of upper-most total water state in the snow-soil subdomain + integer(i4b) :: ixTopLiq ! index of upper-most liquid water state in the snow-soil subdomain + integer(i4b) :: ixTopMat ! index of upper-most total water matric potential state in the soil subdomain + integer(i4b) :: ixTopLMP ! index of upper-most liquid water matric potential state in the soil subdomain + integer(i4b),dimension(in_indexSplit % nSubset) :: ixSequence ! sequential index in model state vector + logical(lgt),dimension(in_indexSplit % nSubset) :: stateTypeMask ! mask of state vector for specific state subsets + logical(lgt),dimension(in_indexSplit % nLayers) :: volFracWat_mask ! mask of layers within the snow+soil domain + logical(lgt),dimension(in_indexSplit % nSoil) :: matricHead_mask ! mask of layers within the soil domain + character(len=256) :: cmessage ! error message of downwind routine ! ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------ ! ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------ ! make association to variables in the data structures fullState: associate(& - + ! number of snow and soil layers, total number of layers, and number of states in the subset + nSnow => in_indexSplit % nSnow ,& ! intent(in): [i4b] number of snow layers + nSoil => in_indexSplit % nSoil ,& ! intent(in): [i4b] number of soil layers + nLayers => in_indexSplit % nLayers ,& ! intent(in): [i4b] total number of layers + nSubset => in_indexSplit % nSubset ,& ! intent(in): [i4b] number of states in the subset ! indices of model state variables for the vegetation domain - ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy air space energy state variable - ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable - ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) + ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy air space energy state variable + ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable + ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) ! indices of the top model state variables in the snow+soil system - ixTopNrg => indx_data%var(iLookINDEX%ixTopNrg)%dat(1) ,& ! intent(in): [i4b] index of upper-most energy state in the snow-soil subdomain - ixTopHyd => indx_data%var(iLookINDEX%ixTopHyd)%dat(1) ,& ! intent(in): [i4b] index of upper-most hydrology state in the snow-soil subdomain + ixTopNrg => indx_data%var(iLookINDEX%ixTopNrg)%dat(1) ,& ! intent(in): [i4b] index of upper-most energy state in the snow-soil subdomain + ixTopHyd => indx_data%var(iLookINDEX%ixTopHyd)%dat(1) ,& ! intent(in): [i4b] index of upper-most hydrology state in the snow-soil subdomain ! index of the storage of water in the aquifer - ixAqWat => indx_data%var(iLookINDEX%ixAqWat)%dat(1) ,& ! intent(in): [i4b] index of the storage of water in the aquifer + ixAqWat => indx_data%var(iLookINDEX%ixAqWat)%dat(1) ,& ! intent(in): [i4b] index of the storage of water in the aquifer ! indices of model state variables - ixMapFull2Subset => indx_data%var(iLookINDEX%ixMapFull2Subset)%dat ,& ! intent(in): [i4b(:)] list of indices in the state subset (missing for values not in the subset) - ixDomainType => indx_data%var(iLookINDEX%ixDomainType)%dat ,& ! intent(in): [i4b(:)] indices defining the domain of the state (iname_veg, iname_snow, iname_soil) - ixStateType => indx_data%var(iLookINDEX%ixStateType)%dat ,& ! intent(in): [i4b(:)] indices defining the type of the state (ixNrgState...) - ixAllState => indx_data%var(iLookINDEX%ixAllState)%dat ,& ! intent(in): [i4b(:)] list of indices for all model state variables (1,2,3,...nState) - ixNrgLayer => indx_data%var(iLookINDEX%ixNrgLayer)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for energy states in the snow+soil domain - ixHydLayer => indx_data%var(iLookINDEX%ixHydLayer)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for hydrology states in the snow+soil domain - ixHydType => indx_data%var(iLookINDEX%ixHydType)%dat ,& ! intent(in): [i4b(:)] index of the type of hydrology states in snow+soil domain + ixMapFull2Subset => indx_data%var(iLookINDEX%ixMapFull2Subset)%dat ,& ! intent(in): [i4b(:)] list of indices in the state subset (missing for values not in the subset) + ixDomainType => indx_data%var(iLookINDEX%ixDomainType)%dat ,& ! intent(in): [i4b(:)] indices defining the domain of the state (iname_veg, iname_snow, iname_soil) + ixStateType => indx_data%var(iLookINDEX%ixStateType)%dat ,& ! intent(in): [i4b(:)] indices defining the type of the state (ixNrgState...) + ixAllState => indx_data%var(iLookINDEX%ixAllState)%dat ,& ! intent(in): [i4b(:)] list of indices for all model state variables (1,2,3,...nState) + ixNrgLayer => indx_data%var(iLookINDEX%ixNrgLayer)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for energy states in the snow+soil domain + ixHydLayer => indx_data%var(iLookINDEX%ixHydLayer)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for hydrology states in the snow+soil domain + ixHydType => indx_data%var(iLookINDEX%ixHydType)%dat ,& ! intent(in): [i4b(:)] index of the type of hydrology states in snow+soil domain ! indices of the entire state vector, all model layers, and soil layers - ixSoilState => indx_data%var(iLookINDEX%ixSoilState)%dat ,& ! intent(in): [i4b(:)] list of indices for all soil layers - ixLayerState => indx_data%var(iLookINDEX%ixLayerState)%dat ,& ! intent(in): [i4b(:)] list of indices for all model layers + ixSoilState => indx_data%var(iLookINDEX%ixSoilState)%dat ,& ! intent(in): [i4b(:)] list of indices for all soil layers + ixLayerState => indx_data%var(iLookINDEX%ixLayerState)%dat ,& ! intent(in): [i4b(:)] list of indices for all model layers ! vector of energy indices for the snow and soil domains ! NOTE: states not in the subset are equal to integerMissing - ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the snow+soil domain - ixSnowOnlyNrg => indx_data%var(iLookINDEX%ixSnowOnlyNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the snow domain - ixSoilOnlyNrg => indx_data%var(iLookINDEX%ixSoilOnlyNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the soil domain + ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the snow+soil domain + ixSnowOnlyNrg => indx_data%var(iLookINDEX%ixSnowOnlyNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the snow domain + ixSoilOnlyNrg => indx_data%var(iLookINDEX%ixSoilOnlyNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the soil domain ! vector of hydrology indices for the snow and soil domains ! NOTE: states not in the subset are equal to integerMissing - ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the snow+soil domain - ixSnowOnlyHyd => indx_data%var(iLookINDEX%ixSnowOnlyHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the snow domain - ixSoilOnlyHyd => indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the soil domain + ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the snow+soil domain + ixSnowOnlyHyd => indx_data%var(iLookINDEX%ixSnowOnlyHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the snow domain + ixSoilOnlyHyd => indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the soil domain ! indices of active model layers - ixLayerActive => indx_data%var(iLookINDEX%ixLayerActive)%dat ,& ! intent(in): [i4b(:)] index of active model layers (inactive=integerMissing) + ixLayerActive => indx_data%var(iLookINDEX%ixLayerActive)%dat ,& ! intent(in): [i4b(:)] index of active model layers (inactive=integerMissing) ! number of state variables of a specific type - nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg )%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow+soil domain - nSnowOnlyNrg => indx_data%var(iLookINDEX%nSnowOnlyNrg )%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow domain - nSoilOnlyNrg => indx_data%var(iLookINDEX%nSoilOnlyNrg )%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the soil domain - nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the snow+soil domain - nSnowOnlyHyd => indx_data%var(iLookINDEX%nSnowOnlyHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the snow domain - nSoilOnlyHyd => indx_data%var(iLookINDEX%nSoilOnlyHyd )%dat(1) & ! intent(in): [i4b] number of hydrology variables in the soil domain + nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg )%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow+soil domain + nSnowOnlyNrg => indx_data%var(iLookINDEX%nSnowOnlyNrg )%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow domain + nSoilOnlyNrg => indx_data%var(iLookINDEX%nSoilOnlyNrg )%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the soil domain + nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the snow+soil domain + nSnowOnlyHyd => indx_data%var(iLookINDEX%nSnowOnlyHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the snow domain + nSoilOnlyHyd => indx_data%var(iLookINDEX%nSoilOnlyHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the soil domain + ! error control + err => out_indexSplit % err ,& ! intent(out): [i4b] error code + message => out_indexSplit % cmessage & ! intent(out): [character] error message ) ! association to variables in the data structures ! ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------ @@ -381,7 +383,7 @@ subroutine indexSplit(stateSubsetMask, & ! intent(in) : logical v ! ------------------------------------------- ! get different masks - volFracWat_mask = (ixHydType==iname_watLayer .or. ixHydType==iname_liqLayer) + volFracWat_mask = (ixHydType( 1:nLayers)==iname_watLayer .or. ixHydType( 1:nLayers)==iname_liqLayer) matricHead_mask = (ixHydType(nSnow+1:nLayers)==iname_matLayer .or. ixHydType(nSnow+1:nLayers)==iname_lmpLayer) ! get state subsets for desired variables @@ -456,10 +458,10 @@ subroutine indexSplit(stateSubsetMask, & ! intent(in) : logical v ! define the mask select case(iVar) - case(iLookINDEX%ixNrgOnly); stateTypeMask = (ixStateType_subset==iname_nrgCanair .or. ixStateType_subset==iname_nrgCanopy .or. ixStateType_subset==iname_nrgLayer) ! list of indices for all energy states - case(iLookINDEX%ixHydOnly); stateTypeMask = (ixStateType_subset==iname_watLayer .or. ixStateType_subset==iname_liqLayer .or. ixStateType_subset==iname_matLayer .or. ixStateType_subset==iname_lmpLayer) ! list of indices for all hydrology states - case(iLookINDEX%ixMatOnly); stateTypeMask = (ixStateType_subset==iname_matLayer .or. ixStateType_subset==iname_lmpLayer) ! list of indices for matric head state variables - case(iLookINDEX%ixMassOnly); stateTypeMask = (ixStateType_subset==iname_watCanopy) ! list of indices for hydrology states (mass of water) + case(iLookINDEX%ixNrgOnly); stateTypeMask = (ixStateType_subset==iname_nrgCanair .or. ixStateType_subset==iname_nrgCanopy .or. ixStateType_subset==iname_nrgLayer) ! list of indices for all energy states + case(iLookINDEX%ixHydOnly); stateTypeMask = (ixStateType_subset==iname_watLayer .or. ixStateType_subset==iname_liqLayer .or. ixStateType_subset==iname_matLayer .or. ixStateType_subset==iname_lmpLayer) ! list of indices for all hydrology states + case(iLookINDEX%ixMatOnly); stateTypeMask = (ixStateType_subset==iname_matLayer .or. ixStateType_subset==iname_lmpLayer) ! list of indices for matric head state variables + case(iLookINDEX%ixMassOnly); stateTypeMask = (ixStateType_subset==iname_watCanopy) ! list of indices for hydrology states (mass of water) case default; cycle ! only need to process the above variables end select ! iVar @@ -512,16 +514,16 @@ end subroutine indexSplit subroutine indxSubset(ixSubset,ixMaster,mask,err,message) implicit none ! input-output: subset of indices for allocation/population - integer(i4b),intent(inout),allocatable :: ixSubset(:) ! subset of indices + integer(i4b),intent(inout),allocatable :: ixSubset(:) ! subset of indices ! input - integer(i4b),intent(in) :: ixMaster(:) ! full list of indices - logical(lgt),intent(in) :: mask(:) ! desired indices + integer(i4b),intent(in) :: ixMaster(:) ! full list of indices + logical(lgt),intent(in) :: mask(:) ! desired indices ! error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------------------------------------- ! local variables - integer(i4b) :: nSubset ! length of the subset + integer(i4b) :: nSubset ! length of the subset ! ----------------------------------------------------------------------------------------------------------------------------------- ! initialize errors err=0; message="indxSubset/" @@ -556,9 +558,6 @@ subroutine indxSubset(ixSubset,ixMaster,mask,err,message) end subroutine indxSubset - - - ! ********************************************************************************************************** ! private subroutine resizeIndx: re-size specific index vectors ! ********************************************************************************************************** diff --git a/build/source/engine/layerDivide.f90 b/build/source/engine/layerDivide.f90 old mode 100755 new mode 100644 index 11a24d712..3e69d5f73 --- a/build/source/engine/layerDivide.f90 +++ b/build/source/engine/layerDivide.f90 @@ -34,16 +34,16 @@ module layerDivide_module ! access missing values USE globalData,only:integerMissing ! missing integer -USE globalData,only:realMissing ! missing double precision number +USE globalData,only:realMissing ! missing real number ! access metadata USE globalData,only:prog_meta,diag_meta,flux_meta,indx_meta ! metadata ! access the derived types to define the data structures USE data_types,only:& - var_d, & ! data vector (dp) + var_d, & ! data vector (rkind) var_ilength, & ! data vector with variable length dimension (i4b) - var_dlength, & ! data vector with variable length dimension (dp) + var_dlength, & ! data vector with variable length dimension (rkind) model_options ! defines the model decisions ! access named variables defining elements in the data structures @@ -76,7 +76,8 @@ module layerDivide_module contains - ! *********************************************************************************************************** + + ! *********************************************************************************************************** ! public subroutine layerDivide: add new snowfall to the system, and increase number of snow layers if needed ! *********************************************************************************************************** subroutine layerDivide(& @@ -131,7 +132,7 @@ subroutine layerDivide(& real(rkind) :: fracLiq ! fraction of liquid water (-) integer(i4b),parameter :: ixVisible=1 ! named variable to define index in array of visible part of the spectrum integer(i4b),parameter :: ixNearIR=2 ! named variable to define index in array of near IR part of the spectrum - real(rkind),parameter :: verySmall=1.e-10_rkind ! a very small number (used for error checking) + real(rkind),parameter :: snowDepthTol=1.e-10_rkind ! tolerance for the snow depth difference (m) ! -------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message="layerDivide/" @@ -184,7 +185,7 @@ subroutine layerDivide(& ! check if create the first snow layer select case(ix_snowLayers) case(sameRulesAllLayers); createLayer = (scalarSnowDepth > zmax) - case(rulesDependLayerIndex); createLayer = (scalarSnowDepth > (zminLayer1 + zmaxLayer1_lower)/2._rkind) ! Initialize the first layer if we're halfway between the minimum and maximum depth for this layer. This gives some room for the layer to change depth in either direction and avoids excessive layer creation/deletion + case(rulesDependLayerIndex); createLayer = (scalarSnowDepth > zmaxLayer1_lower) case default; err=20; message=trim(message)//'unable to identify option to combine/sub-divide snow layers'; return end select ! (option to combine/sub-divide snow layers) @@ -221,12 +222,12 @@ subroutine layerDivide(& mLayerTemp(1) = min(maxFrozenSnowTemp,surfaceLayerSoilTemp) ! snow temperature (K) ! compute the fraction of liquid water associated with the layer temperature - fracLiq = fracliquid(mLayerTemp(1),fc_param) + fracLiq = fracliquid(mLayerTemp(1),fc_param) ! compute volumeteric fraction of liquid water and ice volFracWater = (scalarSWE/scalarSnowDepth)/iden_water ! volumetric fraction of total water (liquid and ice) mLayerVolFracIce(1) = (1._rkind - fracLiq)*volFracWater*(iden_water/iden_ice) ! volumetric fraction of ice (-) - mLayerVolFracLiq(1) = fracLiq *volFracWater ! volumetric fraction of liquid water (-) + mLayerVolFracLiq(1) = fracLiq *volFracWater ! volumetric fraction of liquid water (-) ! end association with local variables to the information in the data structures) end associate @@ -330,8 +331,8 @@ subroutine layerDivide(& layerType(nSnow+2:nLayers+1) = iname_soil ! identify the number of snow and soil layers, and check all is a-OK - nSnow = count(layerType==iname_snow) - nSoil = count(layerType==iname_soil) + nSnow = count(layerType(1:nLayers+1)==iname_snow) + nSoil = count(layerType(1:nLayers+1)==iname_soil) nLayers = nSnow + nSoil ! re-set coordinate variables @@ -342,11 +343,11 @@ subroutine layerDivide(& end do ! check - if(abs(sum(mLayerDepth(1:nSnow)) - scalarSnowDepth) > verySmall)then + if(abs(sum(mLayerDepth(1:nSnow)) - scalarSnowDepth) > snowDepthTol)then print*, 'nSnow = ', nSnow write(*,'(a,1x,f30.25,1x)') 'sum(mLayerDepth(1:nSnow)) = ', sum(mLayerDepth(1:nSnow)) write(*,'(a,1x,f30.25,1x)') 'scalarSnowDepth = ', scalarSnowDepth - write(*,'(a,1x,f30.25,1x)') 'epsilon(scalarSnowDepth) = ', epsilon(scalarSnowDepth) + write(*,'(a,1x,f30.25,1x)') 'snowDepthTol = ', snowDepthTol message=trim(message)//'sum of layer depths does not equal snow depth' err=20; return end if @@ -362,6 +363,7 @@ subroutine layerDivide(& end subroutine layerDivide + ! ************************************************************************************************ ! private subroutine addModelLayer: add an additional layer to all model vectors ! ************************************************************************************************ @@ -432,8 +434,8 @@ subroutine addModelLayer(dataStruct,metaStruct,ix_divide,nSnow,nLayers,err,messa if(stateVariable)then if(ix_upper > 0)then ! (only copy data if the vector exists -- can be a variable for snow, with no layers) if(ix_divide > 0)then - dataStruct%var(ivar)%dat(1:ix_divide) = tempVec_rkind(1:ix_divide) ! copy data - dataStruct%var(ivar)%dat(ix_divide+1) = tempVec_rkind(ix_divide) ! repeat data for the sub-divided layer + dataStruct%var(ivar)%dat(1:ix_divide) = tempVec_rkind(1:ix_divide) ! copy data + dataStruct%var(ivar)%dat(ix_divide+1) = tempVec_rkind(ix_divide) ! repeat data for the sub-divided layer end if if(ix_upper > ix_divide) & dataStruct%var(ivar)%dat(ix_divide+2:ix_upper+1) = tempVec_rkind(ix_divide+1:ix_upper) ! copy data @@ -462,8 +464,8 @@ subroutine addModelLayer(dataStruct,metaStruct,ix_divide,nSnow,nLayers,err,messa if(stateVariable)then if(ix_upper > 0)then ! (only copy data if the vector exists -- can be a variable for snow, with no layers) if(ix_divide > 0)then - dataStruct%var(ivar)%dat(1:ix_divide) = tempVec_i4b(1:ix_divide) ! copy data - dataStruct%var(ivar)%dat(ix_divide+1) = tempVec_i4b(ix_divide) ! repeat data for the sub-divided layer + dataStruct%var(ivar)%dat(1:ix_divide) = tempVec_i4b(1:ix_divide) ! copy data + dataStruct%var(ivar)%dat(ix_divide+1) = tempVec_i4b(ix_divide) ! repeat data for the sub-divided layer end if if(ix_upper > ix_divide) & dataStruct%var(ivar)%dat(ix_divide+2:ix_upper+1) = tempVec_i4b(ix_divide+1:ix_upper) ! copy data diff --git a/build/source/engine/layerMerge.f90 b/build/source/engine/layerMerge.f90 old mode 100755 new mode 100644 index 085b970b9..ef9cd0961 --- a/build/source/engine/layerMerge.f90 +++ b/build/source/engine/layerMerge.f90 @@ -25,7 +25,7 @@ module layerMerge_module ! access missing values USE globalData,only:integerMissing ! missing integer -USE globalData,only:realMissing ! missing double precision number +USE globalData,only:realMissing ! missing real number ! access named variables for snow and soil USE globalData,only:iname_snow ! named variables for snow @@ -41,9 +41,9 @@ module layerMerge_module ! access the derived types to define the data structures USE data_types,only:& - var_d, & ! data vector (dp) + var_d, & ! data vector (rkind) var_ilength, & ! data vector with variable length dimension (i4b) - var_dlength, & ! data vector with variable length dimension (dp) + var_dlength, & ! data vector with variable length dimension (rkind) model_options ! defines the model decisions ! access named variables defining elements in the data structures @@ -133,7 +133,7 @@ subroutine layerMerge(& ) ! end associate statement ! -------------------------------------------------------------------------------------------------------- - ! identify algorithmic control parameters to syb-divide and combine snow layers + ! identify algorithmic control parameters to sub-divide and combine snow layers zminLayer = (/zminLayer1, zminLayer2, zminLayer3, zminLayer4, zminLayer5/) ! intialize the modified layers flag @@ -248,8 +248,6 @@ subroutine layerMerge(& end do ! (looping through snow layers) - !print*, 'ksnow = ', ksnow - ! exit if finished if(kSnow==nCheck)exit @@ -293,13 +291,13 @@ end subroutine layerMerge ! *********************************************************************************************************** subroutine layer_combine(mpar_data,prog_data,diag_data,flux_data,indx_data,iSnow,err,message) ! provide access to variables in the data structures - USE var_lookup,only:iLookPARAM,iLookPROG,iLookINDEX ! named variables for structure elements - USE globalData,only:prog_meta,diag_meta,flux_meta,indx_meta ! metadata - USE data_types,only:var_ilength,var_dlength ! data vectors with variable length dimension - USE data_types,only:var_d ! data structures with fixed dimension + USE var_lookup,only:iLookPARAM,iLookPROG,iLookINDEX ! named variables for structure elements + USE globalData,only:prog_meta,diag_meta,flux_meta,indx_meta ! metadata + USE data_types,only:var_ilength,var_dlength ! data vectors with variable length dimension + USE data_types,only:var_d ! data structures with fixed dimension ! provide access to external modules - USE snow_utils_module,only:fracliquid ! compute fraction of liquid water - USE convE2Temp_module,only:E2T_nosoil,temp2ethpy ! convert temperature to enthalpy + USE snow_utils_module,only:fracliquid ! compute fraction of liquid water + USE enthalpyTemp_module,only:enthalpy2T_snwWat,T2enthalpy_snwWat ! convert temperature to liq+ice enthalpy for a snow layer implicit none ! ------------------------------------------------------------------------------------------------------------ ! input/output: data structures @@ -316,18 +314,18 @@ subroutine layer_combine(mpar_data,prog_data,diag_data,flux_data,indx_data,iSnow ! ------------------------------------------------------------------------------------------------------------ ! local variables character(len=256) :: cmessage ! error message for downwind routine - real(rkind) :: massIce(2) ! mass of ice in the two layers identified for combination (kg m-2) - real(rkind) :: massLiq(2) ! mass of liquid water in the two layers identified for combination (kg m-2) - real(rkind) :: bulkDenWat(2) ! bulk density if total water (liquid water plus ice) in the two layers identified for combination (kg m-3) - real(rkind) :: cBulkDenWat ! combined bulk density of total water (liquid water plus ice) in the two layers identified for combination (kg m-3) - real(rkind) :: cTemp ! combined layer temperature - real(rkind) :: cDepth ! combined layer depth - real(rkind) :: cVolFracIce ! combined layer volumetric fraction of ice - real(rkind) :: cVolFracLiq ! combined layer volumetric fraction of liquid water - real(rkind) :: l1Enthalpy,l2Enthalpy ! enthalpy in the two layers identified for combination (J m-3) - real(rkind) :: cEnthalpy ! combined layer enthalpy (J m-3) - real(rkind) :: fLiq ! fraction of liquid water at the combined temperature cTemp - real(rkind),parameter :: eTol=1.e-1_rkind ! tolerance for the enthalpy-->temperature conversion (J m-3) + real(rkind) :: massIce(2) ! mass of ice in the two layers identified for combination (kg m-2) + real(rkind) :: massLiq(2) ! mass of liquid water in the two layers identified for combination (kg m-2) + real(rkind) :: bulkDenWat(2) ! bulk density if total water (liquid water plus ice) in the two layers identified for combination (kg m-3) + real(rkind) :: cBulkDenWat ! combined bulk density of total water (liquid water plus ice) in the two layers identified for combination (kg m-3) + real(rkind) :: cTemp ! combined layer temperature + real(rkind) :: cDepth ! combined layer depth + real(rkind) :: cVolFracIce ! combined layer volumetric fraction of ice + real(rkind) :: cVolFracLiq ! combined layer volumetric fraction of liquid water + real(rkind) :: l1Enthalpy,l2Enthalpy ! enthalpy in the two layers identified for combination (J m-3) + real(rkind) :: cEnthalpy ! combined layer enthalpy (J m-3) + real(rkind) :: fLiq ! fraction of liquid water at the combined temperature cTemp + real(rkind),parameter :: eTol=1.e-1_rkind ! tolerance for the enthalpy-->temperature conversion (J m-3) integer(i4b) :: nSnow ! number of snow layers integer(i4b) :: nSoil ! number of soil layers integer(i4b) :: nLayers ! total number of layers @@ -363,19 +361,19 @@ subroutine layer_combine(mpar_data,prog_data,diag_data,flux_data,indx_data,iSnow cBulkDenWat = (mLayerDepth(isnow)*bulkDenWat(1) + mLayerDepth(isnow+1)*bulkDenWat(2))/cDepth ! compute enthalpy for each layer (J m-3) - l1Enthalpy = temp2ethpy(mLayerTemp(iSnow), BulkDenWat(1),snowfrz_scale) - l2Enthalpy = temp2ethpy(mLayerTemp(iSnow+1),BulkDenWat(2),snowfrz_scale) + l1Enthalpy = T2enthalpy_snwWat(mLayerTemp(iSnow), BulkDenWat(1),snowfrz_scale) + l2Enthalpy = T2enthalpy_snwWat(mLayerTemp(iSnow+1),BulkDenWat(2),snowfrz_scale) ! compute combined enthalpy (J m-3) - cEnthalpy = (mLayerDepth(isnow)*l1Enthalpy + mLayerDepth(isnow+1)*l2Enthalpy)/cDepth + cEnthalpy = (mLayerDepth(isnow)*l1Enthalpy + mLayerDepth(isnow+1)*l2Enthalpy)/cDepth ! convert enthalpy (J m-3) to temperature (K) - call E2T_nosoil(cEnthalpy,cBulkDenWat,snowfrz_scale,cTemp,err,cmessage) + call enthalpy2T_snwWat(cEnthalpy,cBulkDenWat,snowfrz_scale,cTemp,err,cmessage) if(err/=0)then; err=10; message=trim(message)//trim(cmessage); return; end if ! test enthalpy conversion - if(abs(temp2ethpy(cTemp,cBulkDenWat,snowfrz_scale)/cBulkDenWat - cEnthalpy/cBulkDenWat) > eTol)then - write(*,'(a,1x,f12.5,1x,2(e20.10,1x))') 'enthalpy test', cBulkDenWat, temp2ethpy(cTemp,cBulkDenWat,snowfrz_scale)/cBulkDenWat, cEnthalpy/cBulkDenWat + if(abs(T2enthalpy_snwWat(cTemp,cBulkDenWat,snowfrz_scale)/cBulkDenWat - cEnthalpy/cBulkDenWat) > eTol)then + write(*,'(a,1x,f12.5,1x,2(e20.10,1x))') 'enthalpy test', cBulkDenWat, T2enthalpy_snwWat(cTemp,cBulkDenWat,snowfrz_scale)/cBulkDenWat, cEnthalpy/cBulkDenWat message=trim(message)//'problem with enthalpy-->temperature conversion' err=20; return end if diff --git a/build/source/engine/mDecisions.f90 b/build/source/engine/mDecisions.f90 old mode 100755 new mode 100644 index b658d7c0d..7bc1ab221 --- a/build/source/engine/mDecisions.f90 +++ b/build/source/engine/mDecisions.f90 @@ -57,8 +57,9 @@ module mDecisions_module integer(i4b),parameter,public :: constantScaling = 71 ! constant scaling factor integer(i4b),parameter,public :: laiScaling = 72 ! exponential function of LAI (Leuning, Plant Cell Env 1995: "Scaling from..." [eq 9]) ! look-up values for the choice of numerical method -integer(i4b),parameter,public :: bEuler = 81 ! home-grown backward Euler solution with long time steps -integer(i4b),parameter,public :: sundials = 82 ! SUNDIALS/IDA solution +integer(i4b),parameter,public :: homegrown = 81 ! homegrown backward Euler solution using concepts from numerical recipes +integer(i4b),parameter,public :: kinsol = 82 ! SUNDIALS backward Euler solution using Kinsol +integer(i4b),parameter,public :: ida = 83 ! SUNDIALS solution using IDA ! look-up values for method used to compute derivative integer(i4b),parameter,public :: numerical = 91 ! numerical solution integer(i4b),parameter,public :: analytical = 92 ! analytical solution @@ -122,7 +123,7 @@ module mDecisions_module integer(i4b),parameter,public :: andersonEmpirical = 252 ! semi-empirical method of Anderson (1976) ! look-up values for the choice of method to combine and sub-divide snow layers integer(i4b),parameter,public :: sameRulesAllLayers = 261 ! same combination/sub-division rules applied to all layers -integer(i4b),parameter,public :: rulesDependLayerIndex= 262 ! combination/sub-dividion rules depend on layer index +integer(i4b),parameter,public :: rulesDependLayerIndex= 262 ! combination/sub-division rules depend on layer index ! look-up values for the choice of thermal conductivity representation for snow integer(i4b),parameter,public :: Yen1965 = 271 ! Yen (1965) integer(i4b),parameter,public :: Mellor1977 = 272 ! Mellor (1977) @@ -146,605 +147,667 @@ module mDecisions_module ! look-up values for the choice of snow unloading from the canopy integer(i4b),parameter,public :: meltDripUnload = 321 ! Hedstrom and Pomeroy (1998), Storck et al 2002 (snowUnloadingCoeff & ratioDrip2Unloading) integer(i4b),parameter,public :: windUnload = 322 ! Roesch et al 2001, formulate unloading based on wind and temperature -! ----------------------------------------------------------------------------------------------------------- +! look-up values for the choice of variable in energy equations (BE residual or IDA state variable) +integer(i4b),parameter,public :: closedForm = 323 ! use temperature with closed form heat capacity +integer(i4b),parameter,public :: enthalpyFormLU = 324 ! use enthalpy with soil temperature-enthalpy lookup tables +integer(i4b),parameter,public :: enthalpyForm = 325 ! use enthalpy with soil temperature-enthalpy analytical solution +! look-up values for the choice of choice of full or empty aquifer at start +integer(i4b),parameter,public :: fullStart = 326 ! full aquifer at start +integer(i4b),parameter,public :: emptyStart = 327 ! empty aquifer at start +! look-up values for the infiltration method +integer(i4b),parameter,public :: GreenAmpt = 331 ! Green-Ampt +integer(i4b),parameter,public :: topmodel_GA = 332 ! Green-Ampt-ish for use with qbaseTopmodel hydraulic conductivity +integer(i4b),parameter,public :: noInfiltrationExcess = 333 ! No infiltration excess runoff +! look-up values for the saturation excess surface runoff method +integer(i4b),parameter,public :: zero_SE = 351 ! zero saturation excess surface runoff +integer(i4b),parameter,public :: homegrown_SE = 352 ! homegrown saturation excess surface runoff +integer(i4b),parameter,public :: FUSEPRMS = 353 ! FUSE PRMS surface runoff +integer(i4b),parameter,public :: FUSEAVIC = 354 ! FUSE ARNO/VIC surface runoff +integer(i4b),parameter,public :: FUSETOPM = 355 ! FUSE TOPMODEL surface runoff + +! ----------------------------------------------------------------------------------------------------------- contains - - ! ************************************************************************************************ - ! public subroutine mDecisions: save model decisions as named integers - ! ************************************************************************************************ - subroutine mDecisions(err,message) - ! model time structures - USE multiconst,only:secprday ! number of seconds in a day - USE var_lookup,only:iLookTIME ! named variables that identify indices in the time structures - USE globalData,only:refTime,refJulday ! reference time - USE globalData,only:oldTime ! time from the previous time step - USE globalData,only:startTime,finshTime ! start/end time of simulation - USE globalData,only:dJulianStart ! julian day of start time of simulation - USE globalData,only:dJulianFinsh ! julian day of end time of simulation - USE globalData,only:data_step ! length of data step (s) - USE globalData,only:numtim ! number of time steps in the simulation - ! model decision structures - USE globaldata,only:model_decisions ! model decision structure - USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure - ! forcing metadata - USE globalData,only:forc_meta ! metadata structures - USE var_lookup,only:iLookFORCE ! named variables to define structure elements - ! Noah-MP decision structures - USE noahmp_globals,only:DVEG ! decision for dynamic vegetation - USE noahmp_globals,only:OPT_RAD ! decision for canopy radiation - USE noahmp_globals,only:OPT_ALB ! decision for snow albedo - ! time utility programs - USE time_utils_module,only:extractTime ! extract time info from units string - USE time_utils_module,only:compjulday ! compute the julian day - USE time_utils_module,only:fracDay ! compute fractional day - USE summaFileManager,only: SIM_START_TM, SIM_END_TM ! time info from control file module - - implicit none - ! define output - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! define local variables - character(len=256) :: cmessage ! error message for downwind routine - real(rkind) :: dsec,dsec_tz ! second - ! initialize error control - err=0; message='mDecisions/' - - ! ------------------------------------------------------------------------------------------------- - ! ------------------------------------------------------------------------------------------------- - - ! read information from model decisions file, and populate model decisions structure - call readoption(err,cmessage) - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if - - ! ------------------------------------------------------------------------------------------------- - - ! put reference time information into the time structures - call extractTime(forc_meta(iLookFORCE%time)%varunit, & ! date-time string - refTime%var(iLookTIME%iyyy), & ! year - refTime%var(iLookTIME%im), & ! month - refTime%var(iLookTIME%id), & ! day - refTime%var(iLookTIME%ih), & ! hour - refTime%var(iLookTIME%imin), & ! minute - dsec, & ! second - refTime%var(iLookTIME%ih_tz), & ! time zone hour - refTime%var(iLookTIME%imin_tz), & ! time zone minute - dsec_tz, & ! time zone seconds - err,cmessage) ! error control - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if - - ! compute the julian date (fraction of day) for the reference time - call compjulday(& - refTime%var(iLookTIME%iyyy), & ! year - refTime%var(iLookTIME%im), & ! month - refTime%var(iLookTIME%id), & ! day - refTime%var(iLookTIME%ih), & ! hour - refTime%var(iLookTIME%imin), & ! minute - 0._rkind, & ! second - refJulday, & ! julian date for the start of the simulation - err, cmessage) ! error control - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if - - ! put simulation start time information into the time structures - call extractTime(trim(SIM_START_TM), & ! date-time string - startTime%var(iLookTIME%iyyy), & ! year - startTime%var(iLookTIME%im), & ! month - startTime%var(iLookTIME%id), & ! day - startTime%var(iLookTIME%ih), & ! hour - startTime%var(iLookTIME%imin), & ! minute - dsec, & ! second - startTime%var(iLookTIME%ih_tz), & ! time zone hour - startTime%var(iLookTIME%imin_tz), & ! time zone minnute - dsec_tz, & ! time zone seconds - err,cmessage) ! error control - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if - - ! compute the julian date (fraction of day) for the start of the simulation - call compjulday(& - startTime%var(iLookTIME%iyyy), & ! year - startTime%var(iLookTIME%im), & ! month - startTime%var(iLookTIME%id), & ! day - startTime%var(iLookTIME%ih), & ! hour - startTime%var(iLookTIME%imin), & ! minute - 0._rkind, & ! second - dJulianStart, & ! julian date for the start of the simulation - err, cmessage) ! error control - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if - - ! put simulation end time information into the time structures - call extractTime(trim(SIM_END_TM), & ! date-time string + +! ************************************************************************************************ +! public subroutine mDecisions: save model decisions as named integers +! ************************************************************************************************ +subroutine mDecisions(err,message) + ! model time structures + USE multiconst,only:secprday ! number of seconds in a day + USE var_lookup,only:iLookTIME ! named variables that identify indices in the time structures + USE globalData,only:refTime,refJulDay ! reference time + USE globalData,only:oldTime ! time from the previous time step + USE globalData,only:startTime,finshTime ! start/end time of simulation + USE globalData,only:dJulianStart ! julian day of start time of simulation + USE globalData,only:dJulianFinsh ! julian day of end time of simulation + USE globalData,only:data_step ! length of data step (s) + USE globalData,only:numtim ! number of time steps in the simulation + ! model decision structures + USE globalData,only:model_decisions ! model decision structure + USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure + ! forcing metadata + USE globalData,only:forc_meta ! metadata structures + USE var_lookup,only:iLookFORCE ! named variables to define structure elements + ! Noah-MP decision structures + USE noahmp_globals,only:DVEG ! decision for dynamic vegetation + USE noahmp_globals,only:OPT_RAD ! decision for canopy radiation + USE noahmp_globals,only:OPT_ALB ! decision for snow albedo + ! time utility programs + USE time_utils_module,only:extractTime ! extract time info from units string + USE time_utils_module,only:compjulday ! compute the julian day + USE time_utils_module,only:fracDay ! compute fractional day + USE summaFileManager,only: SIM_START_TM, SIM_END_TM ! time info from control file module + + implicit none + ! define output + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + + ! define local variables + character(len=256) :: cmessage ! error message for downwind routine + real(rkind) :: dsec,dsec_tz ! second + ! initialize error control + err=0; message='mDecisions/' + + ! read information from model decisions file, and populate model decisions structure + call readoption(err,cmessage) + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if + + + ! put reference time information into the time structures + call extractTime(forc_meta(iLookFORCE%time)%varunit, & ! date-time string + refTime%var(iLookTIME%iyyy), & ! year + refTime%var(iLookTIME%im), & ! month + refTime%var(iLookTIME%id), & ! day + refTime%var(iLookTIME%ih), & ! hour + refTime%var(iLookTIME%imin), & ! minute + dsec, & ! second + refTime%var(iLookTIME%ih_tz), & ! time zone hour + refTime%var(iLookTIME%imin_tz), & ! time zone minute + dsec_tz, & ! time zone seconds + err,cmessage) ! error control + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if + + ! compute the julian date (fraction of day) for the reference time + call compjulday(& + refTime%var(iLookTIME%iyyy), & ! year + refTime%var(iLookTIME%im), & ! month + refTime%var(iLookTIME%id), & ! day + refTime%var(iLookTIME%ih), & ! hour + refTime%var(iLookTIME%imin), & ! minute + 0._rkind, & ! second + refJulDay, & ! julian date for the start of the simulation + err, cmessage) ! error control + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if + + ! put simulation start time information into the time structures + call extractTime(trim(SIM_START_TM), & ! date-time string + startTime%var(iLookTIME%iyyy), & ! year + startTime%var(iLookTIME%im), & ! month + startTime%var(iLookTIME%id), & ! day + startTime%var(iLookTIME%ih), & ! hour + startTime%var(iLookTIME%imin), & ! minute + dsec, & ! second + startTime%var(iLookTIME%ih_tz), & ! time zone hour + startTime%var(iLookTIME%imin_tz), & ! time zone minnute + dsec_tz, & ! time zone seconds + err,cmessage) ! error control + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if + + ! compute the julian date (fraction of day) for the start of the simulation + call compjulday(& + startTime%var(iLookTIME%iyyy), & ! year + startTime%var(iLookTIME%im), & ! month + startTime%var(iLookTIME%id), & ! day + startTime%var(iLookTIME%ih), & ! hour + startTime%var(iLookTIME%imin), & ! minute + 0._rkind, & ! second + dJulianStart, & ! julian date for the start of the simulation + err, cmessage) ! error control + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if + + ! put simulation end time information into the time structures + call extractTime(trim(SIM_END_TM), & ! date-time string + finshTime%var(iLookTIME%iyyy), & ! year + finshTime%var(iLookTIME%im), & ! month + finshTime%var(iLookTIME%id), & ! day + finshTime%var(iLookTIME%ih), & ! hour + finshTime%var(iLookTIME%imin), & ! minute + dsec, & ! second + finshTime%var(iLookTIME%ih_tz), & ! time zone hour + finshTime%var(iLookTIME%imin_tz), & ! time zone minnute + dsec_tz, & ! time zone seconds + err,cmessage) ! error control + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if + + ! compute the julian date (fraction of day) for the end of the simulation + call compjulday(& finshTime%var(iLookTIME%iyyy), & ! year finshTime%var(iLookTIME%im), & ! month finshTime%var(iLookTIME%id), & ! day finshTime%var(iLookTIME%ih), & ! hour finshTime%var(iLookTIME%imin), & ! minute - dsec, & ! second - finshTime%var(iLookTIME%ih_tz), & ! time zone hour - finshTime%var(iLookTIME%imin_tz), & ! time zone minnute - dsec_tz, & ! time zone seconds - err,cmessage) ! error control - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if - - ! compute the julian date (fraction of day) for the end of the simulation - call compjulday(& - finshTime%var(iLookTIME%iyyy), & ! year - finshTime%var(iLookTIME%im), & ! month - finshTime%var(iLookTIME%id), & ! day - finshTime%var(iLookTIME%ih), & ! hour - finshTime%var(iLookTIME%imin), & ! minute - 0._rkind, & ! second - dJulianFinsh, & ! julian date for the end of the simulation - err, cmessage) ! error control - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if - - ! check start and finish time - write(*,'(a,i4,1x,4(i2,1x))') 'startTime: iyyy, im, id, ih, imin = ', startTime%var(1:5) - write(*,'(a,i4,1x,4(i2,1x))') 'finshTime: iyyy, im, id, ih, imin = ', finshTime%var(1:5) - - ! check that simulation end time is > start time - if(dJulianFinsh < dJulianStart)then; err=20; message=trim(message)//'end time of simulation occurs before start time'; return; end if - - ! initialize the old time vector (time from the previous time step) - oldTime%var(:) = startTime%var(:) - - ! compute the number of time steps - numtim = nint( (dJulianFinsh - dJulianStart)*secprday/data_step ) + 1 - write(*,'(a,1x,i10)') 'number of time steps = ', numtim - - ! ------------------------------------------------------------------------------------------------- - - ! set Noah-MP options - DVEG=3 ! option for dynamic vegetation - OPT_RAD=3 ! option for canopy radiation - OPT_ALB=2 ! option for snow albedo - - ! set zero option for thee category tables - ! NOTE: we want to keep track of these decisions, but not used in the physics routines - model_decisions(iLookDECISIONS%soilCatTbl)%iDecision = 0 - model_decisions(iLookDECISIONS%vegeParTbl)%iDecision = 0 - - ! identify the choice of function for the soil moisture control on stomatal resistance - select case(trim(model_decisions(iLookDECISIONS%soilStress)%cDecision)) - case('NoahType'); model_decisions(iLookDECISIONS%soilStress)%iDecision = NoahType ! thresholded linear function of volumetric liquid water content - case('CLM_Type'); model_decisions(iLookDECISIONS%soilStress)%iDecision = CLM_Type ! thresholded linear function of matric head - case('SiB_Type'); model_decisions(iLookDECISIONS%soilStress)%iDecision = SiB_Type ! exponential of the log of matric head - case default - err=10; message=trim(message)//"unknown soil moisture function [option="//trim(model_decisions(iLookDECISIONS%soilStress)%cDecision)//"]"; return - end select - - ! identify the choice of function for stomatal resistance - select case(trim(model_decisions(iLookDECISIONS%stomResist)%cDecision)) - case('BallBerry' ); model_decisions(iLookDECISIONS%stomResist)%iDecision = BallBerry ! Ball-Berry - case('Jarvis' ); model_decisions(iLookDECISIONS%stomResist)%iDecision = Jarvis ! Jarvis - case('simpleResistance' ); model_decisions(iLookDECISIONS%stomResist)%iDecision = simpleResistance ! simple resistance formulation - case('BallBerryFlex' ); model_decisions(iLookDECISIONS%stomResist)%iDecision = BallBerryFlex ! flexible Ball-Berry scheme - case('BallBerryTest' ); model_decisions(iLookDECISIONS%stomResist)%iDecision = BallBerryTest ! flexible Ball-Berry scheme (testing) - case default - err=10; message=trim(message)//"unknown stomatal resistance function [option="//trim(model_decisions(iLookDECISIONS%stomResist)%cDecision)//"]"; return - end select - - ! identify the leaf temperature controls on photosynthesis + stomatal resistance - if(model_decisions(iLookDECISIONS%stomResist)%iDecision >= BallBerryFlex)then - select case(trim(model_decisions(iLookDECISIONS%bbTempFunc)%cDecision)) - case('q10Func' ); model_decisions(iLookDECISIONS%bbTempFunc)%iDecision = q10Func - case('Arrhenius' ); model_decisions(iLookDECISIONS%bbTempFunc)%iDecision = Arrhenius - case default - err=10; message=trim(message)//"unknown leaf temperature function [option="//trim(model_decisions(iLookDECISIONS%bbTempFunc)%cDecision)//"]"; return - end select - end if - - ! identify the humidity controls on stomatal resistance - if(model_decisions(iLookDECISIONS%stomResist)%iDecision >= BallBerryFlex)then - select case(trim(model_decisions(iLookDECISIONS%bbHumdFunc)%cDecision)) - case('humidLeafSurface' ); model_decisions(iLookDECISIONS%bbHumdFunc)%iDecision = humidLeafSurface - case('scaledHyperbolic' ); model_decisions(iLookDECISIONS%bbHumdFunc)%iDecision = scaledHyperbolic - case default - err=10; message=trim(message)//"unknown humidity function [option="//trim(model_decisions(iLookDECISIONS%bbHumdFunc)%cDecision)//"]"; return - end select - end if - - ! identify functions for electron transport function (dependence of photosynthesis on PAR) - if(model_decisions(iLookDECISIONS%stomResist)%iDecision >= BallBerryFlex)then - select case(trim(model_decisions(iLookDECISIONS%bbElecFunc)%cDecision)) - case('linear' ); model_decisions(iLookDECISIONS%bbElecFunc)%iDecision = linear - case('linearJmax' ); model_decisions(iLookDECISIONS%bbElecFunc)%iDecision = linearJmax - case('quadraticJmax' ); model_decisions(iLookDECISIONS%bbElecFunc)%iDecision = quadraticJmax - case default - err=10; message=trim(message)//"unknown electron transport function [option="//trim(model_decisions(iLookDECISIONS%bbElecFunc)%cDecision)//"]"; return - end select - end if - - ! identify the use of the co2 compensation point in the stomatal conductance calaculations - if(model_decisions(iLookDECISIONS%stomResist)%iDecision >= BallBerryFlex)then - select case(trim(model_decisions(iLookDECISIONS%bbCO2point)%cDecision)) - case('origBWB' ); model_decisions(iLookDECISIONS%bbCO2point)%iDecision = origBWB - case('Leuning' ); model_decisions(iLookDECISIONS%bbCO2point)%iDecision = Leuning - case default - err=10; message=trim(message)//"unknown option for the co2 compensation point [option="//trim(model_decisions(iLookDECISIONS%bbCO2point)%cDecision)//"]"; return - end select - end if - - ! identify the iterative numerical solution method used in the Ball-Berry stomatal resistance parameterization - if(model_decisions(iLookDECISIONS%stomResist)%iDecision >= BallBerryFlex)then - select case(trim(model_decisions(iLookDECISIONS%bbNumerics)%cDecision)) - case('NoahMPsolution' ); model_decisions(iLookDECISIONS%bbNumerics)%iDecision = NoahMPsolution ! the NoahMP solution (and CLM4): fixed point iteration; max 3 iterations - case('newtonRaphson' ); model_decisions(iLookDECISIONS%bbNumerics)%iDecision = newtonRaphson ! full Newton-Raphson iterative solution to convergence - case default - err=10; message=trim(message)//"unknown option for the Ball-Berry numerical solution [option="//trim(model_decisions(iLookDECISIONS%bbNumerics)%cDecision)//"]"; return - end select - end if - - ! identify the controls on carbon assimilation - if(model_decisions(iLookDECISIONS%stomResist)%iDecision >= BallBerryFlex)then - select case(trim(model_decisions(iLookDECISIONS%bbAssimFnc)%cDecision)) - case('colimitation' ); model_decisions(iLookDECISIONS%bbAssimFnc)%iDecision = colimitation ! enable colimitation, as described by Collatz et al. (1991) and Sellers et al. (1996) - case('minFunc' ); model_decisions(iLookDECISIONS%bbAssimFnc)%iDecision = minFunc ! do not enable colimitation: use minimum of the three controls on carbon assimilation - case default - err=10; message=trim(message)//"unknown option for the controls on carbon assimilation [option="//trim(model_decisions(iLookDECISIONS%bbAssimFnc)%cDecision)//"]"; return - end select - end if - - ! identify the scaling of photosynthesis from the leaf to the canopy - if(model_decisions(iLookDECISIONS%stomResist)%iDecision >= BallBerryFlex)then - select case(trim(model_decisions(iLookDECISIONS%bbCanIntg8)%cDecision)) - case('constantScaling' ); model_decisions(iLookDECISIONS%bbCanIntg8)%iDecision = constantScaling ! constant scaling factor - case('laiScaling' ); model_decisions(iLookDECISIONS%bbCanIntg8)%iDecision = laiScaling ! exponential function of LAI (Leuning, Plant Cell Env 1995: "Scaling from..." [eq 9]) - case default - err=10; message=trim(message)//"unknown option for scaling of photosynthesis from the leaf to the canopy [option="//trim(model_decisions(iLookDECISIONS%bbCanIntg8)%cDecision)//"]"; return - end select - end if - - ! identify the numerical method - select case(trim(model_decisions(iLookDECISIONS%num_method)%cDecision)) - case('bEuler' ); model_decisions(iLookDECISIONS%num_method)%iDecision = bEuler ! home-grown backward Euler solution with long time steps - case('itertive' ); model_decisions(iLookDECISIONS%num_method)%iDecision = bEuler ! home-grown backward Euler solution (included for backwards compatibility) - case('sundials' ); model_decisions(iLookDECISIONS%num_method)%iDecision = sundials ! SUNDIALS/IDA solution - case default - err=10; message=trim(message)//"unknown numerical method [option="//trim(model_decisions(iLookDECISIONS%num_method)%cDecision)//"]"; return - end select - - ! identify the method used to calculate flux derivatives - select case(trim(model_decisions(iLookDECISIONS%fDerivMeth)%cDecision)) - case('numericl'); model_decisions(iLookDECISIONS%fDerivMeth)%iDecision = numerical ! numerical - case('analytic'); model_decisions(iLookDECISIONS%fDerivMeth)%iDecision = analytical ! analytical - case default - err=10; message=trim(message)//"unknown method used to calculate flux derivatives [option="//trim(model_decisions(iLookDECISIONS%fDerivMeth)%cDecision)//"]"; return - end select - - ! identify the method used to determine LAI and SAI - select case(trim(model_decisions(iLookDECISIONS%LAI_method)%cDecision)) - case('monTable'); model_decisions(iLookDECISIONS%LAI_method)%iDecision = monthlyTable ! LAI/SAI taken directly from a monthly table for different vegetation classes - case('specified'); model_decisions(iLookDECISIONS%LAI_method)%iDecision = specified ! LAI/SAI computed from green vegetation fraction and winterSAI and summerLAI parameters - case default - err=10; message=trim(message)//"unknown method to determine LAI and SAI [option="//trim(model_decisions(iLookDECISIONS%LAI_method)%cDecision)//"]"; return - end select - - ! identify the canopy interception parameterization - select case(trim(model_decisions(iLookDECISIONS%cIntercept)%cDecision)) - case('notPopulatedYet'); model_decisions(iLookDECISIONS%cIntercept)%iDecision = unDefined - case('sparseCanopy'); model_decisions(iLookDECISIONS%cIntercept)%iDecision = sparseCanopy - case('storageFunc'); model_decisions(iLookDECISIONS%cIntercept)%iDecision = storageFunc - case default - err=10; message=trim(message)//"unknown canopy interception parameterization [option="//trim(model_decisions(iLookDECISIONS%cIntercept)%cDecision)//"]"; return - end select - - ! identify the form of Richards' equation - select case(trim(model_decisions(iLookDECISIONS%f_Richards)%cDecision)) - case('moisture'); model_decisions(iLookDECISIONS%f_Richards)%iDecision = moisture ! moisture-based form - case('mixdform'); model_decisions(iLookDECISIONS%f_Richards)%iDecision = mixdform ! mixed form - case default - err=10; message=trim(message)//"unknown form of Richards' equation [option="//trim(model_decisions(iLookDECISIONS%f_Richards)%cDecision)//"]"; return - end select - - ! identify the groundwater parameterization - select case(trim(model_decisions(iLookDECISIONS%groundwatr)%cDecision)) - case('qTopmodl'); model_decisions(iLookDECISIONS%groundwatr)%iDecision = qbaseTopmodel ! TOPMODEL-ish baseflow parameterization - case('bigBuckt'); model_decisions(iLookDECISIONS%groundwatr)%iDecision = bigBucket ! a big bucket (lumped aquifer model) - case('noXplict'); model_decisions(iLookDECISIONS%groundwatr)%iDecision = noExplicit ! no explicit groundwater parameterization - case default - err=10; message=trim(message)//"unknown groundwater parameterization [option="//trim(model_decisions(iLookDECISIONS%groundwatr)%cDecision)//"]"; return - end select - - ! identify the hydraulic conductivity profile - select case(trim(model_decisions(iLookDECISIONS%hc_profile)%cDecision)) - case('constant'); model_decisions(iLookDECISIONS%hc_profile)%iDecision = constant ! constant hydraulic conductivity with depth - case('pow_prof'); model_decisions(iLookDECISIONS%hc_profile)%iDecision = powerLaw_profile ! power-law profile - case default - err=10; message=trim(message)//"unknown hydraulic conductivity profile [option="//trim(model_decisions(iLookDECISIONS%hc_profile)%cDecision)//"]"; return - end select - - ! identify the upper boundary conditions for thermodynamics - select case(trim(model_decisions(iLookDECISIONS%bcUpprTdyn)%cDecision)) - case('presTemp'); model_decisions(iLookDECISIONS%bcUpprTdyn)%iDecision = prescribedTemp ! prescribed temperature - case('nrg_flux'); model_decisions(iLookDECISIONS%bcUpprTdyn)%iDecision = energyFlux ! energy flux - case('zeroFlux'); model_decisions(iLookDECISIONS%bcUpprTdyn)%iDecision = zeroFlux ! zero flux - case default - err=10; message=trim(message)//"unknown upper boundary conditions for thermodynamics [option="//trim(model_decisions(iLookDECISIONS%bcUpprTdyn)%cDecision)//"]"; return - end select - - ! identify the lower boundary conditions for thermodynamics - select case(trim(model_decisions(iLookDECISIONS%bcLowrTdyn)%cDecision)) - case('presTemp'); model_decisions(iLookDECISIONS%bcLowrTdyn)%iDecision = prescribedTemp ! prescribed temperature - case('zeroFlux'); model_decisions(iLookDECISIONS%bcLowrTdyn)%iDecision = zeroFlux ! zero flux - case default - err=10; message=trim(message)//"unknown lower boundary conditions for thermodynamics [option="//trim(model_decisions(iLookDECISIONS%bcLowrTdyn)%cDecision)//"]"; return - end select - - ! identify the upper boundary conditions for soil hydrology - select case(trim(model_decisions(iLookDECISIONS%bcUpprSoiH)%cDecision)) - case('presHead'); model_decisions(iLookDECISIONS%bcUpprSoiH)%iDecision = prescribedHead ! prescribed head (volumetric liquid water content for mixed form of Richards' eqn) - case('liq_flux'); model_decisions(iLookDECISIONS%bcUpprSoiH)%iDecision = liquidFlux ! liquid water flux - case default - err=10; message=trim(message)//"unknown upper boundary conditions for soil hydrology [option="//trim(model_decisions(iLookDECISIONS%bcUpprSoiH)%cDecision)//"]"; return - end select - - ! identify the lower boundary conditions for soil hydrology - select case(trim(model_decisions(iLookDECISIONS%bcLowrSoiH)%cDecision)) - case('presHead'); model_decisions(iLookDECISIONS%bcLowrSoiH)%iDecision = prescribedHead ! prescribed head (volumetric liquid water content for mixed form of Richards' eqn) - case('bottmPsi'); model_decisions(iLookDECISIONS%bcLowrSoiH)%iDecision = funcBottomHead ! function of matric head in the lower-most layer - case('drainage'); model_decisions(iLookDECISIONS%bcLowrSoiH)%iDecision = freeDrainage ! free drainage - case('zeroFlux'); model_decisions(iLookDECISIONS%bcLowrSoiH)%iDecision = zeroFlux ! zero flux - case default - err=10; message=trim(message)//"unknown lower boundary conditions for soil hydrology [option="//trim(model_decisions(iLookDECISIONS%bcLowrSoiH)%cDecision)//"]"; return - end select - - ! identify the choice of parameterization for vegetation roughness length and displacement height - select case(trim(model_decisions(iLookDECISIONS%veg_traits)%cDecision)) - case('Raupach_BLM1994'); model_decisions(iLookDECISIONS%veg_traits)%iDecision = Raupach_BLM1994 ! Raupach (BLM 1994) "Simplified expressions..." - case('CM_QJRMS1988' ); model_decisions(iLookDECISIONS%veg_traits)%iDecision = CM_QJRMS1988 ! Choudhury and Monteith (QJRMS 1998) "A four layer model for the heat budget..." - case('vegTypeTable' ); model_decisions(iLookDECISIONS%veg_traits)%iDecision = vegTypeTable ! constant parameters dependent on the vegetation type - case default - err=10; message=trim(message)//"unknown parameterization for vegetation roughness length and displacement height [option="//trim(model_decisions(iLookDECISIONS%veg_traits)%cDecision)//"]"; return - end select - - ! identify the choice of parameterization for the rooting profile - ! NOTE: for backwards compatibility select powerLaw if rooting profile is undefined - select case(trim(model_decisions(iLookDECISIONS%rootProfil)%cDecision)) - case('powerLaw','notPopulatedYet'); model_decisions(iLookDECISIONS%rootProfil)%iDecision = powerLaw ! simple power-law rooting profile - case('doubleExp'); model_decisions(iLookDECISIONS%rootProfil)%iDecision = doubleExp ! the double exponential function of Xeng et al. (JHM 2001) - case default - err=10; message=trim(message)//"unknown parameterization for rooting profile [option="//trim(model_decisions(iLookDECISIONS%rootProfil)%cDecision)//"]"; return - end select - - ! identify the choice of parameterization for canopy emissivity - select case(trim(model_decisions(iLookDECISIONS%canopyEmis)%cDecision)) - case('simplExp'); model_decisions(iLookDECISIONS%canopyEmis)%iDecision = simplExp ! simple exponential function - case('difTrans'); model_decisions(iLookDECISIONS%canopyEmis)%iDecision = difTrans ! parameterized as a function of diffuse transmissivity - case default - err=10; message=trim(message)//"unknown parameterization for canopy emissivity [option="//trim(model_decisions(iLookDECISIONS%canopyEmis)%cDecision)//"]"; return - end select - - ! choice of parameterization for snow interception - select case(trim(model_decisions(iLookDECISIONS%snowIncept)%cDecision)) - case('stickySnow'); model_decisions(iLookDECISIONS%snowIncept)%iDecision = stickySnow ! maximum interception capacity an increasing function of temerature - case('lightSnow' ); model_decisions(iLookDECISIONS%snowIncept)%iDecision = lightSnow ! maximum interception capacity an inverse function of new snow density - case default - err=10; message=trim(message)//"unknown option for snow interception capacity[option="//trim(model_decisions(iLookDECISIONS%snowIncept)%cDecision)//"]"; return - end select - - ! identify the choice of wind profile - select case(trim(model_decisions(iLookDECISIONS%windPrfile)%cDecision)) - case('exponential' ); model_decisions(iLookDECISIONS%windPrfile)%iDecision = exponential ! exponential wind profile extends to the surface - case('logBelowCanopy'); model_decisions(iLookDECISIONS%windPrfile)%iDecision = logBelowCanopy ! logarithmic profile below the vegetation canopy - case default - err=10; message=trim(message)//"unknown option for choice of wind profile[option="//trim(model_decisions(iLookDECISIONS%windPrfile)%cDecision)//"]"; return - end select - - ! identify the choice of atmospheric stability function - select case(trim(model_decisions(iLookDECISIONS%astability)%cDecision)) - case('standard'); model_decisions(iLookDECISIONS%astability)%iDecision = standard ! standard MO similarity, a la Anderson (1976) - case('louisinv'); model_decisions(iLookDECISIONS%astability)%iDecision = louisInversePower ! Louis (1979) inverse power function - case('mahrtexp'); model_decisions(iLookDECISIONS%astability)%iDecision = mahrtExponential ! Mahrt (1987) exponential - case default - err=10; message=trim(message)//"unknown stability function [option="//trim(model_decisions(iLookDECISIONS%astability)%cDecision)//"]"; return - end select - - ! choice of canopy shortwave radiation method - select case(trim(model_decisions(iLookDECISIONS%canopySrad)%cDecision)) - case('noah_mp' ); model_decisions(iLookDECISIONS%canopySrad)%iDecision = noah_mp ! full Noah-MP implementation (including albedo) - case('CLM_2stream'); model_decisions(iLookDECISIONS%canopySrad)%iDecision = CLM_2stream ! CLM 2-stream model (see CLM documentation) - case('UEB_2stream'); model_decisions(iLookDECISIONS%canopySrad)%iDecision = UEB_2stream ! UEB 2-stream model (Mahat and Tarboton, WRR 2011) - case('NL_scatter' ); model_decisions(iLookDECISIONS%canopySrad)%iDecision = NL_scatter ! Simplified method Nijssen and Lettenmaier (JGR 1999) - case('BeersLaw' ); model_decisions(iLookDECISIONS%canopySrad)%iDecision = BeersLaw ! Beer's Law (as implemented in VIC) - case default - err=10; message=trim(message)//"unknown canopy radiation method [option="//trim(model_decisions(iLookDECISIONS%canopySrad)%cDecision)//"]"; return - end select - - ! choice of albedo representation - select case(trim(model_decisions(iLookDECISIONS%alb_method)%cDecision)) - case('conDecay'); model_decisions(iLookDECISIONS%alb_method)%iDecision = constantDecay ! constant decay (e.g., VIC, CLASS) - case('varDecay'); model_decisions(iLookDECISIONS%alb_method)%iDecision = variableDecay ! variable decay (e.g., BATS approach, with destructive metamorphism + soot content) - case default - err=10; message=trim(message)//"unknown option for snow albedo [option="//trim(model_decisions(iLookDECISIONS%alb_method)%cDecision)//"]"; return - end select - - ! choice of snow compaction routine - select case(trim(model_decisions(iLookDECISIONS%compaction)%cDecision)) - case('consettl'); model_decisions(iLookDECISIONS%compaction)%iDecision = constantSettlement ! constant settlement rate - case('anderson'); model_decisions(iLookDECISIONS%compaction)%iDecision = andersonEmpirical ! semi-empirical method of Anderson (1976) - case default - err=10; message=trim(message)//"unknown option for snow compaction [option="//trim(model_decisions(iLookDECISIONS%compaction)%cDecision)//"]"; return - end select - - ! choice of method to combine and sub-divide snow layers - select case(trim(model_decisions(iLookDECISIONS%snowLayers)%cDecision)) - case('jrdn1991'); model_decisions(iLookDECISIONS%snowLayers)%iDecision = sameRulesAllLayers ! SNTHERM option: same combination/sub-dividion rules applied to all layers - case('CLM_2010'); model_decisions(iLookDECISIONS%snowLayers)%iDecision = rulesDependLayerIndex ! CLM option: combination/sub-dividion rules depend on layer index - case default - err=10; message=trim(message)//"unknown option for combination/sub-division of snow layers [option="//trim(model_decisions(iLookDECISIONS%snowLayers)%cDecision)//"]"; return - end select - - ! choice of thermal conductivity representation for snow - select case(trim(model_decisions(iLookDECISIONS%thCondSnow)%cDecision)) - case('tyen1965'); model_decisions(iLookDECISIONS%thCondSnow)%iDecision = Yen1965 ! Yen (1965) - case('melr1977'); model_decisions(iLookDECISIONS%thCondSnow)%iDecision = Mellor1977 ! Mellor (1977) - case('jrdn1991'); model_decisions(iLookDECISIONS%thCondSnow)%iDecision = Jordan1991 ! Jordan (1991) - case('smnv2000'); model_decisions(iLookDECISIONS%thCondSnow)%iDecision = Smirnova2000 ! Smirnova et al. (2000) - case default - err=10; message=trim(message)//"unknown option for thermal conductivity of snow [option="//trim(model_decisions(iLookDECISIONS%thCondSnow)%cDecision)//"]"; return - end select - - ! choice of thermal conductivity representation for soil - select case(trim(model_decisions(iLookDECISIONS%thCondSoil)%cDecision)) - case('funcSoilWet'); model_decisions(iLookDECISIONS%thCondSoil)%iDecision = funcSoilWet ! function of soil wetness - case('mixConstit' ); model_decisions(iLookDECISIONS%thCondSoil)%iDecision = mixConstit ! mixture of constituents - case('hanssonVZJ' ); model_decisions(iLookDECISIONS%thCondSoil)%iDecision = hanssonVZJ ! test case for the mizoguchi lab experiment, Hansson et al. VZJ 2004 - case default - err=10; message=trim(message)//"unknown option for thermal conductivity of soil [option="//trim(model_decisions(iLookDECISIONS%thCondSoil)%cDecision)//"]"; return - end select - - ! choice of method for the spatial representation of groundwater - select case(trim(model_decisions(iLookDECISIONS%spatial_gw)%cDecision)) - case('localColumn'); model_decisions(iLookDECISIONS%spatial_gw)%iDecision = localColumn ! separate groundwater in each local soil column - case('singleBasin'); model_decisions(iLookDECISIONS%spatial_gw)%iDecision = singleBasin ! single groundwater store over the entire basin - case default - err=10; message=trim(message)//"unknown option for spatial representation of groundwater [option="//trim(model_decisions(iLookDECISIONS%spatial_gw)%cDecision)//"]"; return - end select - - ! choice of routing method - select case(trim(model_decisions(iLookDECISIONS%subRouting)%cDecision)) - case('timeDlay'); model_decisions(iLookDECISIONS%subRouting)%iDecision = timeDelay ! time-delay histogram - case('qInstant'); model_decisions(iLookDECISIONS%subRouting)%iDecision = qInstant ! instantaneous routing - case default - err=10; message=trim(message)//"unknown option for sub-grid routing [option="//trim(model_decisions(iLookDECISIONS%subRouting)%cDecision)//"]"; return - end select - - ! choice of new snow density - ! NOTE: use hedAndPom as the default, where density method is undefined (not populated yet) - select case(trim(model_decisions(iLookDECISIONS%snowDenNew)%cDecision)) - case('hedAndPom','notPopulatedYet'); model_decisions(iLookDECISIONS%snowDenNew)%iDecision = hedAndPom ! Hedstrom and Pomeroy (1998), expoential increase - case('anderson'); model_decisions(iLookDECISIONS%snowDenNew)%iDecision = anderson ! Anderson 1976 - case('pahaut_76'); model_decisions(iLookDECISIONS%snowDenNew)%iDecision = pahaut_76 ! Pahaut 1976, wind speed dependent (derived from Col de Porte, French Alps) - case('constDens'); model_decisions(iLookDECISIONS%snowDenNew)%iDecision = constDens ! Constant new snow density - case default - err=10; message=trim(message)//"unknown option for new snow density [option="//trim(model_decisions(iLookDECISIONS%snowDenNew)%cDecision)//"]"; return - end select - - ! choice of snow unloading from canopy - select case(trim(model_decisions(iLookDECISIONS%snowUnload)%cDecision)) - case('meltDripUnload','notPopulatedYet'); model_decisions(iLookDECISIONS%snowUnload)%iDecision = meltDripUnload ! Hedstrom and Pomeroy (1998), Storck et al 2002 (snowUnloadingCoeff & ratioDrip2Unloading) - case('windUnload'); model_decisions(iLookDECISIONS%snowUnload)%iDecision = windUnload ! Roesch et al 2001, formulate unloading based on wind and temperature - case default - err=10; message=trim(message)//"unknown option for snow unloading [option="//trim(model_decisions(iLookDECISIONS%snowUnload)%cDecision)//"]"; return - end select - - - ! ----------------------------------------------------------------------------------------------------------------------------------------------- - ! check for consistency among options - ! ----------------------------------------------------------------------------------------------------------------------------------------------- - - ! check there is prescribedHead for soil hydrology when zeroFlux or prescribedTemp for thermodynamics - !select case(model_decisions(iLookDECISIONS%bcUpprTdyn)%iDecision) - ! case(prescribedTemp,zeroFlux) - ! if(model_decisions(iLookDECISIONS%bcUpprSoiH)%iDecision /= prescribedHead)then - ! message=trim(message)//'upper boundary condition for soil hydology must be presHead with presTemp and zeroFlux options for thermodynamics' - ! err=20; return - ! end if - !end select - - ! check there is prescribedTemp or zeroFlux for thermodynamics when using prescribedHead for soil hydrology - !select case(model_decisions(iLookDECISIONS%bcUpprSoiH)%iDecision) - ! case(prescribedHead) - ! ! check that upper boundary condition for thermodynamics is presTemp or zeroFlux - ! select case(model_decisions(iLookDECISIONS%bcUpprTdyn)%iDecision) - ! case(prescribedTemp,zeroFlux) ! do nothing: this is OK - ! case default - ! message=trim(message)//'upper boundary condition for thermodynamics must be presTemp or zeroFlux with presHead option for soil hydology' - ! err=20; return - ! end select - !end select - - ! check zero flux lower boundary for topmodel baseflow option - select case(model_decisions(iLookDECISIONS%groundwatr)%iDecision) - case(qbaseTopmodel) - if(model_decisions(iLookDECISIONS%bcLowrSoiH)%iDecision /= zeroFlux)then - message=trim(message)//'lower boundary condition for soil hydology must be zeroFlux with qbaseTopmodel option for groundwater' - err=20; return - end if - end select - - ! check power-law profile is selected when using topmodel baseflow option - select case(model_decisions(iLookDECISIONS%groundwatr)%iDecision) - case(qbaseTopmodel) - if(model_decisions(iLookDECISIONS%hc_profile)%iDecision /= powerLaw_profile)then - message=trim(message)//'power-law transmissivity profile must be selected when using topmodel baseflow option' - err=20; return - end if - end select - - ! check bigBucket groundwater option is used when for spatial groundwater is singleBasin - if(model_decisions(iLookDECISIONS%spatial_gw)%iDecision == singleBasin)then - if(model_decisions(iLookDECISIONS%groundwatr)%iDecision /= bigBucket)then - message=trim(message)//'groundwater parameterization must be bigBucket when using singleBasin for spatial_gw' - err=20; return + 0._rkind, & ! second + dJulianFinsh, & ! julian date for the end of the simulation + err, cmessage) ! error control + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if + + ! check start and finish time +#ifndef NGEN_ACTIVE + write(*,'(a,i4,1x,4(i2,1x))') 'startTime: iyyy, im, id, ih, imin = ', startTime%var(1:5) + write(*,'(a,i4,1x,4(i2,1x))') 'finshTime: iyyy, im, id, ih, imin = ', finshTime%var(1:5) +#endif + ! check that simulation end time is > start time + if(dJulianFinsh < dJulianStart)then; err=20; message=trim(message)//'end time of simulation occurs before start time'; return; end if + + ! initialize the old time vector (time from the previous time step) + oldTime%var(:) = startTime%var(:) + + ! compute the number of time steps + numtim = nint( (dJulianFinsh - dJulianStart)*secprday/data_step ) + 1 + + + ! set Noah-MP options + DVEG=3 ! option for dynamic vegetation + OPT_RAD=3 ! option for canopy radiation + OPT_ALB=2 ! option for snow albedo + + ! set zero option for thee category tables + ! NOTE: we want to keep track of these decisions, but not used in the physics routines + model_decisions(iLookDECISIONS%soilCatTbl)%iDecision = 0 + model_decisions(iLookDECISIONS%vegeParTbl)%iDecision = 0 + + ! identify the choice of function for the soil moisture control on stomatal resistance + select case(trim(model_decisions(iLookDECISIONS%soilStress)%cDecision)) + case('NoahType'); model_decisions(iLookDECISIONS%soilStress)%iDecision = NoahType ! thresholded linear function of volumetric liquid water content + case('CLM_Type'); model_decisions(iLookDECISIONS%soilStress)%iDecision = CLM_Type ! thresholded linear function of matric head + case('SiB_Type'); model_decisions(iLookDECISIONS%soilStress)%iDecision = SiB_Type ! exponential of the log of matric head + case default + err=10; message=trim(message)//"unknown soil moisture function [option="//trim(model_decisions(iLookDECISIONS%soilStress)%cDecision)//"]"; return + end select + + ! identify the choice of function for stomatal resistance + select case(trim(model_decisions(iLookDECISIONS%stomResist)%cDecision)) + case('BallBerry' ); model_decisions(iLookDECISIONS%stomResist)%iDecision = BallBerry ! Ball-Berry + case('Jarvis' ); model_decisions(iLookDECISIONS%stomResist)%iDecision = Jarvis ! Jarvis + case('simpleResistance' ); model_decisions(iLookDECISIONS%stomResist)%iDecision = simpleResistance ! simple resistance formulation + case('BallBerryFlex' ); model_decisions(iLookDECISIONS%stomResist)%iDecision = BallBerryFlex ! flexible Ball-Berry scheme + case('BallBerryTest' ); model_decisions(iLookDECISIONS%stomResist)%iDecision = BallBerryTest ! flexible Ball-Berry scheme (testing) + case default + err=10; message=trim(message)//"unknown stomatal resistance function [option="//trim(model_decisions(iLookDECISIONS%stomResist)%cDecision)//"]"; return + end select + + ! identify the leaf temperature controls on photosynthesis + stomatal resistance + if(model_decisions(iLookDECISIONS%stomResist)%iDecision >= BallBerryFlex)then + select case(trim(model_decisions(iLookDECISIONS%bbTempFunc)%cDecision)) + case('q10Func' ); model_decisions(iLookDECISIONS%bbTempFunc)%iDecision = q10Func + case('Arrhenius' ); model_decisions(iLookDECISIONS%bbTempFunc)%iDecision = Arrhenius + case default + err=10; message=trim(message)//"unknown leaf temperature function [option="//trim(model_decisions(iLookDECISIONS%bbTempFunc)%cDecision)//"]"; return + end select end if - end if - - ! ensure that the LAI seaonality option is switched off (this was a silly idea, in retrospect) - !if(model_decisions(iLookDECISIONS%LAI_method)%iDecision == specified)then - ! message=trim(message)//'parameterization of LAI in terms of seasonal cycle of green veg fraction was a silly idea '& - ! //' -- the LAI_method option ["specified"] is no longer supported' - ! err=20; return - !end if - - end subroutine mDecisions - - - ! ************************************************************************************************ - ! private subroutine readoption: read information from model decisions file - ! ************************************************************************************************ - subroutine readoption(err,message) - ! used to read information from model decisions file - USE ascii_util_module,only:file_open ! open file - USE ascii_util_module,only:linewidth ! max character number for one line - USE ascii_util_module,only:get_vlines ! get a vector of non-comment lines - USE summaFileManager,only:SETTINGS_PATH ! path for metadata files - USE summaFileManager,only:M_DECISIONS ! definition of modeling options - USE get_ixname_module,only:get_ixdecisions ! identify index of named variable - USE globalData,only:model_decisions ! model decision structure - implicit none - ! define output - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! define local variables - character(len=256) :: cmessage ! error message for downwind routine - character(LEN=256) :: infile ! input filename - integer(i4b) :: unt ! file unit (free unit output from file_open) - character(LEN=linewidth),allocatable :: charline(:) ! vector of character strings - integer(i4b) :: nDecisions ! number of model decisions - integer(i4b) :: iDecision ! index of model decisions - character(len=32) :: decision ! name of model decision - character(len=32) :: option ! option for model decision - integer(i4b) :: iVar ! index of the decision in the data structure - ! Start procedure here - err=0; message='readoption/' - ! build filename - infile = trim(SETTINGS_PATH)//trim(M_DECISIONS) - write(*,'(2(a,1x))') 'decisions file = ', trim(infile) - ! open file - call file_open(trim(infile),unt,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if - ! get a list of character strings from non-comment lines - call get_vlines(unt,charline,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if - ! close the file unit - close(unt) - ! get the number of model decisions - nDecisions = size(charline) - ! populate the model decisions structure - do iDecision=1,nDecisions - ! extract name of decision and the decision selected - read(charline(iDecision),*,iostat=err) option, decision - if (err/=0) then; err=30; message=trim(message)//"errorReadLine"; return; end if - ! get the index of the decision in the data structure - iVar = get_ixdecisions(trim(option)) - write(*,'(i4,1x,a)') iDecision, trim(option)//': '//trim(decision) - if(iVar<=0)then; err=40; message=trim(message)//"cannotFindDecisionIndex[name='"//trim(option)//"']"; return; end if - ! populate the model decisions structure - model_decisions(iVar)%cOption = trim(option) - model_decisions(iVar)%cDecision = trim(decision) - end do - end subroutine readoption + ! identify the humidity controls on stomatal resistance + if(model_decisions(iLookDECISIONS%stomResist)%iDecision >= BallBerryFlex)then + select case(trim(model_decisions(iLookDECISIONS%bbHumdFunc)%cDecision)) + case('humidLeafSurface' ); model_decisions(iLookDECISIONS%bbHumdFunc)%iDecision = humidLeafSurface + case('scaledHyperbolic' ); model_decisions(iLookDECISIONS%bbHumdFunc)%iDecision = scaledHyperbolic + case default + err=10; message=trim(message)//"unknown humidity function [option="//trim(model_decisions(iLookDECISIONS%bbHumdFunc)%cDecision)//"]"; return + end select + end if + + ! identify functions for electron transport function (dependence of photosynthesis on PAR) + if(model_decisions(iLookDECISIONS%stomResist)%iDecision >= BallBerryFlex)then + select case(trim(model_decisions(iLookDECISIONS%bbElecFunc)%cDecision)) + case('linear' ); model_decisions(iLookDECISIONS%bbElecFunc)%iDecision = linear + case('linearJmax' ); model_decisions(iLookDECISIONS%bbElecFunc)%iDecision = linearJmax + case('quadraticJmax' ); model_decisions(iLookDECISIONS%bbElecFunc)%iDecision = quadraticJmax + case default + err=10; message=trim(message)//"unknown electron transport function [option="//trim(model_decisions(iLookDECISIONS%bbElecFunc)%cDecision)//"]"; return + end select + end if + + ! identify the use of the co2 compensation point in the stomatal conductance calaculations + if(model_decisions(iLookDECISIONS%stomResist)%iDecision >= BallBerryFlex)then + select case(trim(model_decisions(iLookDECISIONS%bbCO2point)%cDecision)) + case('origBWB' ); model_decisions(iLookDECISIONS%bbCO2point)%iDecision = origBWB + case('Leuning' ); model_decisions(iLookDECISIONS%bbCO2point)%iDecision = Leuning + case default + err=10; message=trim(message)//"unknown option for the co2 compensation point [option="//trim(model_decisions(iLookDECISIONS%bbCO2point)%cDecision)//"]"; return + end select + end if + + ! identify the iterative numerical solution method used in the Ball-Berry stomatal resistance parameterization + if(model_decisions(iLookDECISIONS%stomResist)%iDecision >= BallBerryFlex)then + select case(trim(model_decisions(iLookDECISIONS%bbNumerics)%cDecision)) + case('NoahMPsolution' ); model_decisions(iLookDECISIONS%bbNumerics)%iDecision = NoahMPsolution ! the NoahMP solution (and CLM4): fixed point iteration; max 3 iterations + case('newtonRaphson' ); model_decisions(iLookDECISIONS%bbNumerics)%iDecision = newtonRaphson ! full Newton-Raphson iterative solution to convergence + case default + err=10; message=trim(message)//"unknown option for the Ball-Berry numerical solution [option="//trim(model_decisions(iLookDECISIONS%bbNumerics)%cDecision)//"]"; return + end select + end if + + ! identify the controls on carbon assimilation + if(model_decisions(iLookDECISIONS%stomResist)%iDecision >= BallBerryFlex)then + select case(trim(model_decisions(iLookDECISIONS%bbAssimFnc)%cDecision)) + case('colimitation' ); model_decisions(iLookDECISIONS%bbAssimFnc)%iDecision = colimitation ! enable colimitation, as described by Collatz et al. (1991) and Sellers et al. (1996) + case('minFunc' ); model_decisions(iLookDECISIONS%bbAssimFnc)%iDecision = minFunc ! do not enable colimitation: use minimum of the three controls on carbon assimilation + case default + err=10; message=trim(message)//"unknown option for the controls on carbon assimilation [option="//trim(model_decisions(iLookDECISIONS%bbAssimFnc)%cDecision)//"]"; return + end select + end if + + ! identify the scaling of photosynthesis from the leaf to the canopy + if(model_decisions(iLookDECISIONS%stomResist)%iDecision >= BallBerryFlex)then + select case(trim(model_decisions(iLookDECISIONS%bbCanIntg8)%cDecision)) + case('constantScaling' ); model_decisions(iLookDECISIONS%bbCanIntg8)%iDecision = constantScaling ! constant scaling factor + case('laiScaling' ); model_decisions(iLookDECISIONS%bbCanIntg8)%iDecision = laiScaling ! exponential function of LAI (Leuning, Plant Cell Env 1995: "Scaling from..." [eq 9]) + case default + err=10; message=trim(message)//"unknown option for scaling of photosynthesis from the leaf to the canopy [option="//trim(model_decisions(iLookDECISIONS%bbCanIntg8)%cDecision)//"]"; return + end select + end if + + ! identify the numerical method + select case(trim(model_decisions(iLookDECISIONS%num_method)%cDecision)) + case('homegrown'); model_decisions(iLookDECISIONS%num_method)%iDecision = homegrown ! homegrown backward Euler solution using concepts from numerical recipes + case('itertive' ); model_decisions(iLookDECISIONS%num_method)%iDecision = homegrown ! homegrown backward Euler solution (included for backwards compatibility) + case('kinsol' ); model_decisions(iLookDECISIONS%num_method)%iDecision = kinsol ! SUNDIALS backward Euler solution using Kinsol + case('ida' ); model_decisions(iLookDECISIONS%num_method)%iDecision = ida ! SUNDIALS solution using IDA + case default + err=10; message=trim(message)//"unknown numerical method [option="//trim(model_decisions(iLookDECISIONS%num_method)%cDecision)//"]"; return + end select + + ! make sure compiled with SUNDIALS if want to use it +#ifndef SUNDIALS_ACTIVE + if(model_decisions(iLookDECISIONS%num_method)%iDecision==ida .or. model_decisions(iLookDECISIONS%num_method)%iDecision==kinsol)then + err=20; message=trim(message)//'cannot use num_method as ida or kinsol if did not compile with -DCMAKE_BUILD_TYPE=Sundials'; return + endif +#endif + + ! choice of variable in either energy backward Euler residual or IDA state variable + ! for backward Euler solution, enthalpyForm has better coincidence of energy conservation + ! in IDA solution, enthalpyForm makes the state variables to be enthalpy and the residual is computed in enthalpy space + select case(trim(model_decisions(iLookDECISIONS%nrgConserv)%cDecision)) + case('closedForm' ); model_decisions(iLookDECISIONS%nrgConserv)%iDecision = closedForm ! use temperature with closed form heat capacity + case('enthalpyFormLU'); model_decisions(iLookDECISIONS%nrgConserv)%iDecision = enthalpyFormLU ! use enthalpy with soil temperature-enthalpy lookup tables + case('enthalpyForm' ); model_decisions(iLookDECISIONS%nrgConserv)%iDecision = enthalpyForm ! use enthalpy with soil temperature-enthalpy analytical solution + case default + if (trim(model_decisions(iLookDECISIONS%num_method)%cDecision)=='itertive')then + model_decisions(iLookDECISIONS%nrgConserv)%iDecision = closedForm ! included for backwards compatibility + else + err=10; message=trim(message)//"unknown choice of variable in either energy backward Euler residual or IDA state variable [option="//trim(model_decisions(iLookDECISIONS%nrgConserv)%cDecision)//"]"; return + endif + end select + + ! choice of choice of full or empty aquifer at start + ! default ('notPopulatedYet') start with this full, since easier to spin up by draining than filling (filling we need to wait for precipitation) + ! but, if want to compare model method outputs, empty start leads to quicker equilibrium + select case(trim(model_decisions(iLookDECISIONS%aquiferIni)%cDecision)) + case('fullStart','notPopulatedYet'); model_decisions(iLookDECISIONS%aquiferIni)%iDecision = fullStart ! start with full aquifer + case('emptyStart'); model_decisions(iLookDECISIONS%aquiferIni)%iDecision = emptyStart ! start with empty aquifer + case default + err=10; message=trim(message)//"unknown choice of full or empty aquifer at start [option="//trim(model_decisions(iLookDECISIONS%aquiferIni)%cDecision)//"]"; return + end select + + ! identify the method used to calculate flux derivatives + select case(trim(model_decisions(iLookDECISIONS%fDerivMeth)%cDecision)) + case('numericl'); model_decisions(iLookDECISIONS%fDerivMeth)%iDecision = numerical ! numerical + case('analytic'); model_decisions(iLookDECISIONS%fDerivMeth)%iDecision = analytical ! analytical + case default + err=10; message=trim(message)//"unknown method used to calculate flux derivatives [option="//trim(model_decisions(iLookDECISIONS%fDerivMeth)%cDecision)//"]"; return + end select + + ! identify the method used to determine LAI and SAI + select case(trim(model_decisions(iLookDECISIONS%LAI_method)%cDecision)) + case('monTable'); model_decisions(iLookDECISIONS%LAI_method)%iDecision = monthlyTable ! LAI/SAI taken directly from a monthly table for different vegetation classes + case('specified'); model_decisions(iLookDECISIONS%LAI_method)%iDecision = specified ! LAI/SAI computed from green vegetation fraction and winterSAI and summerLAI parameters + case default + err=10; message=trim(message)//"unknown method to determine LAI and SAI [option="//trim(model_decisions(iLookDECISIONS%LAI_method)%cDecision)//"]"; return + end select + + ! identify the canopy interception parameterization + select case(trim(model_decisions(iLookDECISIONS%cIntercept)%cDecision)) + case('notPopulatedYet'); model_decisions(iLookDECISIONS%cIntercept)%iDecision = unDefined + case('sparseCanopy'); model_decisions(iLookDECISIONS%cIntercept)%iDecision = sparseCanopy + case('storageFunc'); model_decisions(iLookDECISIONS%cIntercept)%iDecision = storageFunc + case default + err=10; message=trim(message)//"unknown canopy interception parameterization [option="//trim(model_decisions(iLookDECISIONS%cIntercept)%cDecision)//"]"; return + end select + + ! identify the form of Richards' equation + select case(trim(model_decisions(iLookDECISIONS%f_Richards)%cDecision)) + case('moisture'); model_decisions(iLookDECISIONS%f_Richards)%iDecision = moisture ! moisture-based form + case('mixdform'); model_decisions(iLookDECISIONS%f_Richards)%iDecision = mixdform ! mixed form + case default + err=10; message=trim(message)//"unknown form of Richards' equation [option="//trim(model_decisions(iLookDECISIONS%f_Richards)%cDecision)//"]"; return + end select + + ! identify the groundwater parameterization + select case(trim(model_decisions(iLookDECISIONS%groundwatr)%cDecision)) + case('qTopmodl'); model_decisions(iLookDECISIONS%groundwatr)%iDecision = qbaseTopmodel ! TOPMODEL-ish baseflow parameterization + case('bigBuckt'); model_decisions(iLookDECISIONS%groundwatr)%iDecision = bigBucket ! a big bucket (lumped aquifer model) + case('noXplict'); model_decisions(iLookDECISIONS%groundwatr)%iDecision = noExplicit ! no explicit groundwater parameterization + case default + err=10; message=trim(message)//"unknown groundwater parameterization [option="//trim(model_decisions(iLookDECISIONS%groundwatr)%cDecision)//"]"; return + end select + + ! identify the hydraulic conductivity profile + select case(trim(model_decisions(iLookDECISIONS%hc_profile)%cDecision)) + case('constant'); model_decisions(iLookDECISIONS%hc_profile)%iDecision = constant ! constant hydraulic conductivity with depth + case('pow_prof'); model_decisions(iLookDECISIONS%hc_profile)%iDecision = powerLaw_profile ! power-law profile + case default + err=10; message=trim(message)//"unknown hydraulic conductivity profile [option="//trim(model_decisions(iLookDECISIONS%hc_profile)%cDecision)//"]"; return + end select + + ! identify the upper boundary conditions for thermodynamics + select case(trim(model_decisions(iLookDECISIONS%bcUpprTdyn)%cDecision)) + case('presTemp'); model_decisions(iLookDECISIONS%bcUpprTdyn)%iDecision = prescribedTemp ! prescribed temperature + case('nrg_flux'); model_decisions(iLookDECISIONS%bcUpprTdyn)%iDecision = energyFlux ! energy flux + case('zeroFlux'); model_decisions(iLookDECISIONS%bcUpprTdyn)%iDecision = zeroFlux ! zero flux + case default + err=10; message=trim(message)//"unknown upper boundary conditions for thermodynamics [option="//trim(model_decisions(iLookDECISIONS%bcUpprTdyn)%cDecision)//"]"; return + end select + + ! identify the lower boundary conditions for thermodynamics + select case(trim(model_decisions(iLookDECISIONS%bcLowrTdyn)%cDecision)) + case('presTemp'); model_decisions(iLookDECISIONS%bcLowrTdyn)%iDecision = prescribedTemp ! prescribed temperature + case('zeroFlux'); model_decisions(iLookDECISIONS%bcLowrTdyn)%iDecision = zeroFlux ! zero flux + case default + err=10; message=trim(message)//"unknown lower boundary conditions for thermodynamics [option="//trim(model_decisions(iLookDECISIONS%bcLowrTdyn)%cDecision)//"]"; return + end select + + ! identify the upper boundary conditions for soil hydrology + select case(trim(model_decisions(iLookDECISIONS%bcUpprSoiH)%cDecision)) + case('presHead'); model_decisions(iLookDECISIONS%bcUpprSoiH)%iDecision = prescribedHead ! prescribed head (volumetric liquid water content for mixed form of Richards' eqn) + case('liq_flux'); model_decisions(iLookDECISIONS%bcUpprSoiH)%iDecision = liquidFlux ! liquid water flux + case default + err=10; message=trim(message)//"unknown upper boundary conditions for soil hydrology [option="//trim(model_decisions(iLookDECISIONS%bcUpprSoiH)%cDecision)//"]"; return + end select + + ! identify the lower boundary conditions for soil hydrology + select case(trim(model_decisions(iLookDECISIONS%bcLowrSoiH)%cDecision)) + case('presHead'); model_decisions(iLookDECISIONS%bcLowrSoiH)%iDecision = prescribedHead ! prescribed head (volumetric liquid water content for mixed form of Richards' eqn) + case('bottmPsi'); model_decisions(iLookDECISIONS%bcLowrSoiH)%iDecision = funcBottomHead ! function of matric head in the lower-most layer + case('drainage'); model_decisions(iLookDECISIONS%bcLowrSoiH)%iDecision = freeDrainage ! free drainage + case('zeroFlux'); model_decisions(iLookDECISIONS%bcLowrSoiH)%iDecision = zeroFlux ! zero flux + case default + err=10; message=trim(message)//"unknown lower boundary conditions for soil hydrology [option="//trim(model_decisions(iLookDECISIONS%bcLowrSoiH)%cDecision)//"]"; return + end select + + ! identify the choice of parameterization for vegetation roughness length and displacement height + select case(trim(model_decisions(iLookDECISIONS%veg_traits)%cDecision)) + case('Raupach_BLM1994'); model_decisions(iLookDECISIONS%veg_traits)%iDecision = Raupach_BLM1994 ! Raupach (BLM 1994) "Simplified expressions..." + case('CM_QJRMS1988' ); model_decisions(iLookDECISIONS%veg_traits)%iDecision = CM_QJRMS1988 ! Choudhury and Monteith (QJRMS 1998) "A four layer model for the heat budget..." + case('vegTypeTable' ); model_decisions(iLookDECISIONS%veg_traits)%iDecision = vegTypeTable ! constant parameters dependent on the vegetation type + case default + err=10; message=trim(message)//"unknown parameterization for vegetation roughness length and displacement height [option="//trim(model_decisions(iLookDECISIONS%veg_traits)%cDecision)//"]"; return + end select + + ! identify the choice of parameterization for the rooting profile + ! NOTE: for backwards compatibility select powerLaw if rooting profile is undefined + select case(trim(model_decisions(iLookDECISIONS%rootProfil)%cDecision)) + case('powerLaw','notPopulatedYet'); model_decisions(iLookDECISIONS%rootProfil)%iDecision = powerLaw ! simple power-law rooting profile + case('doubleExp'); model_decisions(iLookDECISIONS%rootProfil)%iDecision = doubleExp ! the double exponential function of Xeng et al. (JHM 2001) + case default + err=10; message=trim(message)//"unknown parameterization for rooting profile [option="//trim(model_decisions(iLookDECISIONS%rootProfil)%cDecision)//"]"; return + end select + + ! identify the choice of parameterization for canopy emissivity + select case(trim(model_decisions(iLookDECISIONS%canopyEmis)%cDecision)) + case('simplExp'); model_decisions(iLookDECISIONS%canopyEmis)%iDecision = simplExp ! simple exponential function + case('difTrans'); model_decisions(iLookDECISIONS%canopyEmis)%iDecision = difTrans ! parameterized as a function of diffuse transmissivity + case default + err=10; message=trim(message)//"unknown parameterization for canopy emissivity [option="//trim(model_decisions(iLookDECISIONS%canopyEmis)%cDecision)//"]"; return + end select + + ! choice of parameterization for snow interception + select case(trim(model_decisions(iLookDECISIONS%snowIncept)%cDecision)) + case('stickySnow'); model_decisions(iLookDECISIONS%snowIncept)%iDecision = stickySnow ! maximum interception capacity an increasing function of temerature + case('lightSnow' ); model_decisions(iLookDECISIONS%snowIncept)%iDecision = lightSnow ! maximum interception capacity an inverse function of new snow density + case default + err=10; message=trim(message)//"unknown option for snow interception capacity[option="//trim(model_decisions(iLookDECISIONS%snowIncept)%cDecision)//"]"; return + end select + + ! identify the choice of wind profile + select case(trim(model_decisions(iLookDECISIONS%windPrfile)%cDecision)) + case('exponential' ); model_decisions(iLookDECISIONS%windPrfile)%iDecision = exponential ! exponential wind profile extends to the surface + case('logBelowCanopy'); model_decisions(iLookDECISIONS%windPrfile)%iDecision = logBelowCanopy ! logarithmic profile below the vegetation canopy + case default + err=10; message=trim(message)//"unknown option for choice of wind profile[option="//trim(model_decisions(iLookDECISIONS%windPrfile)%cDecision)//"]"; return + end select + + ! identify the choice of atmospheric stability function + select case(trim(model_decisions(iLookDECISIONS%astability)%cDecision)) + case('standard'); model_decisions(iLookDECISIONS%astability)%iDecision = standard ! standard MO similarity, a la Anderson (1976) + case('louisinv'); model_decisions(iLookDECISIONS%astability)%iDecision = louisInversePower ! Louis (1979) inverse power function + case('mahrtexp'); model_decisions(iLookDECISIONS%astability)%iDecision = mahrtExponential ! Mahrt (1987) exponential + case default + err=10; message=trim(message)//"unknown stability function [option="//trim(model_decisions(iLookDECISIONS%astability)%cDecision)//"]"; return + end select + + ! choice of canopy shortwave radiation method + select case(trim(model_decisions(iLookDECISIONS%canopySrad)%cDecision)) + case('noah_mp' ); model_decisions(iLookDECISIONS%canopySrad)%iDecision = noah_mp ! full Noah-MP implementation (including albedo) + case('CLM_2stream'); model_decisions(iLookDECISIONS%canopySrad)%iDecision = CLM_2stream ! CLM 2-stream model (see CLM documentation) + case('UEB_2stream'); model_decisions(iLookDECISIONS%canopySrad)%iDecision = UEB_2stream ! UEB 2-stream model (Mahat and Tarboton, WRR 2011) + case('NL_scatter' ); model_decisions(iLookDECISIONS%canopySrad)%iDecision = NL_scatter ! Simplified method Nijssen and Lettenmaier (JGR 1999) + case('BeersLaw' ); model_decisions(iLookDECISIONS%canopySrad)%iDecision = BeersLaw ! Beer's Law (as implemented in VIC) + case default + err=10; message=trim(message)//"unknown canopy radiation method [option="//trim(model_decisions(iLookDECISIONS%canopySrad)%cDecision)//"]"; return + end select + + ! choice of albedo representation + select case(trim(model_decisions(iLookDECISIONS%alb_method)%cDecision)) + case('conDecay'); model_decisions(iLookDECISIONS%alb_method)%iDecision = constantDecay ! constant decay (e.g., VIC, CLASS) + case('varDecay'); model_decisions(iLookDECISIONS%alb_method)%iDecision = variableDecay ! variable decay (e.g., BATS approach, with destructive metamorphism + soot content) + case default + err=10; message=trim(message)//"unknown option for snow albedo [option="//trim(model_decisions(iLookDECISIONS%alb_method)%cDecision)//"]"; return + end select + + ! choice of snow compaction routine + select case(trim(model_decisions(iLookDECISIONS%compaction)%cDecision)) + case('consettl'); model_decisions(iLookDECISIONS%compaction)%iDecision = constantSettlement ! constant settlement rate + case('anderson'); model_decisions(iLookDECISIONS%compaction)%iDecision = andersonEmpirical ! semi-empirical method of Anderson (1976) + case default + err=10; message=trim(message)//"unknown option for snow compaction [option="//trim(model_decisions(iLookDECISIONS%compaction)%cDecision)//"]"; return + end select + + ! choice of method to combine and sub-divide snow layers + select case(trim(model_decisions(iLookDECISIONS%snowLayers)%cDecision)) + case('jrdn1991'); model_decisions(iLookDECISIONS%snowLayers)%iDecision = sameRulesAllLayers ! SNTHERM option: same combination/sub-dividion rules applied to all layers + case('CLM_2010'); model_decisions(iLookDECISIONS%snowLayers)%iDecision = rulesDependLayerIndex ! CLM option: combination/sub-dividion rules depend on layer index + case default + err=10; message=trim(message)//"unknown option for combination/sub-division of snow layers [option="//trim(model_decisions(iLookDECISIONS%snowLayers)%cDecision)//"]"; return + end select + + ! choice of thermal conductivity representation for snow + select case(trim(model_decisions(iLookDECISIONS%thCondSnow)%cDecision)) + case('tyen1965'); model_decisions(iLookDECISIONS%thCondSnow)%iDecision = Yen1965 ! Yen (1965) + case('melr1977'); model_decisions(iLookDECISIONS%thCondSnow)%iDecision = Mellor1977 ! Mellor (1977) + case('jrdn1991'); model_decisions(iLookDECISIONS%thCondSnow)%iDecision = Jordan1991 ! Jordan (1991) + case('smnv2000'); model_decisions(iLookDECISIONS%thCondSnow)%iDecision = Smirnova2000 ! Smirnova et al. (2000) + case default + err=10; message=trim(message)//"unknown option for thermal conductivity of snow [option="//trim(model_decisions(iLookDECISIONS%thCondSnow)%cDecision)//"]"; return + end select + + ! choice of thermal conductivity representation for soil + select case(trim(model_decisions(iLookDECISIONS%thCondSoil)%cDecision)) + case('funcSoilWet'); model_decisions(iLookDECISIONS%thCondSoil)%iDecision = funcSoilWet ! function of soil wetness + case('mixConstit' ); model_decisions(iLookDECISIONS%thCondSoil)%iDecision = mixConstit ! mixture of constituents + case('hanssonVZJ' ); model_decisions(iLookDECISIONS%thCondSoil)%iDecision = hanssonVZJ ! test case for the mizoguchi lab experiment, Hansson et al. VZJ 2004 + case default + err=10; message=trim(message)//"unknown option for thermal conductivity of soil [option="//trim(model_decisions(iLookDECISIONS%thCondSoil)%cDecision)//"]"; return + end select + + ! choice of method for the spatial representation of groundwater + select case(trim(model_decisions(iLookDECISIONS%spatial_gw)%cDecision)) + case('localColumn'); model_decisions(iLookDECISIONS%spatial_gw)%iDecision = localColumn ! separate groundwater in each local soil column + case('singleBasin'); model_decisions(iLookDECISIONS%spatial_gw)%iDecision = singleBasin ! single groundwater store over the entire basin + case default + err=10; message=trim(message)//"unknown option for spatial representation of groundwater [option="//trim(model_decisions(iLookDECISIONS%spatial_gw)%cDecision)//"]"; return + end select + + ! choice of routing method + select case(trim(model_decisions(iLookDECISIONS%subRouting)%cDecision)) + case('timeDlay'); model_decisions(iLookDECISIONS%subRouting)%iDecision = timeDelay ! time-delay histogram + case('qInstant'); model_decisions(iLookDECISIONS%subRouting)%iDecision = qInstant ! instantaneous routing + case default + err=10; message=trim(message)//"unknown option for sub-grid routing [option="//trim(model_decisions(iLookDECISIONS%subRouting)%cDecision)//"]"; return + end select + + ! choice of new snow density + ! NOTE: use hedAndPom as the default, where density method is undefined (not populated yet) + select case(trim(model_decisions(iLookDECISIONS%snowDenNew)%cDecision)) + case('hedAndPom','notPopulatedYet'); model_decisions(iLookDECISIONS%snowDenNew)%iDecision = hedAndPom ! Hedstrom and Pomeroy (1998), expoential increase + case('anderson'); model_decisions(iLookDECISIONS%snowDenNew)%iDecision = anderson ! Anderson 1976 + case('pahaut_76'); model_decisions(iLookDECISIONS%snowDenNew)%iDecision = pahaut_76 ! Pahaut 1976, wind speed dependent (derived from Col de Porte, French Alps) + case('constDens'); model_decisions(iLookDECISIONS%snowDenNew)%iDecision = constDens ! Constant new snow density + case default + err=10; message=trim(message)//"unknown option for new snow density [option="//trim(model_decisions(iLookDECISIONS%snowDenNew)%cDecision)//"]"; return + end select + + ! choice of snow unloading from canopy + select case(trim(model_decisions(iLookDECISIONS%snowUnload)%cDecision)) + case('meltDripUnload','notPopulatedYet'); model_decisions(iLookDECISIONS%snowUnload)%iDecision = meltDripUnload ! Hedstrom and Pomeroy (1998), Storck et al 2002 (snowUnloadingCoeff & ratioDrip2Unloading) + case('windUnload'); model_decisions(iLookDECISIONS%snowUnload)%iDecision = windUnload ! Roesch et al 2001, formulate unloading based on wind and temperature + case default + err=10; message=trim(message)//"unknown option for snow unloading [option="//trim(model_decisions(iLookDECISIONS%snowUnload)%cDecision)//"]"; return + end select + + ! choice of maximum infiltration rate method (for liq_flux soil hydrology upper boundary condition only, all others go by the behavior of noInfExc) + ! NOTE: use topmodel_GA as the default, where infiltration method is undefined (not populated yet) + select case(trim(model_decisions(iLookDECISIONS%infRateMax)%cDecision)) + case('GreenAmpt'); model_decisions(iLookDECISIONS%infRateMax)%iDecision = GreenAmpt ! Green-Ampt + case('topmodel_GA'); model_decisions(iLookDECISIONS%infRateMax)%iDecision = topmodel_GA ! Green-Ampt with TOPMODEL conductivity rate + case('noInfExc'); model_decisions(iLookDECISIONS%infRateMax)%iDecision = noInfiltrationExcess ! no infiltration excess runoff (saturation excess may still occur) + case default + if (trim(model_decisions(iLookDECISIONS%num_method)%cDecision)=='itertive')then + model_decisions(iLookDECISIONS%infRateMax)%iDecision = topmodel_GA ! included for backwards compatibility + else + err=10; message=trim(message)//"unknown option for infiltration method [option="//trim(model_decisions(iLookDECISIONS%infRateMax)%cDecision)//"]"; return + endif + end select + ! choice of method for saturation excess surface runoff + ! NOTE: use homegrown surface runoff procedure as the default + select case(trim(model_decisions(iLookDECISIONS%surfRun_SE)%cDecision)) + case('zero_SE'); model_decisions(iLookDECISIONS%surfRun_SE)%iDecision = zero_SE ! saturation excess surface runoff is zero + case('homegrown_SE','notPopulatedYet'); model_decisions(iLookDECISIONS%surfRun_SE)%iDecision = homegrown_SE ! use SUMMA's homegrown surface runoff procedure for saturation excess runoff + case('FUSEPRMS'); model_decisions(iLookDECISIONS%surfRun_SE)%iDecision = FUSEPRMS ! use FUSE PRMS for saturation excess surface runoff + case('FUSEAVIC'); model_decisions(iLookDECISIONS%surfRun_SE)%iDecision = FUSEAVIC ! use FUSE ARNO/VIC for saturation excess surface runoff + case('FUSETOPM'); model_decisions(iLookDECISIONS%surfRun_SE)%iDecision = FUSETOPM ! use FUSE TOPMODEL for saturation excess surface runoff + case default + err=10; message=trim(message)//"unknown option for saturation excess surface runoff method [option="//trim(model_decisions(iLookDECISIONS%surfRun_SE)%cDecision)//"]"; return + end select + + ! ----------------------------------------------------------------------------------------------------------------------------------------------- + ! check for consistency among options + ! ----------------------------------------------------------------------------------------------------------------------------------------------- + ! check zero flux lower boundary for topmodel baseflow option + select case(model_decisions(iLookDECISIONS%groundwatr)%iDecision) + case(qbaseTopmodel) + if(model_decisions(iLookDECISIONS%bcLowrSoiH)%iDecision /= zeroFlux)then + message=trim(message)//'lower boundary condition for soil hydology must be zeroFlux with qbaseTopmodel option for groundwater (set "bcLowrSoiH" to "zeroFlux" in model decisions input file)' + err=20; return + end if + end select + + ! check power-law profile is selected when using topmodel baseflow option + select case(model_decisions(iLookDECISIONS%groundwatr)%iDecision) + case(qbaseTopmodel) + if(model_decisions(iLookDECISIONS%hc_profile)%iDecision /= powerLaw_profile)then + message=trim(message)//'power-law hydraulic conductivity profile must be selected when using topmodel baseflow option (set "hc_profile" to "pow_prof" in model decisions input file)' + err=20; return + end if + end select + + ! check bigBucket groundwater option is used when for spatial groundwater is singleBasin + if(model_decisions(iLookDECISIONS%spatial_gw)%iDecision == singleBasin)then + if(model_decisions(iLookDECISIONS%groundwatr)%iDecision /= bigBucket)then + message=trim(message)//'groundwater parameterization must be bigBucket when using singleBasin for spatial_gw (set "groundwatr" to "bigBuckt" in model decisions input file)' + err=20; return + end if + end if + + ! check that maximum infiltration rate assumption aligns with groundwater option + ! TOPMODEL baseflow assumes a reduction in hydraulic conductivity with depth, possibly to 0 at the bottom of the soil, and infiltration rate assumptions must match these conductivities + ! BigBucket means we have an aquifer below the soil column, for which Green-Ampt is the most basic assumption. TOPMODEL_GA is not appropriate for this but for backward compatability we throw a warning instead of a graceful exit + select case(model_decisions(iLookDECISIONS%groundwatr)%iDecision) + case(qbaseTopmodel) + if(model_decisions(iLookDECISIONS%infRateMax)%iDecision /= topModel_GA)then + message=trim(message)//'maximum infiltration rate method must be topmodel_GA when using qTopmodl for groundwatr, not '//trim(model_decisions(iLookDECISIONS%infRateMax)%cDecision)//' (set "infRateMax" to "topmodel_GA" in model decisions input file)' + err=20; return + end if + case(bigBucket) + if(model_decisions(iLookDECISIONS%infRateMax)%iDecision == topModel_GA)then + write(*,*) 'DEPRECATION WARNING: Combining groundwater parametrization bigBucket with maximum infiltration rate method topModel_GA is not recommended. This was the default in SUMMA v3.x.x and below, but is not appropriate for this groundwater option. Please use Green-Ampt instead (set "infRateMax" to "GreenAmpt" in model decisions input file)' + ! This preps us for when we want to remove this option in the future + !message=trim(message)//'maximum infiltration rate method (infRateMax) cannot be topModel_GA when using BigBucket for groundwater, use GreenAmpt instead' + !err=20; return + end if + end select + +end subroutine mDecisions + +! ************************************************************************************************ +! private subroutine readoption: read information from model decisions file +! ************************************************************************************************ +subroutine readoption(err,message) + ! used to read information from model decisions file + USE ascii_util_module,only:file_open ! open file + USE ascii_util_module,only:linewidth ! max character number for one line + USE ascii_util_module,only:get_vlines ! get a vector of non-comment lines + USE summaFileManager,only:SETTINGS_PATH ! path for metadata files + USE summaFileManager,only:M_DECISIONS ! definition of modeling options + USE get_ixname_module,only:get_ixdecisions ! identify index of named variable + USE globalData,only:model_decisions ! model decision structure + implicit none + ! define output + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! define local variables + character(len=256) :: cmessage ! error message for downwind routine + character(LEN=256) :: infile ! input filename + integer(i4b) :: unt ! file unit (free unit output from file_open) + character(LEN=linewidth),allocatable :: charline(:) ! vector of character strings + integer(i4b) :: nDecisions ! number of model decisions + integer(i4b) :: iDecision ! index of model decisions + character(len=32) :: decision ! name of model decision + character(len=32) :: option ! option for model decision + integer(i4b) :: iVar ! index of the decision in the data structure + ! Start procedure here + err=0; message='readoption/' + ! build filename + infile = trim(SETTINGS_PATH)//trim(M_DECISIONS) +#ifndef NGEN_ACTIVE + write(*,'(2(a,1x))') 'decisions file = ', trim(infile) +#endif + ! open file + call file_open(trim(infile),unt,err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + ! get a list of character strings from non-comment lines + call get_vlines(unt,charline,err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + ! close the file unit + close(unt) + ! get the number of model decisions + nDecisions = size(charline) + ! populate the model decisions structure + do iDecision=1,nDecisions + ! extract name of decision and the decision selected + read(charline(iDecision),*,iostat=err) option, decision + if (err/=0) then; err=30; message=trim(message)//"errorReadLine"; return; end if + ! get the index of the decision in the data structure + iVar = get_ixdecisions(trim(option)) +#ifndef NGEN_ACTIVE + write(*,'(i4,1x,a)') iDecision, trim(option)//': '//trim(decision) +#endif + if(iVar<=0)then; err=40; message=trim(message)//"cannotFindDecisionIndex[name='"//trim(option)//"']"; return; end if + ! populate the model decisions structure + model_decisions(iVar)%cOption = trim(option) + model_decisions(iVar)%cDecision = trim(decision) + end do +end subroutine readoption end module mDecisions_module diff --git a/build/source/engine/matrixOper.f90 b/build/source/engine/matrixOper.f90 old mode 100755 new mode 100644 index a3a3d6e15..6c09d8c49 --- a/build/source/engine/matrixOper.f90 +++ b/build/source/engine/matrixOper.f90 @@ -23,9 +23,6 @@ module matrixOper_module ! data types USE nrtype -! access the global print flag -USE globalData,only:globalPrintFlag - ! access named variables to describe the form and structure of the matrices used in the numerical solver USE globalData,only: nRHS ! number of unknown variables on the RHS of the linear system A.X=B USE globalData,only: ku ! number of super-diagonal bands @@ -51,11 +48,11 @@ subroutine scaleMatrices(ixMatrix,nState,aJac,fScale,xScale,aJacScaled,err,messa ! input variables integer(i4b),intent(in) :: ixMatrix ! type of matrix (full Jacobian or band diagonal) integer(i4b),intent(in) :: nState ! number of state variables - real(rkind),intent(in) :: aJac(:,:) ! original Jacobian matrix - real(rkind),intent(in) :: fScale(:) ! function scaling vector - real(rkind),intent(in) :: xScale(:) ! "variable" scaling vector, i.e., for state variables + real(rkind),intent(in) :: aJac(:,:) ! original Jacobian matrix + real(rkind),intent(in) :: fScale(:) ! characteristic scale of the function evaluations + real(rkind),intent(in) :: xScale(:) ! characteristic scale of the state vector ! output variables - real(rkind),intent(out) :: aJacScaled(:,:) ! scaled Jacobian matrix + real(rkind),intent(out) :: aJacScaled(:,:) ! scaled Jacobian matrix integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! --------------------------------------------------------------------------------------------------------- @@ -110,10 +107,10 @@ subroutine computeGradient(ixMatrix,nState,aJac,rVec,grad,err,message) ! input integer(i4b),intent(in) :: ixMatrix ! type of matrix (full Jacobian or band diagonal) integer(i4b),intent(in) :: nState ! number of state variables - real(rkind),intent(in) :: aJac(:,:) ! jacobian matrix - real(rkind),intent(in) :: rVec(:) ! residual vector + real(rkind),intent(in) :: aJac(:,:) ! jacobian matrix + real(rkind),intent(in) :: rVec(:) ! residual vector ! output - real(rkind),intent(out) :: grad(:) ! gradient + real(rkind),intent(out) :: grad(:) ! gradient integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local @@ -158,13 +155,13 @@ subroutine lapackSolv(ixMatrix,nState,aJac,rVec,xInc,err,message) ! dummy integer(i4b),intent(in) :: ixMatrix ! type of matrix (full Jacobian or band diagonal) integer(i4b),intent(in) :: nState ! number of state variables - real(rkind),intent(inout) :: aJac(:,:) ! input = the Jacobian matrix A; output = decomposed matrix - real(rkind),intent(in) :: rVec(:) ! the residual vector B - real(rkind),intent(out) :: xInc(:) ! the solution vector X + real(rkind),intent(inout) :: aJac(:,:) ! input = the Jacobian matrix A; output = decomposed matrix + real(rkind),intent(in) :: rVec(:) ! the residual vector B + real(rkind),intent(out) :: xInc(:) ! the solution vector X integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local - real(rkind) :: rhs(nState,1) ! the nState-by-nRHS matrix of matrix B, for the linear system A.X=B + real(rkind) :: rhs(nState,1) ! the nState-by-nRHS matrix of matrix B, for the linear system A.X=B integer(i4b) :: iPiv(nState) ! defines if row i of the matrix was interchanged with row iPiv(i) ! initialize error control select case(ixMatrix) @@ -173,6 +170,8 @@ subroutine lapackSolv(ixMatrix,nState,aJac,rVec,xInc,err,message) case default; err=20; message=trim(message)//'unable to identify option for the type of matrix' end select + !call openblas_set_num_threads(1) ! set the number of threads to 1 + ! form the rhs matrix ! NOTE: copy the vector here to ensure that the residual vector is not overwritten rhs(:,1) = rVec(:) diff --git a/build/source/engine/nr_utility.f90 b/build/source/engine/nr_utility.f90 old mode 100755 new mode 100644 diff --git a/build/source/engine/nrtype.f90 b/build/source/engine/nrtype.f90 old mode 100755 new mode 100644 index c6ea58b9d..91088ada5 --- a/build/source/engine/nrtype.f90 +++ b/build/source/engine/nrtype.f90 @@ -2,6 +2,7 @@ MODULE nrtype IMPLICIT NONE SAVE ! data types + INTEGER, PARAMETER :: I8B = SELECTED_INT_KIND(18) INTEGER, PARAMETER :: I4B = SELECTED_INT_KIND(9) INTEGER, PARAMETER :: I2B = SELECTED_INT_KIND(4) INTEGER, PARAMETER :: I1B = SELECTED_INT_KIND(2) @@ -24,6 +25,6 @@ MODULE nrtype real(rkind), PARAMETER :: TWOPI_D=6.283185307179586476925286766559005768394_rkind ! missing values real(rkind), parameter :: nr_quadMissing=-9999._qp ! missing quadruple precision number - real(rkind), parameter :: nr_realMissing=-9999._rkind ! missing double precision number + real(rkind), parameter :: nr_realMissing=-9999._rkind ! missing real number integer(i4b), parameter :: nr_integerMissing=-9999 ! missing integer END MODULE nrtype diff --git a/build/source/engine/opSplittin.f90 b/build/source/engine/opSplittin.f90 old mode 100755 new mode 100644 index c1ba5b2df..77e5e3e26 --- a/build/source/engine/opSplittin.f90 +++ b/build/source/engine/opSplittin.f90 @@ -28,21 +28,6 @@ module opSplittin_module ! access missing values USE globalData,only:integerMissing ! missing integer -USE globalData,only:realMissing ! missing double precision number -USE globalData,only:quadMissing ! missing quadruple precision number - -! access matrix information -USE globalData,only: nBands ! length of the leading dimension of the band diagonal matrix -USE globalData,only: ixFullMatrix ! named variable for the full Jacobian matrix -USE globalData,only: ixBandMatrix ! named variable for the band diagonal matrix -USE globalData,only: iJac1 ! first layer of the Jacobian to print -USE globalData,only: iJac2 ! last layer of the Jacobian to print - -! domain types -USE globalData,only:iname_cas ! named variables for the canopy air space -USE globalData,only:iname_veg ! named variables for vegetation -USE globalData,only:iname_snow ! named variables for snow -USE globalData,only:iname_soil ! named variables for soil ! state variable type USE globalData,only:iname_nrgCanair ! named variable defining the energy of the canopy air space @@ -57,35 +42,18 @@ module opSplittin_module USE globalData,only:iname_watAquifer ! named variable defining the water storage in the aquifer ! global metadata -USE globalData,only:flux_meta ! metadata on the model fluxes -USE globalData,only:diag_meta ! metadata on the model diagnostic variables -USE globalData,only:prog_meta ! metadata on the model prognostic variables -USE globalData,only:deriv_meta ! metadata on the model derivatives -USE globalData,only:flux2state_orig ! metadata on flux-to-state mapping (original state variables) -USE globalData,only:flux2state_liq ! metadata on flux-to-state mapping (liquid water state variables) - -! constants -USE multiconst,only:& - gravity, & ! acceleration of gravity (m s-2) - Tfreeze, & ! temperature at freezing (K) - LH_fus, & ! latent heat of fusion (J kg-1) - LH_vap, & ! latent heat of vaporization (J kg-1) - LH_sub, & ! latent heat of sublimation (J kg-1) - Cp_air, & ! specific heat of air (J kg-1 K-1) - iden_air, & ! intrinsic density of air (kg m-3) - iden_ice, & ! intrinsic density of ice (kg m-3) - iden_water ! intrinsic density of liquid water (kg m-3) - +USE globalData,only:flux_meta ! metadata on the model fluxes +USE globalData,only:diag_meta ! metadata on the model diagnostic variables +USE globalData,only:prog_meta ! metadata on the model prognostic variables +USE globalData,only:deriv_meta ! metadata on the model derivatives +USE globalData,only:flux2state_orig ! metadata on flux-to-state mapping (original state variables) +USE globalData,only:flux2state_liq ! metadata on flux-to-state mapping (liquid water state variables) + ! provide access to indices that define elements of the data structures -USE var_lookup,only:iLookATTR ! named variables for structure elements -USE var_lookup,only:iLookTYPE ! named variables for structure elements -USE var_lookup,only:iLookPROG ! named variables for structure elements -USE var_lookup,only:iLookDIAG ! named variables for structure elements USE var_lookup,only:iLookFLUX ! named variables for structure elements -USE var_lookup,only:iLookFORCE ! named variables for structure elements -USE var_lookup,only:iLookPARAM ! named variables for structure elements USE var_lookup,only:iLookINDEX ! named variables for structure elements USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure +USE var_lookup,only:iLookPARAM ! named variables for elements of the parameter structure ! look up structure for variable types USE var_lookup,only:iLookVarType @@ -95,23 +63,22 @@ module opSplittin_module ! provide access to the derived types to define the data structures USE data_types,only:& - var_i, & ! data vector (i4b) - var_d, & ! data vector (dp) - var_flagVec, & ! data vector with variable length dimension (i4b) - var_ilength, & ! data vector with variable length dimension (i4b) - var_dlength, & ! data vector with variable length dimension (dp) - model_options ! defines the model decisions - -! look-up values for the choice of groundwater representation (local-column, or single-basin) + var_i, & ! data vector (i4b) + var_d, & ! data vector (rkind) + var_flagVec, & ! data vector with variable length dimension (lgt) + var_ilength, & ! data vector with variable length dimension (i4b) + var_dlength, & ! data vector with variable length dimension (rkind) + zLookup, & ! lookup tables + model_options, & ! defines the model decisions + out_type_stateFilter, & ! classes for stateFilter objects + in_type_indexSplit,out_type_indexSplit, & ! classes for indexSplit objects + in_type_varSubstep,io_type_varSubstep,out_type_varSubstep ! classes for varSubstep objects + +! look-up values for the numerical method USE mDecisions_module,only: & - localColumn, & ! separate groundwater representation in each local soil column - singleBasin ! single groundwater store over the entire basin - -! look-up values for the choice of groundwater parameterization -USE mDecisions_module,only: & - qbaseTopmodel, & ! TOPMODEL-ish baseflow parameterization - bigBucket, & ! a big bucket (lumped aquifer model) - noExplicit ! no explicit groundwater parameterization + homegrown ,& ! home-grown backward Euler solution using concepts from numerical recipes + kinsol ,& ! SUNDIALS backward Euler solution using Kinsol + ida ! SUNDIALS solution using IDA ! safety: set private unless specified otherwise implicit none @@ -121,7 +88,6 @@ module opSplittin_module ! named variables for the coupling method integer(i4b),parameter :: fullyCoupled=1 ! 1st try: fully coupled solution integer(i4b),parameter :: stateTypeSplit=2 ! 2nd try: separate solutions for each state type -integer(i4b),parameter :: nCoupling=2 ! number of possible solutions ! named variables for the state variable split integer(i4b),parameter :: nrgSplit=1 ! order in sequence for the energy operation @@ -140,998 +106,1591 @@ module opSplittin_module ! named variables for the switch between states and domains integer(i4b),parameter :: fullDomain=1 ! full domain (veg+snow+soil) -integer(i4b),parameter :: subDomain=2 ! sub domain (veg, snow, and soil separately) +integer(i4b),parameter :: subDomain=2 ! sub domain (veg, snow, soil, and aquifer separately) ! maximum number of possible splits integer(i4b),parameter :: nStateTypes=2 ! number of state types (energy, water) integer(i4b),parameter :: nDomains=4 ! number of domains (vegetation, snow, soil, and aquifer) -! control parameters -real(rkind),parameter :: valueMissing=-9999._rkind ! missing value -real(rkind),parameter :: verySmall=1.e-12_rkind ! a very small number (used to check consistency) -real(rkind),parameter :: veryBig=1.e+20_rkind ! a very big number -real(rkind),parameter :: dx = 1.e-8_rkind ! finite difference increment +! class definitions + +type, public :: split_select_type ! class for selecting operator splitting methods + ! opSplittin indices (in order) + integer(i4b) :: iSplit ! iteration counter for split_select_loop + integer(i4b) :: ixCoupling + integer(i4b) :: iStateTypeSplit + integer(i4b) :: ixStateThenDomain ! 1=state type split; 2=domain split within a given state type + integer(i4b) :: iDomainSplit + integer(i4b) :: ixSolution + integer(i4b) :: iStateSplit + ! variables for specifying the split + integer(i4b) :: nState ! # of state variables + integer(i4b) :: nSubset ! number of selected state variables for a given split + type(var_flagVec) :: fluxMask ! integer mask defining model fluxes + logical(lgt),allocatable :: stateMask(:) ! mask defining desired state variables + ! flags for splitting method control + logical(lgt) :: stateTypeSplitting,stateThenDomain,domainSplit,solution,stateSplit + contains + procedure :: initialize_flags => split_select_initialize_flags ! initialize flags that control operations + procedure :: initialize_ixCoupling => split_select_initialize_ixCoupling ! initialize operator splitting indices + procedure :: initialize_iStateTypeSplit => split_select_initialize_iStateTypeSplit ! initialize operator splitting indices + procedure :: initialize_ixStateThenDomain => split_select_initialize_ixStateThenDomain ! initialize operator splitting indices + procedure :: initialize_iDomainSplit => split_select_initialize_iDomainSplit ! initialize operator splitting indices + procedure :: initialize_ixSolution => split_select_initialize_ixSolution ! initialize operator splitting indices + procedure :: initialize_iStateSplit => split_select_initialize_iStateSplit ! initialize operator splitting indices + + procedure :: get_stateMask => split_select_compute_stateMask ! compute stateMask and nSubset and load into class object + + procedure :: advance_iSplit => split_select_advance_iSplit ! advance coupling iterator + procedure :: advance_ixCoupling => split_select_advance_ixCoupling ! advance coupling iterator + procedure :: advance_iStateTypeSplit => split_select_advance_iStateTypeSplit ! advance stateTypeSplitting iterator + procedure :: advance_ixStateThenDomain => split_select_advance_ixStateThenDomain ! advance stateThenDomain iterator + procedure :: advance_iDomainSplit => split_select_advance_iDomainSplit ! advance domainSplit iterator + procedure :: advance_ixSolution => split_select_advance_ixSolution ! advance solution iterator + procedure :: advance_iStateSplit => split_select_advance_iStateSplit ! advance stateSplit iterator + + procedure :: logic_exit_stateTypeSplitting => split_select_logic_exit_stateTypeSplitting ! get logical for branch + procedure :: logic_exit_stateThenDomain => split_select_logic_exit_stateThenDomain ! get logical for branch + procedure :: logic_exit_domainSplit => split_select_logic_exit_domainSplit ! get logical for branch + procedure :: logic_exit_solution => split_select_logic_exit_solution ! get logical for branch + procedure :: logic_exit_stateSplit => split_select_logic_exit_stateSplit ! get logical for branch + + procedure :: logic_initialize_stateTypeSplitting => split_select_logic_initialize_stateTypeSplitting ! get logical for branch + procedure :: logic_initialize_stateThenDomain => split_select_logic_initialize_stateThenDomain ! get logical for branch + procedure :: logic_initialize_domainSplit => split_select_logic_initialize_domainSplit ! get logical for branch + procedure :: logic_initialize_solution => split_select_logic_initialize_solution ! get logical for branch + procedure :: logic_initialize_stateSplit => split_select_logic_initialize_stateSplit ! get logical for branch + + procedure :: logic_finalize_stateTypeSplitting => split_select_logic_finalize_stateTypeSplitting ! get logical for branch + procedure :: logic_finalize_stateThenDomain => split_select_logic_finalize_stateThenDomain ! get logical for branch + procedure :: logic_finalize_domainSplit => split_select_logic_finalize_domainSplit ! get logical for branch + procedure :: logic_finalize_solution => split_select_logic_finalize_solution ! get logical for branch + procedure :: logic_finalize_stateSplit => split_select_logic_finalize_stateSplit ! get logical for branch +end type split_select_type contains - - ! ********************************************************************************************************** - ! public subroutine opSplittin: run the coupled energy-mass model for one timestep - ! - ! The logic of the solver is as follows: - ! (1) Attempt different solutions in the following order: (a) fully coupled; (b) split by state type and by - ! domain type for a given energy and mass split (vegetation, snow, and soil); and (c) scalar solution - ! for a given state type and domain subset. - ! (2) For a given split, compute a variable number of substeps (in varSubstep). - ! ********************************************************************************************************** - subroutine opSplittin(& - ! input: model control - nSnow, & ! intent(in): number of snow layers - nSoil, & ! intent(in): number of soil layers - nLayers, & ! intent(in): total number of layers - nState, & ! intent(in): total number of state variables - dt, & ! intent(inout): time step (s) - firstSubStep, & ! intent(in): flag to denote first sub-step - computeVegFlux, & ! intent(in): flag to denote if computing energy flux over vegetation +! ********************************************************************************************************** +! public subroutine opSplittin: run the coupled energy-mass model for one timestep +! +! The logic of the solver is as follows: +! (1) Attempt different solutions in the following order: (a) fully coupled; (b) split by state type and by +! domain type for a given energy and mass split (vegetation, snow, and soil); and (c) scalar solution +! for a given state type and domain subset. +! (2) For a given split, compute a variable number of substeps (in varSubstep). +! ********************************************************************************************************** +subroutine opSplittin(& + ! input: model control + nSnow, & ! intent(in): number of snow layers + nSoil, & ! intent(in): number of soil layers + nLayers, & ! intent(in): total number of layers + nState, & ! intent(in): total number of state variables + dt, & ! intent(in): time step (s) + whole_step, & ! intent(in): length of whole step for surface drainage and average flux + firstSubStep, & ! intent(in): flag to denote first sub-step + firstInnerStep, & ! intent(in): flag to denote if the last time step in maxstep subStep + computeVegFlux, & ! intent(in): flag to denote if computing energy flux over vegetation ! input/output: data structures - type_data, & ! intent(in): type of vegetation and soil - attr_data, & ! intent(in): spatial attributes - forc_data, & ! intent(in): model forcing data - mpar_data, & ! intent(in): model parameters - indx_data, & ! intent(inout): index data - prog_data, & ! intent(inout): model prognostic variables for a local HRU - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - flux_data, & ! intent(inout): model fluxes for a local HRU - bvar_data, & ! intent(in): model variables for the local basin - model_decisions,& ! intent(in): model decisions - ! output: model control - dtMultiplier, & ! intent(out): substep multiplier (-) - tooMuchMelt, & ! intent(out): flag to denote that ice is insufficient to support melt - stepFailure, & ! intent(out): flag to denote step failure - ixCoupling, & ! intent(out): coupling method used in this iteration - err,message) ! intent(out): error code and error message - ! --------------------------------------------------------------------------------------- - ! structure allocations - USE allocspace_module,only:allocLocal ! allocate local data structures - ! simulation of fluxes and residuals given a trial state vector - USE soil_utils_module,only:matricHead ! compute the matric head based on volumetric water content - USE soil_utils_module,only:liquidHead ! compute the liquid water matric potential - ! population/extraction of state vectors - USE indexState_module,only:indexSplit ! get state indices - USE varSubstep_module,only:varSubstep ! complete substeps for a given split - ! identify name of variable type (for error message) - USE get_ixName_module,only:get_varTypeName ! to access type strings for error messages - implicit none - ! --------------------------------------------------------------------------------------- - ! * dummy variables - ! --------------------------------------------------------------------------------------- - ! input: model control - integer(i4b),intent(in) :: nSnow ! number of snow layers - integer(i4b),intent(in) :: nSoil ! number of soil layers - integer(i4b),intent(in) :: nLayers ! total number of layers - integer(i4b),intent(in) :: nState ! total number of state variables - real(rkind),intent(inout) :: dt ! time step (seconds) - logical(lgt),intent(in) :: firstSubStep ! flag to indicate if we are processing the first sub-step - logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) - ! input/output: data structures - type(var_i),intent(in) :: type_data ! type of vegetation and soil - type(var_d),intent(in) :: attr_data ! spatial attributes - type(var_d),intent(in) :: forc_data ! model forcing data - type(var_dlength),intent(in) :: mpar_data ! model parameters - type(var_ilength),intent(inout) :: indx_data ! indices for a local HRU - type(var_dlength),intent(inout) :: prog_data ! prognostic variables for a local HRU - type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU - type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU - type(var_dlength),intent(in) :: bvar_data ! model variables for the local basin - type(model_options),intent(in) :: model_decisions(:) ! model decisions - ! output: model control - real(rkind),intent(out) :: dtMultiplier ! substep multiplier (-) - logical(lgt),intent(out) :: tooMuchMelt ! flag to denote that ice is insufficient to support melt - logical(lgt),intent(out) :: stepFailure ! flag to denote step failure - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! ********************************************************************************************************************************************************* - ! ********************************************************************************************************************************************************* - ! --------------------------------------------------------------------------------------- - ! * general local variables - ! --------------------------------------------------------------------------------------- - character(LEN=256) :: cmessage ! error message of downwind routine - integer(i4b) :: minLayer ! the minimum layer used in assigning flags for flux aggregations - integer(i4b) :: iOffset ! offset to account for different indices in the soil domain - integer(i4b) :: iMin(1),iMax(1) ! bounds of a given vector - integer(i4b) :: iLayer,jLayer ! index of model layer - integer(i4b) :: iSoil ! index of soil layer - integer(i4b) :: iVar ! index of variables in data structures - logical(lgt) :: firstSuccess ! flag to define the first success - logical(lgt) :: firstFluxCall ! flag to define the first flux call - logical(lgt) :: reduceCoupledStep ! flag to define the need to reduce the length of the coupled step - type(var_dlength) :: prog_temp ! temporary model prognostic variables - type(var_dlength) :: diag_temp ! temporary model diagnostic variables - type(var_dlength) :: flux_temp ! temporary model fluxes - type(var_dlength) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables - real(rkind),dimension(nLayers) :: mLayerVolFracIceInit ! initial vector for volumetric fraction of ice (-) - ! ------------------------------------------------------------------------------------------------------ - ! * operator splitting - ! ------------------------------------------------------------------------------------------------------ - ! minimum timestep - real(rkind),parameter :: dtmin_coupled=1800._rkind ! minimum time step for the fully coupled solution (seconds) - real(rkind),parameter :: dtmin_split=60._rkind ! minimum time step for the fully split solution (seconds) - real(rkind),parameter :: dtmin_scalar=10._rkind ! minimum time step for the scalar solution (seconds) - real(rkind) :: dt_min ! minimum time step (seconds) - real(rkind) :: dtInit ! initial time step (seconds) - ! explicit error tolerance (depends on state type split, so defined here) - real(rkind),parameter :: errorTolLiqFlux=0.01_rkind ! error tolerance in the explicit solution (liquid flux) - real(rkind),parameter :: errorTolNrgFlux=10._rkind ! error tolerance in the explicit solution (energy flux) - ! number of substeps taken for a given split - integer(i4b) :: nSubsteps ! number of substeps taken for a given split - ! named variables defining the coupling and solution method - integer(i4b) :: ixCoupling ! index of coupling method (1,2) - integer(i4b) :: ixSolution ! index of solution method (1,2) - integer(i4b) :: ixStateThenDomain ! switch between the state and domain (1,2) - integer(i4b) :: tryDomainSplit ! (0,1) - flag to try the domain split - ! actual number of splits - integer(i4b) :: nStateTypeSplit ! number of splits for the state type - integer(i4b) :: nDomainSplit ! number of splits for the domain - integer(i4b) :: nStateSplit ! number of splits for the states within a given domain - ! indices for the state type and the domain split - integer(i4b) :: iStateTypeSplit ! index of the state type split - integer(i4b) :: iDomainSplit ! index of the domain split - integer(i4b) :: iStateSplit ! index of the state split - ! flux masks - logical(lgt) :: neededFlux(nFlux) ! .true. if flux is needed at all - logical(lgt) :: desiredFlux ! .true. if flux is desired for a given split - type(var_ilength) :: fluxCount ! number of times each flux is updated (should equal nSubsteps) - type(var_flagVec) :: fluxMask ! mask defining model fluxes - ! state masks - integer(i4b),dimension(nState) :: stateCheck ! number of times each state variable is updated (should equal 1) - logical(lgt),dimension(nState) :: stateMask ! mask defining desired state variables - integer(i4b) :: nSubset ! number of selected state variables for a given split - ! flags - logical(lgt) :: failure ! flag to denote failure of substepping - logical(lgt) :: doAdjustTemp ! flag to adjust temperature after the mass split - logical(lgt) :: failedMinimumStep ! flag to denote failure of substepping for a given split - integer(i4b) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) - ! --------------------------------------------------------------------------------------- - ! point to variables in the data structures - ! --------------------------------------------------------------------------------------- - globalVars: associate(& - ! model decisions - ixGroundwater => model_decisions(iLookDECISIONS%groundwatr)%iDecision ,& ! intent(in): [i4b] groundwater parameterization - ixSpatialGroundwater => model_decisions(iLookDECISIONS%spatial_gw)%iDecision ,& ! intent(in): [i4b] spatial representation of groundwater (local-column or single-basin) - ! domain boundary conditions - airtemp => forc_data%var(iLookFORCE%airtemp) ,& ! intent(in): [dp] temperature of the upper boundary of the snow and soil domains (K) - ! vector of energy and hydrology indices for the snow and soil domains - ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the snow+soil domain - ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the snow+soil domain - nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg )%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow+soil domain - nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology state variables in the snow+soil domain - ! indices of model state variables - ixMapSubset2Full => indx_data%var(iLookINDEX%ixMapSubset2Full)%dat ,& ! intent(in): [i4b(:)] list of indices in the state subset (missing for values not in the subset) - ixStateType => indx_data%var(iLookINDEX%ixStateType)%dat ,& ! intent(in): [i4b(:)] indices defining the type of the state (ixNrgState...) - ixNrgCanair => indx_data%var(iLookINDEX%ixNrgCanair)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for energy states in canopy air space domain - ixNrgCanopy => indx_data%var(iLookINDEX%ixNrgCanopy)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for energy states in the canopy domain - ixHydCanopy => indx_data%var(iLookINDEX%ixHydCanopy)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for hydrology states in the canopy domain - ixNrgLayer => indx_data%var(iLookINDEX%ixNrgLayer)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for energy states in the snow+soil domain - ixHydLayer => indx_data%var(iLookINDEX%ixHydLayer)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for hydrology states in the snow+soil domain - ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy air space energy state variable - ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable - ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) - ! numerix tracking - numberStateSplit => indx_data%var(iLookINDEX%numberStateSplit )%dat(1) ,& ! intent(inout): [i4b] number of state splitting solutions (-) - numberDomainSplitNrg => indx_data%var(iLookINDEX%numberDomainSplitNrg )%dat(1) ,& ! intent(inout): [i4b] number of domain splitting solutions for energy (-) - numberDomainSplitMass => indx_data%var(iLookINDEX%numberDomainSplitMass)%dat(1) ,& ! intent(inout): [i4b] number of domain splitting solutions for mass (-) - numberScalarSolutions => indx_data%var(iLookINDEX%numberScalarSolutions)%dat(1) ,& ! intent(inout): [i4b] number of scalar solutions (-) - ! domain configuration - canopyDepth => diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1) ,& ! intent(in): [dp] canopy depth (m) - mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat ,& ! intent(in): [dp(:)] depth of each layer in the snow-soil sub-domain (m) - ! snow parameters - snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1) ,& ! intent(in): [dp] scaling parameter for the snow freezing curve (K-1) - ! depth-varying soil parameters - vGn_m => diag_data%var(iLookDIAG%scalarVGn_m)%dat ,& ! intent(in): [dp(:)] van Genutchen "m" parameter (-) - vGn_n => mpar_data%var(iLookPARAM%vGn_n)%dat ,& ! intent(in): [dp(:)] van Genutchen "n" parameter (-) - vGn_alpha => mpar_data%var(iLookPARAM%vGn_alpha)%dat ,& ! intent(in): [dp(:)] van Genutchen "alpha" parameter (m-1) - theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat ,& ! intent(in): [dp(:)] soil porosity (-) - theta_res => mpar_data%var(iLookPARAM%theta_res)%dat ,& ! intent(in): [dp(:)] soil residual volumetric water content (-) - ! soil parameters - specificStorage => mpar_data%var(iLookPARAM%specificStorage)%dat(1) ,& ! intent(in): [dp] specific storage coefficient (m-1) - ! model diagnostic variables (fraction of liquid water) - scalarFracLiqVeg => diag_data%var(iLookDIAG%scalarFracLiqVeg)%dat(1) ,& ! intent(out): [dp] fraction of liquid water on vegetation (-) - mLayerFracLiqSnow => diag_data%var(iLookDIAG%mLayerFracLiqSnow)%dat ,& ! intent(out): [dp(:)] fraction of liquid water in each snow layer (-) - mLayerMeltFreeze => diag_data%var(iLookDIAG%mLayerMeltFreeze)%dat ,& ! intent(out): [dp(:)] melt-freeze in each snow and soil layer (kg m-3) - ! model state variables (vegetation canopy) - scalarCanairTemp => prog_data%var(iLookPROG%scalarCanairTemp)%dat(1) ,& ! intent(out): [dp] temperature of the canopy air space (K) - scalarCanopyTemp => prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1) ,& ! intent(out): [dp] temperature of the vegetation canopy (K) - scalarCanopyIce => prog_data%var(iLookPROG%scalarCanopyIce)%dat(1) ,& ! intent(out): [dp] mass of ice on the vegetation canopy (kg m-2) - scalarCanopyLiq => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1) ,& ! intent(out): [dp] mass of liquid water on the vegetation canopy (kg m-2) - scalarCanopyWat => prog_data%var(iLookPROG%scalarCanopyWat)%dat(1) ,& ! intent(out): [dp] mass of total water on the vegetation canopy (kg m-2) - ! model state variables (snow and soil domains) - mLayerTemp => prog_data%var(iLookPROG%mLayerTemp)%dat ,& ! intent(out): [dp(:)] temperature of each snow/soil layer (K) - mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat ,& ! intent(out): [dp(:)] volumetric fraction of ice (-) - mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat ,& ! intent(out): [dp(:)] volumetric fraction of liquid water (-) - mLayerVolFracWat => prog_data%var(iLookPROG%mLayerVolFracWat)%dat ,& ! intent(out): [dp(:)] volumetric fraction of total water (-) - mLayerMatricHead => prog_data%var(iLookPROG%mLayerMatricHead)%dat ,& ! intent(out): [dp(:)] matric head (m) - mLayerMatricHeadLiq => diag_data%var(iLookDIAG%mLayerMatricHeadLiq)%dat & ! intent(out): [dp(:)] matric potential of liquid water (m) - ) - ! --------------------------------------------------------------------------------------- - ! initialize error control - err=0; message="opSplittin/" - - ! ***** - ! (0) PRELIMINARIES... - ! ******************** - - ! ----- - ! * initialize... - ! --------------- - - ! set the global print flag - globalPrintFlag=.false. - - if(globalPrintFlag)& - print*, trim(message), dt - - ! initialize the first success call - firstSuccess=.false. - - ! initialize the flags - tooMuchMelt=.false. ! too much melt (merge snow layers) - stepFailure=.false. ! step failure - - ! initialize flag for the success of the substepping - failure=.false. - - ! initialize the flux check - neededFlux(:) = .false. - - ! initialize the state check - stateCheck(:) = 0 - - ! compute the total water content in the vegetation canopy - scalarCanopyWat = scalarCanopyLiq + scalarCanopyIce ! kg m-2 - - ! save volumetric ice content at the start of the step - ! NOTE: used for volumetric loss due to melt-freeze - mLayerVolFracIceInit(:) = mLayerVolFracIce(:) - - ! compute the total water content in snow and soil - ! NOTE: no ice expansion allowed for soil - if(nSnow>0)& - mLayerVolFracWat( 1:nSnow ) = mLayerVolFracLiq( 1:nSnow ) + mLayerVolFracIce( 1:nSnow )*(iden_ice/iden_water) - mLayerVolFracWat(nSnow+1:nLayers) = mLayerVolFracLiq(nSnow+1:nLayers) + mLayerVolFracIce(nSnow+1:nLayers) - - ! compute the liquid water matric potential (m) - ! NOTE: include ice content as part of the solid porosity - major effect of ice is to reduce the pore size; ensure that effSat=1 at saturation - ! (from Zhao et al., J. Hydrol., 1997: Numerical analysis of simultaneous heat and mass transfer...) - do iSoil=1,nSoil - call liquidHead(mLayerMatricHead(iSoil),mLayerVolFracLiq(nSnow+iSoil),mLayerVolFracIce(nSnow+iSoil), & ! input: state variables - vGn_alpha(iSoil),vGn_n(iSoil),theta_sat(iSoil),theta_res(iSoil),vGn_m(iSoil), & ! input: parameters - matricHeadLiq=mLayerMatricHeadLiq(iSoil), & ! output: liquid water matric potential (m) - err=err,message=cmessage) ! output: error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - end do ! looping through soil layers (computing liquid water matric potential) - - ! allocate space for the flux mask (used to define when fluxes are updated) - call allocLocal(flux_meta(:),fluxMask,nSnow,nSoil,err,cmessage) - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif - - ! allocate space for the flux count (used to check that fluxes are only updated once) - call allocLocal(flux_meta(:),fluxCount,nSnow,nSoil,err,cmessage) - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif - - ! allocate space for the temporary prognostic variable structure - call allocLocal(prog_meta(:),prog_temp,nSnow,nSoil,err,cmessage) - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif - - ! allocate space for the temporary diagnostic variable structure - call allocLocal(diag_meta(:),diag_temp,nSnow,nSoil,err,cmessage) - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif - - ! allocate space for the temporary flux variable structure - call allocLocal(flux_meta(:),flux_temp,nSnow,nSoil,err,cmessage) - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif - - ! allocate space for the derivative structure - call allocLocal(deriv_meta(:),deriv_data,nSnow,nSoil,err,cmessage) - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if - - ! intialize the flux conter - do iVar=1,size(flux_meta) ! loop through fluxes - fluxCount%var(iVar)%dat(:) = 0 - end do - - ! initialize the model fluxes - do iVar=1,size(flux_meta) ! loop through fluxes - if(flux2state_orig(iVar)%state1==integerMissing .and. flux2state_orig(iVar)%state2==integerMissing) cycle ! flux does not depend on state (e.g., input) - if(flux2state_orig(iVar)%state1==iname_watCanopy .and. .not.computeVegFlux) cycle ! use input fluxes in cases where there is no canopy - flux_data%var(iVar)%dat(:) = 0._rkind - end do - - ! initialize derivatives - do iVar=1,size(deriv_meta) - deriv_data%var(iVar)%dat(:) = 0._rkind - end do - - ! ========================================================================================================================================== - ! ========================================================================================================================================== - ! ========================================================================================================================================== - ! ========================================================================================================================================== - - ! loop through different coupling strategies - coupling: do ixCoupling=1,nCoupling - - ! initialize the time step - dtInit = min( merge(dt, dtmin_coupled, ixCoupling==fullyCoupled), dt) ! initial time step - dt_min = min( merge(dtmin_coupled, dtmin_split, ixCoupling==fullyCoupled), dt) ! minimum time step - - ! keep track of the number of state splits - if(ixCoupling/=fullyCoupled) numberStateSplit = numberStateSplit + 1 - - ! define the number of operator splits for the state type - select case(ixCoupling) - case(fullyCoupled); nStateTypeSplit=1 - case(stateTypeSplit); nStateTypeSplit=nStateTypes - case default; err=20; message=trim(message)//'coupling case not found'; return - end select ! operator splitting option - - ! define if we wish to try the domain split - select case(ixCoupling) - case(fullyCoupled); tryDomainSplit=0 - case(stateTypeSplit); tryDomainSplit=1 - case default; err=20; message=trim(message)//'coupling case not found'; return - end select ! operator splitting option - - ! state splitting loop - stateTypeSplitLoop: do iStateTypeSplit=1,nStateTypeSplit - - !print*, 'iStateTypeSplit, nStateTypeSplit = ', iStateTypeSplit, nStateTypeSplit - - ! ----- - ! * identify state-specific variables for a given state split... - ! -------------------------------------------------------------- - - ! flag to adjust the temperature - doAdjustTemp = (ixCoupling/=fullyCoupled .and. iStateTypeSplit==massSplit) - - ! modify the state type names associated with the state vector - if(ixCoupling/=fullyCoupled .and. iStateTypeSplit==massSplit)then - if(computeVegFlux)then - where(ixStateType(ixHydCanopy)==iname_watCanopy) ixStateType(ixHydCanopy)=iname_liqCanopy - endif - where(ixStateType(ixHydLayer) ==iname_watLayer) ixStateType(ixHydLayer) =iname_liqLayer - where(ixStateType(ixHydLayer) ==iname_matLayer) ixStateType(ixHydLayer) =iname_lmpLayer - endif ! if modifying state variables for the mass split - - ! first try the state type split, then try the domain split within a given state type - stateThenDomain: do ixStateThenDomain=1,1+tryDomainSplit ! 1=state type split; 2=domain split within a given state type - - !print*, 'start of stateThenDomain loop' - + type_data, & ! intent(in): type of vegetation and soil + attr_data, & ! intent(in): spatial attributes + forc_data, & ! intent(in): model forcing data + mpar_data, & ! intent(in): model parameters + indx_data, & ! intent(inout): index data + prog_data, & ! intent(inout): model prognostic variables for a local HRU + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + flux_data, & ! intent(inout): model fluxes for a local HRU + bvar_data, & ! intent(in): model variables for the local basin + lookup_data, & ! intent(in): lookup tables + model_decisions, & ! intent(in): model decisions + ! output: model control + dtMultiplier, & ! intent(out): substep multiplier (-) + tooMuchMelt, & ! intent(out): flag to denote that ice is insufficient to support melt + stepFailure, & ! intent(out): flag to denote step failure + ixSolution, & ! intent(out): solution method used in this iteration + mean_step_dt, & ! intent(out): mean solution step for the time step + err,message) ! intent(out): error code and error message + ! --------------------------------------------------------------------------------------- + ! structure allocations + USE allocspace_module,only:allocLocal ! allocate local data structures + ! population/extraction of state vectors + USE indexState_module,only:indexSplit ! get state indices + USE varSubstep_module,only:varSubstep ! complete substeps for a given split + implicit none + ! --------------------------------------------------------------------------------------- + ! * dummy variables + ! --------------------------------------------------------------------------------------- + ! input: model control + integer(i4b),intent(in) :: nSnow ! number of snow layers + integer(i4b),intent(in) :: nSoil ! number of soil layers + integer(i4b),intent(in) :: nLayers ! total number of layers + integer(i4b),intent(in) :: nState ! total number of state variables + real(rkind),intent(in) :: dt ! time step (seconds) + real(rkind),intent(in) :: whole_step ! length of whole step for surface drainage and average flux + logical(lgt),intent(in) :: firstSubStep ! flag to indicate if we are processing the first sub-step + logical(lgt),intent(in) :: firstInnerStep ! flag to denote if the first time step in maxstep subStep + logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) + ! input/output: data structures + type(var_i),intent(in) :: type_data ! type of vegetation and soil + type(var_d),intent(in) :: attr_data ! spatial attributes + type(var_d),intent(in) :: forc_data ! model forcing data + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_ilength),intent(inout) :: indx_data ! indices for a local HRU + type(var_dlength),intent(inout) :: prog_data ! prognostic variables for a local HRU + type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(in) :: bvar_data ! model variables for the local basin + type(zLookup), intent(in) :: lookup_data ! lookup tables + type(model_options),intent(in) :: model_decisions(:) ! model decisions + ! output: model control + real(rkind),intent(out) :: dtMultiplier ! substep multiplier (-) + logical(lgt),intent(out) :: tooMuchMelt ! flag to denote that ice is insufficient to support melt + logical(lgt),intent(out) :: stepFailure ! flag to denote step failure + integer(i4b),intent(out) :: ixSolution ! index of solution method (1,2) + real(rkind),intent(out) :: mean_step_dt ! mean solution step for the time step + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! --------------------------------------------------------------------------------------- + ! * general local variables + ! --------------------------------------------------------------------------------------- + character(LEN=256) :: cmessage ! error message of downwind routine + integer(i4b) :: minLayer ! the minimum layer used in assigning flags for flux aggregations + integer(i4b) :: iOffset ! offset to account for different indices in the soil domain + integer(i4b) :: iMin(1),iMax(1) ! bounds of a given vector + integer(i4b) :: iLayer,jLayer ! index of model layer + integer(i4b) :: iVar ! index of variables in data structures + logical(lgt) :: firstSuccess ! flag to define the first success + logical(lgt) :: firstFluxCall ! flag to define the first flux call + logical(lgt) :: reduceCoupledStep ! flag to define the need to reduce the length of the coupled step + logical(lgt) :: return_flag ! flag to indicate the execution of a return statement + type(var_dlength) :: prog_temp ! temporary model prognostic variables + type(var_dlength) :: diag_temp ! temporary model diagnostic variables + type(var_dlength) :: flux_temp ! temporary model fluxes + type(var_dlength) :: flux_mean ! mean model fluxes + type(var_dlength) :: flux_mntemp ! temporary mean model fluxes + type(var_dlength) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + ! ------------------------------------------------------------------------------------------------------ + ! * operator splitting + ! ------------------------------------------------------------------------------------------------------ + ! minimum timestep + real(rkind) :: dtmin_coupled ! minimum time step for the fully coupled solution (seconds) + real(rkind) :: dtmin_split ! minimum time step for the fully split solution (seconds) + real(rkind) :: dtmin_scalar ! minimum time step for the scalar solution (seconds) + real(rkind) :: dt_min ! minimum time step (seconds) + real(rkind) :: dtInit ! initial time step (seconds) + ! number of substeps taken for a given split + integer(i4b) :: nSubsteps ! number of substeps taken for a given split + ! named variables defining the coupling and solution method + integer(i4b) :: ixCoupling ! index of coupling method (1,2) + integer(i4b) :: ixStateThenDomain ! switch between the state and domain (1,2) + integer(i4b) :: tryDomainSplit ! (0,1) - flag to try the domain split + ! actual number of splits + integer(i4b) :: nStateTypeSplit ! number of splits for the state type + integer(i4b) :: nDomainSplit ! number of splits for the domain + integer(i4b) :: nStateSplit ! number of splits for the states within a given domain + ! indices for the state type and the domain split + integer(i4b) :: iStateTypeSplit ! index of the state type split + integer(i4b) :: iDomainSplit ! index of the domain split + integer(i4b) :: iStateSplit ! index of the state split + ! flux masks + logical(lgt) :: neededFlux(nFlux) ! .true. if flux is needed at all + logical(lgt) :: desiredFlux ! .true. if flux is desired for a given split + type(var_ilength) :: fluxCount ! number of times each flux is updated (should equal nSubsteps) + type(var_flagVec) :: fluxMask ! mask defining model fluxes + ! state masks + integer(i4b),dimension(nState) :: stateCheck ! number of times each state variable is updated (should equal 1) + logical(lgt),dimension(nState) :: stateMask ! mask defining desired state variables + integer(i4b) :: nSubset ! number of selected state variables for a given split + ! flags + logical(lgt) :: failure ! flag to denote failure of substepping + logical(lgt) :: doAdjustTemp ! flag to adjust temperature after the mass split + logical(lgt) :: failedMinimumStep ! flag to denote failure of substepping for a given split + integer(i4b) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) + integer(i4b) :: nCoupling + ! mean steps + real(rkind) :: mean_step_state ! mean step over the state (with or without domain splits) + real(rkind) :: mean_step_solution ! mean step for a solution (scalar or vector) + logical(lgt) :: addFirstFlux ! flag to add the first flux to the mask + ! splitting method control variables + logical(lgt) :: exit_split_select,exit_coupling,exit_stateThenDomain,exit_solution + logical(lgt) :: cycle_split_select,cycle_coupling,cycle_stateThenDomain,cycle_domainSplit,cycle_solution + ! ------------------------ classes for subroutine arguments (classes defined in data_types module) ------------------------ + ! ** intent(in) arguments ** || ** intent(inout) arguments ** || ** intent(out) arguments ** + type(in_type_indexSplit) :: in_indexSplit; type(out_type_indexSplit) :: out_indexSplit; ! indexSplit arguments + type(in_type_varSubstep) :: in_varSubstep; type(io_type_varSubstep) :: io_varSubstep; type(out_type_varSubstep) :: out_varSubstep; ! varSubstep arguments + ! ------------------------------------------------------------------------------------------------------------------------- + type(split_select_type) :: split_select ! class object for selecting operator splitting methods + + ! set up split_select object and prepare for split_select_loop + call initialize_opSplittin; if (return_flag) return + + ! execute split_select_loop + call update_opSplittin; if (return_flag) return + + ! validation and error control + call finalize_opSplittin; if (return_flag) return + + contains + + subroutine initialize_opSplittin + ! *** Initial operations for opSplittin *** + ! set splitting parameters + dtmin_coupled = max(1._rkind, mpar_data%var(iLookPARAM%maxstep)%dat(1)/NINT(mpar_data%var(iLookPARAM%be_steps)%dat(1))/10._rkind) + dtmin_split = max(1._rkind, mpar_data%var(iLookPARAM%maxstep)%dat(1)/NINT(mpar_data%var(iLookPARAM%be_steps)%dat(1))/40._rkind) + dtmin_scalar = max(1._rkind, mpar_data%var(iLookPARAM%maxstep)%dat(1)/NINT(mpar_data%var(iLookPARAM%be_steps)%dat(1))/60._rkind) + call initialize_split_select; if (return_flag) return ! initialize split selector object (split_select) + call initialize_split_coupling; if (return_flag) return ! prep for first iteration of update_opSplittin + end subroutine initialize_opSplittin + + subroutine update_opSplittin + ! *** Update operations for opSplittin *** + ! Note: first loop iteration is the fully coupled method, followed by operator splitting methods if required + split_select_loop: do + ! initialize variables + call initialize_split_solve; if (exit_split_select) exit split_select_loop; if (return_flag) return + ! update the trial solution via fully coupled method or operator splitting + call update_split_solve; if (return_flag) return; if (cycle_split_select) cycle split_select_loop + ! validate the trial solution + call finalize_split_solve; if (exit_split_select) exit split_select_loop; if (return_flag) return + end do split_select_loop + end subroutine update_opSplittin + + subroutine finalize_opSplittin + ! *** Final operations for opSplittin *** + call finalize_split_coupling; if (return_flag) return + end subroutine finalize_opSplittin + + subroutine initialize_split_solve + ! *** Initial operations for solving the selected split *** + call initialize_split_stateTypeSplitting; if (exit_split_select.or.return_flag) return + cycle_split_select=.false. ! initialize flag for cycle control of split_select_loop + end subroutine initialize_split_solve + + subroutine update_split_solve + ! *** Update operations for solving the selected split *** + ! Note: split_select data components are used to select the splitting method + if (split_select % stateTypeSplitting) then ! stateTypeSplitting method begins + call initialize_split_stateThenDomain + if (split_select % stateThenDomain) then ! stateThenDomain method begins + call initialize_split_domainSplit; if (return_flag) return + if (split_select % domainSplit) then ! domainSplit method begins + call initialize_split_solution + if (split_select % solution) then ! solution method begins + call initialize_split_stateSplit; if (return_flag) return + if (split_select % stateSplit) then ! stateSplit method begins + ! define masks for selected splitting method + call initialize_split; if (return_flag) return; if (cycle_initialize_split()) then; cycle_split_select=.true.; return; end if + ! update trial solution for selected splitting method + call update_split; if (return_flag) return + ! validate trial solution + call finalize_split; if (return_flag) return; if (cycle_finalize_split()) then; cycle_split_select=.true.; return; end if + end if ! stateSplit method ends + call finalize_split_stateSplit + end if ! solution method ends + call finalize_split_solution + end if ! domainSplit method ends + call finalize_split_domainSplit + end if ! stateThenDomain method ends + call finalize_split_stateThenDomain; if (return_flag) return + end if ! stateTypeSplitting method ends + end subroutine update_split_solve + + subroutine finalize_split_solve + ! *** Final operations for solving the selected split *** + integer(i4b),parameter :: maxSplit=500 ! >= max number of splitting methods (controls upper limit of split_select loop) + call finalize_split_stateTypeSplitting; if (exit_split_select.or.return_flag) return + if (split_select % iSplit.ge.maxSplit) then ! check for errors - execute fail-safe if needed + err=20; message=trim(message)//'split_select loop exceeded max number of iterations'; return_flag=.true.; return + end if + end subroutine finalize_split_solve + + subroutine initialize_split + ! *** Initialize logical masks for selected splitting method *** + call update_stateMask; if (return_flag) return ! get the mask for the state subset - return for a non-zero error code + call validate_split; if (return_flag) return ! verify that the split is valid + if (cycle_initialize_split()) return ! if needed, proceed to next split + + call save_recover ! save/recover copies of variables and fluxes + + call get_split_indices; if (return_flag) return ! get indices for a given split - return for a non-zero error code + call update_fluxMask; if (return_flag) return ! define the mask for the fluxes used - return for a non-zero error code + end subroutine initialize_split + + subroutine update_split + ! *** Update solution for selected splitting method *** + call solve_subset; if (return_flag) return ! solve variable subset for one time step - return for a positive error code + end subroutine update_split + + subroutine finalize_split + ! *** Finalize solution for selected splitting method *** + call assess_solution; if (return_flag) return ! is solution a success or failure? - return for a recovering solution + + call try_other_solution_methods; if (cycle_finalize_split()) return ! if solution failed to converge, try other splitting methods + + call confirm_variable_updates; if (return_flag) return ! check that state variables are updated - return if error + + call success_check ! check for success + call check_exit_stateThenDomain ! check exit criterion for stateThenDomain split + call check_exit_solution; if (return_flag) return ! check exit criterion for solution split - return if error + end subroutine finalize_split + + function cycle_initialize_split() result(cycle_flag) + ! *** Compute loop cycle flag for initialize_split *** + logical(lgt) :: cycle_flag + cycle_flag=any([cycle_domainSplit,cycle_solution]) + end function cycle_initialize_split + + function cycle_finalize_split() result(cycle_flag) + ! *** Compute loop cycle flag for finalize_split *** + logical(lgt) :: cycle_flag + cycle_flag=any([cycle_coupling,cycle_stateThenDomain,cycle_solution]) + end function cycle_finalize_split + + subroutine initialize_split_select + ! *** Initialize split_select class object *** + + ! initizlaize iteration counter for split_select_loop + split_select % iSplit = 1 + + ! initialize # of state variables + split_select % nState = nState + + ! allocate data components + allocate(split_select % stateMask(1:nState),STAT=err) ! allocate split_select components + + ! check for allocation errors + if (err/=0) then + message=trim(message)//'allocation error in initialize_split_select routine for split_select % stateMask' + return_flag=.true.; return + else + return_flag=.false. + end if + + ! initialize split_select % stateMask to default initial case + split_select % stateMask(1:nState) = .true. + + ! initialize flags + exit_split_select=.false. + cycle_split_select=.false. + call split_select % initialize_flags ! initialize control flags + end subroutine initialize_split_select + + subroutine initialize_split_coupling + ! *** Initialize coupling split method *** + call split_select % initialize_ixCoupling + call initialize_coupling; if (return_flag) return ! select coupling options and allocate memory - return if error occurs + end subroutine initialize_split_coupling + + subroutine initialize_split_stateTypeSplitting + ! *** Initialize stateTypeSplitting split method *** + if (split_select % logic_initialize_stateTypeSplitting()) then + ixCoupling=split_select % ixCoupling + if (ixCoupling.gt.nCoupling) then; exit_split_select=.true.; return; end if ! exit if all splits are exhausted + call initialize_stateTypeSplitting; if (return_flag) return ! setup steps for stateTypeSplitting split method - return if error occurs + call split_select % initialize_iStateTypeSplit; split_select % stateTypeSplitting=.true. + end if + if (split_select % logic_exit_stateTypeSplitting()) then + iStateTypeSplit=split_select % iStateTypeSplit; if (iStateTypeSplit.gt.nStateTypeSplit) split_select % stateTypeSplitting=.false. + end if + end subroutine initialize_split_stateTypeSplitting + + subroutine initialize_split_stateThenDomain + ! *** Initialize stateThenDomain split method *** + if (split_select % logic_initialize_stateThenDomain()) then + ! first try the state type split, then try the domain split within a given state type + call initialize_stateThenDomain ! setup steps for stateThenDomain split method -- identify state-specific variables for a given state split + call split_select % initialize_ixStateThenDomain; split_select % stateThenDomain=.true. + end if + if (split_select % logic_exit_stateThenDomain()) then ! stateThenDomain + ixStateThenDomain=split_select % ixStateThenDomain + if (ixStateThenDomain > (1+tryDomainSplit)) then + ixStateThenDomain=ixStateThenDomain-1; split_select % ixStateThenDomain = ixStateThenDomain ! correct index needed after exit + split_select % stateThenDomain=.false. ! eqivalent to exiting the stateThenDomain method + end if + end if + end subroutine initialize_split_stateThenDomain + + subroutine initialize_split_domainSplit + ! *** Initialize domainSplit split method *** + if (split_select % logic_initialize_domainSplit()) then + call initialize_domainSplit; if (return_flag) return ! setup steps for domainSplit split method - return if error occurs + call split_select % initialize_iDomainSplit; split_select % domainSplit=.true. + end if + if (split_select % logic_exit_domainSplit()) then + iDomainSplit=split_select % iDomainSplit + if (split_select % iDomainSplit > nDomainSplit) split_select % domainSplit=.false. + end if + end subroutine initialize_split_domainSplit + + subroutine initialize_split_solution + ! *** Initialize solution split method *** + if (split_select % logic_initialize_solution()) then; call split_select % initialize_ixSolution; split_select % solution=.true.; end if + if (split_select % logic_exit_solution()) then + ixSolution=split_select % ixSolution + if (split_select % ixSolution > nsolutions) split_select % solution=.false. + end if + end subroutine initialize_split_solution + + subroutine initialize_split_stateSplit + ! *** Initialize stateSplit split method *** + if (split_select % logic_initialize_stateSplit()) then + call initialize_stateSplit; if (return_flag) return ! setup steps for stateSplit split method - return if error occurs + call split_select % initialize_iStateSplit; split_select % stateSplit=.true.; ! loop through layers (NOTE: nStateSplit=1 for the vector solution, hence no looping) + end if + if (split_select % logic_exit_stateSplit()) then ! stateSplit begins + iStateSplit=split_select % iStateSplit + if (split_select % iStateSplit > nStateSplit) split_select % stateSplit=.false.; !exit stateSplit + end if + end subroutine initialize_split_stateSplit + + subroutine check_exit_stateThenDomain + ! *** check exit criterion for stateThenDomain split *** + if (exit_stateThenDomain) then ! exit stateThenDomain split if necessary -- deactivate flags for inner splits + call split_select % initialize_ixStateThenDomain + split_select % stateThenDomain=.false.; split_select % domainSplit=.false.; split_select % solution=.false.; split_select % stateSplit=.false. + end if + end subroutine check_exit_stateThenDomain + + subroutine check_exit_solution + ! *** Check exit criterion for solution split - return if needed *** + if (split_select % stateThenDomain) then + if (exit_solution) then; split_select % solution=.false.; split_select % stateSplit=.false.; end if + if (split_select % solution) then + if (return_flag) return ! return if error + call split_select % advance_iStateSplit + end if + end if + end subroutine check_exit_solution + + subroutine finalize_split_stateSplit + ! *** Finalize steps for stateSplit split method *** + if (split_select % logic_finalize_stateSplit()) then + call split_select % advance_ixSolution + end if + end subroutine finalize_split_stateSplit + + subroutine finalize_split_solution + ! *** Finalize steps for solution split method *** + if (split_select % logic_finalize_solution()) then + call finalize_solution ! final steps following solution split method + call split_select % advance_iDomainSplit + end if + end subroutine finalize_split_solution + + subroutine finalize_split_domainSplit + ! *** Finalize steps for domainSplit split method *** + if (split_select % logic_finalize_domainSplit()) then + call split_select % advance_ixStateThenDomain + end if + end subroutine finalize_split_domainSplit + + subroutine finalize_split_stateThenDomain + ! *** Finalize steps for stateThenDomain split method *** + if (split_select % logic_finalize_stateThenDomain()) then + call finalize_stateThenDomain; if (return_flag) return ! final steps following the stateThenDomain split method + call split_select % advance_iStateTypeSplit + end if + end subroutine finalize_split_stateThenDomain + + subroutine finalize_split_stateTypeSplitting + ! *** Finalize steps for stateTypeSplitting split method *** + if (split_select % logic_finalize_stateTypeSplitting()) then + call finalize_stateTypeSplitting + if (exit_coupling) then + call split_select % initialize_ixCoupling; exit_split_select=.true.; return ! success = exit the coupling split method (split_select_loop) + end if + call split_select % advance_ixCoupling + end if + call split_select % advance_iSplit ! advance iteration counter for split_select_loop + end subroutine finalize_split_stateTypeSplitting + + subroutine finalize_split_coupling + ! *** Finalize steps for coupling split method *** + call finalize_coupling; if (return_flag) return ! check variables and fluxes, and apply step halving if needed + end subroutine finalize_split_coupling + + subroutine initialize_coupling + ! *** initial steps for coupling split method *** + ! initialize error control + err=0; message="opSplittin/" + + call get_nCoupling; if (return_flag) return ! get nCoupling value -- return if error + + ! initialize the first success call + firstSuccess=.false. + if (.not.firstInnerStep) firstSuccess=.true. + + ! initialize the flags + tooMuchMelt=.false. ! too much melt (merge snow layers) + stepFailure=.false. ! step failure + + ! initialize flag for the success of the substepping + failure=.false. + + ! initialize the flux check + neededFlux(:) = .false. + + ! initialize the state check + stateCheck(:) = 0 + + ! allocate local structures based on the number of snow and soil layers + call allocate_memory + if (return_flag) return ! return if an error occurs during memory allocation + + ! intialize the flux counter + do iVar=1,size(flux_meta) ! loop through fluxes + fluxCount%var(iVar)%dat(:) = 0 + end do + + ! initialize the model fluxes + do iVar=1,size(flux_meta) ! loop through fluxes + if (flux2state_orig(iVar)%state1==integerMissing .and. flux2state_orig(iVar)%state2==integerMissing) cycle ! flux does not depend on state (e.g., input) + if (flux2state_orig(iVar)%state1==iname_watCanopy .and. .not.computeVegFlux) cycle ! use input fluxes in cases where there is no canopy + if (firstInnerStep) flux_data%var(iVar)%dat(:) = 0._rkind + flux_mean%var(iVar)%dat(:) = 0._rkind + end do + + ! initialize derivatives + do iVar=1,size(deriv_meta) + deriv_data%var(iVar)%dat(:) = 0._rkind + end do + end subroutine initialize_coupling + + subroutine get_nCoupling + ! *** Get nCoupling value *** + associate(ixNumericalMethod => model_decisions(iLookDECISIONS%num_method)%iDecision) ! intent(in): [i4b] choice of numerical solver + ! we just solve the fully coupled problem if IDA for now, splitting can happen otherwise + select case(ixNumericalMethod) + case(ida); nCoupling = 1 + case(kinsol, homegrown); nCoupling = 2 + case default; err=20; message=trim(message)//'solver choice not found'; return_flag=.true.; return + end select + end associate + end subroutine get_nCoupling + + subroutine allocate_memory + ! *** allocate memory for local structures *** + return_flag=.false. ! initialize flag + + ! allocate space for the flux mask (used to define when fluxes are updated) + call allocLocal(flux_meta(:),fluxMask,nSnow,nSoil,err,cmessage) + if (err/=0) then; err=20; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if + + ! allocate space for the flux count (used to check that fluxes are only updated once) + call allocLocal(flux_meta(:),fluxCount,nSnow,nSoil,err,cmessage) + if (err/=0) then; err=20; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if + + ! allocate space for the temporary prognostic variable structure + call allocLocal(prog_meta(:),prog_temp,nSnow,nSoil,err,cmessage) + if (err/=0) then; err=20; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if + + ! allocate space for the temporary diagnostic variable structure + call allocLocal(diag_meta(:),diag_temp,nSnow,nSoil,err,cmessage) + if (err/=0) then; err=20; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if + + ! allocate space for the temporary flux variable structure + call allocLocal(flux_meta(:),flux_temp,nSnow,nSoil,err,cmessage) + if (err/=0) then; err=20; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if + + ! allocate space for the mean flux variable structure + call allocLocal(flux_meta(:),flux_mean,nSnow,nSoil,err,cmessage) + if (err/=0) then; err=20; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if + + ! allocate space for the temporary mean flux variable structure + call allocLocal(flux_meta(:),flux_mntemp,nSnow,nSoil,err,cmessage) + if (err/=0) then; err=20; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if + + ! allocate space for the derivative structure + call allocLocal(deriv_meta(:),deriv_data,nSnow,nSoil,err,cmessage) + if (err/=0) then; err=20; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if + end subroutine allocate_memory + + subroutine finalize_coupling + ! *** final operations for coupling split method *** + ! check that all state variables were updated + if (any(stateCheck==0)) then + message=trim(message)//'some state variables were not updated!' + err=20; return_flag=.true.; return + endif + + ! check that the desired fluxes were computed + do iVar=1,size(flux_meta) + if (neededFlux(iVar) .and. any(fluxCount%var(iVar)%dat==0)) then + print*, 'fluxCount%var(iVar)%dat = ', fluxCount%var(iVar)%dat + message=trim(message)//'flux '//trim(flux_meta(iVar)%varname)//' was not computed' + err=20; return_flag=.true.; return + end if + end do + + ! use step halving if unable to complete the fully coupled solution in one substep + if (ixCoupling/=fullyCoupled .or. nSubsteps>1) dtMultiplier=0.5_rkind + end subroutine finalize_coupling + + subroutine initialize_stateTypeSplitting + ! *** Initial steps to prepare for iterations of the stateTypeSplit split method *** + return_flag=.false. ! initialize flag + ! initialize the time step + dtInit = min(merge(dt, dtmin_coupled, ixCoupling==fullyCoupled), dt) ! initial time step + dt_min = min(merge(dtmin_coupled, dtmin_split, ixCoupling==fullyCoupled), dt) ! minimum time step + + ! get nStateTypeSplit and tryDomainSplit values + call get_nStateTypeSplit_tryDomainSplit(ixCoupling); if (return_flag) return + + mean_step_dt = 0._rkind ! initialize mean step for the time step + addFirstFlux = .true. ! flag to add the first flux to the mask + end subroutine initialize_stateTypeSplitting + + subroutine get_nStateTypeSplit_tryDomainSplit(ixCoupling_value) + ! *** Get nStateTypeSplit and tryDomainSplit values *** + integer(i4b),intent(in) :: ixCoupling_value + ! keep track of the number of state splits + associate(numberStateSplit => indx_data%var(iLookINDEX%numberStateSplit)%dat(1)) ! intent(inout): [i4b] number of state splitting solutions + if (ixCoupling/=fullyCoupled) numberStateSplit = numberStateSplit + 1 + end associate + + ! define the number of operator splits for the state type + select case(ixCoupling_value) + case(fullyCoupled); nStateTypeSplit=1 + case(stateTypeSplit); nStateTypeSplit=nStateTypes + case default; err=20; message=trim(message)//'coupling case not found'; return_flag=.true.; return + end select ! operator splitting option + + ! define if we wish to try the domain split + select case(ixCoupling_value) + case(fullyCoupled); tryDomainSplit=0 + case(stateTypeSplit); tryDomainSplit=1 + case default; err=20; message=trim(message)//'coupling case not found'; return_flag=.true.; return + end select ! operator splitting option + end subroutine get_nStateTypeSplit_tryDomainSplit + + subroutine finalize_stateTypeSplitting + ! *** Final operations subsequent to the stateTypeSplitting split method *** + exit_coupling=.false. ! initialize flag for control + if (ixCoupling==fullyCoupled .and. .not.failure) then; exit_coupling=.true.; return; end if ! success = exit the coupling method in opSplittin + end subroutine finalize_stateTypeSplitting + + subroutine initialize_stateThenDomain + ! *** Identify state-specific variables for a given state split *** + doAdjustTemp = (ixCoupling/=fullyCoupled .and. iStateTypeSplit==massSplit) ! flag to adjust the temperature + associate(& + ixStateType => indx_data%var(iLookINDEX%ixStateType)%dat, & ! intent(in): [i4b(:)] indices defining the type of the state + ixHydCanopy => indx_data%var(iLookINDEX%ixHydCanopy)%dat, & ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for hydrology states in the canopy domain + ixHydLayer => indx_data%var(iLookINDEX%ixHydLayer)%dat ) ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for hydrology states in the snow+soil domain + + ! modify the state type names associated with the state vector + if (ixCoupling/=fullyCoupled .and. iStateTypeSplit==massSplit) then ! if modifying state variables for the mass split + if (computeVegFlux) then + where(ixStateType(ixHydCanopy)==iname_watCanopy) ixStateType(ixHydCanopy)=iname_liqCanopy + end if + where(ixStateType(ixHydLayer)==iname_watLayer) ixStateType(ixHydLayer)=iname_liqLayer + where(ixStateType(ixHydLayer)==iname_matLayer) ixStateType(ixHydLayer)=iname_lmpLayer + end if + end associate + end subroutine initialize_stateThenDomain + + subroutine finalize_stateThenDomain + ! *** Final steps following the stateThenDomain split method *** + ! sum the mean steps for the time step over each state type split + !if (ixStateThenDomain == 2+tryDomainSplit) ixStateThenDomain=1+tryDomainSplit ! correct index value if stateThenDomain method is completed fully + select case(ixStateThenDomain) + case(fullDomain); mean_step_dt = mean_step_dt + mean_step_solution/nStateTypeSplit + case(subDomain); mean_step_dt = mean_step_dt + mean_step_state/nStateTypeSplit + case default; err=20; message=trim(message)//'ixStateThenDomain case not found'; return_flag=.true.; return + end select + associate(& + ixStateType => indx_data%var(iLookINDEX%ixStateType)%dat, & ! intent(in): [i4b(:)] indices defining the type of the state + ixHydCanopy => indx_data%var(iLookINDEX%ixHydCanopy)%dat, & ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for hydrology states in the canopy domain + ixHydLayer => indx_data%var(iLookINDEX%ixHydLayer)%dat ) ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for hydrology states in the snow+soil domain + + ! * reset state variables for the mass split... + ! modify the state type names associated with the state vector + if (ixCoupling/=fullyCoupled .and. iStateTypeSplit==massSplit) then ! if modifying state variables for the mass split + if (computeVegFlux) then + where(ixStateType(ixHydCanopy)==iname_liqCanopy) ixStateType(ixHydCanopy)=iname_watCanopy + end if + where(ixStateType(ixHydLayer)==iname_liqLayer) ixStateType(ixHydLayer)=iname_watLayer + where(ixStateType(ixHydLayer)==iname_lmpLayer) ixStateType(ixHydLayer)=iname_matLayer + end if + end associate + end subroutine finalize_stateThenDomain + + subroutine initialize_domainSplit + ! *** initial operations to set up domainSplit split method *** + return_flag=.false. ! initialize flag + associate(numberDomainSplitNrg => indx_data%var(iLookINDEX%numberDomainSplitNrg )%dat(1),& ! intent(inout): [i4b] number of domain splitting solutions for energy (-) + numberDomainSplitMass => indx_data%var(iLookINDEX%numberDomainSplitMass)%dat(1) )! intent(inout): [i4b] number of domain splitting solutions for mass (-) ! keep track of the number of domain splits - if(iStateTypeSplit==nrgSplit .and. ixStateThenDomain==subDomain) numberDomainSplitNrg = numberDomainSplitNrg + 1 - if(iStateTypeSplit==massSplit .and. ixStateThenDomain==subDomain) numberDomainSplitMass = numberDomainSplitMass + 1 + if (iStateTypeSplit==nrgSplit .and. ixStateThenDomain==subDomain) numberDomainSplitNrg = numberDomainSplitNrg + 1 + if (iStateTypeSplit==massSplit .and. ixStateThenDomain==subDomain) numberDomainSplitMass = numberDomainSplitMass + 1 + end associate - ! define the number of domain splits for the state type - select case(ixStateThenDomain) - case(fullDomain); nDomainSplit=1 - case(subDomain); nDomainSplit=nDomains - case default; err=20; message=trim(message)//'coupling case not found'; return - end select + call get_nDomainSplit(ixStateThenDomain); if (return_flag) return ! get nDomainSplit value -- return if error occurs - ! check that we haven't split the domain when we are fully coupled - if(ixCoupling==fullyCoupled .and. nDomainSplit==nDomains)then + ! check that we haven't split the domain when we are fully coupled + if (ixCoupling==fullyCoupled .and. nDomainSplit==nDomains) then message=trim(message)//'cannot split domains when fully coupled' + return_flag=.true. ! return statement required in opSplittin err=20; return - endif - - ! domain splitting loop - domainSplit: do iDomainSplit=1,nDomainSplit - - ! trial with the vector then scalar solution - solution: do ixSolution=1,nSolutions - - ! initialize error control - err=0; message="opSplittin/" + end if - ! refine the time step - if(ixSolution==scalar)then - dtInit = min(dtmin_split, dt) ! initial time step - dt_min = min(dtmin_scalar, dt) ! minimum time step - endif + mean_step_state = 0._rkind ! initialize mean step for state + end subroutine initialize_domainSplit - ! initialize the first flux call - firstFluxCall=.true. - - ! get the number of split layers - select case(ixSolution) - case(vector); nStateSplit=1 - case(scalar); nStateSplit=count(stateMask) - case default; err=20; message=trim(message)//'unknown solution method'; return + subroutine get_nDomainSplit(ixStateThenDomain_value) + ! *** Get nDomainSplit value *** + integer(i4b),intent(in) :: ixStateThenDomain_value + ! define the number of domain splits for the state type + select case(ixStateThenDomain_value) + case(fullDomain); nDomainSplit=1 + case(subDomain); nDomainSplit=nDomains + case default; err=20; message=trim(message)//'coupling case not found'; + return_flag=.true. ! return statement required in opSplittin + return + end select + end subroutine get_nDomainSplit + + subroutine finalize_solution + ! *** final operations following solution split method *** + ! sum the mean steps for the state over each domain split + mean_step_state = mean_step_state + mean_step_solution/nDomainSplit + end subroutine finalize_solution + + subroutine initialize_stateSplit + ! *** initial operations to set up stateSplit split method *** + return_flag=.false. ! initialize flag + mean_step_solution = 0._rkind ! initialize mean step for a solution + + ! initialize error control + err=0; message="opSplittin/" + + ! refine the time step + if (ixSolution==scalar) then + dtInit = min(dtmin_split, dt) ! initial time step + dt_min = min(dtmin_scalar, dt) ! minimum time step + end if + + ! initialize the first flux call + firstFluxCall=.true. + if (.not.firstInnerStep) firstFluxCall=.false. + + call get_nStateSplit(ixSolution); if (return_flag) return ! get nStateSplit value -- return if error occurs + end subroutine initialize_stateSplit + + subroutine get_nStateSplit(ixSolution_value) + ! *** Get nStateSplit value *** + integer(i4b),intent(in) :: ixSolution_value + ! get the number of split layers + select case(ixSolution_value) + case(vector); nStateSplit=1 + case(scalar); nStateSplit=count(stateMask) + case default; err=20; message=trim(message)//'unknown solution method'; + return_flag=.true. ! return statement required in opSplittin + return + end select + end subroutine get_nStateSplit + + ! **** indexSplit **** + subroutine initialize_indexSplit + call in_indexSplit % initialize(nSnow,nSoil,nLayers,nSubset) + end subroutine initialize_indexSplit + + subroutine finalize_indexSplit + call out_indexSplit % finalize(err,cmessage) + end subroutine finalize_indexSplit + ! **** end indexSplit **** + + ! **** varSubstep **** + subroutine initialize_varSubstep + call in_varSubstep % initialize(dt,dtInit,dt_min,whole_step,nSubset,doAdjustTemp,firstSubStep,computeVegFlux,ixSolution,scalar,iStateSplit,fluxMask) + call io_varSubstep % initialize(firstFluxCall,fluxCount,ixSaturation) + end subroutine initialize_varSubstep + + subroutine finalize_varSubstep + call io_varSubstep % finalize(firstFluxCall,fluxCount,ixSaturation) + call out_varSubstep % finalize(dtMultiplier,nSubsteps,failedMinimumStep,reduceCoupledStep,tooMuchMelt,err,cmessage) + end subroutine finalize_varSubstep + + subroutine solve_subset + ! *** Solve variable subset for one time step *** + return_flag=.false. ! initialize flag + ! keep track of the number of scalar solutions + associate(numberScalarSolutions => indx_data%var(iLookINDEX%numberScalarSolutions)%dat(1)) ! intent(inout): [i4b] number of scalar solutions + if (ixSolution==scalar) numberScalarSolutions = numberScalarSolutions + 1 + end associate + + ! solve variable subset for one full time step + call initialize_varSubstep + call varSubstep(in_varSubstep,io_varSubstep,& ! intent(inout): class objects for model control + model_decisions,lookup_data,type_data,attr_data,forc_data,mpar_data,& ! intent(inout): data structures for model properties + indx_data,prog_data,diag_data,flux_data,flux_mean,deriv_data,bvar_data,& + out_varSubstep) ! intent(out): class object for model control + call finalize_varSubstep + if (err/=0) then + message=trim(message)//trim(cmessage) + if (err>0) then ! return for positive error codes + return_flag=.true.; return + end if + end if ! error control + end subroutine solve_subset + + subroutine assess_solution + ! *** determine whether solution is a success or a failure *** + return_flag=.false. ! initialize flag + + ! reduce coupled step if failed the minimum step for the scalar solution + if (failedMinimumStep .and. ixSolution==scalar) reduceCoupledStep=.true. + + ! if too much melt (or some other need to reduce the coupled step) then return + ! NOTE: need to go all the way back to coupled_em and merge snow layers, as all splitting operations need to occur with the same layer geometry + if (tooMuchMelt .or. reduceCoupledStep) then + stepFailure=.true. + err=0 ! recovering + return_flag=.true. ! return statement required in opSplittin + return + end if + + ! define failure + failure = (failedMinimumStep .or. err<0) + if (.not.failure) firstSuccess=.true. + + ! if failed, need to reset the flux counter + if (failure) then + do iVar=1,size(flux_meta) + iMin=lbound(flux_data%var(iVar)%dat) + iMax=ubound(flux_data%var(iVar)%dat) + do iLayer=iMin(1),iMax(1) + if (fluxMask%var(iVar)%dat(iLayer)) fluxCount%var(iVar)%dat(iLayer) = fluxCount%var(iVar)%dat(iLayer) - nSubsteps + end do + end do + end if + end subroutine assess_solution + + subroutine try_other_solution_methods + ! *** if solution failed to converge, try other splitting methods *** + ! initialize flags + cycle_coupling=.false. + cycle_stateThenDomain=.false. + cycle_solution=.false. + + ! try the fully split solution if failed to converge with a minimum time step in the coupled solution + if (ixCoupling==fullyCoupled .and. failure) then + call split_select % advance_ixCoupling; call split_select % initialize_flags; ! prep for next iteration + cycle_coupling=.true.; return; ! return required to execute cycle statement in opSplittin + end if + + ! try the scalar solution if failed to converge with a minimum time step in the split solution + if (ixCoupling/=fullyCoupled) then + select case(ixStateThenDomain) + case(fullDomain) + if (failure) then + call split_select % advance_ixStateThenDomain ! prep for next iteration + split_select % domainSplit=.false.; split_select % solution=.false.; split_select % stateSplit=.false.; + cycle_stateThenDomain=.true.; return ! return required to execute cycle statement in opSplittin + end if + case(subDomain) + if (failure) then + call split_select % advance_ixSolution; split_select % stateSplit=.false.; ! prep for next iteration + cycle_solution=.true.; return ! return required to execute cycle statement in opSplittin + end if + case default; err=20; message=trim(message)//'unknown ixStateThenDomain case' + end select + end if + end subroutine try_other_solution_methods + + subroutine update_stateMask + ! *** Get the mask for the state subset *** + call split_select % get_stateMask(indx_data,err,cmessage,message,return_flag) + nSubset = split_select % nSubset; stateMask = split_select % stateMask + if (return_flag) return + end subroutine update_stateMask + + subroutine validate_split + ! *** Verify that the split is valid *** + ! initialize flags + cycle_domainSplit=.false. + cycle_solution=.false. + return_flag=.false. + nSubset = split_select % nSubset + + ! check that state variables exist + if (nSubset==0) then + call split_select % advance_iDomainSplit + split_select % solution=.false.; split_select % stateSplit=.false. + cycle_domainSplit=.true. + return + end if + + ! avoid redundant case where vector solution is of length 1 + if (ixSolution==vector .and. count(stateMask)==1) then + call split_select % advance_ixSolution; + split_select % stateSplit=.false.; + cycle_solution=.true. + return + end if + + ! check that we do not attempt the scalar solution for the fully coupled case + if (ixCoupling==fullyCoupled .and. ixSolution==scalar) then + message=trim(message)//'only apply the scalar solution to the fully split coupling strategy' + err=20; return_flag=.true.; return + end if + + ! reset the flag for the first flux call + if (.not.firstSuccess) firstFluxCall=.true. + end subroutine validate_split + + subroutine save_recover + ! save/recover copies of prognostic variables + do iVar=1,size(prog_data%var) + select case(failure) + case(.false.); prog_temp%var(iVar)%dat(:) = prog_data%var(iVar)%dat(:) + case(.true.); prog_data%var(iVar)%dat(:) = prog_temp%var(iVar)%dat(:) + end select + end do + + ! save/recover copies of diagnostic variables + do iVar=1,size(diag_data%var) + select case(failure) + case(.false.); diag_temp%var(iVar)%dat(:) = diag_data%var(iVar)%dat(:) + case(.true.); diag_data%var(iVar)%dat(:) = diag_temp%var(iVar)%dat(:) + end select + end do + + ! save/recover copies of model fluxes and mean fluxes + do iVar=1,size(flux_data%var) + select case(failure) + case(.false.) + flux_temp%var(iVar)%dat(:) = flux_data%var(iVar)%dat(:) + flux_mntemp%var(iVar)%dat(:) = flux_mean%var(iVar)%dat(:) + addFirstFlux = .false. + case(.true.) + flux_data%var(iVar)%dat(:) = flux_temp%var(iVar)%dat(:) + flux_mean%var(iVar)%dat(:) = flux_mntemp%var(iVar)%dat(:) + if (addFirstFlux) addFirstFlux = .true. + end select + end do + end subroutine save_recover + + subroutine get_split_indices + ! *** Get indices for a given split *** + return_flag=.false. ! initialize flag + call initialize_indexSplit + call indexSplit(in_indexSplit,stateMask,indx_data,out_indexSplit) + call finalize_indexSplit + if (err/=0) then; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if + end subroutine get_split_indices + + subroutine confirm_variable_updates + ! *** check that state variables updated *** + return_flag=.false. ! set flag + ! check that state variables updated + where(stateMask) stateCheck = stateCheck+1 + if (any(stateCheck>1)) then + message=trim(message)//'state variable updated more than once!' + err=20; return_flag=.true.; return + end if + end subroutine confirm_variable_updates + + subroutine success_check + ! initialize flags + return_flag=.false. + exit_stateThenDomain=.false. + exit_solution=.false. + ! success = exit solution + if (.not.failure) then + ! sum the mean steps for the successful solution type + mean_step_solution = mean_step_solution + (dt/nSubsteps)/nStateSplit + select case(ixStateThenDomain) + case(fullDomain); if (iStateSplit==nStateSplit) exit_stateThenDomain=.true. ! exit stateThenDomain + case(subDomain); if (iStateSplit==nStateSplit) exit_solution=.true. ! exit solution + case default; err=20; message=trim(message)//'unknown ixStateThenDomain case' + end select + else ! failure + call check_failure; return_flag=.true.; return ! check reason for failure and return + end if ! success check + end subroutine success_check + + subroutine check_failure + ! *** Analyze reason for failure *** + if (ixSolution==scalar) then ! check that we did not fail for the scalar solution (last resort) + message=trim(message)//'failed the minimum step for the scalar solution' + err=20; return + else ! check for an unexpected failure + message=trim(message)//'unexpected failure' + err=20; return + end if + end subroutine check_failure + + subroutine update_fluxMask + ! *** update the fluxMask data structure *** + return_flag=.false. ! initialize flag + + do iVar=1,size(flux_meta) ! loop through flux variables + + if (ixCoupling==fullyCoupled) then ! * identify flux mask for the fully coupled solution + associate(ixStateType_subset => indx_data%var(iLookINDEX%ixStateType_subset)%dat) ! intent(in): [i4b(:)] indices of state types + desiredFlux = any(ixStateType_subset==flux2state_orig(iVar)%state1) .or. any(ixStateType_subset==flux2state_orig(iVar)%state2) + end associate + + ! make sure firstFluxCall fluxes are included in the mask + if (firstFluxCall .and. addFirstFlux) then + if (iVar==iLookFLUX%scalarSoilResistance) desiredFlux = .true. + if (iVar==iLookFLUX%scalarStomResistSunlit) desiredFlux = .true. + if (iVar==iLookFLUX%scalarStomResistShaded) desiredFlux = .true. + if (iVar==iLookFLUX%scalarPhotosynthesisSunlit) desiredFlux = .true. + if (iVar==iLookFLUX%scalarPhotosynthesisShaded) desiredFlux = .true. + end if + + fluxMask%var(iVar)%dat = desiredFlux + + else ! * identify flux mask for the split solution + + associate(ixStateType_subset => indx_data%var(iLookINDEX%ixStateType_subset)%dat) ! intent(in): [i4b(:)] indices of state types + select case(iStateTypeSplit) ! identify the flux mask for a given state split + case(nrgSplit); desiredFlux = any(ixStateType_subset==flux2state_orig(iVar)%state1) .or. any(ixStateType_subset==flux2state_orig(iVar)%state2) + case(massSplit); desiredFlux = any(ixStateType_subset==flux2state_liq(iVar)%state1) .or. any(ixStateType_subset==flux2state_liq(iVar)%state2) + case default; err=20; message=trim(message)//'unable to identify split based on state type'; return_flag=.true.; return end select - - !print*, '*****' - !print*, 'computeVegFlux = ', computeVegFlux - !print*, '(ixSolution==scalar) = ', (ixSolution==scalar) - !print*, 'ixCoupling, iStateTypeSplit, ixStateThenDomain, iDomainSplit, nDomainSplit: ', ixCoupling, iStateTypeSplit, ixStateThenDomain, iDomainSplit, nDomainSplit - !print*, 'ixSoilOnlyHyd = ', indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat - - ! loop through layers (NOTE: nStateSplit=1 for the vector solution, hence no looping) - stateSplit: do iStateSplit=1,nStateSplit - - ! ----- - ! * define state subsets for a given split... - ! ------------------------------------------- - - ! get the mask for the state subset - call stateFilter(ixCoupling,ixSolution,ixStateThenDomain,iStateTypeSplit,iDomainSplit,iStateSplit,& - indx_data,stateMask,nSubset,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (check for errors) - - ! check that state variables exist - if(nSubset==0) cycle domainSplit - - ! avoid redundant case where vector solution is of length 1 - if(ixSolution==vector .and. count(stateMask)==1) cycle solution - - ! check - !print*, 'after stateFilter: stateMask = ', stateMask - !print*, 'count(stateMask) = ', count(stateMask) - - !if(ixSolution==scalar)then - ! print*, 'iStateSplit, nStateSplit = ', iStateSplit, nStateSplit - ! print*, 'start of scalar solution' - ! !print*, 'PAUSE'; read(*,*) - !endif - - ! ----- - ! * assemble vectors for a given split... - ! --------------------------------------- - - ! get indices for a given split - call indexSplit(stateMask, & ! intent(in) : logical vector (.true. if state is in the subset) - nSnow,nSoil,nLayers,nSubset, & ! intent(in) : number of snow and soil layers, and total number of layers - indx_data, & ! intent(inout) : index data structure - err,cmessage) ! intent(out) : error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - - ! ----- - ! * define the mask of the fluxes used... - ! --------------------------------------- - - ! identify the type of state for the states in the subset - stateSubset: associate(ixStateType_subset => indx_data%var(iLookINDEX%ixStateType_subset)%dat ,& ! intent(in): [i4b(:)] indices of state types - ixMapFull2Subset => indx_data%var(iLookINDEX%ixMapFull2Subset)%dat ,& ! intent(in): [i4b(:)] mapping of full state vector to the state subset - ixControlVolume => indx_data%var(iLookINDEX%ixControlVolume)%dat ,& ! intent(in): [i4b(:)] index of control volume for different domains (veg, snow, soil) - ixLayerActive => indx_data%var(iLookINDEX%ixLayerActive)%dat ,& ! intent(in): [i4b(:)] list of indices for all active layers (inactive=integerM - ixDomainType => indx_data%var(iLookINDEX%ixDomainType)%dat ) ! intent(in): [i4b(:)] indices defining the type of the domain (iname_veg, iname_snow, iname_soil) - - ! loop through flux variables - do iVar=1,size(flux_meta) - - ! * identify flux mask for the fully coupled solution - if(ixCoupling==fullyCoupled)then - desiredFlux = any(ixStateType_subset==flux2state_orig(iVar)%state1) .or. any(ixStateType_subset==flux2state_orig(iVar)%state2) - fluxMask%var(iVar)%dat = desiredFlux - - ! * identify flux mask for the split solution - else - - ! identify the flux mask for a given state split - select case(iStateTypeSplit) - case(nrgSplit); desiredFlux = any(ixStateType_subset==flux2state_orig(iVar)%state1) .or. any(ixStateType_subset==flux2state_orig(iVar)%state2) - case(massSplit); desiredFlux = any(ixStateType_subset==flux2state_liq(iVar)%state1) .or. any(ixStateType_subset==flux2state_liq(iVar)%state2) - case default; err=20; message=trim(message)//'unable to identify split based on state type'; return - end select - - ! no domain splitting - if(nDomains==1)then - fluxMask%var(iVar)%dat = desiredFlux - - ! domain splitting - else - - ! initialize to .false. - fluxMask%var(iVar)%dat = .false. - - ! only need to proceed if the flux is desired - if(desiredFlux)then - - ! different domain splitting operations - select case(iDomainSplit) - - ! canopy fluxes -- (:1) gets the upper boundary(0) if it exists - case(vegSplit) - - ! vector solution (should only be present for energy) - if(ixSolution==vector)then - fluxMask%var(iVar)%dat(:1) = desiredFlux - if(ixStateThenDomain>1 .and. iStateTypeSplit/=nrgSplit)then - message=trim(message)//'only expect a vector solution for the vegetation domain for energy' - err=20; return - endif - - ! scalar solution - else - fluxMask%var(iVar)%dat(:1) = desiredFlux - endif - - ! fluxes through snow and soil - case(snowSplit,soilSplit) - - ! loop through layers - do iLayer=1,nLayers - if(ixlayerActive(iLayer)/=integerMissing)then - - ! get the offset (ixLayerActive=1,2,3,...nLayers, and soil vectors nSnow+1, nSnow+2, ..., nLayers) - iOffset = merge(nSnow, 0, flux_meta(iVar)%vartype==iLookVarType%midSoil .or. flux_meta(iVar)%vartype==iLookVarType%ifcSoil) - jLayer = iLayer-iOffset - - ! identify the minimum layer - select case(flux_meta(iVar)%vartype) - case(iLookVarType%ifcToto, iLookVarType%ifcSnow, iLookVarType%ifcSoil); minLayer=merge(jLayer-1, jLayer, jLayer==1) - case(iLookVarType%midToto, iLookVarType%midSnow, iLookVarType%midSoil); minLayer=jLayer - case default; minLayer=integerMissing - end select - - ! set desired layers - select case(flux_meta(iVar)%vartype) - case(iLookVarType%midToto,iLookVarType%ifcToto); fluxMask%var(iVar)%dat(minLayer:jLayer) = desiredFlux - case(iLookVarType%midSnow,iLookVarType%ifcSnow); if(iLayer<=nSnow) fluxMask%var(iVar)%dat(minLayer:jLayer) = desiredFlux - case(iLookVarType%midSoil,iLookVarType%ifcSoil); if(iLayer> nSnow) fluxMask%var(iVar)%dat(minLayer:jLayer) = desiredFlux - end select - - ! add hydrology states for scalar variables - if(iStateTypeSplit==massSplit .and. flux_meta(iVar)%vartype==iLookVarType%scalarv)then - select case(iDomainSplit) - case(snowSplit); if(iLayer==nSnow) fluxMask%var(iVar)%dat = desiredFlux - case(soilSplit); if(iLayer==nSnow+1) fluxMask%var(iVar)%dat = desiredFlux - end select - endif ! if hydrology split and scalar - - endif ! if the layer is active - end do ! looping through layers - - ! check - case default; err=20; message=trim(message)//'unable to identify split based on domain type'; return - end select ! domain split - - endif ! if flux is desired - - endif ! domain splitting - endif ! not fully coupled - - ! define if the flux is desired - if(desiredFlux) neededFlux(iVar)=.true. - !if(desiredFlux) print*, flux_meta(iVar)%varname, fluxMask%var(iVar)%dat - - ! * check - if( globalPrintFlag .and. count(fluxMask%var(iVar)%dat)>0 )& - print*, trim(flux_meta(iVar)%varname) - - end do ! (loop through fluxes) - - end associate stateSubset - - ! ******************************************************************************************************************************* - ! ******************************************************************************************************************************* - ! ******************************************************************************************************************************* - ! ***** trial with a given solution method... - - ! check that we do not attempt the scalar solution for the fully coupled case - if(ixCoupling==fullyCoupled .and. ixSolution==scalar)then - message=trim(message)//'only apply the scalar solution to the fully split coupling strategy' - err=20; return - endif - - ! reset the flag for the first flux call - if(.not.firstSuccess) firstFluxCall=.true. - - ! save/recover copies of prognostic variables - do iVar=1,size(prog_data%var) - select case(failure) - case(.false.); prog_temp%var(iVar)%dat(:) = prog_data%var(iVar)%dat(:) - case(.true.); prog_data%var(iVar)%dat(:) = prog_temp%var(iVar)%dat(:) - end select - end do ! looping through variables - - ! save/recover copies of diagnostic variables - do iVar=1,size(diag_data%var) - select case(failure) - case(.false.); diag_temp%var(iVar)%dat(:) = diag_data%var(iVar)%dat(:) - case(.true.); diag_data%var(iVar)%dat(:) = diag_temp%var(iVar)%dat(:) - end select - end do ! looping through variables - - ! save/recover copies of model fluxes - do iVar=1,size(flux_data%var) - select case(failure) - case(.false.); flux_temp%var(iVar)%dat(:) = flux_data%var(iVar)%dat(:) - case(.true.); flux_data%var(iVar)%dat(:) = flux_temp%var(iVar)%dat(:) - end select - end do ! looping through variables - - ! ----- - ! * solve variable subset for one time step... - ! -------------------------------------------- - - !print*, trim(message)//'before varSubstep: nSubset = ', nSubset - - ! keep track of the number of scalar solutions - if(ixSolution==scalar) numberScalarSolutions = numberScalarSolutions + 1 - - ! solve variable subset for one full time step - call varSubstep(& - ! input: model control - dt, & ! intent(inout) : time step (s) - dtInit, & ! intent(in) : initial time step (seconds) - dt_min, & ! intent(in) : minimum time step (seconds) - nSubset, & ! intent(in) : total number of variables in the state subset - doAdjustTemp, & ! intent(in) : flag to indicate if we adjust the temperature - firstSubStep, & ! intent(in) : flag to denote first sub-step - firstFluxCall, & ! intent(inout) : flag to indicate if we are processing the first flux call - computeVegFlux, & ! intent(in) : flag to denote if computing energy flux over vegetation - (ixSolution==scalar), & ! intent(in) : flag to denote computing the scalar solution - iStateSplit, & ! intent(in) : index of the layer in the splitting operation - fluxMask, & ! intent(in) : mask for the fluxes used in this given state subset - fluxCount, & ! intent(inout) : number of times fluxes are updated (should equal nsubstep) - ! input/output: data structures - model_decisions, & ! intent(in) : model decisions - type_data, & ! intent(in) : type of vegetation and soil - attr_data, & ! intent(in) : spatial attributes - forc_data, & ! intent(in) : model forcing data - mpar_data, & ! intent(in) : model parameters - indx_data, & ! intent(inout) : index data - prog_data, & ! intent(inout) : model prognostic variables for a local HRU - diag_data, & ! intent(inout) : model diagnostic variables for a local HRU - flux_data, & ! intent(inout) : model fluxes for a local HRU - deriv_data, & ! intent(inout) : derivatives in model fluxes w.r.t. relevant state variables - bvar_data, & ! intent(in) : model variables for the local basin - ! output: control - ixSaturation, & ! intent(inout) : index of the lowest saturated layer (NOTE: only computed on the first iteration) - dtMultiplier, & ! intent(out) : substep multiplier (-) - nSubsteps, & ! intent(out) : number of substeps taken for a given split - failedMinimumStep, & ! intent(out) : flag for failed substeps - reduceCoupledStep, & ! intent(out) : flag to reduce the length of the coupled step - tooMuchMelt, & ! intent(out) : flag to denote that ice is insufficient to support melt - err,cmessage) ! intent(out) : error code and error message - if(err/=0)then - message=trim(message)//trim(cmessage) - if(err>0) return - endif ! (check for errors) - - !print*, trim(message)//'after varSubstep: scalarSnowDrainage = ', flux_data%var(iLookFLUX%scalarSnowDrainage)%dat - !print*, trim(message)//'after varSubstep: iLayerLiqFluxSnow = ', flux_data%var(iLookFLUX%iLayerLiqFluxSnow)%dat - !print*, trim(message)//'after varSubstep: iLayerLiqFluxSoil = ', flux_data%var(iLookFLUX%iLayerLiqFluxSoil)%dat - - ! check - !if(ixSolution==scalar)then - ! print*, 'PAUSE: check scalar'; read(*,*) - !endif - - ! reduce coupled step if failed the minimum step for the scalar solution - if(failedMinimumStep .and. ixSolution==scalar) reduceCoupledStep=.true. - - ! check - !if(ixCoupling/=fullyCoupled)then - ! print*, 'dt = ', dt - ! print*, 'after varSubstep: err = ', err - ! print*, 'after varSubstep: cmessage = ', trim(cmessage) - ! print*, 'after varSubstep: computeVegFlux = ', computeVegFlux - ! print*, 'after varSubstep: stateMask = ', stateMask - ! print*, 'after varSubstep: coupling = ', (ixCoupling==fullyCoupled) - ! print*, 'after varSubstep: scalar solve = ', (ixSolution==scalar) - ! print*, 'iStateTypeSplit, nStateTypeSplit = ', iStateTypeSplit, nStateTypeSplit - ! print*, 'iDomainSplit, nDomainSplit = ', iDomainSplit, nDomainSplit - ! print*, 'nSubset = ', nSubset - ! print*, 'tooMuchMelt = ', tooMuchMelt - ! print*, 'reduceCoupledStep = ', reduceCoupledStep - ! print*, 'failedMinimumStep = ', failedMinimumStep, merge('coupled','opSplit',ixCoupling==fullyCoupled) - ! if(ixSolution==scalar)then; print*, 'PAUSE'; read(*,*); endif - !endif - - !if(ixSolution==scalar)then - ! !print*, trim(message)//'stop: checking scalar solution'; stop - ! print*, trim(message)//'pause: checking scalar solution'; read(*,*) - !endif - - !print*, 'tooMuchMelt, reduceCoupledStep = ', tooMuchMelt, reduceCoupledStep - - ! if too much melt (or some other need to reduce the coupled step) then return - ! NOTE: need to go all the way back to coupled_em and merge snow layers, as all splitting operations need to occur with the same layer geometry - if(tooMuchMelt .or. reduceCoupledStep)then - stepFailure=.true. - err=0 ! recovering - return - endif - - ! define failure - failure = (failedMinimumStep .or. err<0) - if(.not.failure) firstSuccess=.true. - - ! if failed, need to reset the flux counter - if(failure)then - !print*, 'failure!' - do iVar=1,size(flux_meta) - iMin=lbound(flux_data%var(iVar)%dat) - iMax=ubound(flux_data%var(iVar)%dat) - do iLayer=iMin(1),iMax(1) - if(fluxMask%var(iVar)%dat(iLayer)) fluxCount%var(iVar)%dat(iLayer) = fluxCount%var(iVar)%dat(iLayer) - nSubsteps - end do - !if(iVar==iLookFLUX%mLayerTranspire) print*, flux_meta(iVar)%varname, fluxCount%var(iVar)%dat - end do - endif - - ! try the fully split solution if failed to converge with a minimum time step in the coupled solution - if(ixCoupling==fullyCoupled .and. failure) cycle coupling - - ! try the scalar solution if failed to converge with a minimum time step in the split solution - if(ixCoupling/=fullyCoupled)then - select case(ixStateThenDomain) - case(fullDomain); if(failure) cycle stateThenDomain - case(subDomain); if(failure) cycle solution - case default; err=20; message=trim(message)//'unknown ixStateThenDomain case' - end select - endif - - ! check that state variables updated - where(stateMask) stateCheck = stateCheck+1 - if(any(stateCheck>1))then - message=trim(message)//'state variable updated more than once!' - err=20; return - endif - - ! success = exit solution - if(.not.failure)then - select case(ixStateThenDomain) - case(fullDomain); if(iStateSplit==nStateSplit) exit stateThenDomain - case(subDomain); if(iStateSplit==nStateSplit) exit solution - case default; err=20; message=trim(message)//'unknown ixStateThenDomain case' - end select - else - - ! check that we did not fail for the scalar solution (last resort) - if(ixSolution==scalar)then - message=trim(message)//'failed the minimum step for the scalar solution' - err=20; return - - ! check for an unexpected failure - else - message=trim(message)//'unexpected failure' - err=20; return - endif - - endif ! success check - - end do stateSplit ! solution with split layers - !print*, 'after stateSplit' - - end do solution ! trial with the full layer solution then the split layer solution - - !print*, 'after solution loop' - - ! ***** trial with a given solution method... - ! ******************************************************************************************************************************* - ! ******************************************************************************************************************************* - ! ******************************************************************************************************************************* - - end do domainSplit ! domain type splitting loop - - !print*, 'ixStateThenDomain = ', ixStateThenDomain - !print*, 'after domain split loop' - - end do stateThenDomain ! switch between the state and the domain - - !print*, 'after stateThenDomain switch' - - ! ----- - ! * reset state variables for the mass split... - ! --------------------------------------------- - - ! modify the state type names associated with the state vector - if(ixCoupling/=fullyCoupled .and. iStateTypeSplit==massSplit)then - if(computeVegFlux)then - where(ixStateType(ixHydCanopy)==iname_liqCanopy) ixStateType(ixHydCanopy)=iname_watCanopy - endif - where(ixStateType(ixHydLayer) ==iname_liqLayer) ixStateType(ixHydLayer) =iname_watLayer - where(ixStateType(ixHydLayer) ==iname_lmpLayer) ixStateType(ixHydLayer) =iname_matLayer - endif ! if modifying state variables for the mass split - - end do stateTypeSplitLoop ! state type splitting loop - - ! check - !if(ixCoupling/=fullyCoupled)then - ! print*, 'PAUSE: end of splitting loop'; read(*,*) - !endif - - ! ========================================================================================================================================== - ! ========================================================================================================================================== - - ! success = exit the coupling loop - ! terminate DO loop early if fullyCoupled returns a solution, - ! so that the loop does not proceed to ixCoupling = stateTypeSplit - if(ixCoupling==fullyCoupled .and. .not. failure) exit coupling - - ! if we reach stateTypeSplit, terminating the DO loop here is cleaner - ! than letting the loop complete, because in the latter case the coupling - ! loop will end with ixCoupling = nCoupling+1 = 3 (a FORTRAN loop - ! increments the index variable at the end of each iteration and stops - ! the loop if the index > specified stop value). Variable ixCoupling is - ! used for error reporting in coupled_em.f90 in the balance checks and - ! we thus need to make sure ixCoupling is not incremented to be larger - ! than nCoupling. - if(ixCoupling==stateTypeSplit .and. .not. failure) exit coupling - - end do coupling ! coupling method - - ! check that all state variables were updated - if(any(stateCheck==0))then - message=trim(message)//'some state variables were not updated!' - err=20; return - endif - - ! check that the desired fluxes were computed - do iVar=1,size(flux_meta) - if(neededFlux(iVar) .and. any(fluxCount%var(iVar)%dat==0))then - print*, 'fluxCount%var(iVar)%dat = ', fluxCount%var(iVar)%dat - message=trim(message)//'flux '//trim(flux_meta(iVar)%varname)//' was not computed' - err=20; return - endif - end do - - ! use step halving if unable to complete the fully coupled solution in one substep - if(ixCoupling/=fullyCoupled .or. nSubsteps>1) dtMultiplier=0.5_rkind - - ! compute the melt in each snow and soil layer - if(nSnow>0) mLayerMeltFreeze( 1:nSnow ) = -(mLayerVolFracIce( 1:nSnow ) - mLayerVolFracIceInit( 1:nSnow ))*iden_ice - mLayerMeltFreeze(nSnow+1:nLayers) = -(mLayerVolFracIce(nSnow+1:nLayers) - mLayerVolFracIceInit(nSnow+1:nLayers))*iden_water - - ! end associate statements - end associate globalVars - - end subroutine opSplittin - - - ! ********************************************************************************************************** - ! private subroutine stateFilter: get a mask for the desired state variables - ! ********************************************************************************************************** - subroutine stateFilter(ixCoupling,ixSolution,ixStateThenDomain,iStateTypeSplit,iDomainSplit,iStateSplit,& - indx_data,stateMask,nSubset,err,message) - - USE indexState_module,only:indxSubset ! get state indices + end associate + + ! make sure firstFluxCall fluxes are included in the mask + if (firstFluxCall .and. addFirstFlux) then + if (iVar==iLookFLUX%scalarSoilResistance) desiredFlux = .true. + if (iVar==iLookFLUX%scalarStomResistSunlit) desiredFlux = .true. + if (iVar==iLookFLUX%scalarStomResistShaded) desiredFlux = .true. + if (iVar==iLookFLUX%scalarPhotosynthesisSunlit) desiredFlux = .true. + if (iVar==iLookFLUX%scalarPhotosynthesisShaded) desiredFlux = .true. + end if + + if (nDomains==1) then ! no domain splitting + fluxMask%var(iVar)%dat = desiredFlux + else ! domain splitting + fluxMask%var(iVar)%dat = .false. ! initialize to .false. + if (desiredFlux) then ! only need to proceed if the flux is desired + select case(iDomainSplit) ! different domain splitting operations + case(vegSplit) ! canopy fluxes -- (:1) gets the upper boundary(0) if it exists + if (ixSolution==vector) then ! vector solution (should only be present for energy) + fluxMask%var(iVar)%dat(:1) = desiredFlux + if (ixStateThenDomain>1 .and. iStateTypeSplit/=nrgSplit) then + message=trim(message)//'only expect a vector solution for the vegetation domain for energy' + err=20; return_flag=.true.; return + end if + else ! scalar solution + fluxMask%var(iVar)%dat(:1) = desiredFlux + end if + case(snowSplit,soilSplit) ! fluxes through snow and soil + + do iLayer=1,nLayers! loop through layers + associate(ixLayerActive => indx_data%var(iLookINDEX%ixLayerActive)%dat) ! intent(in): [i4b(:)] indices for all active layers (inactive=integerMissing) + if (ixLayerActive(iLayer)/=integerMissing) then + + ! get the offset (ixLayerActive=1,2,3,...nLayers, and soil vectors nSnow+1, nSnow+2, ..., nLayers) + iOffset = merge(nSnow, 0, flux_meta(iVar)%vartype==iLookVarType%midSoil .or. flux_meta(iVar)%vartype==iLookVarType%ifcSoil) + jLayer = iLayer-iOffset + + ! identify the minimum layer + select case(flux_meta(iVar)%vartype) + case(iLookVarType%ifcToto, iLookVarType%ifcSnow, iLookVarType%ifcSoil); minLayer=merge(jLayer-1, jLayer, jLayer==1) + case(iLookVarType%midToto, iLookVarType%midSnow, iLookVarType%midSoil); minLayer=jLayer + case default; minLayer=integerMissing + end select + + ! set desired layers + select case(flux_meta(iVar)%vartype) + case(iLookVarType%midToto,iLookVarType%ifcToto); fluxMask%var(iVar)%dat(minLayer:jLayer) = desiredFlux + case(iLookVarType%midSnow,iLookVarType%ifcSnow); if (iLayer<=nSnow) fluxMask%var(iVar)%dat(minLayer:jLayer) = desiredFlux + case(iLookVarType%midSoil,iLookVarType%ifcSoil); if (iLayer> nSnow) fluxMask%var(iVar)%dat(minLayer:jLayer) = desiredFlux + end select + + ! add hydrology states for scalar variables + if (iStateTypeSplit==massSplit .and. flux_meta(iVar)%vartype==iLookVarType%scalarv) then + select case(iDomainSplit) + case(snowSplit); if(iLayer==nSnow) fluxMask%var(iVar)%dat = desiredFlux + case(soilSplit); + if(iVar==iLookFLUX%scalarSoilDrainage .or. iVar==iLookFLUX%scalarAquiferRecharge & ! soil drainage, aq recharge changes with the bottom layer + .or. iVar==iLookFLUX%scalarSoilBaseflow) then ! soil baseflow changes with all layers, so compute after bottom layer + if(iLayer==nLayers) fluxMask%var(iVar)%dat = desiredFlux + else ! other scalar variables in the soil domain change with the surface layer + if(iLayer==nSnow+1) fluxMask%var(iVar)%dat = desiredFlux + end if + end select + end if ! if hydrology split and scalar + + end if ! if the layer is active + end associate + end do ! end looping through layers + + case(aquiferSplit) ! fluxes through aquifer + fluxMask%var(iVar)%dat(:) = desiredFlux + case default; err=20; message=trim(message)//'unable to identify split based on domain type'; return_flag=.true.; return ! check + end select ! domain split + end if ! end if flux is desired + end if ! end if domain splitting + end if ! end if not fully coupled + + ! define if the flux is desired + if (desiredFlux) neededFlux(iVar)=.true. + if ( globalPrintFlag .and. count(fluxMask%var(iVar)%dat)>0 ) print*,'computing flux', trim(flux_meta(iVar)%varname) + + end do ! end looping through fluxes + + end subroutine update_fluxMask + +end subroutine opSplittin + +! ****** Class procedures for split_select_type class ****** + +subroutine split_select_initialize_flags(split_select) + ! *** Initialize flags for opSplittin split methods *** + class(split_select_type),intent(inout) :: split_select ! class object for operator splitting selector + split_select % stateTypeSplitting=.false. + split_select % stateThenDomain=.false. + split_select % domainSplit=.false. + split_select % solution=.false. + split_select % stateSplit=.false. +end subroutine split_select_initialize_flags + +subroutine split_select_advance_iSplit(split_select) + ! *** Advance index for coupling split method *** + class(split_select_type),intent(inout) :: split_select ! class object for operator splitting selector + split_select % iSplit = split_select % iSplit + 1 +end subroutine split_select_advance_iSplit + +subroutine split_select_advance_ixCoupling(split_select) + ! *** Advance index for coupling split method *** + class(split_select_type),intent(inout) :: split_select ! class object for operator splitting selector + split_select % ixCoupling = split_select % ixCoupling + 1 +end subroutine split_select_advance_ixCoupling + +subroutine split_select_advance_iStateTypeSplit(split_select) + ! *** Advance index for stateTypeSplit split method *** + class(split_select_type),intent(inout) :: split_select ! class object for operator splitting selector + split_select % iStateTypeSplit = split_select % iStateTypeSplit + 1 +end subroutine split_select_advance_iStateTypeSplit + +subroutine split_select_advance_ixStateThenDomain(split_select) + ! *** Advance index for stateThenDomain split method *** + class(split_select_type),intent(inout) :: split_select ! class object for operator splitting selector + split_select % ixStateThenDomain = split_select % ixStateThenDomain + 1 +end subroutine split_select_advance_ixStateThenDomain + +subroutine split_select_advance_iDomainSplit(split_select) + ! *** Advance index for domainSplit split method *** + class(split_select_type),intent(inout) :: split_select ! class object for operator splitting selector + split_select % iDomainSplit = split_select % iDomainSplit + 1 +end subroutine split_select_advance_iDomainSplit + +subroutine split_select_advance_ixSolution(split_select) + ! *** Advance index for solution split method *** + class(split_select_type),intent(inout) :: split_select ! class object for operator splitting selector + split_select % ixSolution = split_select % ixSolution + 1 +end subroutine split_select_advance_ixSolution + +subroutine split_select_advance_iStateSplit(split_select) + ! *** Advance index for stateSplit split method *** + class(split_select_type),intent(inout) :: split_select ! class object for operator splitting selector + split_select % iStateSplit = split_select % iStateSplit + 1 +end subroutine split_select_advance_iStateSplit + +subroutine split_select_initialize_ixCoupling(split_select) + ! *** initialize operator splitting indices for split_select_type class *** + class(split_select_type),intent(inout) :: split_select ! class object for operator splitting selector + split_select % ixCoupling = 1 +end subroutine split_select_initialize_ixCoupling + +subroutine split_select_initialize_iStateTypeSplit(split_select) + ! *** initialize operator splitting indices for split_select_type class *** + class(split_select_type),intent(inout) :: split_select ! class object for operator splitting selector + split_select % iStateTypeSplit = 1 +end subroutine split_select_initialize_iStateTypeSplit + +subroutine split_select_initialize_ixStateThenDomain(split_select) + ! *** initialize operator splitting indices for split_select_type class *** + class(split_select_type),intent(inout) :: split_select ! class object for operator splitting selector + split_select % ixStateThenDomain = 1 +end subroutine split_select_initialize_ixStateThenDomain + +subroutine split_select_initialize_iDomainSplit(split_select) + ! *** initialize operator splitting indices for split_select_type class *** + class(split_select_type),intent(inout) :: split_select ! class object for operator splitting selector + split_select % iDomainSplit = 1 +end subroutine split_select_initialize_iDomainSplit + +subroutine split_select_initialize_ixSolution(split_select) + ! *** initialize operator splitting indices for split_select_type class *** + class(split_select_type),intent(inout) :: split_select ! class object for operator splitting selector + split_select % ixSolution = 1 +end subroutine split_select_initialize_ixSolution + +subroutine split_select_initialize_iStateSplit(split_select) + ! *** initialize operator splitting indices for split_select_type class *** + class(split_select_type),intent(inout) :: split_select ! class object for operator splitting selector + split_select % iStateSplit = 1 +end subroutine split_select_initialize_iStateSplit + +logical(lgt) function split_select_logic_initialize_stateTypeSplitting(split_select) + ! *** Compute logical for branch in split_select loop *** + class(split_select_type),intent(in) :: split_select ! class object for operator splitting selector + split_select_logic_initialize_stateTypeSplitting=& + &(split_select % stateSplit.eqv..false.).and.(split_select % solution.eqv..false.).and.(split_select % domainSplit.eqv..false.).and.(split_select % stateThenDomain.eqv..false.).and.(split_select % stateTypeSplitting.eqv..false.) +end function split_select_logic_initialize_stateTypeSplitting + +logical(lgt) function split_select_logic_exit_stateTypeSplitting(split_select) + ! *** Compute logical for branch in split_select loop *** + class(split_select_type),intent(in) :: split_select ! class object for operator splitting selector + split_select_logic_exit_stateTypeSplitting=& + &(split_select % stateSplit.eqv..false.).and.(split_select % solution.eqv..false.).and.(split_select % domainSplit.eqv..false.).and.(split_select % stateThenDomain.eqv..false.).and.(split_select % stateTypeSplitting.eqv..true.) +end function split_select_logic_exit_stateTypeSplitting + +logical(lgt) function split_select_logic_initialize_stateThenDomain(split_select) + ! *** Compute logical for branch in split_select loop *** + class(split_select_type),intent(in) :: split_select ! class object for operator splitting selector + split_select_logic_initialize_stateThenDomain=& + &(split_select % stateSplit.eqv..false.).and.(split_select % solution.eqv..false.).and.(split_select % domainSplit.eqv..false.).and.(split_select % stateThenDomain.eqv..false.) +end function split_select_logic_initialize_stateThenDomain + +logical(lgt) function split_select_logic_exit_stateThenDomain(split_select) + ! *** Compute logical for branch in split_select loop *** + class(split_select_type),intent(in) :: split_select ! class object for operator splitting selector + split_select_logic_exit_stateThenDomain=& + &(split_select % stateSplit.eqv..false.).and.(split_select % solution.eqv..false.).and.(split_select % domainSplit.eqv..false.).and.(split_select % stateThenDomain.eqv..true.) +end function split_select_logic_exit_stateThenDomain + +logical(lgt) function split_select_logic_initialize_domainSplit(split_select) + ! *** Compute logical for branch in split_select loop *** + class(split_select_type),intent(in) :: split_select ! class object for operator splitting selector + split_select_logic_initialize_domainSplit=& + &(split_select % stateSplit.eqv..false.).and.(split_select % solution.eqv..false.).and.(split_select % domainSplit.eqv..false.) +end function split_select_logic_initialize_domainSplit + +logical(lgt) function split_select_logic_exit_domainSplit(split_select) + ! *** Compute logical for branch in split_select loop *** + class(split_select_type),intent(in) :: split_select ! class object for operator splitting selector + split_select_logic_exit_domainSplit=& + &(split_select % stateSplit.eqv..false.).and.(split_select % solution.eqv..false.).and.(split_select % domainSplit.eqv..true.) +end function split_select_logic_exit_domainSplit + +logical(lgt) function split_select_logic_initialize_solution(split_select) + ! *** Compute logical for branch in split_select loop *** + class(split_select_type),intent(in) :: split_select ! class object for operator splitting selector + split_select_logic_initialize_solution=(split_select % stateSplit.eqv..false.).and.(split_select % solution.eqv..false.) +end function split_select_logic_initialize_solution + +logical(lgt) function split_select_logic_exit_solution(split_select) + ! *** Compute logical for branch in split_select loop *** + class(split_select_type),intent(in) :: split_select ! class object for operator splitting selector + split_select_logic_exit_solution=(split_select % stateSplit.eqv..false.).and.(split_select % solution.eqv..true.) +end function split_select_logic_exit_solution + +logical(lgt) function split_select_logic_initialize_stateSplit(split_select) + ! *** Compute logical for branch in split_select loop *** + class(split_select_type),intent(in) :: split_select ! class object for operator splitting selector + split_select_logic_initialize_stateSplit=(split_select % stateSplit.eqv..false.) +end function split_select_logic_initialize_stateSplit + +logical(lgt) function split_select_logic_exit_stateSplit(split_select) + ! *** Compute logical for branch in split_select loop *** + class(split_select_type),intent(in) :: split_select ! class object for operator splitting selector + split_select_logic_exit_stateSplit=(split_select % stateSplit.eqv..true.) +end function split_select_logic_exit_stateSplit + +logical(lgt) function split_select_logic_finalize_stateSplit(split_select) + ! *** Compute logical for branch in split_select loop *** + class(split_select_type),intent(in) :: split_select ! class object for operator splitting selector + split_select_logic_finalize_stateSplit=& + &(split_select % stateSplit.eqv..false.).and.(split_select % solution.eqv..true.).and.(split_select % stateThenDomain.eqv..true.) +end function split_select_logic_finalize_stateSplit + +logical(lgt) function split_select_logic_finalize_solution(split_select) + ! *** Compute logical for branch in split_select loop *** + class(split_select_type),intent(in) :: split_select ! class object for operator splitting selector + split_select_logic_finalize_solution=& + &(split_select % stateSplit.eqv..false.).and.(split_select % solution.eqv..false.).and.(split_select % stateThenDomain.eqv..true.) +end function split_select_logic_finalize_solution + +logical(lgt) function split_select_logic_finalize_domainSplit(split_select) + ! *** Compute logical for branch in split_select loop *** + class(split_select_type),intent(in) :: split_select ! class object for operator splitting selector + split_select_logic_finalize_domainSplit=& + &(split_select % stateSplit.eqv..false.).and.(split_select % solution.eqv..false.).and.(split_select % domainSplit.eqv..false.).and.(split_select % stateThenDomain.eqv..true.) +end function split_select_logic_finalize_domainSplit + +logical(lgt) function split_select_logic_finalize_stateThenDomain(split_select) + ! *** Compute logical for branch in split_select loop *** + class(split_select_type),intent(in) :: split_select ! class object for operator splitting selector + split_select_logic_finalize_stateThenDomain=& + &(split_select % stateSplit.eqv..false.).and.(split_select % solution.eqv..false.).and.(split_select % domainSplit.eqv..false.).and.(split_select % stateThenDomain.eqv..false.) +end function split_select_logic_finalize_stateThenDomain + +logical(lgt) function split_select_logic_finalize_stateTypeSplitting(split_select) + ! *** Compute logical for branch in split_select loop *** + class(split_select_type),intent(in) :: split_select ! class object for operator splitting selector + split_select_logic_finalize_stateTypeSplitting=& + &(split_select % stateSplit.eqv..false.).and.(split_select % solution.eqv..false.).and.(split_select % domainSplit.eqv..false.).and.(split_select % stateThenDomain.eqv..false.).and.(split_select % stateTypeSplitting.eqv..false.) +end function split_select_logic_finalize_stateTypeSplitting + +subroutine split_select_compute_stateMask(split_select,indx_data,err,cmessage,message,return_flag) + ! *** Get the mask for the state subset *** + class(split_select_type),intent(inout) :: split_select ! class object for operator splitting selector + type(var_ilength),intent(in) :: indx_data ! indices for a local HRU + integer(i4b),intent(out) :: err ! intent(out): error code + character(*),intent(out) :: cmessage ! intent(out): error message + character(*),intent(out) :: message ! error message + logical(lgt),intent(out) :: return_flag ! return flag + ! local variables + type(out_type_stateFilter) :: out_stateFilter ! number of selected state variables for a given split and error control + + err=0 ! initialize error code + return_flag=.false. ! initialize flag + call stateFilter(indx_data,split_select,out_stateFilter) + call out_stateFilter % finalize(err,cmessage) + if (err/=0) then; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if ! error control +end subroutine split_select_compute_stateMask + + +! ********************************************************************************************************** +! private subroutine stateFilter: get a mask for the desired state variables +! ********************************************************************************************************** + subroutine stateFilter(indx_data,split_select,out_stateFilter) + USE indexState_module,only:indxSubset ! get state indices implicit none ! input - integer(i4b),intent(in) :: ixCoupling ! index of coupling method (1,2) - integer(i4b),intent(in) :: ixSolution ! index of solution method (1,2) - integer(i4b),intent(in) :: ixStateThenDomain ! switch between full domain and sub domains - integer(i4b),intent(in) :: iStateTypeSplit ! index of the state type split - integer(i4b),intent(in) :: iDomainSplit ! index of the domain split - integer(i4b),intent(in) :: iStateSplit ! index of the layer split - type(var_ilength),intent(inout) :: indx_data ! indices for a local HRU + type(var_ilength),intent(in) :: indx_data ! indices for a local HRU + ! input-output + type(split_select_type),intent(inout) :: split_select ! class object for operator splitting selector ! output - logical(lgt),intent(out) :: stateMask(:) ! mask defining desired state variables - integer(i4b),intent(out) :: nSubset ! number of selected state variables for a given split - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + type(out_type_stateFilter),intent(out) :: out_stateFilter ! number of selected state variables for a given split and error control ! local - integer(i4b),allocatable :: ixSubset(:) ! list of indices in the state subset - character(len=256) :: cmessage ! error message - ! -------------------------------------------------------------------------------------------------------------------------------------------------------------------------- + integer(i4b),allocatable :: ixSubset(:) ! list of indices in the state subset + character(len=256) :: cmessage ! error message + logical(lgt) :: return_flag ! flag to indicate a return + ! ---------------------------------------------------------------------------------------------------------------------------------------------------- ! data structures - associate(& - ! indices of model state variables - ixStateType => indx_data%var(iLookINDEX%ixStateType)%dat ,& ! intent(in): [i4b(:)] indices defining the type of the state (ixNrgState...) - ixNrgCanair => indx_data%var(iLookINDEX%ixNrgCanair)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for energy states in canopy air space domain - ixNrgCanopy => indx_data%var(iLookINDEX%ixNrgCanopy)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for energy states in the canopy domain - ixHydCanopy => indx_data%var(iLookINDEX%ixHydCanopy)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for hydrology states in the canopy domain - ixNrgLayer => indx_data%var(iLookINDEX%ixNrgLayer)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for energy states in the snow+soil domain - ixHydLayer => indx_data%var(iLookINDEX%ixHydLayer)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for hydrology states in the snow+soil domain - ixWatAquifer => indx_data%var(iLookINDEX%ixWatAquifer)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for water storage in the aquifer - ixAllState => indx_data%var(iLookINDEX%ixAllState)%dat ,& ! intent(in): [i4b(:)] list of indices for all model state variables (1,2,3,...nState) - ! number of layers - nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in): [i4b] number of snow layers - nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1) ,& ! intent(in): [i4b] number of soil layers - nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1) & ! intent(in): [i4b] total number of layers - ) ! data structures - ! -------------------------------------------------------------------------------------------------------------------------------------------------------------------------- - ! initialize error control - err=0; message='stateFilter/' - - ! identify splitting option - select case(ixCoupling) - - ! ----- - ! - fully coupled... - ! ------------------ - - ! use all state variables - case(fullyCoupled); stateMask(:) = .true. - - ! ----- - ! - splitting by state type... - ! ---------------------------- - - ! initial split by state type - case(stateTypeSplit) - - ! switch between full domain and sub domains - select case(ixStateThenDomain) - - ! split into energy and mass - case(fullDomain) - select case(iStateTypeSplit) - case(nrgSplit); stateMask = (ixStateType==iname_nrgCanair .or. ixStateType==iname_nrgCanopy .or. ixStateType==iname_nrgLayer) - case(massSplit); stateMask = (ixStateType==iname_liqCanopy .or. ixStateType==iname_liqLayer .or. ixStateType==iname_lmpLayer .or. ixStateType==iname_watAquifer) - case default; err=20; message=trim(message)//'unable to identify split based on state type'; return - end select - - ! split into vegetation, snow, and soil - case(subDomain) - - ! define state mask - stateMask=.false. ! (initialize state mask) - select case(iStateTypeSplit) - - ! define mask for energy - case(nrgSplit) - select case(iDomainSplit) - case(vegSplit) - if(ixNrgCanair(1)/=integerMissing) stateMask(ixNrgCanair) = .true. ! energy of the canopy air space - if(ixNrgCanopy(1)/=integerMissing) stateMask(ixNrgCanopy) = .true. ! energy of the vegetation canopy - stateMask(ixNrgLayer(1)) = .true. ! energy of the upper-most layer in the snow+soil domain - case(snowSplit); if(nSnow>1) stateMask(ixNrgLayer(2:nSnow)) = .true. ! NOTE: (2:) because the top layer in the snow+soil domain included in vegSplit - case(soilSplit); stateMask(ixNrgLayer(max(2,nSnow+1):nLayers)) = .true. ! NOTE: max(2,nSnow+1) gives second layer unless more than 2 snow layers - case(aquiferSplit) ! do nothing: no energy state variable for the aquifer domain - case default; err=20; message=trim(message)//'unable to identify model sub-domain'; return - end select - - ! define mask for water - case(massSplit) - select case(iDomainSplit) - case(vegSplit); if(ixHydCanopy(1)/=integerMissing) stateMask(ixHydCanopy) = .true. ! hydrology of the vegetation canopy - case(snowSplit); stateMask(ixHydLayer(1:nSnow)) = .true. ! snow hydrology - case(soilSplit); stateMask(ixHydLayer(nSnow+1:nLayers)) = .true. ! soil hydrology - case(aquiferSplit); if(ixWatAquifer(1)/=integerMissing) stateMask(ixWatAquifer) = .true. ! aquifer storage - case default; err=20; message=trim(message)//'unable to identify model sub-domain'; return - end select - - ! check - case default; err=20; message=trim(message)//'unable to identify the state type'; return - end select ! (split based on state type) + associate(ixCoupling => split_select % ixCoupling ,& ! intent(in): [i4b] index of coupling method (1,2) + err => out_stateFilter % err ,& ! intent(out): error code + message => out_stateFilter % cmessage ) ! intent(out): error message + + err=0; message='stateFilter/'; return_flag=.false. ! initialize error control + ! identify splitting option + select case(ixCoupling) + ! *** fully coupled *** + case(fullyCoupled); call fullyCoupled_stateMask ! get stateMask for fully coupled method + ! *** splitting by state type *** + case(stateTypeSplit) ! initial split by state type + call stateTypeSplit_stateMask; if (return_flag) return ! get stateMask for state split method -- return if error ! check - case default; err=20; message=trim(message)//'unable to identify the switch between full domains and sub domains'; return - end select ! (switch between full domains and sub domains) - - ! check - case default; err=20; message=trim(message)//'unable to identify coupling method'; return - end select ! (selecting solution method) - - !print*, 'stateMask = ', stateMask - - ! identify scalar solutions - if(ixSolution==scalar)then - - ! get the subset of indices - call indxSubset(ixSubset, ixAllState, stateMask, err, cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + case default; err=20; message=trim(message)//'unable to identify coupling method'; return_flag=.true.; return + end select ! selecting solution method - ! get the mask - stateMask(:) = .false. - stateMask( ixSubset(iStateSplit) ) = .true. - - ! check - if(count(stateMask)/=1)then - message=trim(message)//'expect size=1 (scalar)' - err=20; return - endif + ! initialize ixSubset + allocate(ixSubset(1_i4b),STAT=err) + if (err/=0) then; message=trim(message)//'allocation error in stateFilter for ixSubset'; return_flag=.true.; return; end if + ixSubset = 0._rkind + end associate - endif + call identify_scalar_solutions; if (return_flag) return ! identify scalar solutions -- return if error occurs ! get the number of selected state variables - nSubset = count(stateMask) + split_select % nSubset = count(split_select % stateMask) - ! end associations - end associate +contains - end subroutine stateFilter + subroutine fullyCoupled_stateMask + ! *** Get fully coupled stateMask *** + split_select % stateMask(:) = .true. ! use all state variables + end subroutine fullyCoupled_stateMask + + subroutine stateTypeSplit_stateMask + ! *** Get state type split stateMask *** + return_flag=.false. ! initialize flag + ! switch between full domain and sub domains + associate(& + ixStateThenDomain => split_select % ixStateThenDomain,& ! intent(in): [i4b] switch between full domain and sub domains + err => out_stateFilter % err ,& ! intent(out): error code + message => out_stateFilter % cmessage ) ! intent(out): error message + select case(ixStateThenDomain) + ! split into energy and mass + case(fullDomain); call stateTypeSplit_fullDomain_stateMask; if (return_flag) return + ! split into vegetation, snow, and soil + case(subDomain); call stateTypeSplit_subDomain_stateMask; if (return_flag) return + ! check + case default + err=20; message=trim(message)//'unable to identify the switch between full domains and sub domains'; return_flag=.true.; return + end select + end associate + end subroutine stateTypeSplit_stateMask + + subroutine stateTypeSplit_fullDomain_stateMask + ! *** Get full domain stateMask *** + return_flag=.false. ! initialize flag + associate(iStateTypeSplit => split_select % iStateTypeSplit,& ! intent(in): [i4b] index of the state type split + err => out_stateFilter % err ,& ! intent(out): error code + message => out_stateFilter % cmessage ) ! intent(out): error message + select case(iStateTypeSplit) + case(nrgSplit); call stateTypeSplit_fullDomain_nrgSplit_stateMask + case(massSplit); call stateTypeSplit_fullDomain_massSplit_stateMask + case default; err=20; message=trim(message)//'unable to identify split based on state type'; return_flag=.true.; return + end select + end associate + end subroutine stateTypeSplit_fullDomain_stateMask + + subroutine stateTypeSplit_fullDomain_nrgSplit_stateMask + ! *** Get state type full domain energy split stateMask *** + associate(ixStateType => indx_data%var(iLookINDEX%ixStateType)%dat) ! intent(in): [i4b(:)] indices defining the type of the state (ixNrgState...) + split_select % stateMask = (ixStateType==iname_nrgCanair .or. ixStateType==iname_nrgCanopy .or. ixStateType==iname_nrgLayer) + end associate + end subroutine stateTypeSplit_fullDomain_nrgSplit_stateMask + + subroutine stateTypeSplit_fullDomain_massSplit_stateMask + ! *** Get state type full domain mass split stateMask *** + associate(ixStateType => indx_data%var(iLookINDEX%ixStateType)%dat) ! intent(in): [i4b(:)] indices defining the type of the state (ixNrgState...) + split_select % stateMask = (ixStateType==iname_liqCanopy .or. ixStateType==iname_liqLayer .or. & + & ixStateType==iname_lmpLayer .or. ixStateType==iname_watAquifer) + end associate + end subroutine stateTypeSplit_fullDomain_massSplit_stateMask + + subroutine stateTypeSplit_subDomain_stateMask + ! *** Get subdomain stateMask *** + return_flag=.false. ! initialize flag + ! define state mask + associate(& + iStateTypeSplit => split_select % iStateTypeSplit,& ! intent(in): [i4b] index of the state type split + err => out_stateFilter % err ,& ! intent(out): error code + message => out_stateFilter % cmessage ) ! intent(out): error message + split_select % stateMask(:)=.false. ! initialize state mask + select case(iStateTypeSplit) + ! define mask for energy + case(nrgSplit); call stateTypeSplit_subDomain_nrgSplit_stateMask; if (return_flag) return + ! define mask for water + case(massSplit); call stateTypeSplit_subDomain_massSplit_stateMask; if (return_flag) return + ! check + case default; err=20; message=trim(message)//'unable to identify the state type'; return_flag=.true.; return + end select ! (split based on state type) + end associate + end subroutine stateTypeSplit_subDomain_stateMask + + subroutine stateTypeSplit_subDomain_nrgSplit_stateMask + ! *** Get subdomain energy split stateMask *** + return_flag=.false. ! initialize flag + associate(& + iDomainSplit => split_select % iDomainSplit,& ! intent(in): [i4b] index of the domain split + err => out_stateFilter % err ,& ! intent(out): error code + message => out_stateFilter % cmessage ) ! intent(out): error message + select case(iDomainSplit) + case(vegSplit); call stateTypeSplit_subDomain_nrgSplit_vegSplit_stateMask ! vegetation subdomain + case(snowSplit); call stateTypeSplit_subDomain_nrgSplit_snowSplit_stateMask ! snow subdomain + case(soilSplit); call stateTypeSplit_subDomain_nrgSplit_soilSplit_stateMask ! soil subdomain + case(aquiferSplit) ! do nothing: no energy state variable for the aquifer domain ! aquifer subdomain + case default; err=20; message=trim(message)//'unable to identify model sub-domain'; return_flag=.true.; return + end select + end associate + end subroutine stateTypeSplit_subDomain_nrgSplit_stateMask + + subroutine stateTypeSplit_subDomain_nrgSplit_vegSplit_stateMask + ! *** Get state type subdomain energy vegetation split *** + associate(& + ixNrgCanair => indx_data%var(iLookINDEX%ixNrgCanair)%dat,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for energy states in canopy air space domain + ixNrgCanopy => indx_data%var(iLookINDEX%ixNrgCanopy)%dat,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for energy states in the canopy domain + ixNrgLayer => indx_data%var(iLookINDEX%ixNrgLayer)%dat ) ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for energy states in the snow+soil domain + if (ixNrgCanair(1)/=integerMissing) split_select % stateMask(ixNrgCanair) = .true. ! energy of the canopy air space + if (ixNrgCanopy(1)/=integerMissing) split_select % stateMask(ixNrgCanopy) = .true. ! energy of the vegetation canopy + split_select % stateMask(ixNrgLayer(1)) = .true. ! energy of the upper-most layer in the snow+soil domain + end associate + end subroutine stateTypeSplit_subDomain_nrgSplit_vegSplit_stateMask + + subroutine stateTypeSplit_subDomain_nrgSplit_snowSplit_stateMask + associate(& + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in): [i4b] number of snow layers + ixNrgLayer => indx_data%var(iLookINDEX%ixNrgLayer)%dat ) ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for energy states in the snow+soil domain + ! *** Get state type subdomain energy snow split *** + if (nSnow>1) split_select % stateMask(ixNrgLayer(2:nSnow)) = .true. ! NOTE: (2:) because the top layer in the snow+soil domain included in vegSplit + end associate + end subroutine stateTypeSplit_subDomain_nrgSplit_snowSplit_stateMask + + subroutine stateTypeSplit_subDomain_nrgSplit_soilSplit_stateMask + ! *** Get state type subdomain energy soil split *** + associate(& + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in): [i4b] number of snow layers + nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1),& ! intent(in): [i4b] total number of layers + ixNrgLayer => indx_data%var(iLookINDEX%ixNrgLayer)%dat ) ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for energy states in the snow+soil domain + split_select % stateMask(ixNrgLayer(max(2,nSnow+1):nLayers)) = .true. ! NOTE: max(2,nSnow+1) gives second layer unless more than 2 snow layers + end associate + end subroutine stateTypeSplit_subDomain_nrgSplit_soilSplit_stateMask + + subroutine stateTypeSplit_subDomain_massSplit_stateMask + ! *** Get subdomain mass split stateMask *** + return_flag=.false. ! initialize flag + associate(& + iDomainSplit => split_select % iDomainSplit,& ! intent(in): [i4b] index of the domain split + err => out_stateFilter % err ,& ! intent(out): error code + message => out_stateFilter % cmessage ) ! intent(out): error message + select case(iDomainSplit) + case(vegSplit); call stateTypeSplit_subDomain_massSplit_vegSplit_stateMask ! vegetation subdomain + case(snowSplit); call stateTypeSplit_subDomain_massSplit_snowSplit_stateMask ! snow subdomain + case(soilSplit); call stateTypeSplit_subDomain_massSplit_soilSplit_stateMask ! soil subdomain + case(aquiferSplit); call stateTypeSplit_subDomain_massSplit_aquiferSplit_stateMask ! aquifer subdomain + case default; err=20; message=trim(message)//'unable to identify model sub-domain'; return_flag=.true.; return + end select + end associate + end subroutine stateTypeSplit_subDomain_massSplit_stateMask + + subroutine stateTypeSplit_subDomain_massSplit_vegSplit_stateMask + ! *** Get mass state vegetation subdomain split stateMask *** + associate(ixHydCanopy => indx_data%var(iLookINDEX%ixHydCanopy)%dat) ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for hydrology states in the canopy domain + if (ixHydCanopy(1)/=integerMissing) split_select % stateMask(ixHydCanopy) = .true. ! hydrology of the vegetation canopy + end associate + end subroutine stateTypeSplit_subDomain_massSplit_vegSplit_stateMask + + subroutine stateTypeSplit_subDomain_massSplit_snowSplit_stateMask + ! *** Get mass state snow subdomain split stateMask *** + associate(& + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in): [i4b] number of snow layers + ixHydLayer => indx_data%var(iLookINDEX%ixHydLayer)%dat ) ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for hydrology states in the snow+soil domain + split_select % stateMask(ixHydLayer(1:nSnow)) = .true. ! snow hydrology + end associate + end subroutine stateTypeSplit_subDomain_massSplit_snowSplit_stateMask + + subroutine stateTypeSplit_subDomain_massSplit_soilSplit_stateMask + ! *** Get mass state soil subdomain split stateMask *** + associate(& + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in): [i4b] number of snow layers + nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1),& ! intent(in): [i4b] total number of layers + ixHydLayer => indx_data%var(iLookINDEX%ixHydLayer)%dat ) ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for hydrology states in the snow+soil domain + split_select % stateMask(ixHydLayer(nSnow+1:nLayers)) = .true. ! soil hydrology + end associate + end subroutine stateTypeSplit_subDomain_massSplit_soilSplit_stateMask + + subroutine stateTypeSplit_subDomain_massSplit_aquiferSplit_stateMask + ! *** Get mass state aquifer subdomain split stateMask *** + associate(ixWatAquifer => indx_data%var(iLookINDEX%ixWatAquifer)%dat) ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for water storage in the aquifer + if (ixWatAquifer(1)/=integerMissing) split_select % stateMask(ixWatAquifer) = .true. ! aquifer storage + end associate + end subroutine stateTypeSplit_subDomain_massSplit_aquiferSplit_stateMask + + subroutine identify_scalar_solutions + ! *** Identify scalar solutions *** + return_flag=.false. ! initialize flag + associate(ixAllState => indx_data%var(iLookINDEX%ixAllState)%dat,& ! intent(in): [i4b(:)] list of indices for all model state variables (1,2,3,...nState) + ixSolution => split_select % ixSolution ,& ! intent(in): [i4b] index of solution method (1,2) + iStateSplit => split_select % iStateSplit ,& ! intent(in): [i4b] index of the layer split + err => out_stateFilter % err ,& ! intent(out): error code + message => out_stateFilter % cmessage ) ! intent(out): error message + if (ixSolution==scalar) then + ! get the subset of indices + call indxSubset(ixSubset, ixAllState, split_select % stateMask, err, cmessage) + if (err/=0) then; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if + ! get the mask + split_select % stateMask(:) = .false. + split_select % stateMask( ixSubset(iStateSplit) ) = .true. + ! check + if (count(split_select % stateMask)/=1) then + message=trim(message)//'expect size=1 (scalar)' + err=20; return_flag=.true.; return + end if + end if + end associate + + end subroutine identify_scalar_solutions + +end subroutine stateFilter end module opSplittin_module diff --git a/build/source/engine/pOverwrite.f90 b/build/source/engine/pOverwrite.f90 old mode 100755 new mode 100644 index 34648eccd..726143f5b --- a/build/source/engine/pOverwrite.f90 +++ b/build/source/engine/pOverwrite.f90 @@ -29,7 +29,7 @@ module pOverwrite_module ! ************************************************************************************************ ! public subroutine pOverwrite: use Noah tables to overwrite default model parameters ! ************************************************************************************************ - subroutine pOverwrite(ixVeg,ixSoil,defaultParam,err,message) + subroutine pOverwrite(ixVeg,ixSoil,soilCatTbl, defaultParam,err,message) ! SUMMA dictionary USE var_lookup,only:iLookPARAM ! named variables for elements of the data structures ! Noah table dimensions @@ -43,17 +43,25 @@ subroutine pOverwrite(ixVeg,ixSoil,defaultParam,err,message) USE NOAHMP_VEG_PARAMETERS, only: VCMX25 ! Noah-MP: maximum Rubisco carboxylation rate (umol m-2 s-1) USE NOAHMP_VEG_PARAMETERS, only: MP ! Noah-MP: slope of conductance-photosynthesis relationship (-) ! Noah soil tables - USE module_sf_noahlsm, only: theta_res, theta_sat, vGn_alpha, vGn_n, k_soil ! van Genutchen soil parameters + USE module_sf_noahlsm, only: theta_res, theta_sat, vGn_alpha, vGn_n, k_soil ! van Genutchen soil parameters, only ROSETTA USE module_sf_noahlsm, only: REFSMC ! Noah-MP: reference volumetric soil moisture content (-) USE module_sf_noahlsm, only: WLTSMC ! Noah-MP: volumetric soil moisture content when plants are wilting (-) + USE module_sf_noahlsm, only: SATDK ! Noah-MP: saturated hydraulic conductivity (m s-1) + USE module_sf_noahlsm, only: DRYSMC ! Noah-MP: dry soil moisture content (-) + USE module_sf_noahlsm, only: MAXSMC ! Noah-MP: soil porosity (-) + USE module_sf_noahlsm, only: SATPSI ! Noah-MP: saturated soil matric potential (m) + USE module_sf_noahlsm, only: BB ! Noah-MP: Clapp-Hornberger exponent (-) implicit none ! define input integer(i4b),intent(in) :: ixVeg ! vegetation category integer(i4b),intent(in) :: ixSoil ! soil category + character(*), intent(in) :: soilCatTbl ! soil category table name ! define output - real(rkind),intent(inout) :: defaultParam(:) ! default model parameters + real(rkind),intent(inout) :: defaultParam(:) ! default model parameters integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message + ! local variables + real(rkind) :: p ! temporary variable for van Genuchten parameter calculation ! Start procedure here err=0; message="pOverwrite/" @@ -82,13 +90,26 @@ subroutine pOverwrite(ixVeg,ixSoil,defaultParam,err,message) defaultParam(iLookPARAM%cond2photo_slope) = MP(ixVeg) ! Noah-MP: slope of conductance-photosynthesis relationship (-) ! include parameters from the soil tables - defaultParam(iLookPARAM%k_soil) = k_soil(ixSoil) ! hydraulic conductivity (m s-1) - defaultParam(iLookPARAM%theta_res) = theta_res(ixSoil) ! residual volumetric liquid water content (-) - defaultParam(iLookPARAM%theta_sat) = theta_sat(ixSoil) ! soil porosity (-) - defaultParam(iLookPARAM%vGn_alpha) = vGn_alpha(ixSoil) ! van Genutchen "alpha" parameter (m-1) - defaultParam(iLookPARAM%vGn_n) = vGn_n(ixSoil) ! van Genutchen "n" parameter (-) - defaultParam(iLookPARAM%critSoilTranspire) = REFSMC(ixSoil) ! Noah-MP: reference volumetric soil moisture content (-) - defaultParam(iLookPARAM%critSoilWilting) = WLTSMC(ixSoil) ! Noah-MP: volumetric soil moisture content when plants are wilting (-) + select case(trim(soilCatTbl)) + case('ROSETTA') + ! use van Genutchen parameters only available for ROSETTA soil categories + defaultParam(iLookPARAM%k_soil) = k_soil(ixSoil) ! hydraulic conductivity (m s-1) + defaultParam(iLookPARAM%theta_res) = theta_res(ixSoil) ! residual volumetric liquid water content (-) + defaultParam(iLookPARAM%theta_sat) = theta_sat(ixSoil) ! soil porosity (-) + defaultParam(iLookPARAM%vGn_alpha) = vGn_alpha(ixSoil) ! van Genutchen "alpha" parameter (m-1) + defaultParam(iLookPARAM%vGn_n) = vGn_n(ixSoil) ! van Genutchen "n" parameter (-) + case('STAS','STAS-RUC') + defaultParam(iLookPARAM%k_soil) = SATDK(ixSoil) ! Noah-MP: saturated hydraulic conductivity (m s-1) + defaultParam(iLookPARAM%theta_res) = DRYSMC(ixSoil) ! Noah-MP: minumum soil moisture content used as residual volumetric liquid water content (-) + defaultParam(iLookPARAM%theta_sat) = MAXSMC(ixSoil) ! Noah-MP: soil porosity (-) + ! following Morel-Seytouxet al., 1996, use empirical relations to estimate van Genuchten parameters from Clapp-Hornberger parameters + defaultParam(iLookPARAM%vGn_n) = (BB(ixSoil)+1._rkind)/BB(ixSoil) ! Noah-MP: van Genuchten n parameter (-) + p = 2.0_rkind*BB(ixSoil)+3.0_rkind + defaultParam(iLookPARAM%vGn_alpha) = -1._rkind/SATPSI(ixSoil) * (p + 3._rkind)/(2._rkind*p* (p - 1._rkind)) * & + (147.8_rkind + 8.1_rkind*p + 0.092_rkind * p**2_i4b) / (55.6_rkind + 7.4_rkind*p + p**2_i4b) ! Noah-MP: van Genuchten alpha parameter (m-1) + end select + defaultParam(iLookPARAM%critSoilTranspire) = REFSMC(ixSoil) ! Noah-MP: reference volumetric soil moisture content (-) + defaultParam(iLookPARAM%critSoilWilting) = WLTSMC(ixSoil) ! Noah-MP: volumetric soil moisture content when plants are wilting (-) end subroutine pOverwrite diff --git a/build/source/engine/paramCheck.f90 b/build/source/engine/paramCheck.f90 old mode 100755 new mode 100644 index 0cf3742ab..c372f2aa0 --- a/build/source/engine/paramCheck.f90 +++ b/build/source/engine/paramCheck.f90 @@ -39,7 +39,7 @@ subroutine paramCheck(mpar_data,err,message) USE globalData,only:model_decisions ! model decision structure USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure ! SUMMA look-up variables - USE data_types,only:var_dlength ! data vector with variable length dimension (dp): x%var(:)%dat(:) + USE data_types,only:var_dlength ! data vector with variable length dimension (rkind): x%var(:)%dat(:) USE var_lookup,only:iLookPARAM ! named variables for elements of the data structures implicit none ! define input @@ -49,9 +49,9 @@ subroutine paramCheck(mpar_data,err,message) character(*),intent(out) :: message ! error message ! local variables integer(i4b) :: iLayer ! index of model layers - real(rkind),dimension(5) :: zminLayer ! minimum layer depth in each layer (m) - real(rkind),dimension(4) :: zmaxLayer_lower ! lower value of maximum layer depth - real(rkind),dimension(4) :: zmaxLayer_upper ! upper value of maximum layer depth + real(rkind),dimension(5) :: zminLayer ! minimum layer depth in each layer (m) + real(rkind),dimension(4) :: zmaxLayer_lower ! lower value of maximum layer depth + real(rkind),dimension(4) :: zmaxLayer_upper ! upper value of maximum layer depth ! Start procedure here err=0; message="paramCheck/" @@ -107,7 +107,8 @@ subroutine paramCheck(mpar_data,err,message) ! ------------------------------------------------------------------------------------------------------------------------------------------- ! ***** - ! * check parameter dependencies... + ! * check soil parameter dependencies... + ! theta_res < critSoilWilting < critSoilTranspire < fieldCapacit < theta_sat ! ********************************* ! associations @@ -116,8 +117,8 @@ subroutine paramCheck(mpar_data,err,message) heightCanopyTop => mpar_data%var(iLookPARAM%heightCanopyTop)%dat(1), & ! intent(in): [dp] height at the top of the vegetation canopy (m) heightCanopyBottom => mpar_data%var(iLookPARAM%heightCanopyBottom)%dat(1),& ! intent(in): [dp] height at the bottom of the vegetation canopy (m) ! transpiration - critSoilWilting => mpar_data%var(iLookPARAM%critSoilWilting)%dat, & ! intent(in): [dp] critical vol. liq. water content when plants are wilting (-) - critSoilTranspire => mpar_data%var(iLookPARAM%critSoilTranspire)%dat, & ! intent(in): [dp] critical vol. liq. water content when transpiration is limited (-) + critSoilWilting => mpar_data%var(iLookPARAM%critSoilWilting)%dat(1), & ! intent(in): [dp] critical vol. liq. water content when plants are wilting (-) + critSoilTranspire => mpar_data%var(iLookPARAM%critSoilTranspire)%dat(1), & ! intent(in): [dp] critical vol. liq. water content when transpiration is limited (-) ! soil properties fieldCapacity => mpar_data%var(iLookPARAM%fieldCapacity)%dat(1), & ! intent(in): [dp] field capacity (-) theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat, & ! intent(in): [dp(:)] soil porosity (-) @@ -161,13 +162,15 @@ subroutine paramCheck(mpar_data,err,message) end if ! check transpiration - if( any(critSoilTranspire < critSoilWilting) )then + if( critSoilTranspire < critSoilWilting )then write(message,'(a,i0,a)') trim(message)//'critical point for transpiration is less than the wilting point' err=20; return endif ! check porosity if( any(theta_sat < theta_res) )then + print*, 'theta_res = ', theta_res + print*, 'theta_sat = ', theta_sat write(message,'(a,i0,a)') trim(message)//'porosity is less than the residual liquid water content' err=20; return endif diff --git a/build/source/engine/qTimeDelay.f90 b/build/source/engine/qTimeDelay.f90 old mode 100755 new mode 100644 index ba5a5aa16..cc48f35ef --- a/build/source/engine/qTimeDelay.f90 +++ b/build/source/engine/qTimeDelay.f90 @@ -22,6 +22,7 @@ module qTimeDelay_module ! data types USE nrtype +USE globalData,only:realMissing ! missing real number ! look-up values for the sub-grid routing method USE mDecisions_module,only: & @@ -49,18 +50,18 @@ subroutine qOverland(& err,message) ! error control implicit none ! input - integer(i4b),intent(in) :: ixRouting ! index for routing method - real(rkind),intent(in) :: averageTotalRunoff ! total runoff to the channel from all active components (m s-1) - real(rkind),intent(in) :: fracFuture(:) ! fraction of runoff in future time steps (m s-1) - real(rkind),intent(inout) :: qFuture(:) ! runoff in future time steps (m s-1) + integer(i4b),intent(in) :: ixRouting ! index for routing method + real(rkind),intent(in) :: averageTotalRunoff ! total runoff to the channel from all active components (m s-1) + real(rkind),intent(in) :: fracFuture(:) ! fraction of runoff in future time steps (m s-1) + real(rkind),intent(inout) :: qFuture(:) ! runoff in future time steps (m s-1) ! output - real(rkind),intent(out) :: averageInstantRunoff ! instantaneous runoff (m s-1) - real(rkind),intent(out) :: averageRoutedRunoff ! routed runoff (m s-1) - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + real(rkind),intent(out) :: averageInstantRunoff ! instantaneous runoff (m s-1) + real(rkind),intent(out) :: averageRoutedRunoff ! routed runoff (m s-1) + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message ! internal - integer(i4b) :: nTDH ! number of points in the time-delay histogram - integer(i4b) :: iFuture ! index in time delay histogram + integer(i4b) :: nTDH ! number of points in the time-delay histogram + integer(i4b) :: iFuture ! index in time delay histogram ! initialize error control err=0; message='qOverland/' @@ -91,6 +92,11 @@ subroutine qOverland(& case default; err=20; message=trim(message)//'cannot find option for sub-grid routing'; return end select ! (select option for sub-grid routing) + ! For open water SUMMA doesn't run any calculations + ! the values for any output variables in the netCDF will stay at the value at which they were initialized, which may be a large negative + ! Coast may be similarly large and negative + !if (averageRoutedRunoff < 0._rkind) averageRoutedRunoff = realMissing + end subroutine qOverland diff --git a/build/source/engine/read_attrb.f90 b/build/source/engine/read_attrb.f90 old mode 100755 new mode 100644 index 8f13ac0f9..f26a79d7f --- a/build/source/engine/read_attrb.f90 +++ b/build/source/engine/read_attrb.f90 @@ -53,8 +53,8 @@ subroutine read_dimension(attrFile,fileGRU,fileHRU,nGRU,nHRU,err,message,startGR integer(i4b) :: sGRU ! starting GRU integer(i4b) :: iHRU ! HRU couinting index integer(i4b) :: iGRU ! GRU loop index - integer(8),allocatable :: gru_id(:),hru_id(:)! read gru/hru IDs in from attributes file - integer(8),allocatable :: hru2gru_id(:) ! read hru->gru mapping in from attributes file + integer(i8b),allocatable :: gru_id(:),hru_id(:)! read gru/hru IDs in from attributes file + integer(i8b),allocatable :: hru2gru_id(:) ! read hru->gru mapping in from attributes file integer(i4b),allocatable :: hru_ix(:) ! hru index for search ! define variables for NetCDF file operation @@ -123,16 +123,17 @@ subroutine read_dimension(attrFile,fileGRU,fileHRU,nGRU,nHRU,err,message,startGR err = nf90_inq_varid(ncID,"hru2gruId",varID); if (err/=0) then; message=trim(message)//'problem finding hru2gruId'; return; end if err = nf90_get_var(ncID,varID,hru2gru_id); if (err/=0) then; message=trim(message)//'problem reading hru2gruId'; return; end if - ! close netcdf file - call nc_file_close(ncID,err,cmessage) - if (err/=0) then; message=trim(message)//trim(cmessage); return; end if - ! array from 1 to total # of HRUs in attributes file hru_ix=arth(1,1,fileHRU) ! check that the mappings are not alreaday allocated -if (allocated(gru_struc)) then; message=trim(message)//'gru_struc is unexpectedly allocated'; return; end if -if (allocated(index_map)) then; message=trim(message)//'index_map is unexpectedly allocated'; return; end if +#ifdef NGEN_ACTIVE +if (allocated(gru_struc)) deallocate(gru_struc) ! free existing mapping possibly from previous GRU run +if (allocated(index_map)) deallocate(index_map) ! free existing mapping possibly from previous GRU run +#else +if (allocated(gru_struc)) then; err=20; message=trim(message)//'gru_struc is unexpectedly allocated'; return; end if +if (allocated(index_map)) then; err=20; message=trim(message)//'index_map is unexpectedly allocated'; return; end if +#endif ! allocate first level of gru to hru mapping allocate(gru_struc(nGRU)) @@ -157,6 +158,10 @@ subroutine read_dimension(attrFile,fileGRU,fileHRU,nGRU,nHRU,err,message,startGR if (count(hru2gru_Id == gru_id(iGRU+sGRU-1)) < 1) then; err=20; message=trim(message)//'problem finding HRUs belonging to GRU'; return; end if gru_struc(iGRU)%hruCount = count(hru2gru_Id == gru_id(iGRU+sGRU-1)) ! number of HRUs in each GRU +#ifdef NGEN_ACTIVE + if (gru_struc(iGRU)%hruCount > 1) then; err=20; message=trim(message)//'NGEN currently only supports single-HRU per GRU'; return; end if + print *, 'GRU id is ', gru_id(iGRU+sGRU-1) +#endif gru_struc(iGRU)%gru_id = gru_id(iGRU+sGRU-1) ! set gru id gru_struc(iGRU)%gru_nc = iGRU+sGRU-1 ! set gru index in the netcdf file @@ -187,6 +192,11 @@ subroutine read_dimension(attrFile,fileGRU,fileHRU,nGRU,nHRU,err,message,startGR end if ! not checkHRU +deallocate(gru_id, hru_ix, hru_id, hru2gru_id) +! close netcdf file +call nc_file_close(ncID,err,cmessage) +if (err/=0) then; message=trim(message)//trim(cmessage); return; end if + end subroutine read_dimension ! ************************************************************************************************ @@ -200,8 +210,8 @@ subroutine read_attrb(attrFile,nGRU,attrStruct,typeStruct,idStruct,err,message) USE netcdf_util_module,only:netcdf_err ! netcdf error handling function ! provide access to derived data types USE data_types,only:gru_hru_int ! x%gru(:)%hru(:)%var(:) (i4b) - USE data_types,only:gru_hru_int8 ! x%gru(:)%hru(:)%var(:) integer(8) - USE data_types,only:gru_hru_double ! x%gru(:)%hru(:)%var(:) (dp) + USE data_types,only:gru_hru_int8 ! x%gru(:)%hru(:)%var(:) (i8b) + USE data_types,only:gru_hru_double ! x%gru(:)%hru(:)%var(:) (rkind) ! provide access to global data USE globalData,only:gru_struc ! gru-hru mapping structure USE globalData,only:attr_meta,type_meta,id_meta ! metadata structures @@ -239,8 +249,8 @@ subroutine read_attrb(attrFile,nGRU,attrStruct,typeStruct,idStruct,err,message) integer(i4b),parameter :: numerical=102 ! named variable to denote numerical data integer(i4b),parameter :: idrelated=103 ! named variable to denote ID related data integer(i4b) :: categorical_var(1) ! temporary categorical variable from local attributes netcdf file - real(rkind) :: numeric_var(1) ! temporary numeric variable from local attributes netcdf file - integer(8) :: idrelated_var(1) ! temporary ID related variable from local attributes netcdf file + real(rkind) :: numeric_var(1) ! temporary numeric variable from local attributes netcdf file + integer(i8b) :: idrelated_var(1) ! temporary ID related variable from local attributes netcdf file ! define mapping variables @@ -340,8 +350,12 @@ subroutine read_attrb(attrFile,nGRU,attrStruct,typeStruct,idStruct,err,message) end do end do - ! for mapping varibles, do nothing (information read above) - case('hru2gruId','gruId'); cycle + ! for mapping varibles, do nothing (information read above in read_dimension) + case('hru2gruId','gruId') + ! get the index of the variable + varType = idrelated + varIndx = get_ixId(varName) + checkId(varIndx) = .true. ! check that variables are what we expect case default; message=trim(message)//'unknown variable ['//trim(varName)//'] in local attributes file'; err=20; return @@ -393,14 +407,14 @@ subroutine read_attrb(attrFile,nGRU,attrStruct,typeStruct,idStruct,err,message) ! ********************************************************************************************** ! (5) close netcdf file ! ********************************************************************************************** - call nc_file_close(ncID,err,cmessage) - if (err/=0)then; message=trim(message)//trim(cmessage); return; end if - - ! free memory +! free memory deallocate(checkType) deallocate(checkId) deallocate(checkAttr) + call nc_file_close(ncID,err,cmessage) + if (err/=0)then; message=trim(message)//trim(cmessage); return; end if + end subroutine read_attrb end module read_attrb_module diff --git a/build/source/engine/read_force.f90 b/build/source/engine/read_force.f90 old mode 100755 new mode 100644 index fbfa51baa..db50ac85b --- a/build/source/engine/read_force.f90 +++ b/build/source/engine/read_force.f90 @@ -24,7 +24,7 @@ module read_force_module USE nrtype ! variable types, etc. ! derived data types -USE data_types,only:gru_hru_double ! x%gru(:)%hru(:)%var(:) (dp) +USE data_types,only:gru_hru_double ! x%gru(:)%hru(:)%var(:) (rkind) ! constants USE multiconst,only:secprday ! number of seconds in a day @@ -43,8 +43,8 @@ module read_force_module USE globalData,only:data_step ! length of the data step (s) USE globalData,only:forcFileInfo ! forcing file info USE globalData,only:dJulianStart ! julian day of start time of simulation -USE globalData,only:refJulday ! reference time (fractional julian days) -USE globalData,only:refJulday_data ! reference time for data files (fractional julian days) +USE globalData,only:refJulDay ! reference time (fractional julian days) +USE globalData,only:refJulDay_data ! reference time for data files (fractional julian days) USE globalData,only:fracJulDay ! fractional julian days since the start of year USE globalData,only:yearLength ! number of days in the current year USE globalData,only:nHRUfile ! number of days in the data file @@ -63,7 +63,7 @@ module read_force_module public::read_force ! global parameters -real(rkind),parameter :: verySmall=1e-3_rkind ! tiny number +real(rkind),parameter :: timeDiffTol=1.e-3_rkind ! time difference tolerance (units=days) to check if the time is correct real(rkind),parameter :: smallOffset=1.e-8_rkind ! small offset (units=days) to force ih=0 at the start of the day contains @@ -75,7 +75,7 @@ module read_force_module subroutine read_force(istep,iFile,iRead,ncid,time_data,forcStruct,err,message) ! provide access to subroutines USE netcdf ! netcdf capability - USE time_utils_module,only:compJulday ! convert calendar date to julian day + USE time_utils_module,only:compJulDay ! convert calendar date to julian day USE time_utils_module,only:compcalday ! convert julian day to calendar date USE time_utils_module,only:elapsedSec ! calculate the elapsed time implicit none @@ -95,8 +95,8 @@ subroutine read_force(istep,iFile,iRead,ncid,time_data,forcStruct,err,message) integer(i4b) :: iGRU,iHRU ! index of GRU and HRU character(len=256),save :: infile ! filename character(len=256) :: cmessage ! error message for downwind routine - real(rkind) :: startJulDay ! julian day at the start of the year - real(rkind) :: currentJulday ! Julian day of current time step + real(rkind) :: startJulDay ! julian day at the start of the year + real(rkind) :: currentJulDay ! Julian day of current time step logical(lgt),parameter :: checkTime=.false. ! flag to check the time ! Start procedure here err=0; message="read_force/" @@ -111,6 +111,15 @@ subroutine read_force(istep,iFile,iRead,ncid,time_data,forcStruct,err,message) currentJulDay = dJulianStart + (data_step*real(iStep-1,dp))/secprday end if +#ifdef NGEN_FORCING_ACTIVE + ! ********************************************************************************************** + ! ***** part 0-1: if using NGEN forcing will be using forcing read with BMI and only need time + ! ********************************************************************************************** + ! get forcing time data + call createForcingTimeData(currentJulDay,time_data,err,message) + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + +#else ! ********************************************************************************************** ! ***** part 0: if initial step, then open first file and find initial model time step ! ***** loop through as many forcing files as necessary to find the initial model step @@ -119,7 +128,7 @@ subroutine read_force(istep,iFile,iRead,ncid,time_data,forcStruct,err,message) if(ncid==integerMissing)then ! file is closed if ncid==integerMissing ! identify the first time step - call getFirstTimestep(currentJulday,iFile,iRead,ncid,err,cmessage) + call getFirstTimestep(currentJulDay,iFile,iRead,ncid,err,cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return; end if end if ! if the file is not yet open @@ -158,7 +167,7 @@ subroutine read_force(istep,iFile,iRead,ncid,time_data,forcStruct,err,message) end if ! if we've passed the end of the NetCDF file ! read forcing data - call readForcingData(currentJulday,ncId,iFile,iRead,nHRUlocal,time_data,forcStruct,err,message) + call readForcingData(currentJulDay,ncId,iFile,iRead,nHRUlocal,time_data,forcStruct,err,message) if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! check that the file was in fact open @@ -166,6 +175,7 @@ subroutine read_force(istep,iFile,iRead,ncid,time_data,forcStruct,err,message) message=trim(message)//'expect the file to be open' err=20; return end if ! end ncid open check +#endif ! ********************************************************************************************** ! ***** part 2: compute time @@ -183,15 +193,15 @@ subroutine read_force(istep,iFile,iRead,ncid,time_data,forcStruct,err,message) time_data(iLookTIME%id), & ! input = day time_data(iLookTIME%ih), & ! input = hour time_data(iLookTIME%imin),0._rkind, & ! input = minute/second - currentJulday,err,cmessage) ! output = julian day (fraction of day) + error control + currentJulDay,err,cmessage) ! output = julian day (fraction of day) + error control if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! compute the time since the start of the year (in fractional days) - fracJulday = currentJulday - startJulDay + fracJulDay = currentJulDay - startJulDay ! set timing of current forcing vector (in seconds since reference day) ! NOTE: It is a bit silly to have time information for each HRU and GRU do iGRU=1,size(gru_struc) do iHRU=1,gru_struc(iGRU)%hruCount - forcStruct%gru(iGRU)%hru(iHRU)%var(iLookFORCE%time) = (currentJulday-refJulday)*secprday + forcStruct%gru(iGRU)%hru(iHRU)%var(iLookFORCE%time) = (currentJulDay-refJulDay)*secprday end do ! looping through HRUs end do ! looping through GRUs @@ -214,7 +224,7 @@ subroutine read_force(istep,iFile,iRead,ncid,time_data,forcStruct,err,message) time_data(iLookTIME%id), & ! day time_data(iLookTIME%ih), & ! hour time_data(iLookTIME%imin), & ! minute - fracJulday, & ! fractional julian day for the current time step + fracJulDay, & ! fractional julian day for the current time step yearLength ! number of days in the current year !pause ' checking time' end if @@ -230,12 +240,12 @@ end subroutine read_force ! ************************************************************************* ! * private subroutine: find first timestep in any of the forcing files... ! ************************************************************************* - subroutine getFirstTimestep(currentJulday,iFile,iRead,ncid,err,message) + subroutine getFirstTimestep(currentJulDay,iFile,iRead,ncid,err,message) USE netcdf ! netcdf capability USE nr_utility_module,only:arth ! get a sequence of numbers implicit none ! define input - real(rkind),intent(in) :: currentJulday ! Julian day of current time step + real(rkind),intent(in) :: currentJulDay ! Julian day of current time step ! define input-output variables integer(i4b),intent(inout) :: iFile ! index of current forcing file in forcing file list integer(i4b),intent(inout) :: iRead ! index of read position in time dimension in current netcdf file @@ -297,14 +307,14 @@ subroutine getFirstTimestep(currentJulday,iFile,iRead,ncid,err,message) if(err/=nf90_noerr)then; message=trim(message)//'trouble reading time vector/'//trim(nf90_strerror(err)); return; endif ! get time vector & convert units based on offset and data step - fileTime = arth(0,1,dimLen) * data_step/secprday + refJulday_data & + fileTime = arth(0,1,dimLen) * data_step/secprday + refJulDay_data & + timeVal(1)/forcFileInfo(iFile)%convTime2Days - ! find difference of fileTime from currentJulday - diffTime=abs(fileTime-currentJulday) + ! find difference of fileTime from currentJulDay + diffTime=abs(fileTime-currentJulDay) ! start time is in the current file - if(any(diffTime < verySmall))then + if(any(diffTime < timeDiffTol))then iRead=minloc(diffTime,1) exit @@ -332,7 +342,7 @@ subroutine openForcingFile(iFile,infile,ncId,err,message) USE netcdf_util_module,only:nc_file_open ! open netcdf file USE time_utils_module,only:fracDay ! compute fractional day USE time_utils_module,only:extractTime ! extract time info from units string - USE time_utils_module,only:compJulday ! convert calendar date to julian day + USE time_utils_module,only:compJulDay ! convert calendar date to julian day USE globalData,only:tmZoneOffsetFracDay ! time zone offset in fractional days USE globalData,only:ncTime ! time zone information from NetCDF file (timeOffset = longitude/15. - ncTimeOffset) USE globalData,only:utcTime ! all times in UTC (timeOffset = longitude/15. hours) @@ -385,8 +395,8 @@ subroutine openForcingFile(iFile,infile,ncId,err,message) ! convert the reference time to days since the beginning of time - call compjulday(iyyy,im,id,ih,imin,dsec, & ! output = year, month, day, hour, minute, second - refJulday_data,err,cmessage) ! output = julian day (fraction of day) + error control + call compjulday(iyyy,im,id,ih,imin,dsec, & ! input = year, month, day, hour, minute, second + refJulDay_data,err,cmessage) ! output = julian day (fraction of day) + error control if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! get the time multiplier needed to convert time to units of days @@ -403,13 +413,13 @@ end subroutine openForcingFile ! ************************************************************************* ! * read the NetCDF forcing data ! ************************************************************************* - subroutine readForcingData(currentJulday,ncId,iFile,iRead,nHRUlocal,time_data,forcStruct,err,message) + subroutine readForcingData(currentJulDay,ncId,iFile,iRead,nHRUlocal,time_data,forcStruct,err,message) USE netcdf ! netcdf capability USE time_utils_module,only:compcalday ! convert julian day to calendar date - USE time_utils_module,only:compJulday ! convert calendar date to julian day - USE get_ixname_module,only:get_ixforce ! identify index of named variable + USE time_utils_module,only:compJulDay ! convert calendar date to julian day + USE get_ixname_module,only:get_ixForce ! identify index of named variable ! dummy variables - real(rkind),intent(in) :: currentJulday ! Julian day of current time step + real(rkind),intent(in) :: currentJulDay ! Julian day of current time step integer(i4b) ,intent(in) :: ncId ! NetCDF ID integer(i4b) ,intent(in) :: iFile ! index of forcing file integer(i4b) ,intent(in) :: iRead ! index in data file @@ -422,7 +432,7 @@ subroutine readForcingData(currentJulday,ncId,iFile,iRead,nHRUlocal,time_data,fo character(len=256) :: cmessage ! error message for downwind routine integer(i4b) :: varId ! variable identifier character(len = nf90_max_name) :: varName ! dimenison name - real(rkind) :: varTime(1) ! time variable of current forcing data step being read + real(rkind) :: varTime(1) ! time variable of current forcing data step being read ! other local variables integer(i4b) :: iGRU,iHRU ! index of GRU and HRU integer(i4b) :: iHRU_global ! index of HRU in the NetCDF file @@ -430,12 +440,11 @@ subroutine readForcingData(currentJulday,ncId,iFile,iRead,nHRUlocal,time_data,fo integer(i4b) :: iline ! loop through lines in the file integer(i4b) :: iNC ! loop through variables in forcing file integer(i4b) :: iVar ! index of forcing variable in forcing data vector - logical(lgt),parameter :: checkTime=.false. ! flag to check the time - real(rkind) :: dsec ! double precision seconds (not used) - real(rkind) :: dataJulDay ! julian day of current forcing data step being read - real(rkind),dimension(nHRUlocal) :: dataVec ! vector of data - real(rkind),dimension(1) :: dataVal ! single data value - real(rkind),parameter :: dataMin=-1._rkind ! minimum allowable data value (all forcing variables should be positive) + real(rkind) :: dsec ! double precision seconds (not used) + real(rkind) :: dataJulDay ! julian day of current forcing data step being read + real(rkind),dimension(nHRUlocal) :: dataVec ! vector of data + real(rkind),dimension(1) :: dataVal ! single data value + real(rkind),parameter :: dataMin=-1._rkind ! minimum allowable data value (all forcing variables should be positive) logical(lgt),dimension(size(forc_meta)) :: checkForce ! flags to check forcing data variables exist logical(lgt),parameter :: simultaneousRead=.true. ! flag to denote reading all HRUs at once ! Start procedure here @@ -449,8 +458,8 @@ subroutine readForcingData(currentJulday,ncId,iFile,iRead,nHRUlocal,time_data,fo err = nf90_get_var(ncid,varId,varTime,start=(/iRead/)); if(err/=nf90_noerr)then; message=trim(message)//'trouble reading time variable/'//trim(nf90_strerror(err)); return; endif ! check that the computed julian day matches the time information in the NetCDF file - dataJulDay = varTime(1)/forcFileInfo(iFile)%convTime2Days + refJulday_data - if(abs(currentJulday - dataJulDay) > verySmall)then + dataJulDay = varTime(1)/forcFileInfo(iFile)%convTime2Days + refJulDay_data + if(abs(currentJulDay - dataJulDay) > timeDiffTol)then write(message,'(a,f18.8,a,f18.8)') trim(message)//'date for time step: ',dataJulDay,' differs from the expected date: ',currentJulDay err=40; return end if @@ -486,7 +495,7 @@ subroutine readForcingData(currentJulday,ncId,iFile,iRead,nHRUlocal,time_data,fo ! get index in forcing structure iVar = forcFileInfo(iFile)%var_ix(iNC) checkForce(iVar) = .true. - + ! get variable name for error reporting err=nf90_inquire_variable(ncid,iNC,name=varName) if(err/=nf90_noerr)then; message=trim(message)//'problem reading forcing variable name from netCDF: '//trim(nf90_strerror(err)); return; endif @@ -504,7 +513,6 @@ subroutine readForcingData(currentJulday,ncId,iFile,iRead,nHRUlocal,time_data,fo ! define global HRU iHRU_global = gru_struc(iGRU)%hruInfo(iHRU)%hru_nc iHRU_local = (iHRU_global - ixHRUfile_min)+1 - !print*, 'iGRU, iHRU, iHRU_global, iHRU_local = ', iGRU, iHRU, iHRU_global, iHRU_local ! read forcing data for a single HRU if(.not.simultaneousRead)then @@ -520,8 +528,7 @@ subroutine readForcingData(currentJulday,ncId,iFile,iRead,nHRUlocal,time_data,fo ! get individual data value if(simultaneousRead) dataVal(1) = dataVec(iHRU_local) - !print*, trim(varname)//': ', dataVal(1) - + ! check individual data value if(dataVal(1) bvarData%var(iLookBVAR%basin__totalArea)%dat(1) ) @@ -286,7 +274,7 @@ subroutine run_oneGRU(& ! output bvarData%var(iLookBVAR%averageInstantRunoff)%dat(1), & ! intent(out): instantaneous runoff (m s-1) bvarData%var(iLookBVAR%averageRoutedRunoff)%dat(1), & ! intent(out): routed runoff (m s-1) - err,message) ! intent(out): error control + err,message) ! intent(out): error control if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif end associate diff --git a/build/source/engine/run_oneHRU.f90 b/build/source/engine/run_oneHRU.f90 old mode 100755 new mode 100644 index ea882d375..fe8791b38 --- a/build/source/engine/run_oneHRU.f90 +++ b/build/source/engine/run_oneHRU.f90 @@ -25,10 +25,11 @@ module run_oneHRU_module ! data types USE data_types,only:& - var_i, & ! x%var(:) (i4b) - var_d, & ! x%var(:) (dp) - var_ilength, & ! x%var(:)%dat (i4b) - var_dlength ! x%var(:)%dat (dp) + var_i, & ! x%var(:) (i4b) + var_d, & ! x%var(:) (rkind) + var_ilength, & ! x%var(:)%dat (i4b) + var_dlength, & ! x%var(:)%dat (rkind) + zLookup ! x%z(:)%var(:)%lookup(:) (rkind) ! access vegetation data USE globalData,only:greenVegFrac_monthly ! fraction of green vegetation in each month (0-1) @@ -52,16 +53,17 @@ module run_oneHRU_module USE globalData,only:model_decisions ! model decision structure USE var_lookup,only:iLookDECISIONS ! look-up values for model decisions +! these are needed because we cannot access them in modules locally if we might use those modules with Actors +USE globalData,only:fracJulDay ! fractional julian days since the start of year +USE globalData,only:yearLength ! number of days in the current year +USE globalData,only:tmZoneOffsetFracDay ! time zone offset in fractional days + ! provide access to the named variables that describe model decisions -USE mDecisions_module,only:& ! look-up values for LAI decisions - monthlyTable,& ! LAI/SAI taken directly from a monthly table for different vegetation classes - specified ! LAI/SAI computed from green vegetation fraction and winterSAI and summerLAI parameters +USE mDecisions_module,only: & ! look-up values for LAI decisions + monthlyTable,& ! LAI/SAI taken directly from a monthly table for different vegetation classes + specified ! LAI/SAI computed from green vegetation fraction and winterSAI and summerLAI parameters -! ----------------------------------------------------------------------------------------------------------------------------------- -! ----------------------------------------------------------------------------------------------------------------------------------- ! ----- global variables that are modified ------------------------------------------------------------------------------------------ -! ----------------------------------------------------------------------------------------------------------------------------------- -! ----------------------------------------------------------------------------------------------------------------------------------- ! Noah-MP parameters USE NOAHMP_VEG_PARAMETERS,only:SAIM,LAIM ! 2-d tables for stem area index and leaf area index (vegType,month) @@ -84,6 +86,7 @@ module run_oneHRU_module ! simulation for a single HRU subroutine run_oneHRU(& ! model control + hru_nc, & ! intent(in): hru index in netcdf hruId, & ! intent(in): hruId dt_init, & ! intent(inout): used to initialize the length of the sub-step for each HRU computeVegFlux, & ! intent(inout): flag to indicate if we are computing fluxes over vegetation (false=no, true=yes) @@ -92,6 +95,7 @@ subroutine run_oneHRU(& timeVec, & ! intent(in): model time data typeData, & ! intent(in): local classification of soil veg etc. for each HRU attrData, & ! intent(in): local attributes for each HRU + lookupData, & ! intent(in): local lookup tables for each HRU bvarData, & ! intent(in): basin-average variables ! data structures (input-output) mparData, & ! intent(inout): local model parameters @@ -111,16 +115,18 @@ subroutine run_oneHRU(& implicit none ! ----- define dummy variables ------------------------------------------------------------------------------------------ - + ! model control - integer(8) , intent(in) :: hruId ! hruId - real(rkind) , intent(inout) :: dt_init ! used to initialize the length of the sub-step for each HRU + integer(i4b) , intent(in) :: hru_nc ! hru index in netcdf + integer(i8b) , intent(in) :: hruId ! hruId + real(rkind) , intent(inout) :: dt_init ! used to initialize the length of the sub-step for each HRU logical(lgt) , intent(inout) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (false=no, true=yes) integer(i4b) , intent(inout) :: nSnow,nSoil,nLayers ! number of snow and soil layers ! data structures (input) - integer(i4b) , intent(in) :: timeVec(:) ! int vector -- model time data - type(var_i) , intent(in) :: typeData ! x%var(:) -- local classification of soil veg etc. for each HRU - type(var_d) , intent(in) :: attrData ! x%var(:) -- local attributes for each HRU + integer(i4b) , intent(in) :: timeVec(:) ! int vector -- model time data + type(var_i) , intent(in) :: typeData ! x%var(:) -- local classification of soil veg etc. for each HRU + type(var_d) , intent(in) :: attrData ! x%var(:) -- local attributes for each HRU + type(zLookup) , intent(in) :: lookupData ! x%z(:)%var(:)%lookup(:) -- local lookup tables for each HRU type(var_dlength) , intent(in) :: bvarData ! x%var(:)%dat -- basin-average variables ! data structures (input-output) type(var_dlength) , intent(inout) :: mparData ! x%var(:)%dat -- local (HRU) model parameters @@ -136,24 +142,21 @@ subroutine run_oneHRU(& ! ----- define local variables ------------------------------------------------------------------------------------------ ! local variables - character(len=256) :: cmessage ! error message - real(rkind) , allocatable :: zSoilReverseSign(:) ! height at bottom of each soil layer, negative downwards (m) + character(len=256) :: cmessage ! error message ! initialize error control - err=0; write(message, '(A20,I0,A2)' ) 'run_oneHRU (hruId = ',hruId,')/' - + err=0; write(message, '(A21,I0,A10,I0,A2)' ) 'run_oneHRU (hru nc = ',hru_nc ,', hruId = ',hruId,')/' + ! ----- hru initialization --------------------------------------------------------------------------------------------- + ! initialize the number of flux calls + diagData%var(iLookDIAG%numFluxCalls)%dat(1) = 0._rkind ! water pixel: do nothing - if (typeData%var(iLookTYPE%vegTypeIndex) == isWater) return - - ! get height at bottom of each soil layer, negative downwards (used in Noah MP) - allocate(zSoilReverseSign(nSoil),stat=err) - if(err/=0)then - message=trim(message)//'problem allocating space for zSoilReverseSign' - err=20; return + if (typeData%var(iLookTYPE%vegTypeIndex) == isWater)then + ! Set wall_clock time to zero so it does not get a random value + diagData%var(iLookDIAG%wallClockTime)%dat(1) = 0._rkind + return endif - zSoilReverseSign(:) = -progData%var(iLookPROG%iLayerHeight)%dat(nSnow+1:nLayers) ! populate parameters in Noah-MP modules ! Passing a maxSoilLayer in order to pass the check for NROOT, that is done to avoid making any changes to Noah-MP code. @@ -161,17 +164,9 @@ subroutine run_oneHRU(& call REDPRM(typeData%var(iLookTYPE%vegTypeIndex), & ! vegetation type index typeData%var(iLookTYPE%soilTypeIndex), & ! soil type typeData%var(iLookTYPE%slopeTypeIndex), & ! slope type index - zSoilReverseSign, & ! * not used: height at bottom of each layer [NOTE: negative] (m) maxSoilLayers, & ! number of soil layers urbanVegCategory) ! vegetation category for urban areas - ! deallocate height at bottom of each soil layer(used in Noah MP) - deallocate(zSoilReverseSign,stat=err) - if(err/=0)then - message=trim(message)//'problem deallocating space for zSoilReverseSign' - err=20; return - endif - ! overwrite the minimum resistance if(overwriteRSMIN) RSMIN = mparData%var(iLookPARAM%minStomatalResistance)%dat(1) @@ -188,40 +183,42 @@ subroutine run_oneHRU(& ! ----- hru forcing ---------------------------------------------------------------------------------------------------- ! compute derived forcing variables - call derivforce(timeVec, & ! vector of time information - forcData%var, & ! vector of model forcing data - attrData%var, & ! vector of model attributes - mparData, & ! data structure of model parameters - progData, & ! data structure of model prognostic variables - diagData, & ! data structure of model diagnostic variables - fluxData, & ! data structure of model fluxes - err,cmessage) ! error control + call derivforce(timeVec, & ! vector of time information + forcData%var, & ! vector of model forcing data + attrData%var, & ! vector of model attributes + mparData, & ! data structure of model parameters + progData, & ! data structure of model prognostic variables + diagData, & ! data structure of model diagnostic variables + fluxData, & ! data structure of model fluxes + tmZoneOffsetFracDay,& ! time zone offset in fractional days + err,cmessage) ! error control if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif ! ----- run the model -------------------------------------------------------------------------------------------------- - ! initialize the number of flux calls - diagData%var(iLookDIAG%numFluxCalls)%dat(1) = 0._rkind - ! run the model for a single HRU call coupled_em(& ! model control hruId, & ! intent(in): hruId dt_init, & ! intent(inout): initial time step + 1, & ! intent(in): used to adjust the length of the timestep with failure in Actors (non-Actors here, always 1) computeVegFlux, & ! intent(inout): flag to indicate if we are computing fluxes over vegetation + fracJulDay, & ! intent(in): fractional julian days since the start of year + yearLength, & ! intent(in): number of days in the current year ! data structures (input) typeData, & ! intent(in): local classification of soil veg etc. for each HRU attrData, & ! intent(in): local attributes for each HRU forcData, & ! intent(in): model forcing data mparData, & ! intent(in): model parameters bvarData, & ! intent(in): basin-average model variables + lookupData, & ! intent(in): lookup tables ! data structures (input-output) indxData, & ! intent(inout): model indices progData, & ! intent(inout): model prognostic variables for a local HRU diagData, & ! intent(inout): model diagnostic variables for a local HRU fluxData, & ! intent(inout): model fluxes for a local HRU ! error control - err,cmessage) ! intent(out): error control + err,cmessage) ! intent(out): error control if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif ! update the number of layers diff --git a/build/source/engine/snowAlbedo.f90 b/build/source/engine/snowAlbedo.f90 old mode 100755 new mode 100644 index c1329f36b..22651619d --- a/build/source/engine/snowAlbedo.f90 +++ b/build/source/engine/snowAlbedo.f90 @@ -22,6 +22,7 @@ module snowAlbedo_module ! data types USE nrtype ! numerical recipes data types +USE globalData,only:realMissing ! missing real number ! physical constants USE multiconst,only:Tfreeze ! freezing point of pure water (K) @@ -29,8 +30,8 @@ module snowAlbedo_module ! derived types to define the data structures USE data_types,only:& var_i, & ! data vector (i4b) - var_d, & ! data vector (dp) - var_dlength, & ! data vector with variable length dimension (dp) + var_d, & ! data vector (rkind) + var_dlength, & ! data vector with variable length dimension (rkind) model_options ! defines the model decisions ! named variables defining elements in the data structures @@ -55,9 +56,6 @@ module snowAlbedo_module implicit none private public::snowAlbedo - -! dimensions -integer(i4b),parameter :: nBands=2 ! number of spectral bands for shortwave radiation contains @@ -66,8 +64,8 @@ module snowAlbedo_module ! ******************************************************************************************************* subroutine snowAlbedo(& ! input: model control - dt, & ! intent(in): model time step (s) - snowPresence, & ! intent(in): logical flag to denote if snow is present + dt, & ! intent(in): model time step (s) + snowPresence, & ! intent(in): logical flag to denote if snow is present ! input/output: data structures model_decisions, & ! intent(in): model decisions mpar_data, & ! intent(in): model parameters @@ -75,36 +73,35 @@ subroutine snowAlbedo(& diag_data, & ! intent(inout): model diagnostic variables for a local HRU prog_data, & ! intent(inout): model prognostic variables for a local HRU ! output: error control - err,message) ! intent(out): error control + err,message) ! intent(out): error control ! -------------------------------------------------------------------------------------------------------------------------------------- ! provide access to desired modules USE snow_utils_module,only:fracliquid ! compute fraction of liquid water at a given temperature ! -------------------------------------------------------------------------------------------------------------------------------------- ! input: model control - real(rkind),intent(in) :: dt ! model time step - logical(lgt),intent(in) :: snowPresence ! logical flag to denote if snow is present + real(rkind),intent(in) :: dt ! model time step + logical(lgt),intent(in) :: snowPresence ! logical flag to denote if snow is present ! input/output: data structures - type(model_options),intent(in) :: model_decisions(:) ! model decisions - type(var_dlength),intent(in) :: mpar_data ! model parameters - type(var_dlength),intent(in) :: flux_data ! model flux variables - type(var_dlength),intent(inout) :: diag_data ! model diagnostic variables for a local HRU - type(var_dlength),intent(inout) :: prog_data ! model prognostic variables for a local HRU + type(model_options),intent(in) :: model_decisions(:) ! model decisions + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_dlength),intent(in) :: flux_data ! model flux variables + type(var_dlength),intent(inout) :: diag_data ! model diagnostic variables for a local HRU + type(var_dlength),intent(inout) :: prog_data ! model prognostic variables for a local HRU ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message ! local variables - integer(i4b),parameter :: ixVisible=1 ! named variable to define index in array of visible part of the spectrum - integer(i4b),parameter :: ixNearIR=2 ! named variable to define index in array of near IR part of the spectrum - real(rkind),parameter :: valueMissing=-9999._rkind ! missing value -- will cause problems if snow albedo is ever used for the non-snow case - real(rkind),parameter :: slushExp=10._rkind ! "slush" exponent, to increase decay when snow is near Tfreeze - real(rkind),parameter :: fractionLiqThresh=0.001_rkind ! threshold for the fraction of liquid water to switch to spring albedo minimum - real(rkind) :: fractionLiq ! fraction of liquid water (-) - real(rkind) :: age1,age2,age3 ! aging factors (-) - real(rkind) :: decayFactor ! albedo decay factor (-) - real(rkind) :: refreshFactor ! albedo refreshment factor, representing albedo increase due to snowfall (-) - real(rkind) :: albedoMin ! minimum albedo -- depends if in winter or spring conditions (-) - real(rkind) :: fZen ! factor to modify albedo at low zenith angles (-) - real(rkind),parameter :: bPar=2._rkind ! empirical parameter in fZen + integer(i4b),parameter :: ixVisible=1 ! named variable to define index in array of visible part of the spectrum + integer(i4b),parameter :: ixNearIR=2 ! named variable to define index in array of near IR part of the spectrum + real(rkind),parameter :: slushExp=10._rkind ! "slush" exponent, to increase decay when snow is near Tfreeze + real(rkind),parameter :: fractionLiqThresh=0.001_rkind ! threshold for the fraction of liquid water to switch to spring albedo minimum + real(rkind) :: fractionLiq ! fraction of liquid water (-) + real(rkind) :: age1,age2,age3 ! aging factors (-) + real(rkind) :: decayFactor ! albedo decay factor (-) + real(rkind) :: refreshFactor ! albedo refreshment factor, representing albedo increase due to snowfall (-) + real(rkind) :: albedoMin ! minimum albedo -- depends if in winter or spring conditions (-) + real(rkind) :: fZen ! factor to modify albedo at low zenith angles (-) + real(rkind),parameter :: bPar=2._rkind ! empirical parameter in fZen ! initialize error control err=0; message='snowAlbedo/' ! -------------------------------------------------------------------------------------------------------------------------------------- @@ -144,9 +141,9 @@ subroutine snowAlbedo(& ! return early if no snow if(.not. snowPresence)then - scalarSnowAlbedo = valueMissing - spectralSnowAlbedoDirect(:) = valueMissing - spectralSnowAlbedoDiffuse(:) = valueMissing + scalarSnowAlbedo = realMissing + spectralSnowAlbedoDirect(:) = realMissing + spectralSnowAlbedoDiffuse(:) = realMissing return end if diff --git a/build/source/engine/snowLiqFlx.f90 b/build/source/engine/snowLiqFlx.f90 old mode 100755 new mode 100644 index 48b67f590..6d1aa6951 --- a/build/source/engine/snowLiqFlx.f90 +++ b/build/source/engine/snowLiqFlx.f90 @@ -21,182 +21,167 @@ module snowLiqFlx_module ! access modules -USE nrtype ! numerical recipes data types -USE multiconst,only:iden_ice,iden_water ! intrinsic density of ice and water (kg m-3) +USE nrtype ! numerical recipes data types +USE multiconst,only:iden_ice,iden_water ! intrinsic density of ice and water (kg m-3) ! access missing values -USE globalData,only:integerMissing ! missing integer -USE globalData,only:realMissing ! missing real number +USE globalData,only:integerMissing ! missing integer +USE globalData,only:realMissing ! missing real number +USE globalData,only:maxVolIceContent ! snow maximum volumetric ice content to store water (-) ! named variables -USE var_lookup,only:iLookINDEX ! named variables for structure elements -USE var_lookup,only:iLookPARAM ! named variables for structure elements -USE var_lookup,only:iLookPROG ! named variables for structure elements -USE var_lookup,only:iLookDIAG ! named variables for structure elements +USE var_lookup,only:iLookINDEX ! named variables for structure elements +USE var_lookup,only:iLookPARAM ! named variables for structure elements +USE var_lookup,only:iLookPROG ! named variables for structure elements +USE var_lookup,only:iLookDIAG ! named variables for structure elements ! data types -USE data_types,only:var_d ! x%var(:) (dp) -USE data_types,only:var_dlength ! x%var(:)%dat (dp) -USE data_types,only:var_ilength ! x%var(:)%dat (i4b) +USE data_types,only:var_d ! x%var(:) [rkind] +USE data_types,only:var_dlength ! x%var(:)%dat [rkind] +USE data_types,only:var_ilength ! x%var(:)%dat [i4b] +USE data_types,only:in_type_snowLiqFlx ! data type for intent(in) arguments +USE data_types,only:io_type_snowLiqFlx ! data type for intent(inout) arguments +USE data_types,only:out_type_snowLiqFlx ! data type for intent(out) arguments ! privacy implicit none private -public::snowLiqFlx +public :: snowLiqFlx contains - - - ! ************************************************************************************************ - ! public subroutine snowLiqFlx: compute liquid water flux through the snowpack - ! ************************************************************************************************ - subroutine snowLiqFlx(& - ! input: model control - nSnow, & ! intent(in): number of snow layers - firstFluxCall, & ! intent(in): the first flux call - scalarSolution, & ! intent(in): flag to indicate the scalar solution - ! input: forcing for the snow domain - scalarThroughfallRain, & ! intent(in): rain that reaches the snow surface without ever touching vegetation (kg m-2 s-1) - scalarCanopyLiqDrainage, & ! intent(in): liquid drainage from the vegetation canopy (kg m-2 s-1) - ! input: model state vector - mLayerVolFracLiqTrial, & ! intent(in): trial value of volumetric fraction of liquid water at the current iteration (-) - ! input-output: data structures - indx_data, & ! intent(in): model indices - mpar_data, & ! intent(in): model parameters - prog_data, & ! intent(in): model prognostic variables for a local HRU - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - ! output: fluxes and derivatives - iLayerLiqFluxSnow, & ! intent(inout): vertical liquid water flux at layer interfaces (m s-1) - iLayerLiqFluxSnowDeriv, & ! intent(inout): derivative in vertical liquid water flux at layer interfaces (m s-1) - ! output: error control - err,message) ! intent(out): error control - implicit none - ! input: model control - integer(i4b),intent(in) :: nSnow ! number of snow layers - logical(lgt),intent(in) :: firstFluxCall ! the first flux call - logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution - ! input: forcing for the snow domain - real(rkind),intent(in) :: scalarThroughfallRain ! computed throughfall rate (kg m-2 s-1) - real(rkind),intent(in) :: scalarCanopyLiqDrainage ! computed drainage of liquid water (kg m-2 s-1) - ! input: model state vector - real(rkind),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value of volumetric fraction of liquid water at the current iteration (-) - ! input-output: data structures - type(var_ilength),intent(in) :: indx_data ! model indices - type(var_dlength),intent(in) :: mpar_data ! model parameters - type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU - type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU - ! output: fluxes and derivatives - real(rkind),intent(inout) :: iLayerLiqFluxSnow(0:) ! vertical liquid water flux at layer interfaces (m s-1) - real(rkind),intent(inout) :: iLayerLiqFluxSnowDeriv(0:) ! derivative in vertical liquid water flux at layer interfaces (m s-1) - ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! ------------------------------------------------------------------------------------------------------------------------------------------ - ! local variables - integer(i4b) :: i ! search index for scalar solution - integer(i4b) :: iLayer ! layer index - integer(i4b) :: ixTop ! top layer in subroutine call - integer(i4b) :: ixBot ! bottom layer in subroutine call - real(rkind) :: multResid ! multiplier for the residual water content (-) - real(rkind),parameter :: residThrs=550._rkind ! ice density threshold to reduce residual liquid water content (kg m-3) - real(rkind),parameter :: residScal=10._rkind ! scaling factor for residual liquid water content reduction factor (kg m-3) - real(rkind),parameter :: maxVolIceContent=0.7_rkind ! maximum volumetric ice content to store water (-) - real(rkind) :: availCap ! available storage capacity [0,1] (-) - real(rkind) :: relSaturn ! relative saturation [0,1] (-) - ! ------------------------------------------------------------------------------------------------------------------------------------------ - ! make association of local variables with information in the data structures - associate(& - ! input: layer indices - ixLayerState => indx_data%var(iLookINDEX%ixLayerState)%dat, & ! intent(in): list of indices for all model layers - ixSnowOnlyHyd => indx_data%var(iLookINDEX%ixSnowOnlyHyd)%dat, & ! intent(in): index in the state subset for hydrology state variables in the snow domain - ! input: snow properties and parameters - mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat(1:nSnow), & ! intent(in): volumetric ice content at the start of the time step (-) - Fcapil => mpar_data%var(iLookPARAM%Fcapil)%dat(1), & ! intent(in): capillary retention as a fraction of the total pore volume (-) - k_snow => mpar_data%var(iLookPARAM%k_snow)%dat(1), & ! intent(in): hydraulic conductivity of snow (m s-1), 0.0055 = approx. 20 m/hr, from UEB - mw_exp => mpar_data%var(iLookPARAM%mw_exp)%dat(1), & ! intent(in): exponent for meltwater flow (-) - ! input/output: diagnostic variables -- only computed for the first iteration - mLayerPoreSpace => diag_data%var(iLookDIAG%mLayerPoreSpace)%dat, & ! intent(inout): pore space in each snow layer (-) - mLayerThetaResid => diag_data%var(iLookDIAG%mLayerThetaResid)%dat & ! intent(inout): esidual volumetric liquid water content in each snow layer (-) - ) ! association of local variables with information in the data structures - ! ------------------------------------------------------------------------------------------------------------------------------------------ - ! initialize error control - err=0; message='snowLiqFlx/' - - ! check that the input vectors match nSnow - if(size(mLayerVolFracLiqTrial)/=nSnow .or. size(mLayerVolFracIce)/=nSnow .or. & - size(iLayerLiqFluxSnow)/=nSnow+1 .or. size(iLayerLiqFluxSnowDeriv)/=nSnow+1) then - err=20; message=trim(message)//'size mismatch of input/output vectors'; return - end if - - ! check the meltwater exponent is >=1 - if(mw_exp<1._rkind)then; err=20; message=trim(message)//'meltwater exponent < 1'; return; end if - - ! get the indices for the snow+soil layers - ixTop = integerMissing - if(scalarSolution)then - ! WARNING: Previously this was implemented as: - ! ixLayerDesired = pack(ixLayerState, ixSnowOnlyHyd/=integerMissing) - ! ixTop = ixLayerDesired(1) - ! ixBot = ixLayerDesired(1) - ! This implementation can result in a segfault when using JRDN layering. - ! The segfault occurs when trying to access `mw_exp` in: - ! iLayerLiqFluxSnow(iLayer) = k_snow*relSaturn**mw_exp - ! Debugging found that the `pack` statement caused `mw_exp` to no longer be accessible. - ! We have not been able to determine the underlying reason for this segfault. - do i=1,size(ixSnowOnlyHyd) - if(ixSnowOnlyHyd(i) /= integerMissing)then - ixTop=ixLayerState(i) - ixBot=ixTop - exit ! break out of loop once found - endif - end do - if(ixTop == integerMissing)then - err=20; message=trim(message)//'Unable to identify snow layer for scalar solution!'; return - end if - else - ixTop = 1 - ixBot = nSnow - endif - - ! define the liquid flux at the upper boundary (m s-1) - iLayerLiqFluxSnow(0) = (scalarThroughfallRain + scalarCanopyLiqDrainage)/iden_water - iLayerLiqFluxSnowDeriv(0) = 0._rkind - - ! compute properties fixed over the time step - if(firstFluxCall)then - ! loop through snow layers - do iLayer=1,nSnow - ! compute the reduction in liquid water holding capacity at high snow density (-) - multResid = 1._rkind / ( 1._rkind + exp( (mLayerVolFracIce(iLayer)*iden_ice - residThrs) / residScal) ) - ! compute the pore space (-) - mLayerPoreSpace(iLayer) = 1._rkind - mLayerVolFracIce(iLayer) - ! compute the residual volumetric liquid water content (-) - mLayerThetaResid(iLayer) = Fcapil*mLayerPoreSpace(iLayer) * multResid - end do ! (looping through snow layers) - end if ! (if the first flux call) - - ! compute fluxes - do iLayer=ixTop,ixBot ! (loop through snow layers) - ! check that flow occurs - if(mLayerVolFracLiqTrial(iLayer) > mLayerThetaResid(iLayer))then - ! compute the relative saturation (-) - availCap = mLayerPoreSpace(iLayer) - mLayerThetaResid(iLayer) ! available capacity - relSaturn = (mLayerVolFracLiqTrial(iLayer) - mLayerThetaResid(iLayer)) / availCap ! relative saturation - iLayerLiqFluxSnow(iLayer) = k_snow*relSaturn**mw_exp - iLayerLiqFluxSnowDeriv(iLayer) = ( (k_snow*mw_exp)/availCap ) * relSaturn**(mw_exp - 1._rkind) - if(mLayerVolFracIce(iLayer) > maxVolIceContent)then ! NOTE: use start-of-step ice content, to avoid convergence problems - ! ** allow liquid water to pass through under very high ice density - iLayerLiqFluxSnow(iLayer) = iLayerLiqFluxSnow(iLayer) + iLayerLiqFluxSnow(iLayer-1) !NOTE: derivative may need to be updated in future. - end if - else ! flow does not occur - iLayerLiqFluxSnow(iLayer) = 0._rkind - iLayerLiqFluxSnowDeriv(iLayer) = 0._rkind - endif ! storage above residual content - end do ! loop through snow layers - - ! end association of local variables with information in the data structures - end associate - - end subroutine snowLiqFlx - +! ************************************************************************************************ +! public subroutine snowLiqFlx: compute liquid water flux through the snowpack +! ************************************************************************************************ +subroutine snowLiqFlx(& + ! input: model control, forcing, and model state vector + in_snowLiqFlx, & ! intent(in): model control, forcing, and model state vector + ! input-output: data structures + indx_data, & ! intent(in): model indices + mpar_data, & ! intent(in): model parameters + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + ! input-output: fluxes and derivatives + io_snowLiqFlx, & ! intent(inout): fluxes and derivatives + ! output: error control + out_snowLiqFlx) ! intent(out): error control + implicit none + ! input: model control, forcing, and model state vector + type(in_type_snowLiqFlx) :: in_snowLiqFlx ! model control, forcing, and model state vector + ! input-output: data structures + type(var_ilength),intent(in) :: indx_data ! model indices + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU + type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU + ! input-output: fluxes and derivatives + type(io_type_snowLiqFlx) :: io_snowLiqFlx ! fluxes and derivatives + ! output: error control + type(out_type_snowLiqFlx) :: out_snowLiqFlx ! error control + ! ------------------------------ ------------------------------------------------------------------------------------------------------------ + ! local variables + integer(i4b) :: nSnow ! number of snow layers + integer(i4b) :: i ! search index for scalar solution + integer(i4b) :: iLayer ! layer index + integer(i4b) :: ixTop ! top layer in subroutine call + integer(i4b) :: ixBot ! bottom layer in subroutine call + real(rkind) :: multResid ! multiplier for the residual water content (-) + real(rkind),parameter :: residThrs=550._rkind ! ice density threshold to reduce residual liquid water content (kg m-3) + real(rkind),parameter :: residScal=10._rkind ! scaling factor for residual liquid water content reduction factor (kg m-3) + real(rkind) :: availCap ! available storage capacity [0,1] (-) + real(rkind) :: relSaturn ! relative saturation [0,1] (-) + ! ------------------------------------------------------------------------------------------------------------------------------------------ + ! make association of local variables with information in the data structures + nSnow=in_snowLiqFlx % nSnow ! get number of snow layers + associate(& + ! input: model control + firstFluxCall => in_snowLiqFlx % firstFluxCall, & ! intent(in): the first flux call + scalarSolution => in_snowLiqFlx % scalarSolution, & ! intent(in): flag to denote if implementing the scalar solution + ! input: forcing for the snow domain + scalarThroughfallRain => in_snowLiqFlx % scalarThroughfallRain, & ! intent(in): computed throughfall rate (kg m-2 s-1) + scalarCanopyLiqDrainage => in_snowLiqFlx % scalarCanopyLiqDrainage, & ! intent(in): computed drainage of liquid water (kg m-2 s-1) + ! input: model state vector + mLayerVolFracLiqTrial => in_snowLiqFlx % mLayerVolFracLiqTrial, & ! intent(in): trial value of volumetric fraction of liquid water at the current iteration (-) + ! input: layer indices + ixLayerState => indx_data%var(iLookINDEX%ixLayerState)%dat, & ! intent(in): list of indices for all model layers + ixSnowOnlyHyd => indx_data%var(iLookINDEX%ixSnowOnlyHyd)%dat, & ! intent(in): index in the state subset for hydrology state variables in the snow domain + ! input: snow properties and parameters + mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat(1:nSnow), & ! intent(in): volumetric ice content at the start of the time step (-) + Fcapil => mpar_data%var(iLookPARAM%Fcapil)%dat(1), & ! intent(in): capillary retention as a fraction of the total pore volume (-) + k_snow => mpar_data%var(iLookPARAM%k_snow)%dat(1), & ! intent(in): hydraulic conductivity of snow (m s-1), 0.0055 = approx. 20 m/hr, from UEB + mw_exp => mpar_data%var(iLookPARAM%mw_exp)%dat(1), & ! intent(in): exponent for meltwater flow (-) + ! input-output: diagnostic variables -- only computed for the first iteration + mLayerPoreSpace => diag_data%var(iLookDIAG%mLayerPoreSpace)%dat, & ! intent(inout): pore space in each snow layer (-) + mLayerThetaResid => diag_data%var(iLookDIAG%mLayerThetaResid)%dat, & ! intent(inout): esidual volumetric liquid water content in each snow layer (-) + ! input-output: fluxes and derivatives + iLayerLiqFluxSnow => io_snowLiqFlx % iLayerLiqFluxSnow, & ! intent(inout): vertical liquid water flux at layer interfaces (m s-1) + iLayerLiqFluxSnowDeriv => io_snowLiqFlx % iLayerLiqFluxSnowDeriv, & ! intent(inout): derivative in vertical liquid water flux at layer interfaces (m s-1) + ! output: error control + err => out_snowLiqFlx % err, & ! intent(out): error code + message => out_snowLiqFlx % cmessage & ! intent(out): error message + ) ! end association of local variables with information in the data structures + ! ------------------------------------------------------------------------------------------------------------------------------------------ + ! initialize error control + err=0; message='snowLiqFlx/' + + ! check that the input vectors match nSnow + if (size(mLayerVolFracLiqTrial)/=nSnow .or. size(mLayerVolFracIce)/=nSnow .or. & + size(iLayerLiqFluxSnow)/=nSnow+1 .or. size(iLayerLiqFluxSnowDeriv)/=nSnow+1) then + err=20; message=trim(message)//'size mismatch of input/output vectors'; return + end if + + ! check the meltwater exponent is >=1 + if (mw_exp<1._rkind) then; err=20; message=trim(message)//'meltwater exponent < 1'; return; end if + + ! get the indices for the snow+soil layers + ixTop = integerMissing + if (scalarSolution) then + do i=1,size(ixSnowOnlyHyd) + if (ixSnowOnlyHyd(i) /= integerMissing) then + ixTop=ixLayerState(i) + ixBot=ixTop + exit ! break out of loop once found + end if + end do + if (ixTop == integerMissing) then + err=20; message=trim(message)//'Unable to identify snow layer for scalar solution!'; return + end if + else + ixTop = 1 + ixBot = nSnow + end if + + ! define the liquid flux at the upper boundary (m s-1) + iLayerLiqFluxSnow(0) = (scalarThroughfallRain + scalarCanopyLiqDrainage)/iden_water + iLayerLiqFluxSnowDeriv(0) = 0._rkind !computed inside computJacob + + ! compute properties fixed over the time step + if (firstFluxCall) then + ! loop through snow layers + do iLayer=1,nSnow ! loop through snow layers + multResid = 1._rkind/(1._rkind + exp((mLayerVolFracIce(iLayer)*iden_ice - residThrs)/residScal)) ! compute the reduction in liquid water holding capacity at high snow density (-) + mLayerPoreSpace(iLayer) = 1._rkind - mLayerVolFracIce(iLayer) ! compute the pore space (-) + mLayerThetaResid(iLayer) = Fcapil*mLayerPoreSpace(iLayer)*multResid ! compute the residual volumetric liquid water content (-) + end do ! end looping through snow layers + end if ! end if the first flux call + + ! compute fluxes + do iLayer=ixTop,ixBot ! loop through snow layers + if (mLayerVolFracLiqTrial(iLayer) > mLayerThetaResid(iLayer)) then ! check that flow occurs + ! compute the relative saturation (-) + availCap = mLayerPoreSpace(iLayer) - mLayerThetaResid(iLayer) ! available capacity + relSaturn = (mLayerVolFracLiqTrial(iLayer) - mLayerThetaResid(iLayer)) / availCap ! relative saturation + iLayerLiqFluxSnow(iLayer) = k_snow*relSaturn**mw_exp + iLayerLiqFluxSnowDeriv(iLayer) = ( (k_snow*mw_exp)/availCap ) * relSaturn**(mw_exp - 1._rkind) + if (mLayerVolFracIce(iLayer) > maxVolIceContent) then ! NOTE: use start-of-step ice content, to avoid convergence problems + ! ** allow liquid water to pass through under very high ice density + iLayerLiqFluxSnow(iLayer) = iLayerLiqFluxSnow(iLayer) + iLayerLiqFluxSnow(iLayer-1) + end if + else ! flow does not occur + iLayerLiqFluxSnow(iLayer) = 0._rkind + iLayerLiqFluxSnowDeriv(iLayer) = 0._rkind + end if ! storage above residual content + end do ! end loop through snow layers + + end associate ! end association of local variables with information in the data structures + +end subroutine snowLiqFlx end module snowLiqFlx_module diff --git a/build/source/engine/snow_utils.f90 b/build/source/engine/snow_utils.f90 old mode 100755 new mode 100644 index 8ad277d30..18c633cc2 --- a/build/source/engine/snow_utils.f90 +++ b/build/source/engine/snow_utils.f90 @@ -42,73 +42,70 @@ module snow_utils_module contains - ! *********************************************************************************************************** - ! public function fracliquid: compute fraction of liquid water - ! *********************************************************************************************************** - function fracliquid(Tk,fc_param) - implicit none - real(rkind),intent(in) :: Tk ! temperature (K) - real(rkind),intent(in) :: fc_param ! freezing curve parameter (K-1) - real(rkind) :: fracliquid ! fraction of liquid water (-) - ! compute fraction of liquid water (-) - fracliquid = 1._rkind / ( 1._rkind + (fc_param*( Tfreeze - min(Tk,Tfreeze) ))**2._rkind ) - end function fracliquid +! *********************************************************************************************************** +! public function fracliquid: compute fraction of liquid water +! *********************************************************************************************************** +function fracliquid(Tk,fc_param) + implicit none + real(rkind),intent(in) :: Tk ! temperature (K) + real(rkind),intent(in) :: fc_param ! freezing curve parameter (K-1) + real(rkind) :: fracliquid ! fraction of liquid water (-) + ! compute fraction of liquid water (-) + fracliquid = 1._rkind / ( 1._rkind + (fc_param*( Tfreeze - min(Tk,Tfreeze) ))**2_i4b ) +end function fracliquid +! *********************************************************************************************************** +! public function templiquid: invert the fraction of liquid water function +! *********************************************************************************************************** +function templiquid(fracliquid,fc_param) + implicit none + real(rkind),intent(in) :: fracliquid ! fraction of liquid water (-) + real(rkind),intent(in) :: fc_param ! freezing curve parameter (K-1) + real(rkind) :: templiquid ! temperature (K) + ! compute temperature based on the fraction of liquid water (K) + templiquid = Tfreeze - ((1._rkind/fracliquid - 1._rkind)/fc_param**2_i4b)**(0.5_rkind) +end function templiquid - ! *********************************************************************************************************** - ! public function templiquid: invert the fraction of liquid water function - ! *********************************************************************************************************** - function templiquid(fracliquid,fc_param) - implicit none - real(rkind),intent(in) :: fracliquid ! fraction of liquid water (-) - real(rkind),intent(in) :: fc_param ! freezing curve parameter (K-1) - real(rkind) :: templiquid ! temperature (K) - ! compute temperature based on the fraction of liquid water (K) - templiquid = Tfreeze - ((1._rkind/fracliquid - 1._rkind)/fc_param**2._rkind)**(0.5_rkind) - end function templiquid +! *********************************************************************************************************** +! public function dFracLiq_dTk: differentiate the freezing curve +! *********************************************************************************************************** +function dFracLiq_dTk(Tk,fc_param) + implicit none + ! dummies + real(rkind),intent(in) :: Tk ! temperature (K) + real(rkind),intent(in) :: fc_param ! freezing curve parameter (K-1) + real(rkind) :: dFracLiq_dTk ! differentiate the freezing curve (K-1) + ! locals + real(rkind) :: Tdep ! temperature depression (K) + real(rkind) :: Tdim ! dimensionless temperature (-) + ! compute local variables (just to make things more efficient) + Tdep = Tfreeze - min(Tk,Tfreeze) + Tdim = fc_param*Tdep + ! differentiate the freezing curve w.r.t temperature + dFracLiq_dTk = (fc_param*2._rkind*Tdim) / ( ( 1._rkind + Tdim**2_i4b)**2_i4b ) +end function dFracLiq_dTk - - ! *********************************************************************************************************** - ! public function dFracLiq_dTk: differentiate the freezing curve - ! *********************************************************************************************************** - function dFracLiq_dTk(Tk,fc_param) - implicit none - ! dummies - real(rkind),intent(in) :: Tk ! temperature (K) - real(rkind),intent(in) :: fc_param ! freezing curve parameter (K-1) - real(rkind) :: dFracLiq_dTk ! differentiate the freezing curve (K-1) - ! locals - real(rkind) :: Tdep ! temperature depression (K) - real(rkind) :: Tdim ! dimensionless temperature (-) - ! compute local variables (just to make things more efficient) - Tdep = Tfreeze - min(Tk,Tfreeze) - Tdim = fc_param*Tdep - ! differentiate the freezing curve w.r.t temperature - dFracLiq_dTk = (fc_param*2._rkind*Tdim) / ( ( 1._rkind + Tdim**2._rkind)**2._rkind ) - end function dFracLiq_dTk - - - ! *********************************************************************************************************** - ! public subroutine tcond_snow: compute thermal conductivity of snow - ! *********************************************************************************************************** - subroutine tcond_snow(BulkDenIce,thermlcond,err,message) - implicit none - real(rkind),intent(in) :: BulkDenIce ! bulk density of ice (kg m-3) - real(rkind),intent(out) :: thermlcond ! thermal conductivity of snow (W m-1 K-1) - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! initialize error control - err=0; message="tcond_snow/" - ! compute thermal conductivity of snow - select case(model_decisions(iLookDECISIONS%thCondSnow)%iDecision) - case(Yen1965); thermlcond = 3.217d-6 * BulkDenIce**2._rkind ! Yen (1965) - case(Mellor1977); thermlcond = 2.576d-6 * BulkDenIce**2._rkind + 7.4d-2 ! Mellor (1977) - case(Jordan1991); thermlcond = lambda_air + (7.75d-5*BulkDenIce + 1.105d-6*(BulkDenIce**2._rkind)) & - * (lambda_ice-lambda_air) ! Jordan (1991) +! *********************************************************************************************************** +! public subroutine tcond_snow: compute thermal conductivity of snow +! *********************************************************************************************************** +subroutine tcond_snow(BulkDenIce,thermlcond,err,message) + implicit none + real(rkind),intent(in) :: BulkDenIce ! bulk density of ice (kg m-3) + real(rkind),intent(out) :: thermlcond ! thermal conductivity of snow (W m-1 K-1) + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! initialize error control + err=0; message="tcond_snow/" + ! compute thermal conductivity of snow + select case(model_decisions(iLookDECISIONS%thCondSnow)%iDecision) + case(Yen1965); thermlcond = 3.217d-6 * BulkDenIce**2_i4b ! Yen (1965) + case(Mellor1977); thermlcond = 2.576d-6 * BulkDenIce**2_i4b + 7.4d-2 ! Mellor (1977) + case(Jordan1991); thermlcond = lambda_air + (7.75d-5*BulkDenIce + 1.105d-6*(BulkDenIce**2_i4b)) & + * (lambda_ice-lambda_air) ! Jordan (1991) case default - err=10; message=trim(message)//"unknownOption"; return - end select - end subroutine tcond_snow + err=10; message=trim(message)//"unknownOption"; return + end select +end subroutine tcond_snow end module snow_utils_module diff --git a/build/source/engine/snwCompact.f90 b/build/source/engine/snwCompact.f90 old mode 100755 new mode 100644 index 06d897bf6..5a66f0261 --- a/build/source/engine/snwCompact.f90 +++ b/build/source/engine/snwCompact.f90 @@ -39,69 +39,65 @@ module snwDensify_module ! public subroutine snwDensify: compute change in snow density over the time step ! ************************************************************************************************ subroutine snwDensify(& - ! intent(in): variables dt, & ! intent(in): time step (s) nSnow, & ! intent(in): number of snow layers mLayerTemp, & ! intent(in): temperature of each layer (K) mLayerMeltFreeze, & ! intent(in): volumnetric melt in each layer (kg m-3) - ! intent(in): parameters densScalGrowth, & ! intent(in): density scaling factor for grain growth (kg-1 m3) tempScalGrowth, & ! intent(in): temperature scaling factor for grain growth (K-1) grainGrowthRate, & ! intent(in): rate of grain growth (s-1) densScalOvrbdn, & ! intent(in): density scaling factor for overburden pressure (kg-1 m3) tempScalOvrbdn, & ! intent(in): temperature scaling factor for overburden pressure (K-1) - baseViscosity, & ! intent(in): viscosity coefficient at T=T_frz and snow density=0 (kg m-2 s) - + baseViscosity, & ! intent(in): viscosity coefficient at T=T_frz and snow density=0 (kg m-2 s) ! intent(inout): state variables mLayerDepth, & ! intent(inout): depth of each layer (m) mLayerVolFracLiqNew, & ! intent(inout): volumetric fraction of liquid water after itertations (-) mLayerVolFracIceNew, & ! intent(inout): volumetric fraction of ice after itertations (-) - ! output: error control err,message) ! intent(out): error control ! ----------------------------------------------------------------------------------------------------------------------------------------- ! compute change in snow density over the time step implicit none ! intent(in): variables - real(rkind),intent(in) :: dt ! time step (seconds) + real(rkind),intent(in) :: dt ! time step (seconds) integer(i4b),intent(in) :: nSnow ! number of snow layers - real(rkind),intent(in) :: mLayerTemp(:) ! temperature of each snow layer after iterations (K) - real(rkind),intent(in) :: mLayerMeltFreeze(:) ! volumetric melt in each layer (kg m-3) + real(rkind),intent(in) :: mLayerTemp(:) ! temperature of each snow layer after iterations (K) + real(rkind),intent(in) :: mLayerMeltFreeze(:) ! volumetric melt in each layer (kg m-3) ! intent(in): parameters - real(rkind),intent(in) :: densScalGrowth ! density scaling factor for grain growth (kg-1 m3) - real(rkind),intent(in) :: tempScalGrowth ! temperature scaling factor for grain growth (K-1) - real(rkind),intent(in) :: grainGrowthRate ! rate of grain growth (s-1) - real(rkind),intent(in) :: densScalOvrbdn ! density scaling factor for overburden pressure (kg-1 m3) - real(rkind),intent(in) :: tempScalOvrbdn ! temperature scaling factor for overburden pressure (K-1) - real(rkind),intent(in) :: baseViscosity ! viscosity coefficient at T=T_frz and snow density=0 (kg m-2 s) + real(rkind),intent(in) :: densScalGrowth ! density scaling factor for grain growth (kg-1 m3) + real(rkind),intent(in) :: tempScalGrowth ! temperature scaling factor for grain growth (K-1) + real(rkind),intent(in) :: grainGrowthRate ! rate of grain growth (s-1) + real(rkind),intent(in) :: densScalOvrbdn ! density scaling factor for overburden pressure (kg-1 m3) + real(rkind),intent(in) :: tempScalOvrbdn ! temperature scaling factor for overburden pressure (K-1) + real(rkind),intent(in) :: baseViscosity ! viscosity coefficient at T=T_frz and snow density=0 (kg m-2 s) ! intent(inout): state variables - real(rkind),intent(inout) :: mLayerDepth(:) ! depth of each layer (m) - real(rkind),intent(inout) :: mLayerVolFracLiqNew(:) ! volumetric fraction of liquid water in each snow layer after iterations (-) - real(rkind),intent(inout) :: mLayerVolFracIceNew(:) ! volumetric fraction of ice in each snow layer after iterations (-) + real(rkind),intent(inout) :: mLayerDepth(:) ! depth of each layer (m) + real(rkind),intent(inout) :: mLayerVolFracLiqNew(:) ! volumetric fraction of liquid water in each snow layer after iterations (-) + real(rkind),intent(inout) :: mLayerVolFracIceNew(:) ! volumetric fraction of ice in each snow layer after iterations (-) ! intent(out): error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------------------------------------------- ! define local variables - integer(i4b) :: iSnow ! index of snow layers - real(rkind) :: chi1,chi2,chi3,chi4,chi5 ! multipliers in the densification algorithm (-) - real(rkind) :: halfWeight ! half of the weight of the current snow layer (kg m-2) - real(rkind) :: weightSnow ! total weight of snow above the current snow layer (kg m-2) - real(rkind) :: CR_grainGrowth ! compaction rate for grain growth (s-1) - real(rkind) :: CR_ovrvdnPress ! compaction rate associated with over-burden pressure (s-1) - real(rkind) :: CR_metamorph ! compaction rate for metamorphism (s-1) - real(rkind) :: massIceOld ! mass of ice in the snow layer (kg m-2) - real(rkind) :: massLiqOld ! mass of liquid water in the snow layer (kg m-2) - real(rkind) :: scalarDepthNew ! updated layer depth (m) - real(rkind) :: scalarDepthMin ! minimum layer depth (m) - real(rkind) :: volFracIceLoss ! volumetric fraction of ice lost due to melt and sublimation (-) - real(rkind), dimension(nSnow) :: mLayerVolFracAirNew ! volumetric fraction of air in each layer after compaction (-) - real(rkind),parameter :: snwden_min=100._rkind ! minimum snow density for reducing metamorphism rate (kg m-3) - real(rkind),parameter :: snwDensityMax=550._rkind ! maximum snow density for collapse under melt (kg m-3) - real(rkind),parameter :: wetSnowThresh=0.01_rkind ! threshold to discriminate between "wet" and "dry" snow - real(rkind),parameter :: minLayerDensity=40._rkind ! minimum snow density allowed for any layer (kg m-3) + integer(i4b) :: iSnow ! index of snow layers + real(rkind) :: chi1,chi2,chi3,chi4,chi5 ! multipliers in the densification algorithm (-) + real(rkind) :: halfWeight ! half of the weight of the current snow layer (kg m-2) + real(rkind) :: weightSnow ! total weight of snow above the current snow layer (kg m-2) + real(rkind) :: CR_grainGrowth ! compaction rate for grain growth (s-1) + real(rkind) :: CR_ovrvdnPress ! compaction rate associated with over-burden pressure (s-1) + real(rkind) :: CR_metamorph ! compaction rate for metamorphism (s-1) + real(rkind) :: massIceOld ! mass of ice in the snow layer (kg m-2) + real(rkind) :: massLiqOld ! mass of liquid water in the snow layer (kg m-2) + real(rkind) :: scalarDepthNew ! updated layer depth (m) + real(rkind) :: scalarDepthMin ! minimum layer depth (m) + real(rkind) :: volFracIceLoss ! volumetric fraction of ice lost due to melt and sublimation (-) + real(rkind), dimension(nSnow) :: mLayerVolFracAirNew ! volumetric fraction of air in each layer after compaction (-) + real(rkind),parameter :: snwden_min=100._rkind ! minimum snow density for reducing metamorphism rate (kg m-3) + real(rkind),parameter :: snwDensityMax=550._rkind ! maximum snow density for collapse under melt (kg m-3) + real(rkind),parameter :: wetSnowThresh=0.01_rkind ! threshold to discriminate between "wet" and "dry" snow + real(rkind),parameter :: minLayerDensity=40._rkind ! minimum snow density allowed for any layer (kg m-3) ! ----------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message="snwDensify/" @@ -115,9 +111,6 @@ subroutine snwDensify(& ! loop through snow layers do iSnow=1,nSnow - ! print starting density - !write(*,'(a,1x,i4,1x,f9.3)') 'b4 compact: iSnow, density = ', iSnow, mLayerVolFracIceNew(iSnow)*iden_ice - ! save mass of liquid water and ice (mass does not change) massIceOld = iden_ice*mLayerVolFracIceNew(iSnow)*mLayerDepth(iSnow) ! (kg m-2) massLiqOld = iden_water*mLayerVolFracLiqNew(iSnow)*mLayerDepth(iSnow) ! (kg m-2) @@ -154,7 +147,6 @@ subroutine snwDensify(& volFracIceLoss = max(0._rkind,mLayerMeltFreeze(iSnow)/iden_ice) ! volumetric fraction of ice lost due to melt (-) ! (adjust snow depth to account for cavitation) scalarDepthNew = mLayerDepth(iSnow) * mLayerVolFracIceNew(iSnow)/(mLayerVolFracIceNew(iSnow) + volFracIceLoss) - !print*, 'volFracIceLoss = ', volFracIceLoss else scalarDepthNew = mLayerDepth(iSnow) end if @@ -178,8 +170,6 @@ subroutine snwDensify(& mLayerVolFracIceNew(iSnow) = massIceOld/(mLayerDepth(iSnow)*iden_ice) mLayerVolFracLiqNew(iSnow) = massLiqOld/(mLayerDepth(iSnow)*iden_water) mLayerVolFracAirNew(iSnow) = 1.0_rkind - mLayerVolFracIceNew(iSnow) - mLayerVolFracLiqNew(iSnow) - !write(*,'(a,1x,i4,1x,f9.3)') 'after compact: iSnow, density = ', iSnow, mLayerVolFracIceNew(iSnow)*iden_ice - !if(mLayerMeltFreeze(iSnow) > 20._rkind) pause 'meaningful melt' end do ! looping through snow layers diff --git a/build/source/engine/soilLiqFlx.f90 b/build/source/engine/soilLiqFlx.f90 old mode 100755 new mode 100644 index b7b5970b0..25a4682c7 --- a/build/source/engine/soilLiqFlx.f90 +++ b/build/source/engine/soilLiqFlx.f90 @@ -23,24 +23,31 @@ module soilLiqFlx_module ! data types USE nrtype -USE data_types,only:var_d ! x%var(:) (dp) +USE data_types,only:var_d ! x%var(:) (rkind) USE data_types,only:var_ilength ! x%var(:)%dat (i4b) -USE data_types,only:var_dlength ! x%var(:)%dat (dp) +USE data_types,only:var_dlength ! x%var(:)%dat (rkind) +USE data_types,only:in_type_soilLiqFlx ! derived type for intent(in) arguments +USE data_types,only:io_type_soilLiqFlx ! derived type for intent(inout) arguments +USE data_types,only:out_type_soilLiqFlx ! derived type for intent(out) arguments +USE data_types,only:in_type_diagv_node ! derived type for intent(in) arguments +USE data_types,only:out_type_diagv_node ! derived type for intent(out) arguments +USE data_types,only:in_type_surfaceFlx ! derived type for intent(in) arguments +USE data_types,only:io_type_surfaceFlx ! derived type for intent(inout) arguments +USE data_types,only:out_type_surfaceFlx ! derived type for intent(out) arguments +USE data_types,only:in_type_iLayerFlux ! derived type for intent(in) arguments +USE data_types,only:out_type_iLayerFlux ! derived type for intent(out) arguments +USE data_types,only:in_type_qDrainFlux ! derived type for intent(in) arguments +USE data_types,only:out_type_qDrainFlux ! derived type for intent(out) arguments ! missing values -USE globalData,only:integerMissing ! missing integer -USE globalData,only:realMissing ! missing real number +USE globalData,only:integerMissing ! missing integer +USE globalData,only:realMissing ! missing real number +USE globalData,only:veryBig ! a very big number +USE globalData,only:verySmall ! a small number used as an additive constant to check if substantial difference among real numbers +USE globalData,only:verySmaller ! a smaller number used as an additive constant to check if substantial difference among real numbers ! physical constants -USE multiconst,only:& - LH_fus, & ! latent heat of fusion (J kg-1) - LH_vap, & ! latent heat of vaporization (J kg-1) - LH_sub, & ! latent heat of sublimation (J kg-1) - gravity, & ! gravitational acceleteration (m s-2) - Tfreeze, & ! freezing point of pure water (K) - iden_air,& ! intrinsic density of air (kg m-3) - iden_ice,& ! intrinsic density of ice (kg m-3) - iden_water ! intrinsic density of water (kg m-3) +USE multiconst,only:iden_water ! intrinsic density of water (kg m-3) ! named variables USE var_lookup,only:iLookPROG ! named variables for structure elements @@ -54,1706 +61,2209 @@ module soilLiqFlx_module USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure ! provide access to look-up values for model decisions -USE mDecisions_module,only: & - ! look-up values for method used to compute derivative - numerical, & ! numerical solution - analytical, & ! analytical solution - ! look-up values for the form of Richards' equation - moisture, & ! moisture-based form of Richards' equation - mixdform, & ! mixed form of Richards' equation - ! look-up values for the type of hydraulic conductivity profile - constant, & ! constant hydraulic conductivity with depth - powerLaw_profile, & ! power-law profile - ! look-up values for the choice of groundwater parameterization - qbaseTopmodel, & ! TOPMODEL-ish baseflow parameterization - bigBucket, & ! a big bucket (lumped aquifer model) - noExplicit, & ! no explicit groundwater parameterization - ! look-up values for the choice of boundary conditions for hydrology - prescribedHead, & ! prescribed head (volumetric liquid water content for mixed form of Richards' eqn) - funcBottomHead, & ! function of matric head in the lower-most layer - freeDrainage, & ! free drainage - liquidFlux, & ! liquid water flux - zeroFlux ! zero flux +USE mDecisions_module,only: & + ! look-up values for method used to compute derivative + numerical, & ! numerical solution + analytical, & ! analytical solution + ! look-up values for the form of Richards' equation + moisture, & ! moisture-based form of Richards' equation + mixdform, & ! mixed form of Richards' equation + ! look-up values for the type of hydraulic conductivity profile + constant, & ! constant hydraulic conductivity with depth + powerLaw_profile, & ! power-law profile + ! look-up values for the choice of groundwater parameterization + qbaseTopmodel, & ! TOPMODEL-ish baseflow parameterization + bigBucket, & ! a big bucket (lumped aquifer model) + noExplicit, & ! no explicit groundwater parameterization + ! look-up values for the choice of boundary conditions for hydrology + prescribedHead, & ! prescribed head (volumetric liquid water content for mixed form of Richards' eqn) + funcBottomHead, & ! function of matric head in the lower-most layer + freeDrainage, & ! free drainage + liquidFlux, & ! liquid water flux + zeroFlux, & ! zero flux + ! look-up values for the choice of saturation excesssurface runoff parameterization + zero_SE, & ! zero saturation excess surface runoff parameterization + homegrown_SE, & ! homegrown saturation excess surface runoff parameterization + FUSEPRMS, & ! FUSE PRMS surface runoff parameterization + FUSEAVIC, & ! FUSE ARNO/VIC surface runoff parameterization + FUSETOPM, & ! FUSE TOPMODEL surface runoff parameterization + ! look-up values for the maximum infiltration rate parameterization + GreenAmpt, & ! Green-Ampt parameterization + topmodel_GA, & ! Green-Ampt parameterization with conductivity profile from TOPMODEL-ish parameterization + noInfiltrationExcess ! no infiltration excess runoff ! ----------------------------------------------------------------------------------------------------------- implicit none private public::soilLiqFlx -! constant parameters -real(rkind),parameter :: verySmall=1.e-12_rkind ! a very small number (used to avoid divide by zero) -real(rkind),parameter :: dx=1.e-8_rkind ! finite difference increment -contains - - ! *************************************************************************************************************** - ! public subroutine soilLiqFlx: compute liquid water fluxes and their derivatives - ! *************************************************************************************************************** - subroutine soilLiqFlx(& - ! input: model control - nSoil, & ! intent(in): number of soil layers - doInfiltrate, & ! intent(in): flag to compute infiltration - scalarSolution, & ! intent(in): flag to indicate the scalar solution - deriv_desired, & ! intent(in): flag indicating if derivatives are desired - ! input: trial state variables - mLayerTempTrial, & ! intent(in): temperature (K) - mLayerMatricHeadTrial, & ! intent(in): matric head (m) - mLayerVolFracLiqTrial, & ! intent(in): volumetric fraction of liquid water (-) - mLayerVolFracIceTrial, & ! intent(in): volumetric fraction of ice (-) - ! input: pre-computed derivatives - mLayerdTheta_dTk, & ! intent(in): derivative in volumetric liquid water content w.r.t. temperature (K-1) - dPsiLiq_dTemp, & ! intent(in): derivative in liquid water matric potential w.r.t. temperature (m K-1) - ! input: fluxes - scalarCanopyTranspiration, & ! intent(in): canopy transpiration (kg m-2 s-1) - scalarGroundEvaporation, & ! intent(in): ground evaporation (kg m-2 s-1) - scalarRainPlusMelt, & ! intent(in): rain plus melt (m s-1) - ! input-output: data structures - mpar_data, & ! intent(in): model parameters - indx_data, & ! intent(in): model indices - prog_data, & ! intent(in): model prognostic variables for a local HRU - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - flux_data, & ! intent(inout): model fluxes for a local HRU - ! output: diagnostic variables for surface runoff - xMaxInfilRate, & ! intent(inout): maximum infiltration rate (m s-1) - scalarInfilArea, & ! intent(inout): fraction of unfrozen area where water can infiltrate (-) - scalarFrozenArea, & ! intent(inout): fraction of area that is considered impermeable due to soil ice (-) - scalarSurfaceRunoff, & ! intent(out): surface runoff (m s-1) - ! output: diagnostic variables for model layers - mLayerdTheta_dPsi, & ! intent(out): derivative in the soil water characteristic w.r.t. psi (m-1) - mLayerdPsi_dTheta, & ! intent(out): derivative in the soil water characteristic w.r.t. theta (m) - dHydCond_dMatric, & ! intent(out): derivative in hydraulic conductivity w.r.t matric head (s-1) - ! output: fluxes - scalarSurfaceInfiltration, & ! intent(out): surface infiltration rate (m s-1) - iLayerLiqFluxSoil, & ! intent(out): liquid fluxes at layer interfaces (m s-1) - mLayerTranspire, & ! intent(out): transpiration loss from each soil layer (m s-1) - mLayerHydCond, & ! intent(out): hydraulic conductivity in each soil layer (m s-1) - ! output: derivatives in fluxes w.r.t. hydrology state variables -- matric head or volumetric lquid water -- in the layer above and layer below (m s-1 or s-1) - dq_dHydStateAbove, & ! intent(out): derivatives in the flux w.r.t. volumetric liquid water content in the layer above (m s-1) - dq_dHydStateBelow, & ! intent(out): derivatives in the flux w.r.t. volumetric liquid water content in the layer below (m s-1) - ! output: derivatives in fluxes w.r.t. energy state variables -- now just temperature -- in the layer above and layer below (m s-1 K-1) - dq_dNrgStateAbove, & ! intent(out): derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) - dq_dNrgStateBelow, & ! intent(out): derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) - ! output: error control - err,message) ! intent(out): error control - ! utility modules - USE soil_utils_module,only:volFracLiq ! compute volumetric fraction of liquid water - USE soil_utils_module,only:matricHead ! compute matric head (m) - USE soil_utils_module,only:dTheta_dPsi ! compute derivative of the soil moisture characteristic w.r.t. psi (m-1) - USE soil_utils_module,only:dPsi_dTheta ! compute derivative of the soil moisture characteristic w.r.t. theta (m) - USE soil_utils_module,only:hydCond_psi ! compute hydraulic conductivity as a function of matric head - USE soil_utils_module,only:hydCond_liq ! compute hydraulic conductivity as a function of volumetric liquid water content - USE soil_utils_module,only:hydCondMP_liq ! compute hydraulic conductivity of macropores as a function of volumetric liquid water content - ! ------------------------------------------------------------------------------------------------------------------------------------------------- - implicit none - ! input: model control - integer(i4b),intent(in) :: nSoil ! number of soil layers - logical(lgt),intent(in) :: doInfiltrate ! flag to compute infiltration - logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution - logical(lgt),intent(in) :: deriv_desired ! flag indicating if derivatives are desired - ! input: trial model state variables - real(rkind),intent(in) :: mLayerTempTrial(:) ! temperature in each layer at the current iteration (m) - real(rkind),intent(in) :: mLayerMatricHeadTrial(:) ! matric head in each layer at the current iteration (m) - real(rkind),intent(in) :: mLayerVolFracLiqTrial(:) ! volumetric fraction of liquid water at the current iteration (-) - real(rkind),intent(in) :: mLayerVolFracIceTrial(:) ! volumetric fraction of ice at the current iteration (-) - ! input: pre-computed derivatves - real(rkind),intent(in) :: mLayerdTheta_dTk(:) ! derivative in volumetric liquid water content w.r.t. temperature (K-1) - real(rkind),intent(in) :: dPsiLiq_dTemp(:) ! derivative in liquid water matric potential w.r.t. temperature (m K-1) - ! input: model fluxes - real(rkind),intent(in) :: scalarCanopyTranspiration ! canopy transpiration (kg m-2 s-1) - real(rkind),intent(in) :: scalarGroundEvaporation ! ground evaporation (kg m-2 s-1) - real(rkind),intent(in) :: scalarRainPlusMelt ! rain plus melt (m s-1) - ! input-output: data structures - type(var_dlength),intent(in) :: mpar_data ! model parameters - type(var_ilength),intent(in) :: indx_data ! state vector geometry - type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU - type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU - type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU - ! output: diagnostic variables for surface runoff - real(rkind),intent(inout) :: xMaxInfilRate ! maximum infiltration rate (m s-1) - real(rkind),intent(inout) :: scalarInfilArea ! fraction of unfrozen area where water can infiltrate (-) - real(rkind),intent(inout) :: scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) - real(rkind),intent(inout) :: scalarSurfaceRunoff ! surface runoff (m s-1) - ! output: diagnostic variables for each layer - real(rkind),intent(inout) :: mLayerdTheta_dPsi(:) ! derivative in the soil water characteristic w.r.t. psi (m-1) - real(rkind),intent(inout) :: mLayerdPsi_dTheta(:) ! derivative in the soil water characteristic w.r.t. theta (m) - real(rkind),intent(inout) :: dHydCond_dMatric(:) ! derivative in hydraulic conductivity w.r.t matric head (s-1) - ! output: liquid fluxes - real(rkind),intent(inout) :: scalarSurfaceInfiltration ! surface infiltration rate (m s-1) - real(rkind),intent(inout) :: iLayerLiqFluxSoil(0:) ! liquid flux at soil layer interfaces (m s-1) - real(rkind),intent(inout) :: mLayerTranspire(:) ! transpiration loss from each soil layer (m s-1) - real(rkind),intent(inout) :: mLayerHydCond(:) ! hydraulic conductivity in each soil layer (m s-1) - ! output: derivatives in fluxes w.r.t. state variables in the layer above and layer below (m s-1) - real(rkind),intent(inout) :: dq_dHydStateAbove(0:) ! derivative in the flux in layer interfaces w.r.t. state variables in the layer above - real(rkind),intent(inout) :: dq_dHydStateBelow(0:) ! derivative in the flux in layer interfaces w.r.t. state variables in the layer below - ! output: derivatives in fluxes w.r.t. energy state variables -- now just temperature -- in the layer above and layer below (m s-1 K-1) - real(rkind),intent(inout) :: dq_dNrgStateAbove(0:) ! derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) - real(rkind),intent(inout) :: dq_dNrgStateBelow(0:) ! derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) - ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! ----------------------------------------------------------------------------------------------------------------------------------------------------- - ! local variables: general - character(LEN=256) :: cmessage ! error message of downwind routine - integer(i4b) :: ibeg,iend ! start and end indices of the soil layers in concatanated snow-soil vector - logical(lgt) :: desireAnal ! flag to identify if analytical derivatives are desired - integer(i4b) :: iLayer,iSoil ! index of soil layer - integer(i4b) :: ixLayerDesired(1) ! layer desired (scalar solution) - integer(i4b) :: ixTop ! top layer in subroutine call - integer(i4b) :: ixBot ! bottom layer in subroutine call - ! additional variables to compute numerical derivatives - integer(i4b) :: nFlux ! number of flux calculations required (>1 = numerical derivatives with one-sided finite differences) - integer(i4b) :: itry ! index of different flux calculations - integer(i4b),parameter :: unperturbed=0 ! named variable to identify the case of unperturbed state variables - integer(i4b),parameter :: perturbState=1 ! named variable to identify the case where we perturb the state in the current layer - integer(i4b),parameter :: perturbStateAbove=2 ! named variable to identify the case where we perturb the state layer above - integer(i4b),parameter :: perturbStateBelow=3 ! named variable to identify the case where we perturb the state layer below - integer(i4b) :: ixPerturb ! index of element in 2-element vector to perturb - integer(i4b) :: ixOriginal ! index of perturbed element in the original vector - real(rkind) :: scalarVolFracLiqTrial ! trial value of volumetric liquid water content (-) - real(rkind) :: scalarMatricHeadTrial ! trial value of matric head (m) - real(rkind) :: scalarHydCondTrial ! trial value of hydraulic conductivity (m s-1) - real(rkind) :: scalarHydCondMicro ! trial value of hydraulic conductivity of micropores (m s-1) - real(rkind) :: scalarHydCondMacro ! trial value of hydraulic conductivity of macropores (m s-1) - real(rkind) :: scalarFlux ! vertical flux (m s-1) - real(rkind) :: scalarFlux_dStateAbove ! vertical flux with perturbation to the state above (m s-1) - real(rkind) :: scalarFlux_dStateBelow ! vertical flux with perturbation to the state below (m s-1) - ! transpiration sink term - real(rkind),dimension(nSoil) :: mLayerTranspireFrac ! fraction of transpiration allocated to each soil layer (-) - ! diagnostic variables - real(rkind),dimension(nSoil) :: iceImpedeFac ! ice impedence factor at layer mid-points (-) - real(rkind),dimension(nSoil) :: mLayerDiffuse ! diffusivity at layer mid-point (m2 s-1) - real(rkind),dimension(nSoil) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) - real(rkind),dimension(nSoil) :: dDiffuse_dVolLiq ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) - real(rkind),dimension(nSoil) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) - real(rkind),dimension(0:nSoil) :: iLayerHydCond ! hydraulic conductivity at layer interface (m s-1) - real(rkind),dimension(0:nSoil) :: iLayerDiffuse ! diffusivity at layer interface (m2 s-1) - ! compute surface flux - integer(i4b) :: nRoots ! number of soil layers with roots - integer(i4b) :: ixIce ! index of the lowest soil layer that contains ice - real(rkind),dimension(0:nSoil) :: iLayerHeight ! height of the layer interfaces (m) - ! compute fluxes and derivatives at layer interfaces - real(rkind),dimension(2) :: vectorVolFracLiqTrial ! trial value of volumetric liquid water content (-) - real(rkind),dimension(2) :: vectorMatricHeadTrial ! trial value of matric head (m) - real(rkind),dimension(2) :: vectorHydCondTrial ! trial value of hydraulic conductivity (m s-1) - real(rkind),dimension(2) :: vectorDiffuseTrial ! trial value of hydraulic diffusivity (m2 s-1) - real(rkind) :: scalardPsi_dTheta ! derivative in soil water characteristix, used for perturbations when computing numerical derivatives - ! ------------------------------------------------------------------------------------------------------------------------------------------------- - ! initialize error control - err=0; message='soilLiqFlx/' - - ! get indices for the data structures - ibeg = indx_data%var(iLookINDEX%nSnow)%dat(1) + 1 - iend = indx_data%var(iLookINDEX%nSnow)%dat(1) + indx_data%var(iLookINDEX%nSoil)%dat(1) - - ! get a copy of iLayerHeight - ! NOTE: performance hit, though cannot define the shape (0:) with the associate construct - iLayerHeight(0:nSoil) = prog_data%var(iLookPROG%iLayerHeight)%dat(ibeg-1:iend) ! height of the layer interfaces (m) - - ! make association between local variables and the information in the data structures - associate(& - ! input: model control - ixDerivMethod => model_decisions(iLookDECISIONS%fDerivMeth)%iDecision, & ! intent(in): index of the method used to calculate flux derivatives - ixRichards => model_decisions(iLookDECISIONS%f_Richards)%iDecision, & ! intent(in): index of the form of Richards' equation - ixBcUpperSoilHydrology => model_decisions(iLookDECISIONS%bcUpprSoiH)%iDecision, & ! intent(in): index of the upper boundary conditions for soil hydrology - ixBcLowerSoilHydrology => model_decisions(iLookDECISIONS%bcLowrSoiH)%iDecision, & ! intent(in): index of the lower boundary conditions for soil hydrology - ! input: model indices - ixMatricHead => indx_data%var(iLookINDEX%ixMatricHead)%dat, & ! intent(in): indices of soil layers where matric head is the state variable - ixSoilOnlyHyd => indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat, & ! intent(in): index in the state subset for hydrology state variables in the soil domain - ! input: model coordinate variables -- NOTE: use of ibeg and iend - mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat(ibeg:iend), & ! intent(in): depth of the layer (m) - mLayerHeight => prog_data%var(iLookPROG%mLayerHeight)%dat(ibeg:iend), & ! intent(in): height of the layer mid-point (m) - ! input: upper boundary conditions - upperBoundHead => mpar_data%var(iLookPARAM%upperBoundHead)%dat(1), & ! intent(in): upper boundary condition for matric head (m) - upperBoundTheta => mpar_data%var(iLookPARAM%upperBoundTheta)%dat(1), & ! intent(in): upper boundary condition for volumetric liquid water content (-) - ! input: lower boundary conditions - lowerBoundHead => mpar_data%var(iLookPARAM%lowerBoundHead)%dat(1), & ! intent(in): lower boundary condition for matric head (m) - lowerBoundTheta => mpar_data%var(iLookPARAM%lowerBoundTheta)%dat(1), & ! intent(in): lower boundary condition for volumetric liquid water content (-) - ! input: vertically variable soil parameters - vGn_m => diag_data%var(iLookDIAG%scalarVGn_m)%dat, & ! intent(in): van Genutchen "m" parameter (-) - vGn_n => mpar_data%var(iLookPARAM%vGn_n)%dat, & ! intent(in): van Genutchen "n" parameter (-) - vGn_alpha => mpar_data%var(iLookPARAM%vGn_alpha)%dat, & ! intent(in): van Genutchen "alpha" parameter (m-1) - theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat, & ! intent(in): soil porosity (-) - theta_res => mpar_data%var(iLookPARAM%theta_res)%dat, & ! intent(in): soil residual volumetric water content (-) - ! input: vertically constant soil parameters - wettingFrontSuction => mpar_data%var(iLookPARAM%wettingFrontSuction)%dat(1), & ! intent(in): Green-Ampt wetting front suction (m) - rootingDepth => mpar_data%var(iLookPARAM%rootingDepth)%dat(1), & ! intent(in): rooting depth (m) - kAnisotropic => mpar_data%var(iLookPARAM%kAnisotropic)%dat(1), & ! intent(in): anisotropy factor for lateral hydraulic conductivity (-) - zScale_TOPMODEL => mpar_data%var(iLookPARAM%zScale_TOPMODEL)%dat(1), & ! intent(in): TOPMODEL scaling factor (m) - qSurfScale => mpar_data%var(iLookPARAM%qSurfScale)%dat(1), & ! intent(in): scaling factor in the surface runoff parameterization (-) - f_impede => mpar_data%var(iLookPARAM%f_impede)%dat(1), & ! intent(in): ice impedence factor (-) - soilIceScale => mpar_data%var(iLookPARAM%soilIceScale)%dat(1), & ! intent(in): scaling factor for depth of soil ice, used to get frozen fraction (m) - soilIceCV => mpar_data%var(iLookPARAM%soilIceCV)%dat(1), & ! intent(in): CV of depth of soil ice, used to get frozen fraction (-) - theta_mp => mpar_data%var(iLookPARAM%theta_mp)%dat, & ! intent(in): volumetric liquid water content when macropore flow begins (-) - mpExp => mpar_data%var(iLookPARAM%mpExp)%dat(1), & ! intent(in): empirical exponent in macropore flow equation (-) - ! input: saturated hydraulic conductivity - mLayerSatHydCondMP => flux_data%var(iLookFLUX%mLayerSatHydCondMP)%dat, & ! intent(in): saturated hydraulic conductivity of macropores at the mid-point of each layer (m s-1) - mLayerSatHydCond => flux_data%var(iLookFLUX%mLayerSatHydCond)%dat, & ! intent(in): saturated hydraulic conductivity at the mid-point of each layer (m s-1) - iLayerSatHydCond => flux_data%var(iLookFLUX%iLayerSatHydCond)%dat, & ! intent(in): saturated hydraulic conductivity at the interface of each layer (m s-1) - ! input: factors limiting transpiration (from vegFlux routine) - mLayerRootDensity => diag_data%var(iLookDIAG%mLayerRootDensity)%dat, & ! intent(in): root density in each layer (-) - scalarTranspireLim => diag_data%var(iLookDIAG%scalarTranspireLim)%dat(1), & ! intent(in): weighted average of the transpiration limiting factor (-) - mLayerTranspireLim => diag_data%var(iLookDIAG%mLayerTranspireLim)%dat & ! intent(in): transpiration limiting factor in each layer (-) - ) ! associating local variables with the information in the data structures - - ! ------------------------------------------------------------------------------------------------------------------------------------------------- - ! preliminaries - ! ------------------------------------------------------------------------------------------------------------------------------------------------- - - ! define the pethod to compute derivatives - !print*, 'numerical derivatives = ', (ixDerivMethod==numerical) - - ! numerical derivatives are not implemented yet - if(ixDerivMethod==numerical)then - message=trim(message)//'numerical derivates do not account for the cross derivatives between hydrology and thermodynamics' - err=20; return - end if - - ! check the need to compute analytical derivatives - if(deriv_desired .and. ixDerivMethod==analytical)then - desireAnal = .true. - else - desireAnal = .false. - end if - - ! check the need to compute numerical derivatives - if(deriv_desired .and. ixDerivMethod==numerical)then - nFlux=3 ! compute the derivatives using one-sided finite differences - else - nFlux=0 ! compute analytical derivatives - end if - - ! get the indices for the soil layers - if(scalarSolution)then - ixLayerDesired = pack(ixMatricHead, ixSoilOnlyHyd/=integerMissing) - ixTop = ixLayerDesired(1) - ixBot = ixLayerDesired(1) - else - ixTop = 1 - ixBot = nSoil - endif - - ! identify the number of layers that contain roots - nRoots = count(iLayerHeight(0:nSoil-1) < rootingDepth-verySmall) - if(nRoots==0)then - message=trim(message)//'no layers with roots' - err=20; return - endif - - ! identify lowest soil layer with ice - ! NOTE: cannot use count because there may be an unfrozen wedge - ixIce = 0 ! initialize the index of the ice layer (0 means no ice in the soil profile) - do iLayer=1,nSoil ! (loop through soil layers) - if(mLayerVolFracIceTrial(iLayer) > verySmall) ixIce = iLayer - end do - !if(ixIce==nSoil)then; err=20; message=trim(message)//'ice extends to the bottom of the soil profile'; return; end if - - ! ************************************************************************************************************************************************* - ! ************************************************************************************************************************************************* - - ! ------------------------------------------------------------------------------------------------------------------------------------------------- - ! compute the transpiration sink term - ! ------------------------------------------------------------------------------------------------------------------------------------------------- - - ! check the need to compute transpiration (NOTE: intent=inout) - if( .not. (scalarSolution .and. ixTop>1) )then - - ! compute the fraction of transpiration loss from each soil layer - if(scalarTranspireLim > tiny(scalarTranspireLim))then ! (transpiration may be non-zero even if the soil moisture limiting factor is zero) - mLayerTranspireFrac(:) = mLayerRootDensity(:)*mLayerTranspireLim(:)/scalarTranspireLim - else ! (possible for there to be non-zero conductance and therefore transpiration in this case) - mLayerTranspireFrac(:) = mLayerRootDensity(:) / sum(mLayerRootDensity) - end if - - ! check fractions sum to one - if(abs(sum(mLayerTranspireFrac) - 1._rkind) > verySmall)then - message=trim(message)//'fraction transpiration in soil layers does not sum to one' - err=20; return - endif - - ! compute transpiration loss from each soil layer (kg m-2 s-1 --> m s-1) - mLayerTranspire = mLayerTranspireFrac(:)*scalarCanopyTranspiration/iden_water - - ! special case of prescribed head -- no transpiration - if(ixBcUpperSoilHydrology==prescribedHead) mLayerTranspire(:) = 0._rkind - - endif ! if need to compute transpiration - - ! ************************************************************************************************************************************************* - ! ************************************************************************************************************************************************* - - ! ------------------------------------------------------------------------------------------------------------------------------------------------- - ! compute diagnostic variables at the nodes throughout the soil profile - ! ------------------------------------------------------------------------------------------------------------------------------------------------- - do iSoil=ixTop,min(ixBot+1,nSoil) ! (loop through soil layers) - - call diagv_node(& - ! input: model control - desireAnal, & ! intent(in): flag indicating if derivatives are desired - ixRichards, & ! intent(in): index defining the option for Richards' equation (moisture or mixdform) - ! input: state variables - mLayerTempTrial(iSoil), & ! intent(in): temperature (K) - mLayerMatricHeadTrial(iSoil), & ! intent(in): matric head in each layer (m) - mLayerVolFracLiqTrial(iSoil), & ! intent(in): volumetric liquid water content in each soil layer (-) - mLayerVolFracIceTrial(iSoil), & ! intent(in): volumetric ice content in each soil layer (-) - ! input: pre-computed deriavatives - mLayerdTheta_dTk(iSoil), & ! intent(in): derivative in volumetric liquid water content w.r.t. temperature (K-1) - dPsiLiq_dTemp(iSoil), & ! intent(in): derivative in liquid water matric potential w.r.t. temperature (m K-1) - ! input: soil parameters - vGn_alpha(iSoil), & ! intent(in): van Genutchen "alpha" parameter (m-1) - vGn_n(iSoil), & ! intent(in): van Genutchen "n" parameter (-) - VGn_m(iSoil), & ! intent(in): van Genutchen "m" parameter (-) - mpExp, & ! intent(in): empirical exponent in macropore flow equation (-) - theta_sat(iSoil), & ! intent(in): soil porosity (-) - theta_res(iSoil), & ! intent(in): soil residual volumetric water content (-) - theta_mp(iSoil), & ! intent(in): volumetric liquid water content when macropore flow begins (-) - f_impede, & ! intent(in): ice impedence factor (-) - ! input: saturated hydraulic conductivity - mLayerSatHydCond(iSoil), & ! intent(in): saturated hydraulic conductivity at the mid-point of each layer (m s-1) - mLayerSatHydCondMP(iSoil), & ! intent(in): saturated hydraulic conductivity of macropores at the mid-point of each layer (m s-1) - ! output: derivative in the soil water characteristic - mLayerdPsi_dTheta(iSoil), & ! intent(out): derivative in the soil water characteristic - mLayerdTheta_dPsi(iSoil), & ! intent(out): derivative in the soil water characteristic - ! output: transmittance - mLayerHydCond(iSoil), & ! intent(out): hydraulic conductivity at layer mid-points (m s-1) - mLayerDiffuse(iSoil), & ! intent(out): diffusivity at layer mid-points (m2 s-1) - iceImpedeFac(iSoil), & ! intent(out): ice impedence factor in each layer (-) - ! output: transmittance derivatives - dHydCond_dVolLiq(iSoil), & ! intent(out): derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) - dDiffuse_dVolLiq(iSoil), & ! intent(out): derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) - dHydCond_dMatric(iSoil), & ! intent(out): derivative in hydraulic conductivity w.r.t matric head (m s-1) - dHydCond_dTemp(iSoil), & ! intent(out): derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) - ! output: error control - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if - - end do ! (looping through soil layers) - - ! ************************************************************************************************************************************************* - ! ************************************************************************************************************************************************* - - ! ------------------------------------------------------------------------------------------------------------------------------------------------- - ! compute infiltraton at the surface and its derivative w.r.t. mass in the upper soil layer - ! ------------------------------------------------------------------------------------------------------------------------------------------------- - - ! set derivative w.r.t. state above to zero (does not exist) - dq_dHydStateAbove(0) = 0._rkind - dq_dNrgStateAbove(0) = 0._rkind - - ! either one or multiple flux calls, depending on if using analytical or numerical derivatives - do itry=nFlux,0,-1 ! (work backwards to ensure all computed fluxes come from the un-perturbed case) - - ! ===== - ! get input state variables... - ! ============================ - ! identify the type of perturbation - select case(itry) - - ! skip undesired perturbations - case(perturbStateAbove); cycle ! cannot perturb state above (does not exist) -- so keep cycling - case(perturbState); cycle ! perturbing the layer below the flux at the top interface - - ! un-perturbed case - case(unperturbed) - scalarVolFracLiqTrial = mLayerVolFracLiqTrial(1) - scalarMatricHeadTrial = mLayerMatricHeadTrial(1) - - ! perturb soil state (one-sided finite differences) - case(perturbStateBelow) - ! (perturbation depends on the form of Richards' equation) - select case(ixRichards) - case(moisture) - scalarVolFracLiqTrial = mLayerVolFracLiqTrial(1) + dx - scalarMatricHeadTrial = mLayerMatricHeadTrial(1) - case(mixdform) - scalarVolFracLiqTrial = mLayerVolFracLiqTrial(1) - scalarMatricHeadTrial = mLayerMatricHeadTrial(1) + dx - case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return - end select ! (form of Richards' equation - ! check for an unknown perturbation - case default; err=10; message=trim(message)//"unknown perturbation"; return +! flag to denote if updating infiltration during iterations for testing purposes +logical(lgt),parameter :: updateInfil=.true. +contains - end select ! (type of perturbation) - ! ===== - ! compute surface flux and its derivative... - ! ========================================== - - call surfaceFlx(& - ! input: model control - doInfiltrate, & ! intent(in): flag indicating if desire to compute infiltration - desireAnal, & ! intent(in): flag indicating if derivatives are desired - ixRichards, & ! intent(in): index defining the form of Richards' equation (moisture or mixdform) - ixBcUpperSoilHydrology, & ! intent(in): index defining the type of boundary conditions (neumann or diriclet) - nRoots, & ! intent(in): number of layers that contain roots - ixIce, & ! intent(in): index of lowest ice layer - ! input: state variables - scalarMatricHeadTrial, & ! intent(in): matric head in the upper-most soil layer (m) - scalarVolFracLiqTrial, & ! intent(in): volumetric liquid water content the upper-most soil layer (-) - mLayerVolFracLiqTrial, & ! intent(in): volumetric liquid water content in each soil layer (-) - mLayerVolFracIceTrial, & ! intent(in): volumetric ice content in each soil layer (-) - ! input: depth of upper-most soil layer (m) - mLayerDepth, & ! intent(in): depth of each soil layer (m) - iLayerHeight, & ! intent(in): height at the interface of each layer (m) - ! input: boundary conditions - upperBoundHead, & ! intent(in): upper boundary condition (m) - upperBoundTheta, & ! intent(in): upper boundary condition (-) - ! input: flux at the upper boundary - scalarRainPlusMelt, & ! intent(in): rain plus melt (m s-1) - ! input: transmittance - iLayerSatHydCond(0), & ! intent(in): saturated hydraulic conductivity at the surface (m s-1) - dHydCond_dTemp(1), & ! intent(in): derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) - iceImpedeFac(1), & ! intent(in): ice impedence factor in the upper-most soil layer (-) - ! input: soil parameters - vGn_alpha(1), & ! intent(in): van Genutchen "alpha" parameter (m-1) - vGn_n(1), & ! intent(in): van Genutchen "n" parameter (-) - VGn_m(1), & ! intent(in): van Genutchen "m" parameter (-) - theta_sat(1), & ! intent(in): soil porosity (-) - theta_res(1), & ! intent(in): soil residual volumetric water content (-) - qSurfScale, & ! intent(in): scaling factor in the surface runoff parameterization (-) - zScale_TOPMODEL, & ! intent(in): scaling factor used to describe decrease in hydraulic conductivity with depth (m) - rootingDepth, & ! intent(in): rooting depth (m) - wettingFrontSuction, & ! intent(in): Green-Ampt wetting front suction (m) - soilIceScale, & ! intent(in): soil ice scaling factor in Gamma distribution used to define frozen area (m) - soilIceCV, & ! intent(in): soil ice CV in Gamma distribution used to define frozen area (-) - ! input-output: hydraulic conductivity and diffusivity at the surface - iLayerHydCond(0), & ! intent(inout): hydraulic conductivity at the surface (m s-1) - iLayerDiffuse(0), & ! intent(inout): hydraulic diffusivity at the surface (m2 s-1) - ! input-output: fluxes at layer interfaces and surface runoff - xMaxInfilRate, & ! intent(inout): maximum infiltration rate (m s-1) - scalarInfilArea, & ! intent(inout): fraction of unfrozen area where water can infiltrate (-) - scalarFrozenArea, & ! intent(inout): fraction of area that is considered impermeable due to soil ice (-) - scalarSurfaceRunoff, & ! intent(out): surface runoff (m s-1) - scalarSurfaceInfiltration, & ! intent(out): surface infiltration (m s-1) - ! input-output: deriavtives in surface infiltration w.r.t. volumetric liquid water (m s-1) and matric head (s-1) in the upper-most soil layer - dq_dHydStateBelow(0), & ! intent(inout): derivative in surface infiltration w.r.t. hydrology state variable in the upper-most soil layer (m s-1 or s-1) - dq_dNrgStateBelow(0), & ! intent(out): derivative in surface infiltration w.r.t. energy state variable in the upper-most soil layer (m s-1 K-1) - ! output: error control - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if +! *************************************************************************************************************** +! public subroutine soilLiqFlx: compute liquid water fluxes and their derivatives +! *************************************************************************************************************** +subroutine soilLiqFlx(& + ! input: model control, trial state variables, derivatives, and fluxes + in_soilLiqFlx, & ! intent(in): model control, trial state variables, derivatives, and fluxes + ! input-output: data structures + mpar_data, & ! intent(in): model parameters + indx_data, & ! intent(in): model indices + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + flux_data, & ! intent(inout): model fluxes for a local HRU + ! input-output: diagnostic variables, fluxes, and derivatives + io_soilLiqFlx, & ! intent(inout): diagnostic variables, fluxes, and derivatives + ! output: error control + out_soilLiqFlx) ! intent(out): error control + ! ------------------------------------------------------------------------------------------------------------------------------------------------- + implicit none + ! input: model control, trial state variables, derivatives, and fluxes + type(in_type_soilLiqFlx),intent(in) :: in_soilLiqFlx ! model control, trial state variables, derivatives, and fluxes + ! input-output: data structures + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_ilength),intent(in) :: indx_data ! state vector geometry + type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU + type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU + ! input-output: diagnostic variables, fluxes, and derivatives + type(io_type_soilLiqFlx),intent(inout) :: io_soilLiqFlx ! diagnostic variables, fluxes, and derivatives + ! output: error control + type(out_type_soilLiqFlx),intent(out) :: out_soilLiqFlx ! error code and error message + ! ----------------------------------------------------------------------------------------------------------------------------------------------------- + ! local variables: general + character(LEN=256) :: cmessage ! error message of downwind routine + integer(i4b) :: nSoil ! number of soil layers + integer(i4b) :: ibeg,iend ! start and end indices of the soil layers in concatanated snow-soil vector + integer(i4b) :: iLayer,iSoil ! index of soil layer + integer(i4b) :: ixLayerDesired(1) ! layer desired (scalar solution) + integer(i4b) :: ixTop ! top layer in subroutine call + integer(i4b) :: ixBot ! bottom layer in subroutine call + ! transpiration sink term + real(rkind),dimension(in_soilLiqFlx % nSoil) :: mLayerTranspireFrac ! fraction of transpiration allocated to each soil layer (-) + ! diagnostic variables + real(rkind),dimension(in_soilLiqFlx % nSoil) :: iceImpedeFac ! ice impedence factor at layer mid-points (-) + real(rkind),dimension(in_soilLiqFlx % nSoil) :: mLayerDiffuse ! diffusivity at layer mid-point (m2 s-1) + real(rkind),dimension(in_soilLiqFlx % nSoil) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) + real(rkind),dimension(in_soilLiqFlx % nSoil) :: dDiffuse_dVolLiq ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) + real(rkind),dimension(in_soilLiqFlx % nSoil) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + real(rkind),dimension(0:in_soilLiqFlx % nSoil) :: iLayerHydCond ! hydraulic conductivity at layer interface (m s-1) + real(rkind),dimension(0:in_soilLiqFlx % nSoil) :: iLayerDiffuse ! diffusivity at layer interface (m2 s-1) + ! compute surface flux + integer(i4b) :: nRoots ! number of soil layers with roots + integer(i4b) :: ixIce ! index of the lowest soil layer that contains ice + real(rkind),dimension(0:in_soilLiqFlx % nSoil) :: iLayerHeight ! height of the layer interfaces (m) + ! error control + logical(lgt) :: return_flag ! flag for return statements + ! ------------------------------------------------------------------------------------------------------------------------------------------------- + + ! ** Initialize indices, error control, and get layer information ** + call initialize_soilLiqFlx; if (return_flag) return + + ! ** Compute transpiration, diagnostic variables, infiltration, and interface fluxes ** + call update_soilLiqFlx; if (return_flag) return + + ! ** Final error control ** + call finalize_soilLiqFlx; if (return_flag) return + +contains - ! include base soil evaporation as the upper boundary flux - iLayerLiqFluxSoil(0) = scalarGroundEvaporation/iden_water + scalarSurfaceInfiltration - - ! get copies of surface flux to compute numerical derivatives - if(deriv_desired .and. ixDerivMethod==numerical)then - select case(itry) - case(unperturbed); scalarFlux = iLayerLiqFluxSoil(0) - case(perturbStateBelow); scalarFlux_dStateBelow = iLayerLiqFluxSoil(0) - case default; err=10; message=trim(message)//"unknown perturbation"; return - end select + subroutine initialize_soilLiqFlx + ! **** Initial operations for soilLiqFlx module subroutine **** + + ! ** assign variables used in main associate block ** + nSoil = in_soilLiqFlx % nSoil ! get number of soil layers from input arguments + + ! get indices for the data structures + ibeg = indx_data%var(iLookINDEX%nSnow)%dat(1) + 1 + iend = indx_data%var(iLookINDEX%nSnow)%dat(1) + indx_data%var(iLookINDEX%nSoil)%dat(1) + + ! get a copy of iLayerHeight (for soil layers only) + ! NOTE: performance hit, though cannot define the shape (0:) with the associate construct + iLayerHeight(0:nSoil) = prog_data%var(iLookPROG%iLayerHeight)%dat(ibeg-1:iend) ! height of the layer interfaces (m) + + ! ** initialize error control ** + return_flag=.false. + associate(& + err => out_soilLiqFlx % err, & ! intent(out): error code + message => out_soilLiqFlx % cmessage & ! intent(out): error message + &) + err=0; message='soilLiqFlx/' ! initialize error control + end associate + + ! ** get the indices for the soil layers ** + associate(& + scalarSolution => in_soilLiqFlx % scalarSolution, & ! intent(in): flag to denote if implementing the scalar solution + ixMatricHead => indx_data%var(iLookINDEX%ixMatricHead)%dat, & ! intent(in): indices of soil layers where matric head is the state variable + ixSoilOnlyHyd => indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat & ! intent(in): index in the state subset for hydrology state variables in the soil domain + &) + if (scalarSolution) then + ixLayerDesired = pack(ixMatricHead, ixSoilOnlyHyd/=integerMissing) + ixTop = ixLayerDesired(1) + ixBot = ixLayerDesired(1) + else + ixTop = 1 + ixBot = nSoil + end if + end associate + + ! ** identify the number of layers that contain roots ** + associate(& + rootingDepth => mpar_data%var(iLookPARAM%rootingDepth)%dat(1),& ! intent(in): rooting depth (m) + err => out_soilLiqFlx % err, & ! intent(out): error code + message => out_soilLiqFlx % cmessage & ! intent(out): error message + &) + nRoots = count(iLayerHeight(0:nSoil-1) < rootingDepth-verySmall) + if(nRoots==0)then; message=trim(message)//'no layers with roots'; err=20; return_flag=.true.; return; end if + end associate + + ! ** identify lowest soil layer with ice ** + ! NOTE: cannot use count because there may be an unfrozen wedge + associate(& + mLayerVolFracIceTrial => in_soilLiqFlx % mLayerVolFracIceTrial & ! intent(in): volumetric fraction of ice at the current iteration (-) + &) + ixIce = 0 ! initialize the index of the ice layer (0 means no ice in the soil profile) + do iLayer=1,nSoil ! (loop through soil layers) + if (mLayerVolFracIceTrial(iLayer) > verySmaller) ixIce = iLayer + end do + end associate + end subroutine initialize_soilLiqFlx + + subroutine update_soilLiqFlx + ! **** Main computations for soilLiqFlx module subroutine **** + + if ( .not. (in_soilLiqFlx % scalarSolution .and. ixTop>1) ) then ! check the need to compute transpiration + call compute_transpiration_sink; if (return_flag) return + end if + + call compute_diagnostic_variables; if (return_flag) return + + call compute_surface_infiltration; if (return_flag) return + + call compute_interface_fluxes_derivatives; if (return_flag) return + + if ( .not. (in_soilLiqFlx % scalarSolution .and. ixTop out_soilLiqFlx % err, & ! intent(out): error code + message => out_soilLiqFlx % cmessage & ! intent(out): error message + &) + if(err/=0)then; message=trim(message)//trim("finalize_soilLiqFlx: final error check failed"); return_flag=.true.; return; end if + end associate + end subroutine finalize_soilLiqFlx + + subroutine compute_transpiration_sink + ! **** Compute the transpiration sink term **** + + call update_transpiration_loss_fraction + call finalize_transpiration_loss_fraction; if (return_flag) return + + call update_transpiration_loss + end subroutine compute_transpiration_sink + + subroutine update_transpiration_loss_fraction + ! **** Update the fraction of transpiration loss from each soil layer ***** + associate(& + scalarTranspireLim => diag_data%var(iLookDIAG%scalarTranspireLim)%dat(1), & ! intent(in): weighted average of the transpiration limiting factor (-) + mLayerRootDensity => diag_data%var(iLookDIAG%mLayerRootDensity)%dat, & ! intent(in): root density in each layer (-) + mLayerTranspireLim => diag_data%var(iLookDIAG%mLayerTranspireLim)%dat & ! intent(in): transpiration limiting factor in each layer (-) + &) + ! transpiration may be non-zero even if the soil moisture limiting factor is zero + if (scalarTranspireLim > tiny(scalarTranspireLim)) then + mLayerTranspireFrac(:) = mLayerRootDensity(:)*mLayerTranspireLim(:)/scalarTranspireLim + else ! possibility of non-zero conductance and therefore transpiration in this case + mLayerTranspireFrac(:) = mLayerRootDensity(:) / sum(mLayerRootDensity) end if - - ! ===== - ! get hydraulic conductivty... - ! ============================ - ! start with the un-perturbed case - vectorHydCondTrial(1:2) = mLayerHydCond(iLayer:iLayer+1) - vectorDiffuseTrial(1:2) = mLayerDiffuse(iLayer:iLayer+1) - ! make appropriate perturbations - if(ixPerturb > 0)then - select case(ixRichards) - case(moisture) - scalardPsi_dTheta = dPsi_dTheta(vectorVolFracLiqTrial(ixPerturb),vGn_alpha(ixPerturb),theta_res(ixPerturb),theta_sat(ixPerturb),vGn_n(ixPerturb),vGn_m(ixPerturb)) - vectorHydCondTrial(ixPerturb) = hydCond_liq(vectorVolFracLiqTrial(ixPerturb),mLayerSatHydCond(ixOriginal),theta_res(ixPerturb),theta_sat(ixPerturb),vGn_m(ixPerturb)) * iceImpedeFac(ixOriginal) - vectorDiffuseTrial(ixPerturb) = scalardPsi_dTheta * vectorHydCondTrial(ixPerturb) - case(mixdform) - scalarVolFracLiqTrial = volFracLiq(vectorMatricHeadTrial(ixPerturb),vGn_alpha(ixPerturb),theta_res(ixPerturb),theta_sat(ixPerturb),vGn_n(ixPerturb),vGn_m(ixPerturb)) - scalarHydCondMicro = hydCond_psi(vectorMatricHeadTrial(ixPerturb),mLayerSatHydCond(ixOriginal),vGn_alpha(ixPerturb),vGn_n(ixPerturb),vGn_m(ixPerturb)) * iceImpedeFac(ixOriginal) - scalarHydCondMacro = hydCondMP_liq(scalarVolFracLiqTrial,theta_sat(ixPerturb),theta_mp(ixPerturb),mpExp,mLayerSatHydCondMP(ixOriginal),mLayerSatHydCond(ixOriginal)) - vectorHydCondTrial(ixPerturb) = scalarHydCondMicro + scalarHydCondMacro - case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return - end select ! (form of Richards' equation) + end associate + end subroutine update_transpiration_loss_fraction + + subroutine finalize_transpiration_loss_fraction + ! **** Finalize operations for the fraction of transpiration loss from each soil layer ***** + associate(& + err => out_soilLiqFlx % err, & ! intent(out): error code + message => out_soilLiqFlx % cmessage & ! intent(out): error message + &) + ! check fractions sum to one + if (abs(sum(mLayerTranspireFrac) - 1._rkind) > verySmaller) then + message=trim(message)//'fraction transpiration in soil layers does not sum to one'; err=20; return_flag=.true.; return end if - - ! ===== - ! compute vertical flux at layer interface and its derivative w.r.t. the state above and the state below... - ! ========================================================================================================= - - ! NOTE: computing flux at the bottom of the layer - - call iLayerFlux(& - ! input: model control - desireAnal, & ! intent(in): flag indicating if derivatives are desired - ixRichards, & ! intent(in): index defining the form of Richards' equation (moisture or mixdform) - ! input: state variables (adjacent layers) - vectorMatricHeadTrial, & ! intent(in): matric head at the soil nodes (m) - vectorVolFracLiqTrial, & ! intent(in): volumetric liquid water content at the soil nodes (-) - ! input: model coordinate variables (adjacent layers) - mLayerHeight(iLayer:iLayer+1), & ! intent(in): height of the soil nodes (m) - ! input: temperature derivatives - dPsiLiq_dTemp(iLayer:iLayer+1), & ! intent(in): derivative in liquid water matric potential w.r.t. temperature (m K-1) - dHydCond_dTemp(iLayer:iLayer+1), & ! intent(in): derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) - ! input: transmittance (adjacent layers) - vectorHydCondTrial, & ! intent(in): hydraulic conductivity at the soil nodes (m s-1) - vectorDiffuseTrial, & ! intent(in): hydraulic diffusivity at the soil nodes (m2 s-1) - ! input: transmittance derivatives (adjacent layers) - dHydCond_dVolLiq(iLayer:iLayer+1), & ! intent(in): change in hydraulic conductivity w.r.t. change in volumetric liquid water content (m s-1) - dDiffuse_dVolLiq(iLayer:iLayer+1), & ! intent(in): change in hydraulic diffusivity w.r.t. change in volumetric liquid water content (m2 s-1) - dHydCond_dMatric(iLayer:iLayer+1), & ! intent(in): change in hydraulic conductivity w.r.t. change in matric head (s-1) - ! output: tranmsmittance at the layer interface (scalars) - iLayerHydCond(iLayer), & ! intent(out): hydraulic conductivity at the interface between layers (m s-1) - iLayerDiffuse(iLayer), & ! intent(out): hydraulic diffusivity at the interface between layers (m2 s-1) - ! output: vertical flux at the layer interface (scalars) - iLayerLiqFluxSoil(iLayer), & ! intent(out): vertical flux of liquid water at the layer interface (m s-1) - ! output: derivatives in fluxes w.r.t. state variables -- matric head or volumetric lquid water -- in the layer above and layer below (m s-1 or s-1) - dq_dHydStateAbove(iLayer), & ! intent(out): derivatives in the flux w.r.t. matric head or volumetric lquid water in the layer above (m s-1 or s-1) - dq_dHydStateBelow(iLayer), & ! intent(out): derivatives in the flux w.r.t. matric head or volumetric lquid water in the layer below (m s-1 or s-1) - ! output: derivatives in fluxes w.r.t. energy state variables -- now just temperature -- in the layer above and layer below (m s-1 K-1) - dq_dNrgStateAbove(iLayer), & ! intent(out): derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) - dq_dNrgStateBelow(iLayer), & ! intent(out): derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) - ! output: error control - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if - - ! compute total vertical flux, to compute derivatives - if(deriv_desired .and. ixDerivMethod==numerical)then - select case(itry) - case(unperturbed); scalarFlux = iLayerLiqFluxSoil(iLayer) - case(perturbStateAbove); scalarFlux_dStateAbove = iLayerLiqFluxSoil(iLayer) - case(perturbStateBelow); scalarFlux_dStateBelow = iLayerLiqFluxSoil(iLayer) - case default; err=10; message=trim(message)//"unknown perturbation"; return - end select + end associate + end subroutine finalize_transpiration_loss_fraction + + subroutine update_transpiration_loss + ! **** Update transpiration loss from each soil layer (kg m-2 s-1 --> m s-1)***** + associate(& + scalarCanopyTranspiration => in_soilLiqFlx % scalarCanopyTranspiration, & ! canopy transpiration (kg m-2 s-1) + mLayerTranspire => io_soilLiqFlx % mLayerTranspire, & ! transpiration loss from each soil layer (m s-1) + ! intent(inout): derivatives in the soil layer transpiration flux ... + mLayerdTrans_dCanWat => io_soilLiqFlx % mLayerdTrans_dCanWat, & ! ... w.r.t. canopy total water + mLayerdTrans_dTCanair => io_soilLiqFlx % mLayerdTrans_dTCanair, & ! ... w.r.t. canopy air temperature + mLayerdTrans_dTCanopy => io_soilLiqFlx % mLayerdTrans_dTCanopy, & ! ... w.r.t. canopy temperature + mLayerdTrans_dTGround => io_soilLiqFlx % mLayerdTrans_dTGround, & ! ... w.r.t. ground temperature + ! intent(in): derivative in canopy transpiration ... + dCanopyTrans_dCanWat => in_soilLiqFlx % dCanopyTrans_dCanWat, & ! ... w.r.t. canopy total water content (s-1) + dCanopyTrans_dTCanair => in_soilLiqFlx % dCanopyTrans_dTCanair, & ! ... w.r.t. canopy air temperature (kg m-2 s-1 K-1) + dCanopyTrans_dTCanopy => in_soilLiqFlx % dCanopyTrans_dTCanopy, & ! ... w.r.t. canopy temperature (kg m-2 s-1 K-1) + dCanopyTrans_dTGround => in_soilLiqFlx % dCanopyTrans_dTGround, & ! ... w.r.t. ground temperature (kg m-2 s-1 K-1) + ! intent(in): index of the upper boundary conditions for soil hydrology + ixBcUpperSoilHydrology => model_decisions(iLookDECISIONS%bcUpprSoiH)%iDecision & + &) + if (ixBcUpperSoilHydrology==prescribedHead) then ! special case of prescribed head -- no transpiration + mLayerTranspire(:) = 0._rkind + ! derivatives in transpiration w.r.t. canopy state variables + mLayerdTrans_dCanWat(:) = 0._rkind + mLayerdTrans_dTCanair(:)= 0._rkind + mLayerdTrans_dTCanopy(:)= 0._rkind + mLayerdTrans_dTGround(:)= 0._rkind + else + mLayerTranspire(:) = mLayerTranspireFrac(:)*scalarCanopyTranspiration/iden_water + ! * derivatives in transpiration w.r.t. canopy state variables * + mLayerdTrans_dCanWat(:) = mLayerTranspireFrac(:)*dCanopyTrans_dCanWat /iden_water + mLayerdTrans_dTCanair(:) = mLayerTranspireFrac(:)*dCanopyTrans_dTCanair/iden_water + mLayerdTrans_dTCanopy(:) = mLayerTranspireFrac(:)*dCanopyTrans_dTCanopy/iden_water + mLayerdTrans_dTGround(:) = mLayerTranspireFrac(:)*dCanopyTrans_dTGround/iden_water end if + end associate + end subroutine update_transpiration_loss + + subroutine compute_diagnostic_variables + ! **** compute diagnostic variables at the nodes throughout the soil profile **** + type(in_type_diagv_node) :: in_diagv_node ! input data object for diagv_node + type(out_type_diagv_node) :: out_diagv_node ! output data object for diagv_node + + do iSoil=ixTop,min(ixBot+1,nSoil) ! loop through soil layers + + call initialize_compute_diagnostic_variables(in_diagv_node) + + call update_compute_diagnostic_variables(in_diagv_node,out_diagv_node) + + call finalize_compute_diagnostic_variables(out_diagv_node); if (return_flag) return + + end do + end subroutine compute_diagnostic_variables + + subroutine initialize_compute_diagnostic_variables(in_diagv_node) + ! **** Initialize operations for the compute_diagnostic_variables subroutine **** + type(in_type_diagv_node),intent(out) :: in_diagv_node ! input data object for diagv_node + ! interface local name space to input data object for diagv_node + call in_diagv_node % initialize(iSoil,in_soilLiqFlx,model_decisions,diag_data,mpar_data,flux_data) + end subroutine initialize_compute_diagnostic_variables + + subroutine update_compute_diagnostic_variables(in_diagv_node,out_diagv_node) + ! **** Update operations for the compute_diagnostic_variables subroutine **** + type(in_type_diagv_node) ,intent(in) :: in_diagv_node ! input data object for diagv_node + type(out_type_diagv_node),intent(out) :: out_diagv_node ! output data object for diagv_node + ! compute diagnostic variables + call diagv_node(in_diagv_node,out_diagv_node) + end subroutine update_compute_diagnostic_variables + + subroutine finalize_compute_diagnostic_variables(out_diagv_node) + ! **** Finalize operations for the compute_diagnostic_variables subroutine **** + type(out_type_diagv_node),intent(in) :: out_diagv_node ! output data object for diagv_node + ! interface output data object for diagv_node to local name space + associate(& + err => out_soilLiqFlx % err, & ! error code + message => out_soilLiqFlx % cmessage & ! error message + &) + call out_diagv_node % finalize(iSoil,nSoil,io_soilLiqFlx,mLayerDiffuse,iceImpedeFac,& + &dHydCond_dVolLiq,dDiffuse_dVolLiq,dHydCond_dTemp,err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if + end associate + end subroutine finalize_compute_diagnostic_variables + + subroutine compute_surface_infiltration + ! **** compute infiltration at the surface and its derivative w.r.t. mass in the upper soil layer **** + type(in_type_surfaceFlx) :: in_surfaceFlx + type(io_type_surfaceFlx) :: io_surfaceFlx + type(out_type_surfaceFlx) :: out_surfaceFlx + + call initialize_compute_surface_infiltration(in_surfaceFlx,io_surfaceFlx) + + call update_compute_surface_infiltration(in_surfaceFlx,io_surfaceFlx,out_surfaceFlx) + + call finalize_compute_surface_infiltration(io_surfaceFlx,out_surfaceFlx); if (return_flag) return + + end subroutine compute_surface_infiltration + + subroutine initialize_compute_surface_infiltration(in_surfaceFlx,io_surfaceFlx) + ! **** Initialize operations for compute_surface_infiltration **** + type(in_type_surfaceFlx),intent(out) :: in_surfaceFlx + type(io_type_surfaceFlx),intent(out) :: io_surfaceFlx + ! set derivative w.r.t. state above to zero (does not exist) + associate(& + ! intent(inout): flux derivatives ... + dq_dHydStateAbove => io_soilLiqFlx % dq_dHydStateAbove,& ! ... in layer interfaces w.r.t. state variables in the layer above + dq_dNrgStateAbove => io_soilLiqFlx % dq_dNrgStateAbove & ! ... w.r.t. temperature in the layer above (m s-1 K-1) + &) + dq_dHydStateAbove(0) = 0._rkind + dq_dNrgStateAbove(0) = 0._rkind + end associate - end do ! (looping through different flux calculations -- one or multiple calls depending if desire for numerical or analytical derivatives) + ! compute surface flux and its derivative... + call in_surfaceFlx % initialize(nRoots,ixIce,nSoil,ibeg,iend,in_soilLiqFlx,io_soilLiqFlx,& + &model_decisions,prog_data,mpar_data,flux_data,diag_data,& + &iLayerHeight,dHydCond_dTemp,iceImpedeFac) + call io_surfaceFlx % initialize(nSoil,io_soilLiqFlx,iLayerHydCond,iLayerDiffuse) + end subroutine initialize_compute_surface_infiltration + + subroutine update_compute_surface_infiltration(in_surfaceFlx,io_surfaceFlx,out_surfaceFlx) + ! **** Update operations for compute_surface_infiltration **** + type(in_type_surfaceFlx) ,intent(in) :: in_surfaceFlx + type(io_type_surfaceFlx) ,intent(inout) :: io_surfaceFlx + type(out_type_surfaceFlx),intent(out) :: out_surfaceFlx + call surfaceFlx(io_soilLiqFlx,in_surfaceFlx,io_surfaceFlx,out_surfaceFlx) + end subroutine update_compute_surface_infiltration + + subroutine finalize_compute_surface_infiltration(io_surfaceFlx,out_surfaceFlx) + ! **** Finalize operations for compute_surface_infiltration **** + type(io_type_surfaceFlx) ,intent(in) :: io_surfaceFlx + type(out_type_surfaceFlx),intent(in) :: out_surfaceFlx + + ! interface object data components with local name space + call io_surfaceFlx % finalize(nSoil,io_soilLiqFlx,iLayerHydCond,iLayerDiffuse) + associate(& + err => out_soilLiqFlx % err, & ! error code + message => out_soilLiqFlx % cmessage & ! error message + &) + call out_surfaceFlx % finalize(io_soilLiqFlx,err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if + end associate - ! compute numerical derivatives - if(deriv_desired .and. ixDerivMethod==numerical)then - dq_dHydStateAbove(iLayer) = (scalarFlux_dStateAbove - scalarFlux)/dx ! change in drainage flux w.r.t. change in the state in the layer below (m s-1 or s-1) - dq_dHydStateBelow(iLayer) = (scalarFlux_dStateBelow - scalarFlux)/dx ! change in drainage flux w.r.t. change in the state in the layer below (m s-1 or s-1) - end if + ! include base soil evaporation as the upper boundary flux + associate(& + iLayerLiqFluxSoil => io_soilLiqFlx % iLayerLiqFluxSoil, & ! liquid flux at soil layer interfaces (m s-1) + scalarGroundEvaporation => in_soilLiqFlx % scalarGroundEvaporation,& ! ground evaporation (kg m-2 s-1) + scalarSurfaceInfiltration => io_soilLiqFlx % scalarInfiltration, & ! surface infiltration rate (m s-1) + dq_dHydStateBelow => io_soilLiqFlx % dq_dHydStateBelow, & ! derivative in the flux in layer interfaces w.r.t. state variables in the layer below + dq_dNrgStateBelow => io_soilLiqFlx % dq_dNrgStateBelow & ! derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) + &) + iLayerLiqFluxSoil(0) = scalarGroundEvaporation/iden_water + scalarSurfaceInfiltration + + dq_dHydStateBelow(0) = 0._rkind ! contribution will be in dq_dHydStateLayerSurfVec(1) + dq_dNrgStateBelow(0) = 0._rkind ! contribution will be in dq_dNrgStateLayerSurfVec(1) + end associate + end subroutine finalize_compute_surface_infiltration + + subroutine compute_interface_fluxes_derivatives + ! **** compute fluxes and derivatives at layer interfaces **** + type(in_type_iLayerFlux) :: in_iLayerFlux ! input data object for iLayerFlux + type(out_type_iLayerFlux) :: out_iLayerFlux ! output data object for iLayerFlux + + ! computing flux at the bottom of the layer + do iLayer=ixTop,min(ixBot,nSoil-1) + + call initialize_compute_interface_fluxes_derivatives(in_iLayerFlux) + + call update_compute_interface_fluxes_derivatives(in_iLayerFlux,out_iLayerFlux) + + call finalize_compute_interface_fluxes_derivatives(out_iLayerFlux); if (return_flag) return + + end do + end subroutine compute_interface_fluxes_derivatives + + subroutine initialize_compute_interface_fluxes_derivatives(in_iLayerFlux) + ! **** Initialize operations for compute_interface_fluxes_derivatives subroutine **** + type(in_type_iLayerFlux),intent(out) :: in_iLayerFlux ! input data object for iLayerFlux + ! interface local name space to iLayerFlux input object + call in_iLayerFlux % initialize(iLayer,nSoil,ibeg,iend,in_soilLiqFlx,io_soilLiqFlx,model_decisions,& + &prog_data,mLayerDiffuse,dHydCond_dTemp,dHydCond_dVolLiq,dDiffuse_dVolLiq) + end subroutine initialize_compute_interface_fluxes_derivatives + + subroutine update_compute_interface_fluxes_derivatives(in_iLayerFlux,out_iLayerFlux) + ! **** Update operations for compute_interface_fluxes_derivatives subroutine **** + type(in_type_iLayerFlux) ,intent(in) :: in_iLayerFlux ! input data object for iLayerFlux + type(out_type_iLayerFlux),intent(out) :: out_iLayerFlux ! output data object for iLayerFlux + ! compute fluxes at layer interface + call iLayerFlux(in_iLayerFlux,out_iLayerFlux) + end subroutine update_compute_interface_fluxes_derivatives + + subroutine finalize_compute_interface_fluxes_derivatives(out_iLayerFlux) + ! **** Finalize operations for compute_interface_fluxes_derivatives subroutine + type(out_type_iLayerFlux),intent(in) :: out_iLayerFlux ! output data object for iLayerFlux + ! interface iLayerFlux output object to local name space + associate(& + err => out_soilLiqFlx % err, & ! error code + message => out_soilLiqFlx % cmessage & ! error message + &) + call out_iLayerFlux % finalize(iLayer,nSoil,io_soilLiqFlx,iLayerHydCond,iLayerDiffuse,err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if + end associate + end subroutine finalize_compute_interface_fluxes_derivatives + + subroutine compute_drainage_flux + ! **** Compute the drainage flux from the bottom of the soil profile and its derivative **** + type(in_type_qDrainFlux) :: in_qDrainFlux + type(out_type_qDrainFlux) :: out_qDrainFlux + + call initialize_compute_drainage_flux(in_qDrainFlux) + + call update_compute_drainage_flux(in_qDrainFlux,out_qDrainFlux) + + call finalize_compute_drainage_flux(out_qDrainFlux); if (return_flag) return + + end subroutine compute_drainage_flux + + subroutine initialize_compute_drainage_flux(in_qDrainFlux) + ! **** Initialize operations for compute_drainage_flux **** + type(in_type_qDrainFlux),intent(out) :: in_qDrainFlux + call in_qDrainFlux % initialize(nSoil,ibeg,iend,in_soilLiqFlx,io_soilLiqFlx,model_decisions,& + &prog_data,mpar_data,flux_data,diag_data,iceImpedeFac,& + &dHydCond_dVolLiq,dHydCond_dTemp) + end subroutine initialize_compute_drainage_flux + + subroutine update_compute_drainage_flux(in_qDrainFlux,out_qDrainFlux) + ! **** Update operations for compute_drainage_flux **** + type(in_type_qDrainFlux) ,intent(in) :: in_qDrainFlux + type(out_type_qDrainFlux),intent(out) :: out_qDrainFlux + call qDrainFlux(in_qDrainFlux,out_qDrainFlux) + end subroutine update_compute_drainage_flux + + subroutine finalize_compute_drainage_flux(out_qDrainFlux) + ! **** finalize operations for compute_drainage_flux **** + type(out_type_qDrainFlux),intent(in) :: out_qDrainFlux + associate(& + err => out_soilLiqFlx % err, & ! error code + message => out_soilLiqFlx % cmessage & ! error message + &) + call out_qDrainFlux % finalize(nSoil,io_soilLiqFlx,iLayerHydCond,iLayerDiffuse,err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if + end associate - ! check - !if(iLayer==6) write(*,'(a,i4,1x,10(e25.15,1x))') 'iLayer, vectorMatricHeadTrial, iLayerHydCond(iLayer), iLayerLiqFluxSoil(iLayer) = ',& - ! iLayer, vectorMatricHeadTrial, iLayerHydCond(iLayer), iLayerLiqFluxSoil(iLayer) - !if(iLayer==1) write(*,'(a,i4,1x,L1,1x,2(e15.5,1x))') 'iLayer, (ixDerivMethod==numerical), dq_dHydStateBelow(iLayer-1), dq_dHydStateAbove(iLayer) = ', & - ! iLayer, (ixDerivMethod==numerical), dq_dHydStateBelow(iLayer-1), dq_dHydStateAbove(iLayer) - !pause - - end do ! (looping through soil layers) - - ! add infiltration to the upper-most unfrozen layer - ! NOTE: this is done here rather than in surface runoff - !iLayerLiqFluxSoil(ixIce) = iLayerLiqFluxSoil(ixIce) + scalarSurfaceInfiltration - - ! ************************************************************************************************************************************************* - ! ************************************************************************************************************************************************* - - ! ------------------------------------------------------------------------------------------------------------------------------------------------- - ! * compute drainage flux from the bottom of the soil profile, and its derivative - ! ------------------------------------------------------------------------------------------------------------------------------------------------- - - ! define the need to compute drainage - if( .not. (scalarSolution .and. ixTop io_soilLiqFlx % dq_dHydStateBelow,& ! ... hydrology state variables in the layer below + dq_dNrgStateBelow => io_soilLiqFlx % dq_dNrgStateBelow & ! ... temperature in the layer below (m s-1 K-1) + &) + dq_dHydStateBelow(nSoil) = 0._rkind ! keep this here in case we want to couple some day.... + dq_dNrgStateBelow(nSoil) = 0._rkind ! keep this here in case we want to couple some day.... + end associate + end subroutine finalize_compute_drainage_flux +end subroutine soilLiqFlx + +! *************************************************************************************************************** +! private subroutine diagv_node: compute transmittance and derivatives for model nodes +! *************************************************************************************************************** +subroutine diagv_node(in_diagv_node,out_diagv_node) + USE soil_utils_module,only:iceImpede ! compute the ice impedence factor + USE soil_utils_module,only:volFracLiq ! compute volumetric fraction of liquid water as a function of matric head + USE soil_utils_module,only:matricHead ! compute matric head (m) + USE soil_utils_module,only:hydCond_psi ! compute hydraulic conductivity as a function of matric head + USE soil_utils_module,only:hydCond_liq ! compute hydraulic conductivity as a function of volumetric liquid water content + USE soil_utils_module,only:hydCondMP_liq ! compute hydraulic conductivity of macropores as a function of volumetric liquid water content + USE soil_utils_module,only:dTheta_dPsi ! compute derivative of the soil moisture characteristic w.r.t. psi (m-1) + USE soil_utils_module,only:dPsi_dTheta ! compute derivative of the soil moisture characteristic w.r.t. theta (m) + USE soil_utils_module,only:dPsi_dTheta2 ! compute derivative in dPsi_dTheta (m) + USE soil_utils_module,only:dHydCond_dLiq ! compute derivative in hydraulic conductivity w.r.t. volumetric liquid water content (m s-1) + USE soil_utils_module,only:dHydCond_dPsi ! compute derivative in hydraulic conductivity w.r.t. matric head (s-1) + USE soil_utils_module,only:dIceImpede_dTemp ! compute the derivative in the ice impedance factor w.r.t. temperature (K-1) + ! compute hydraulic transmittance and derivatives for all layers + implicit none + ! input: model control, variables, derivatives, and parameters + type(in_type_diagv_node), intent(in) :: in_diagv_node + ! output: characteristic derivatives, transmittance variables, and error control + type(out_type_diagv_node), intent(out) :: out_diagv_node + ! local variables + real(rkind) :: localVolFracLiq ! local volumetric fraction of liquid water + real(rkind) :: scalarHydCondMP ! hydraulic conductivity of macropores at layer mid-points (m s-1) + real(rkind) :: dIceImpede_dT ! derivative in ice impedance factor w.r.t. temperature (K-1) + real(rkind) :: dHydCondMacro_dVolLiq ! derivative in hydraulic conductivity of macropores w.r.t volumetric liquid water content (m s-1) + real(rkind) :: dHydCondMacro_dMatric ! derivative in hydraulic conductivity of macropores w.r.t matric head (s-1) + real(rkind) :: dHydCondMicro_dMatric ! derivative in hydraulic conductivity of micropores w.r.t matric head (s-1) + real(rkind) :: dHydCondMicro_dTemp ! derivative in hydraulic conductivity of micropores w.r.t temperature (m s-1 K-1) + real(rkind) :: dPsi_dTheta2a ! derivative in dPsi_dTheta (analytical) + real(rkind) :: dIceImpede_dLiq ! derivative in ice impedence factor w.r.t. volumetric liquid water content (-) + real(rkind) :: hydCond_noIce ! hydraulic conductivity in the absence of ice (m s-1) + real(rkind) :: dK_dLiq__noIce ! derivative in hydraulic conductivity w.r.t volumetric liquid water content, in the absence of ice (m s-1) + real(rkind) :: dK_dPsi__noIce ! derivative in hydraulic conductivity w.r.t matric head, in the absence of ice (s-1) + real(rkind) :: relSatMP ! relative saturation of macropores (-) + logical(lgt) :: return_flag ! flag for return statements + + call initialize_diagv_node + + call update_diagv_node; if (return_flag) return + + call finalize_diagv_node; if (return_flag) return - ! (use un-perturbed value) - case default - scalarHydCondTrial = mLayerHydCond(nSoil) ! hydraulic conductivity at the mid-point of the lowest unsaturated soil layer (m s-1) - - end select ! (re-computing hydraulic conductivity) - - ! ===== - ! compute drainage flux and its derivative... - ! =========================================== - - call qDrainFlux(& - ! input: model control - desireAnal, & ! intent(in): flag indicating if derivatives are desired - ixRichards, & ! intent(in): index defining the form of Richards' equation (moisture or mixdform) - ixBcLowerSoilHydrology, & ! intent(in): index defining the type of boundary conditions - ! input: state variables - scalarMatricHeadTrial, & ! intent(in): matric head in the lowest unsaturated node (m) - scalarVolFracLiqTrial, & ! intent(in): volumetric liquid water content the lowest unsaturated node (-) - ! input: model coordinate variables - mLayerDepth(nSoil), & ! intent(in): depth of the lowest unsaturated soil layer (m) - mLayerHeight(nSoil), & ! intent(in): height of the lowest unsaturated soil node (m) - ! input: boundary conditions - lowerBoundHead, & ! intent(in): lower boundary condition (m) - lowerBoundTheta, & ! intent(in): lower boundary condition (-) - ! input: derivative in the soil water characteristic - mLayerdPsi_dTheta(nSoil), & ! intent(in): derivative in the soil water characteristic - ! input: transmittance - iLayerSatHydCond(0), & ! intent(in): saturated hydraulic conductivity at the surface (m s-1) - iLayerSatHydCond(nSoil), & ! intent(in): saturated hydraulic conductivity at the bottom of the unsaturated zone (m s-1) - scalarHydCondTrial, & ! intent(in): hydraulic conductivity at the node itself (m s-1) - iceImpedeFac(nSoil), & ! intent(in): ice impedence factor in the lower-most soil layer (-) - ! input: transmittance derivatives - dHydCond_dVolLiq(nSoil), & ! intent(in): derivative in hydraulic conductivity w.r.t. volumetric liquid water content (m s-1) - dHydCond_dMatric(nSoil), & ! intent(in): derivative in hydraulic conductivity w.r.t. matric head (s-1) - dHydCond_dTemp(nSoil), & ! intent(in): derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) - ! input: soil parameters - vGn_alpha(nSoil), & ! intent(in): van Genutchen "alpha" parameter (m-1) - vGn_n(nSoil), & ! intent(in): van Genutchen "n" parameter (-) - VGn_m(nSoil), & ! intent(in): van Genutchen "m" parameter (-) - theta_sat(nSoil), & ! intent(in): soil porosity (-) - theta_res(nSoil), & ! intent(in): soil residual volumetric water content (-) - kAnisotropic, & ! intent(in): anisotropy factor for lateral hydraulic conductivity (-) - zScale_TOPMODEL, & ! intent(in): TOPMODEL scaling factor (m) - ! output: hydraulic conductivity and diffusivity at the surface - iLayerHydCond(nSoil), & ! intent(out): hydraulic conductivity at the bottom of the unsatuarted zone (m s-1) - iLayerDiffuse(nSoil), & ! intent(out): hydraulic diffusivity at the bottom of the unsatuarted zone (m2 s-1) - ! output: drainage flux - iLayerLiqFluxSoil(nSoil), & ! intent(out): drainage flux (m s-1) - ! output: derivatives in drainage flux - dq_dHydStateAbove(nSoil), & ! intent(out): change in drainage flux w.r.t. change in hydrology state in lowest unsaturated node (m s-1 or s-1) - dq_dNrgStateAbove(nSoil), & ! intent(out): change in drainage flux w.r.t. change in energy state in lowest unsaturated node (m s-1 or s-1) - ! output: error control - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if - - ! get copies of drainage flux to compute derivatives - if(deriv_desired .and. ixDerivMethod==numerical)then - select case(itry) - case(unperturbed); scalarFlux = iLayerLiqFluxSoil(nSoil) - case(perturbStateAbove); scalarFlux_dStateAbove = iLayerLiqFluxSoil(nSoil) - case(perturbStateBelow); err=20; message=trim(message)//'lower state should never be perturbed when computing drainage do not expect to get here'; return - case default; err=10; message=trim(message)//"unknown perturbation"; return - end select - end if +contains - end do ! (looping through different flux calculations -- one or multiple calls depending if desire for numerical or analytical derivatives) + subroutine initialize_diagv_node + ! **** Initialize operations for diagv_node **** + ! initialize error control + return_flag=.false. + associate(& + err => out_diagv_node % err , & ! error code + message => out_diagv_node % message & ! error message + &) + err=0; message="diagv_node/" + end associate + end subroutine initialize_diagv_node + + subroutine update_diagv_node + ! **** Update operations for diagv_node **** + + call update_diagv_node_characteristic_derivatives; if (return_flag) return + + call update_diagv_node_hydraulic_conductivity; if (return_flag) return + + end subroutine update_diagv_node + + subroutine update_diagv_node_characteristic_derivatives + ! **** Update operations for diagv_node: compute characteristic derivatives **** + ! compute the derivative in the soil water characteristic + associate(& + ! input: model control + ixRichards => in_diagv_node % ixRichards, & ! index defining the option for Richards' equation (moisture or mixdform) + ! input: state and diagnostic variables + scalarMatricHeadLiqTrial => in_diagv_node % scalarMatricHeadLiqTrial, & ! liquid matric head in each layer (m) + scalarVolFracLiqTrial => in_diagv_node % scalarVolFracLiqTrial , & ! volumetric fraction of liquid water in a given layer (-) + ! input: soil parameters + vGn_alpha => in_diagv_node % vGn_alpha, & ! van Genuchten "alpha" parameter (m-1) + vGn_n => in_diagv_node % vGn_n , & ! van Genuchten "n" parameter (-) + vGn_m => in_diagv_node % vGn_m , & ! van Genuchten "m" parameter (-) + mpExp => in_diagv_node % mpExp , & ! empirical exponent in macropore flow equation (-) + theta_sat => in_diagv_node % theta_sat, & ! soil porosity (-) + theta_res => in_diagv_node % theta_res, & ! soil residual volumetric water content (-) + ! output: derivative in the soil water characteristic + scalardPsi_dTheta => out_diagv_node % scalardPsi_dTheta, & ! derivative in the soil water characteristic + scalardTheta_dPsi => out_diagv_node % scalardTheta_dPsi, & ! derivative in the soil water characteristic + ! output: error control + err => out_diagv_node % err , & ! error code + message => out_diagv_node % message & ! error message + &) - ! compute numerical derivatives - ! NOTE: drainage derivatives w.r.t. state below are *actually* w.r.t. water table depth, so need to be corrected for aquifer storage - ! (note also negative sign to account for inverse relationship between water table depth and aquifer storage) - if(deriv_desired .and. ixDerivMethod==numerical)then - dq_dHydStateAbove(nSoil) = (scalarFlux_dStateAbove - scalarFlux)/dx ! change in drainage flux w.r.t. change in state in lowest unsaturated node (m s-1 or s-1) - end if + select case(ixRichards) + case(moisture) + scalardPsi_dTheta = dPsi_dTheta(scalarVolFracLiqTrial,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) + scalardTheta_dPsi = realMissing ! deliberately cause problems if this is ever used + case(mixdform) + scalardTheta_dPsi = dTheta_dPsi(scalarMatricHeadLiqTrial,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) + scalardPsi_dTheta = dPsi_dTheta(scalarVolFracLiqTrial,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) + case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return_flag=.true.; return + end select + + end associate + end subroutine update_diagv_node_characteristic_derivatives + + subroutine update_diagv_node_hydraulic_conductivity + ! **** Update operations for diagv_node: compute hydraulic conductivity and derivatives **** + ! compute hydraulic conductivity and its derivative in each soil layer + associate(& + scalarVolFracIceTrial => in_diagv_node % scalarVolFracIceTrial, & ! volumetric fraction of ice in a given layer (-) + f_impede => in_diagv_node % f_impede, & ! ice impedence factor (-) + iceImpedeFac => out_diagv_node % iceImpedeFac & ! ice impedence factor in each layer (-) + &) + ! compute the ice impedence factor and its derivative w.r.t. volumetric liquid water content (-) + call iceImpede(scalarVolFracIceTrial,f_impede, & ! input + iceImpedeFac,dIceImpede_dLiq) ! output + end associate + + associate(& + ! input: model control + ixRichards => in_diagv_node % ixRichards , & ! index defining the option for Richards' equation (moisture or mixdform) + ! output: error control + err => out_diagv_node % err , & ! error code + message => out_diagv_node % message & ! error message + &) + select case(ixRichards) + case(moisture) ! moisture-based form of Richards' equation + call update_diagv_node_hydraulic_conductivity_moisture_form; if (return_flag) return + case(mixdform) ! mixed form of Richards' equation -- just compute hydraulic condictivity + call update_diagv_node_hydraulic_conductivity_mixed_form; if (return_flag) return + case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return_flag=.true.; return + end select + end associate + end subroutine update_diagv_node_hydraulic_conductivity + + subroutine update_diagv_node_hydraulic_conductivity_moisture_form + ! **** Update operations for diagv_node: compute hydraulic conductivity and derivatives for moisture form of Richards' equation **** + + ! validation + associate(& + ! output: error control + err => out_diagv_node % err , & ! error code + message => out_diagv_node % message & ! error message + &) + ! haven't included macropores yet -- return with error for now + err=20; message=trim(message)//'still need to include macropores for the moisture-based form of Richards eqn' + return_flag=.true.; return + end associate + + ! computation + associate(& + ! input: state and diagnostic variables + scalarVolFracLiqTrial => in_diagv_node % scalarVolFracLiqTrial , & ! volumetric fraction of liquid water in a given layer (-) + scalarVolFracIceTrial => in_diagv_node % scalarVolFracIceTrial , & ! volumetric fraction of ice in a given layer (-) + ! input: soil parameters + vGn_alpha => in_diagv_node % vGn_alpha, & ! van Genuchten "alpha" parameter (m-1) + vGn_n => in_diagv_node % vGn_n , & ! van Genuchten "n" parameter (-) + vGn_m => in_diagv_node % vGn_m , & ! van Genuchten "m" parameter (-) + theta_sat => in_diagv_node % theta_sat, & ! soil porosity (-) + theta_res => in_diagv_node % theta_res, & ! soil residual volumetric water content (-) + ! input: saturated hydraulic conductivity ... + scalarSatHydCond => in_diagv_node % scalarSatHydCond, & ! ... at the mid-point of a given layer (m s-1) + ! output: derivative in the soil water characteristic + scalardPsi_dTheta => out_diagv_node % scalardPsi_dTheta, & ! derivative in the soil water characteristic + ! output: transmittance + scalarHydCond => out_diagv_node % scalarHydCond, & ! hydraulic conductivity at layer mid-points (m s-1) + scalarDiffuse => out_diagv_node % scalarDiffuse, & ! diffusivity at layer mid-points (m2 s-1) + iceImpedeFac => out_diagv_node % iceImpedeFac , & ! ice impedence factor in each layer (-) + ! output: transmittance derivatives in ... + dHydCond_dVolLiq => out_diagv_node % dHydCond_dVolLiq, & ! ... hydraulic conductivity w.r.t volumetric liquid water content (m s-1) + dDiffuse_dVolLiq => out_diagv_node % dDiffuse_dVolLiq, & ! ... hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) + dHydCond_dMatric => out_diagv_node % dHydCond_dMatric & ! ... hydraulic conductivity w.r.t matric head (s-1) + &) - ! no dependence on the aquifer for drainage - dq_dHydStateBelow(nSoil) = 0._rkind ! keep this here in case we want to couple some day.... - dq_dNrgStateBelow(nSoil) = 0._rkind ! keep this here in case we want to couple some day.... - - ! print drainage - !print*, 'iLayerLiqFluxSoil(nSoil) = ', iLayerLiqFluxSoil(nSoil) - - endif ! if computing drainage - ! end of drainage section - - ! ***************************************************************************************************************************************************************** - ! ***************************************************************************************************************************************************************** - - ! end association between local variables and the information in the data structures - end associate - - end subroutine soilLiqFlx - - ! *************************************************************************************************************** - ! private subroutine diagv_node: compute transmittance and derivatives for model nodes - ! *************************************************************************************************************** - subroutine diagv_node(& - ! input: model control - deriv_desired, & ! intent(in): flag indicating if derivatives are desired - ixRichards, & ! intent(in): index defining the option for Richards' equation (moisture or mixdform) - ! input: state variables - scalarTempTrial, & ! intent(in): temperature (K) - scalarMatricHeadTrial, & ! intent(in): matric head in a given layer (m) - scalarVolFracLiqTrial, & ! intent(in): volumetric liquid water content in a given soil layer (-) - scalarVolFracIceTrial, & ! intent(in): volumetric ice content in a given soil layer (-) - ! input: pre-computed deriavatives - dTheta_dTk, & ! intent(in): derivative in volumetric liquid water content w.r.t. temperature (K-1) - dPsiLiq_dTemp, & ! intent(in): derivative in liquid water matric potential w.r.t. temperature (m K-1) - ! input: soil parameters - vGn_alpha, & ! intent(in): van Genutchen "alpha" parameter (m-1) - vGn_n, & ! intent(in): van Genutchen "n" parameter (-) - VGn_m, & ! intent(in): van Genutchen "m" parameter (-) - mpExp, & ! intent(in): empirical exponent in macropore flow equation (-) - theta_sat, & ! intent(in): soil porosity (-) - theta_res, & ! intent(in): soil residual volumetric water content (-) - theta_mp, & ! intent(in): volumetric liquid water content when macropore flow begins (-) - f_impede, & ! intent(in): ice impedence factor (-) - ! input: saturated hydraulic conductivity - scalarSatHydCond, & ! intent(in): saturated hydraulic conductivity at the mid-point of a given layer (m s-1) - scalarSatHydCondMP, & ! intent(in): saturated hydraulic conductivity of macropores at the mid-point of a given layer (m s-1) - ! output: derivative in the soil water characteristic - scalardPsi_dTheta, & ! derivative in the soil water characteristic - scalardTheta_dPsi, & ! derivative in the soil water characteristic - ! output: transmittance - scalarHydCond, & ! intent(out): hydraulic conductivity at layer mid-points (m s-1) - scalarDiffuse, & ! intent(out): diffusivity at layer mid-points (m2 s-1) - iceImpedeFac, & ! intent(out): ice impedence factor in each layer (-) - ! output: transmittance derivatives - dHydCond_dVolLiq, & ! intent(out): derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) - dDiffuse_dVolLiq, & ! intent(out): derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) - dHydCond_dMatric, & ! intent(out): derivative in hydraulic conductivity w.r.t matric head (m s-1) - dHydCond_dTemp, & ! intent(out): derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) - ! output: error control - err,message) ! intent(out): error control - USE soil_utils_module,only:iceImpede ! compute the ice impedence factor - USE soil_utils_module,only:volFracLiq ! compute volumetric fraction of liquid water as a function of matric head - USE soil_utils_module,only:matricHead ! compute matric head (m) - USE soil_utils_module,only:hydCond_psi ! compute hydraulic conductivity as a function of matric head - USE soil_utils_module,only:hydCond_liq ! compute hydraulic conductivity as a function of volumetric liquid water content - USE soil_utils_module,only:hydCondMP_liq ! compute hydraulic conductivity of macropores as a function of volumetric liquid water content - USE soil_utils_module,only:dTheta_dPsi ! compute derivative of the soil moisture characteristic w.r.t. psi (m-1) - USE soil_utils_module,only:dPsi_dTheta ! compute derivative of the soil moisture characteristic w.r.t. theta (m) - USE soil_utils_module,only:dPsi_dTheta2 ! compute derivative in dPsi_dTheta (m) - USE soil_utils_module,only:dHydCond_dLiq ! compute derivative in hydraulic conductivity w.r.t. volumetric liquid water content (m s-1) - USE soil_utils_module,only:dHydCond_dPsi ! compute derivative in hydraulic conductivity w.r.t. matric head (s-1) - USE soil_utils_module,only:dIceImpede_dTemp ! compute the derivative in the ice impedance factor w.r.t. temperature (K-1) - ! compute hydraulic transmittance and derivatives for all layers - implicit none - ! input: model control - logical(lgt),intent(in) :: deriv_desired ! flag indicating if derivatives are desired - integer(i4b),intent(in) :: ixRichards ! index defining the option for Richards' equation (moisture or mixdform) - ! input: state and diagnostic variables - real(rkind),intent(in) :: scalarTempTrial ! temperature in each layer (K) - real(rkind),intent(in) :: scalarMatricHeadTrial ! matric head in each layer (m) - real(rkind),intent(in) :: scalarVolFracLiqTrial ! volumetric fraction of liquid water in a given layer (-) - real(rkind),intent(in) :: scalarVolFracIceTrial ! volumetric fraction of ice in a given layer (-) - ! input: pre-computed deriavatives - real(rkind),intent(in) :: dTheta_dTk ! derivative in volumetric liquid water content w.r.t. temperature (K-1) - real(rkind),intent(in) :: dPsiLiq_dTemp ! derivative in liquid water matric potential w.r.t. temperature (m K-1) - ! input: soil parameters - real(rkind),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) - real(rkind),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) - real(rkind),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) - real(rkind),intent(in) :: mpExp ! empirical exponent in macropore flow equation (-) - real(rkind),intent(in) :: theta_sat ! soil porosity (-) - real(rkind),intent(in) :: theta_res ! soil residual volumetric water content (-) - real(rkind),intent(in) :: theta_mp ! volumetric liquid water content when macropore flow begins (-) - real(rkind),intent(in) :: f_impede ! ice impedence factor (-) - ! input: saturated hydraulic conductivity - real(rkind),intent(in) :: scalarSatHydCond ! saturated hydraulic conductivity at the mid-point of a given layer (m s-1) - real(rkind),intent(in) :: scalarSatHydCondMP ! saturated hydraulic conductivity of macropores at the mid-point of a given layer (m s-1) - ! output: derivative in the soil water characteristic - real(rkind),intent(out) :: scalardPsi_dTheta ! derivative in the soil water characteristic - real(rkind),intent(out) :: scalardTheta_dPsi ! derivative in the soil water characteristic - ! output: transmittance - real(rkind),intent(out) :: scalarHydCond ! hydraulic conductivity at layer mid-points (m s-1) - real(rkind),intent(out) :: scalarDiffuse ! diffusivity at layer mid-points (m2 s-1) - real(rkind),intent(out) :: iceImpedeFac ! ice impedence factor in each layer (-) - ! output: transmittance derivatives - real(rkind),intent(out) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) - real(rkind),intent(out) :: dDiffuse_dVolLiq ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) - real(rkind),intent(out) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t matric head (s-1) - real(rkind),intent(out) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) - ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! local variables - real(rkind) :: localVolFracLiq ! local volumetric fraction of liquid water - real(rkind) :: scalarHydCondMP ! hydraulic conductivity of macropores at layer mid-points (m s-1) - real(rkind) :: dIceImpede_dT ! derivative in ice impedance factor w.r.t. temperature (K-1) - real(rkind) :: dHydCondMacro_dVolLiq ! derivative in hydraulic conductivity of macropores w.r.t volumetric liquid water content (m s-1) - real(rkind) :: dHydCondMacro_dMatric ! derivative in hydraulic conductivity of macropores w.r.t matric head (s-1) - real(rkind) :: dHydCondMicro_dMatric ! derivative in hydraulic conductivity of micropores w.r.t matric head (s-1) - real(rkind) :: dHydCondMicro_dTemp ! derivative in hydraulic conductivity of micropores w.r.t temperature (m s-1 K-1) - real(rkind) :: dPsi_dTheta2a ! derivative in dPsi_dTheta (analytical) - real(rkind) :: dIceImpede_dLiq ! derivative in ice impedence factor w.r.t. volumetric liquid water content (-) - real(rkind) :: hydCond_noIce ! hydraulic conductivity in the absence of ice (m s-1) - real(rkind) :: dK_dLiq__noIce ! derivative in hydraulic conductivity w.r.t volumetric liquid water content, in the absence of ice (m s-1) - real(rkind) :: dK_dPsi__noIce ! derivative in hydraulic conductivity w.r.t matric head, in the absence of ice (s-1) - real(rkind) :: relSatMP ! relative saturation of macropores (-) - ! local variables to test the derivative - logical(lgt),parameter :: testDeriv=.false. ! local flag to test the derivative - real(rkind) :: xConst ! LH_fus/(gravity*Tfreeze), used in freezing point depression equation (m K-1) - real(rkind) :: vTheta ! volumetric fraction of total water (-) - real(rkind) :: volLiq ! volumetric fraction of liquid water (-) - real(rkind) :: volIce ! volumetric fraction of ice (-) - real(rkind) :: volFracLiq1,volFracLiq2 ! different trial values of volumetric liquid water content (-) - real(rkind) :: effSat ! effective saturation (-) - real(rkind) :: psiLiq ! liquid water matric potential (m) - real(rkind) :: hydCon ! hydraulic conductivity (m s-1) - real(rkind) :: hydIce ! hydraulic conductivity after accounting for ice impedance (-) - real(rkind),parameter :: dx = 1.e-8_rkind ! finite difference increment (m) - ! initialize error control - err=0; message="diagv_node/" - - ! ***** - ! compute the derivative in the soil water characteristic - select case(ixRichards) - case(moisture) - scalardPsi_dTheta = dPsi_dTheta(scalarvolFracLiqTrial,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) - scalardTheta_dPsi = realMissing ! (deliberately cause problems if this is ever used) - case(mixdform) - scalardTheta_dPsi = dTheta_dPsi(scalarMatricHeadTrial,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) - scalardPsi_dTheta = dPsi_dTheta(scalarvolFracLiqTrial,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) - if(testDeriv)then - volFracLiq1 = volFracLiq(scalarMatricHeadTrial, vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) - volFracLiq2 = volFracLiq(scalarMatricHeadTrial+dx,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) - end if ! (testing the derivative) - case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return - end select - - ! ***** - ! compute hydraulic conductivity and its derivative in each soil layer - - ! compute the ice impedence factor and its derivative w.r.t. volumetric liquid water content (-) - call iceImpede(scalarVolFracIceTrial,f_impede, & ! input - iceImpedeFac,dIceImpede_dLiq) ! output - - select case(ixRichards) - ! ***** moisture-based form of Richards' equation - case(moisture) - ! haven't included macropores yet - err=20; message=trim(message)//'still need to include macropores for the moisture-based form of Richards eqn'; return ! compute the hydraulic conductivity (m s-1) and diffusivity (m2 s-1) for a given layer hydCond_noIce = hydCond_liq(scalarVolFracLiqTrial,scalarSatHydCond,theta_res,theta_sat,vGn_m) scalarHydCond = hydCond_noIce*iceImpedeFac scalarDiffuse = scalardPsi_dTheta * scalarHydCond ! compute derivative in hydraulic conductivity (m s-1) and hydraulic diffusivity (m2 s-1) - if(deriv_desired)then - if(scalarVolFracIceTrial > epsilon(iceImpedeFac))then + if (scalarVolFracIceTrial > epsilon(iceImpedeFac)) then dK_dLiq__noIce = dHydCond_dLiq(scalarVolFracLiqTrial,scalarSatHydCond,theta_res,theta_sat,vGn_m,.true.) ! [.true. = analytical] dHydCond_dVolLiq = hydCond_noIce*dIceImpede_dLiq + dK_dLiq__noIce*iceImpedeFac - else + else dHydCond_dVolLiq = dHydCond_dLiq(scalarVolFracLiqTrial,scalarSatHydCond,theta_res,theta_sat,vGn_m,.true.) - end if - dPsi_dTheta2a = dPsi_dTheta2(scalarVolFracLiqTrial,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m,.true.) ! [.true. = analytical] compute derivative in dPsi_dTheta (m) - dDiffuse_dVolLiq = dHydCond_dVolLiq*scalardPsi_dTheta + scalarHydCond*dPsi_dTheta2a - dHydCond_dMatric = realMissing ! not used, so cause problems end if + dPsi_dTheta2a = dPsi_dTheta2(scalarVolFracLiqTrial,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m,.true.) ! [.true. = analytical] compute derivative in dPsi_dTheta (m) + dDiffuse_dVolLiq = dHydCond_dVolLiq*scalardPsi_dTheta + scalarHydCond*dPsi_dTheta2a + dHydCond_dMatric = realMissing ! not used, so cause problems + + end associate + end subroutine update_diagv_node_hydraulic_conductivity_moisture_form + + subroutine update_diagv_node_hydraulic_conductivity_mixed_form + ! **** Update operations for diagv_node: compute hydraulic conductivity and derivatives for mixed form of Richards' equation **** + associate(& + ! input: state and diagnostic variables + scalarMatricHeadLiqTrial => in_diagv_node % scalarMatricHeadLiqTrial, & ! liquid matric head in each layer (m) + scalarVolFracIceTrial => in_diagv_node % scalarVolFracIceTrial , & ! volumetric fraction of ice in a given layer (-) + ! input: pre-computed derivatives + dTheta_dTk => in_diagv_node % dTheta_dTk , & ! derivative in volumetric liquid water content w.r.t. temperature (K-1) + dPsiLiq_dTemp => in_diagv_node % dPsiLiq_dTemp, & ! derivative in liquid water matric potential w.r.t. temperature (m K-1) + ! input: soil parameters + vGn_alpha => in_diagv_node % vGn_alpha, & ! van Genuchten "alpha" parameter (m-1) + vGn_n => in_diagv_node % vGn_n , & ! van Genuchten "n" parameter (-) + vGn_m => in_diagv_node % vGn_m , & ! van Genuchten "m" parameter (-) + mpExp => in_diagv_node % mpExp , & ! empirical exponent in macropore flow equation (-) + theta_sat => in_diagv_node % theta_sat, & ! soil porosity (-) + theta_res => in_diagv_node % theta_res, & ! soil residual volumetric water content (-) + theta_mp => in_diagv_node % theta_mp , & ! volumetric liquid water content when macropore flow begins (-) + f_impede => in_diagv_node % f_impede , & ! ice impedence factor (-) + ! input: saturated hydraulic conductivity ... + scalarSatHydCond => in_diagv_node % scalarSatHydCond, & ! ... at the mid-point of a given layer (m s-1) + scalarSatHydCondMP => in_diagv_node % scalarSatHydCondMP,& ! ... of macropores at the mid-point of a given layer (m s-1) + ! output: derivative in the soil water characteristic + scalardTheta_dPsi => out_diagv_node % scalardTheta_dPsi, & ! derivative in the soil water characteristic + ! output: transmittance + scalarHydCond => out_diagv_node % scalarHydCond, & ! hydraulic conductivity at layer mid-points (m s-1) + scalarDiffuse => out_diagv_node % scalarDiffuse, & ! diffusivity at layer mid-points (m2 s-1) + iceImpedeFac => out_diagv_node % iceImpedeFac , & ! ice impedence factor in each layer (-) + ! output: transmittance derivatives in ... + dHydCond_dVolLiq => out_diagv_node % dHydCond_dVolLiq, & ! ... hydraulic conductivity w.r.t volumetric liquid water content (m s-1) + dDiffuse_dVolLiq => out_diagv_node % dDiffuse_dVolLiq, & ! ... hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) + dHydCond_dMatric => out_diagv_node % dHydCond_dMatric, & ! ... hydraulic conductivity w.r.t matric head (s-1) + dHydCond_dTemp => out_diagv_node % dHydCond_dTemp & ! ... hydraulic conductivity w.r.t temperature (m s-1 K-1) + &) - ! ***** mixed form of Richards' equation -- just compute hydraulic condictivity - case(mixdform) ! compute the hydraulic conductivity (m s-1) and diffusivity (m2 s-1) for a given layer - hydCond_noIce = hydCond_psi(scalarMatricHeadTrial,scalarSatHydCond,vGn_alpha,vGn_n,vGn_m) + hydCond_noIce = hydCond_psi(scalarMatricHeadLiqTrial,scalarSatHydCond,vGn_alpha,vGn_n,vGn_m) scalarDiffuse = realMissing ! not used, so cause problems ! compute the hydraulic conductivity of macropores (m s-1) - localVolFracLiq = volFracLiq(scalarMatricHeadTrial,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) + localVolFracLiq = volFracLiq(scalarMatricHeadLiqTrial,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) scalarHydCondMP = hydCondMP_liq(localVolFracLiq,theta_sat,theta_mp,mpExp,scalarSatHydCondMP,scalarSatHydCond) scalarHydCond = hydCond_noIce*iceImpedeFac + scalarHydCondMP ! compute derivative in hydraulic conductivity (m s-1) - if(deriv_desired)then - ! (compute derivative for macropores) - if(localVolFracLiq > theta_mp)then + ! compute derivative for macropores + if (localVolFracLiq > theta_mp) then relSatMP = (localVolFracLiq - theta_mp)/(theta_sat - theta_mp) dHydCondMacro_dVolLiq = ((scalarSatHydCondMP - scalarSatHydCond)/(theta_sat - theta_mp))*mpExp*(relSatMP**(mpExp - 1._rkind)) dHydCondMacro_dMatric = scalardTheta_dPsi*dHydCondMacro_dVolLiq - else + else dHydCondMacro_dVolLiq = 0._rkind dHydCondMacro_dMatric = 0._rkind - end if - ! (compute derivatives for micropores) - if(scalarVolFracIceTrial > verySmall)then - dK_dPsi__noIce = dHydCond_dPsi(scalarMatricHeadTrial,scalarSatHydCond,vGn_alpha,vGn_n,vGn_m,.true.) ! analytical + end if + ! compute derivatives for micropores + if (scalarVolFracIceTrial > verySmaller) then + dK_dPsi__noIce = dHydCond_dPsi(scalarMatricHeadLiqTrial,scalarSatHydCond,vGn_alpha,vGn_n,vGn_m,.true.) ! analytical dHydCondMicro_dTemp = dPsiLiq_dTemp*dK_dPsi__noIce ! m s-1 K-1 dHydCondMicro_dMatric = hydCond_noIce*dIceImpede_dLiq*scalardTheta_dPsi + dK_dPsi__noIce*iceImpedeFac - else + else dHydCondMicro_dTemp = 0._rkind - dHydCondMicro_dMatric = dHydCond_dPsi(scalarMatricHeadTrial,scalarSatHydCond,vGn_alpha,vGn_n,vGn_m,.true.) - end if - ! (combine derivatives) - dHydCond_dMatric = dHydCondMicro_dMatric + dHydCondMacro_dMatric - - ! (compute analytical derivative for change in ice impedance factor w.r.t. temperature) - call dIceImpede_dTemp(scalarVolFracIceTrial, & ! intent(in): trial value of volumetric ice content (-) - dTheta_dTk, & ! intent(in): derivative in volumetric liquid water content w.r.t. temperature (K-1) - f_impede, & ! intent(in): ice impedance parameter (-) - dIceImpede_dT ) ! intent(out): derivative in ice impedance factor w.r.t. temperature (K-1) - ! (compute derivative in hydraulic conductivity w.r.t. temperature) - dHydCond_dTemp = hydCond_noIce*dIceImpede_dT + dHydCondMicro_dTemp*iceImpedeFac - ! (test derivative) - if(testDeriv)then - xConst = LH_fus/(gravity*Tfreeze) ! m K-1 (NOTE: J = kg m2 s-2) - vTheta = scalarVolFracIceTrial + scalarVolFracLiqTrial - volLiq = volFracLiq(xConst*(scalarTempTrial+dx - Tfreeze),vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) - volIce = vTheta - volLiq - effSat = (volLiq - theta_res)/(theta_sat - volIce - theta_res) - psiLiq = matricHead(effSat,vGn_alpha,0._rkind,1._rkind,vGn_n,vGn_m) ! use effective saturation, so theta_res=0 and theta_sat=1 - hydCon = hydCond_psi(psiLiq,scalarSatHydCond,vGn_alpha,vGn_n,vGn_m) - call iceImpede(volIce,f_impede,iceImpedeFac,dIceImpede_dLiq) - hydIce = hydCon*iceImpedeFac - print*, 'test derivative: ', (psiLiq - scalarMatricHeadTrial)/dx, dPsiLiq_dTemp - print*, 'test derivative: ', (hydCon - hydCond_noIce)/dx, dHydCondMicro_dTemp - print*, 'test derivative: ', (hydIce - scalarHydCond)/dx, dHydCond_dTemp - print*, 'press any key to continue'; read(*,*) ! (alternative to the deprecated 'pause' statement) - end if ! testing the derivative - ! (set values that are not used to missing) - dHydCond_dVolLiq = realMissing ! not used, so cause problems - dDiffuse_dVolLiq = realMissing ! not used, so cause problems + dHydCondMicro_dMatric = dHydCond_dPsi(scalarMatricHeadLiqTrial,scalarSatHydCond,vGn_alpha,vGn_n,vGn_m,.true.) + end if + ! combine derivatives + dHydCond_dMatric = dHydCondMicro_dMatric + dHydCondMacro_dMatric + + ! compute analytical derivative for change in ice impedance factor w.r.t. temperature + call dIceImpede_dTemp(scalarVolFracIceTrial, & ! intent(in): trial value of volumetric ice content (-) + dTheta_dTk, & ! intent(in): derivative in volumetric liquid water content w.r.t. temperature (K-1) + f_impede, & ! intent(in): ice impedance parameter (-) + dIceImpede_dT ) ! intent(out): derivative in ice impedance factor w.r.t. temperature (K-1) + ! compute derivative in hydraulic conductivity w.r.t. temperature + dHydCond_dTemp = hydCond_noIce*dIceImpede_dT + dHydCondMicro_dTemp*iceImpedeFac + ! set values that are not used to missing + dHydCond_dVolLiq = realMissing ! not used, so cause problems + dDiffuse_dVolLiq = realMissing ! not used, so cause problems + + end associate + end subroutine update_diagv_node_hydraulic_conductivity_mixed_form + + subroutine finalize_diagv_node + associate(& + err => out_diagv_node % err , & ! error code + message => out_diagv_node % message & ! error message + &) + ! final error check + if(err/=0)then; message=trim(message)//'unanticipated error in diagv_node'; return_flag=.true.; return; end if + end associate + end subroutine finalize_diagv_node + +end subroutine diagv_node + +! *************************************************************************************************************** +! private subroutine surfaceFlx: compute the surface flux and its derivative +! *************************************************************************************************************** +subroutine surfaceFlx(io_soilLiqFlx,in_surfaceFlx,io_surfaceFlx,out_surfaceFlx) + USE soil_utils_module,only:volFracLiq ! compute volumetric fraction of liquid water as a function of matric head (-) + USE soil_utils_module,only:hydCond_psi ! compute hydraulic conductivity as a function of matric head (m s-1) + USE soil_utils_module,only:hydCond_liq ! compute hydraulic conductivity as a function of volumetric liquid water content (m s-1) + USE soil_utils_module,only:dPsi_dTheta ! compute derivative of the soil moisture characteristic w.r.t. theta (m) + USE soil_utils_module,only:crit_soilT ! compute critical temperature below which ice exists + USE soil_utils_module,only:gammp,gammp_complex ! compute the regularized lower incomplete Gamma function + ! compute infiltraton at the surface and its derivative w.r.t. mass in the upper soil layer + implicit none + ! ----------------------------------------------------------------------------------------------------------------------------- + ! input: use soilLiqFlx object for array dimensions + type(io_type_soilLiqFlx) ,intent(in) :: io_soilLiqFlx ! input-output object for soilLiqFlx + ! input: model control, variables, derivatives, soil layer depth, boundary conditions, fluxes, and transmittance and soil parameters + type(in_type_surfaceFlx) ,intent(in) :: in_surfaceFlx ! input object for surfaceFlx + ! input-output: hydraulic conductivity and diffusivity, and infiltration parameters + type(io_type_surfaceFlx) ,intent(inout) :: io_surfaceFlx ! input object for surfaceFlx + ! output: runoff, infiltration, derivatives, and error control + type(out_type_surfaceFlx),intent(out) :: out_surfaceFlx ! output object for surfaceFlx + ! ----------------------------------------------------------------------------------------------------------------------------- + ! local variables + ! general + integer(i4b) :: iLayer ! index of soil layer + real(rkind) :: Tcrit ! temperature where all water is unfrozen (K) + real(rkind) :: fPart1,fPart2 ! different parts of a function + real(rkind) :: dPart1(1:in_surfaceFlx % nSoil) ! derivatives for different parts of a function + real(rkind) :: dPart2(1:in_surfaceFlx % nSoil) ! derivatives for different parts of a function + real(rkind) :: dfracCap(1:in_surfaceFlx % nSoil) ! derivatives for different parts of a function + real(rkind) :: dfInfRaw(1:in_surfaceFlx % nSoil) ! derivatives for different parts of a function + real(rkind) :: total_soil_depth ! total depth of soil (m) + ! head boundary condition + real(rkind) :: cFlux ! capillary flux (m s-1) + ! simplified Green-Ampt infiltration + real(rkind) :: rootZoneLiq ! depth of liquid water in the root zone (m) + real(rkind) :: rootZoneIce ! depth of ice in the root zone (m) + real(rkind) :: availCapacity ! available storage capacity in the root zone (m) + real(rkind) :: depthWettingFront ! depth to the wetting front (m) + real(rkind) :: hydCondWettingFront ! hydraulic conductivity at the wetting front (m s-1) + ! saturated area associated with variable storage capacity + real(rkind) :: fracCap ! fraction of pore space filled with liquid water and ice (-) + real(rkind) :: fInfRaw ! infiltrating area before imposing solution constraints (-) + real(rkind),parameter :: maxFracCap=0.995_rkind ! maximum fraction capacity -- used to avoid numerical problems associated with an enormous derivative + real(rkind),parameter :: scaleFactor=0.000001_rkind ! scale factor for the smoothing function (-) + real(rkind),parameter :: qSurfScaleMax=1000._rkind ! maximum surface runoff scaling factor (-) + ! fraction of impermeable area associated with frozen ground + real(rkind) :: alpha ! shape parameter in the Gamma distribution + real(rkind) :: xLimg ! upper limit of the integral + ! FUSE + real(rkind),parameter :: alpha_LSE=1.e3_rkind ! smoothness parameter for LSE smoother function + real(rkind),parameter :: roundoff_tolerance = 1.e2_rkind * epsilon(1._rkind) ! tolerance for round-off error is near machine epsilon + real(rkind) :: S1 ! total water content in upper soil layer (m) + real(rkind) :: S1_max ! Maximum storage in the upper layer (m) + ! FUSE PRMS variables + real(rkind) :: phi_tens ! fraction of total storage as tension storage (m) + real(rkind) :: SatArea_max ! maximum saturated area (-) + real(rkind) :: S1_T ! tension water content in upper soil layer (m) + real(rkind) :: S1_T_max ! maximum tension water content in upper soil layer (m) + ! FUSE ARNO/VIC variables + logical(lgt),parameter :: smoother = .true. ! control for optional smoothing in base variable + real(rkind) :: base ! base used in saturated area formula (-) ARNO/VIC + real(rkind) :: b_arnovic ! ARNO/VIC exponent (-) + real(rkind) :: S1_star ! total water content in upper FUSE layer computed with a smoothed min (m) + ! FUSE TOPMODEL variables + real(rkind) :: alpha_topmodel ! gamma shape + real(rkind) :: chi_topmodel ! gamma scale + real(rkind) :: lambda ! mean for alpha_topmodel + real(rkind) :: mu ! offset for alpha_topmodel + real(rkind) :: x_crit ! critical x (random variable) value + real(rkind),parameter :: zeta_upper=1.e3_rkind ! upper limit of integral (approaches infinity, but ~1000 provides an accurate result) + real(rkind) :: zeta_crit ! critical topographic index value (log space) + real(rkind) :: zeta_crit_n ! critical topographic index value (power-transformed) + real(rkind) :: n_topmodel ! TOPMODEL exponent exponent (must be sufficiently large to avoid divergence of lambda_n -- n>=3.5 or so) + complex(rkind) :: lambda_n ! mean of the power-transformed topographic index + ! derivatives + real(rkind) :: dVolFracLiq_dWat(1:in_surfaceFlx % nSoil) ! ... vol fraction of liquid w.r.t. water state variable in root layers + real(rkind) :: dVolFracIce_dWat(1:in_surfaceFlx % nSoil) ! ... vol fraction of ice w.r.t. water state variable in root layers + real(rkind) :: dVolFracLiq_dTk(1:in_surfaceFlx % nSoil) ! ... vol fraction of liquid w.r.t. temperature in root layers + real(rkind) :: dVolFracIce_dTk(1:in_surfaceFlx % nSoil) ! ... vol fraction of ice w.r.t. temperature in root layers + real(rkind) :: dRootZoneLiq_dWat(1:in_surfaceFlx % nSoil) ! ... vol fraction of scalar root zone liquid w.r.t. water state variable in root layers + real(rkind) :: dRootZoneIce_dWat(1:in_surfaceFlx % nSoil) ! ... vol fraction of scalar root zone ice w.r.t. water state variable in root layers + real(rkind) :: dRootZoneLiq_dTk(1:in_surfaceFlx % nSoil) ! ... vol fraction of scalar root zone liquid w.r.t. temperature in root layers + real(rkind) :: dRootZoneIce_dTk(1:in_surfaceFlx % nSoil) ! ... vol fraction of scalar root zone ice w.r.t. temperature in root layers + real(rkind) :: dDepthWettingFront_dWat(1:in_surfaceFlx % nSoil) ! ... scalar depth of wetting front w.r.t. water state variable in root layers + real(rkind) :: dDepthWettingFront_dTk(1:in_surfaceFlx % nSoil) ! ... scalar depth of wetting front w.r.t. temperature in root layers + real(rkind) :: dxMaxInfilRate_dWat(1:in_surfaceFlx % nSoil) ! ... scalar max infiltration rate w.r.t. water state variable in root layers + real(rkind) :: dxMaxInfilRate_dTk(1:in_surfaceFlx % nSoil) ! ... scalar max infiltration rate w.r.t. temperature in root layers + real(rkind) :: dInfilArea_dWat(1:in_surfaceFlx % nSoil) ! ... scalar infiltration rate w.r.t. water state variable in canopy or snow and root layers + real(rkind) :: dInfilArea_dTk(1:in_surfaceFlx % nSoil) ! ... scalar infiltration rate w.r.t. temperature in canopy or snow and root layers + real(rkind) :: dFrozenArea_dWat(1:in_surfaceFlx % nSoil) ! ... scalar frozen area w.r.t. water state variable in canopy or snow and root layers + real(rkind) :: dFrozenArea_dTk(1:in_surfaceFlx % nSoil) ! ... scalar frozen area w.r.t. temperature in canopy or snow and root layers + real(rkind) :: dInfilRate_dWat(1:in_surfaceFlx % nSoil) ! ... scalar infiltration rate w.r.t. water state variable in canopy or snow and root layers + real(rkind) :: dInfilRate_dTk(1:in_surfaceFlx % nSoil) ! ... scalar infiltration rate w.r.t. temperature in canopy or snow and root layers + ! error control + logical(lgt) :: return_flag ! logical flag for return statements + + call initialize_surfaceFlx + + call update_surfaceFlx; if (return_flag) return + + call finalize_surfaceFlx; if (return_flag) return + +contains + + subroutine initialize_surfaceFlx + ! **** Initialize operations for surfaceFlx **** + ! allocate output object array components + out_surfaceFlx % dq_dHydStateVec = io_soilLiqFlx % dq_dHydStateLayerSurfVec + out_surfaceFlx % dq_dNrgStateVec = io_soilLiqFlx % dq_dNrgStateLayerSurfVec + + ! initialize error control + return_flag=.false. + associate(& + err => out_surfaceFlx % err , & ! error code + message => out_surfaceFlx % message & ! error message + &) + err=0; message="surfaceFlx/" + end associate + + ! initialize derivatives + associate(& + ! output: derivatives in surface infiltration w.r.t. ... + dq_dHydStateVec => out_surfaceFlx % dq_dHydStateVec , & ! ... hydrology state in above soil snow or canopy and every soil layer (m s-1 or s-1) + dq_dNrgStateVec => out_surfaceFlx % dq_dNrgStateVec & ! ... energy state in above soil snow or canopy and every soil layer (m s-1 K-1) + &) + dVolFracLiq_dWat(:) = 0._rkind + dVolFracIce_dWat(:) = 0._rkind + dVolFracLiq_dTk(:) = 0._rkind + dVolFracIce_dTk(:) = 0._rkind + dInfilArea_dWat(:) = 0._rkind + dInfilArea_dTk(:) = 0._rkind + dInfilRate_dWat(:) = 0._rkind + dInfilRate_dTk(:) = 0._rkind + dxMaxInfilRate_dWat(:) = 0._rkind + dxMaxInfilRate_dTk(:) = 0._rkind + dFrozenArea_dWat(:) = 0._rkind + dFrozenArea_dTk(:) = 0._rkind + dq_dHydStateVec(:) = 0._rkind + dq_dNrgStateVec(:) = 0._rkind ! energy state variable is temperature (transformed outside soilLiqFlx_module if needed) + end associate + + ! initialize runoff and infiltration values + associate(& + scalarSurfaceRunoff => out_surfaceFlx % scalarSurfaceRunoff , & ! surface runoff (m s-1) + scalarSurfaceRunoff_IE => out_surfaceFlx % scalarSurfaceRunoff_IE , & ! infiltration excess surface runoff (m s-1) + scalarSurfaceRunoff_SE => out_surfaceFlx % scalarSurfaceRunoff_SE , & ! saturation excess surface runoff (m s-1) + scalarSurfaceInfiltration => out_surfaceFlx % scalarSurfaceInfiltration & ! surface infiltration (m s-1) + &) + scalarSurfaceRunoff = 0._rkind + scalarSurfaceRunoff_IE = 0._rkind + scalarSurfaceRunoff_SE = 0._rkind + scalarSurfaceInfiltration = 0._rkind + end associate + + end subroutine initialize_surfaceFlx + + subroutine update_surfaceFlx + ! **** Update operations for surfaceFlx **** + associate(& + ! input: model control + firstSplitOper => in_surfaceFlx % firstSplitOper, & ! flag indicating if desire to compute infiltration + bc_upper => in_surfaceFlx % bc_upper, & ! index defining the type of boundary conditions + ixInfRateMax => in_surfaceFlx % ixInfRateMax, & ! index defining the maximum infiltration rate method + surfRun_SE => in_surfaceFlx % surfRun_SE, & ! index defining the saturation excess surface runoff method + ! input to compute infiltration + scalarRainPlusMelt => in_surfaceFlx % scalarRainPlusMelt, & ! rain plus melt (m s-1) + ! output: infiltration area and saturated area + scalarInfilArea => io_surfaceFlx % scalarInfilArea, & ! fraction of area where water can infiltrate, may be frozen (-) + scalarSaturatedArea => io_surfaceFlx % scalarSaturatedArea, & ! saturated area fraction (-) + ! output: runoff and infiltration + scalarSurfaceRunoff_SE => out_surfaceFlx % scalarSurfaceRunoff_SE, & ! saturation excess surface runoff (m s-1) + scalarSurfaceRunoff => out_surfaceFlx % scalarSurfaceRunoff, & ! surface runoff (m s-1) + ! output: derivatives in surface infiltration w.r.t. ... + dq_dHydStateVec => out_surfaceFlx % dq_dHydStateVec, & ! ... hydrology state in above soil snow or canopy and every soil layer (m s-1 or s-1) + dq_dNrgStateVec => out_surfaceFlx % dq_dNrgStateVec, & ! ... energy state in above soil snow or canopy and every soil layer (m s-1 K-1) + ! output: error control + err => out_surfaceFlx % err , & ! error code + message => out_surfaceFlx % message & ! error message + &) + + ! compute the surface flux and its derivative + if (firstSplitOper .or. updateInfil) then + select case(bc_upper) + case(prescribedHead) ! head condition, no frozen area and all area infiltrates + call update_surfaceFlx_prescribedHead; if (return_flag) return + + case(liquidFlux) ! flux condition + ! compute volumetric fraction of liquid and ice water in each soil layer and their derivatives + if(updateInfil) call update_volFracLiq_derivatives; if (return_flag) return + + ! Get infiltration area not considering frozen area, based on SE method + select case(surfRun_SE) ! saturation excess surface runoff method, sets infiltration area (not considering frozen) and its derivatives + case(zero_SE) ! zero saturation excess surface runoff, all area infiltrates if not frozen + io_surfaceFlx % scalarInfilArea = 1._rkind + case(homegrown_SE) ! homegrown saturation excess surface runoff (original SUMMA method) + call update_surfaceFlx_homegrown_infilArea; if (return_flag) return + case(FUSEPRMS) ! FUSE PRMS surface runoff + call update_surfaceFlx_FUSE_PRMS_infilArea; if (return_flag) return + case(FUSEAVIC) ! FUSE ARNO/VIC surface runoff + call update_surfaceFlx_FUSE_ARNO_VIC_infilArea; if (return_flag) return + case(FUSETOPM) ! FUSE TOPMODEL surface runoff + call update_surfaceFlx_FUSE_TOPMODEL_infilArea; if (return_flag) return + case default; err=20; message=trim(message)//'unknown saturation excess surface runoff method'; return_flag=.true.; return + end select + + ! compute saturated area and saturation excess surface runoff + if (scalarInfilArea < 0._rkind) then; err=20; message=trim(message)//'infiltration area less than zero'; return_flag=.true.; return; end if + scalarSaturatedArea = 1._rkind - scalarInfilArea + scalarSurfaceRunoff_SE = scalarRainPlusMelt * scalarSaturatedArea + + ! Calculate maximum infiltration rate and scalarFrozenArea (and their derivatives if needed) + select case(ixInfRateMax) ! maximum infiltration rate method (controls infiltration excess surface runoff) + case(noInfiltrationExcess) ! zero infiltration excess surface runoff + call update_surfaceFlx_liquidFlux_noinfratemax + case(GreenAmpt, topmodel_GA) ! infiltration excess runoff possible + call update_surfaceFlx_liquidFlux_calculate_infratemax; if (return_flag) return + case default; err=20; message=trim(message)//'unknown infiltration excess surface runoff method'; return_flag=.true.; return + end select + + ! Compute total infiltration, gets infiltration excess surface runoff, modifies saturation excess surface runoff if more rain than can infiltrate + call update_surfaceFlx_liquidFlux_infiltration; if (return_flag) return + + ! update the derivatives for any combination of SE and IE parametrization options + if(updateInfil) call update_surfaceFlx_liquidFlux_derivatives + + case default; err=20; message=trim(message)//'unknown upper boundary condition for soil hydrology'; return_flag=.true.; return ! end of select of bc_upper + end select + else ! do not compute infiltration after first flux call in a splitting operation unless updateInfil is true + dq_dHydStateVec(:) = realMissing ! not used, so cause problems + dq_dNrgStateVec(:) = realMissing ! not used, so cause problems + end if + + end associate + end subroutine update_surfaceFlx + +subroutine update_volFracLiq_derivatives + ! **** Updates the derivatives for volumetric fraction of liquid and ice water in each soil layer **** + ! local variables + integer(i4b) :: nLayers ! number of soil layers to process + logical(lgt) :: doIce ! flag indicating whether ice derivatives are needed + + associate(& + ! input: model control + ixInfRateMax => in_surfaceFlx % ixInfRateMax , & ! index defining the maximum infiltration rate method + surfRun_SE => in_surfaceFlx % surfRun_SE , & ! index defining the saturation excess surface runoff method + ixRichards => in_surfaceFlx % ixRichards , & ! index defining the option for Richards' equation (moisture or mixdform) + nRoots => in_surfaceFlx % nRoots , & ! number of layers that contain roots + nSoil => in_surfaceFlx % nSoil , & ! total number of soil layers + ! input: state and diagnostic variables + mLayerTemp => in_surfaceFlx % mLayerTemp , & ! temperature (K) + mLayerMatricHead => in_surfaceFlx % mLayerMatricHead , & ! matric head in each soil layer (m) + ! input: pre-computed derivatives in ... + dTheta_dTk => in_surfaceFlx % dTheta_dTk , & ! ... volumetric liquid water content w.r.t. temperature (K-1) + dTheta_dPsi => in_surfaceFlx % dTheta_dPsi , & ! ... the soil water characteristic w.r.t. psi (m-1) + mLayerdPsi_dTheta => in_surfaceFlx % mLayerdPsi_dTheta , & ! ... the soil water characteristic w.r.t. theta (m) + ! output: error control + err => out_surfaceFlx % err , & ! error code + message => out_surfaceFlx % message & ! error message + &) + + ! determine number of layers to process and whether ice derivatives are needed + if (surfRun_SE ==homegrown_SE) then ! need only root zone derivatives but need ice derivatives + nLayers = nRoots + doIce = .true. + else ! might need entire soil column (FUSE methods), might need ice derivatives (infiltration excess method) + if (ixInfRateMax == noInfiltrationExcess) then + if (surfRun_SE ==zero_SE) then ! no derivatives needed + nLayers = 0 + doIce = .false. + else ! FUSE methods do not need ice derivatives + nLayers = nSoil + doIce = .false. + end if + else ! infiltration excess method needs ice derivatives in root zone + if (surfRun_SE == zero_SE) then ! only need root zone derivatives + nLayers = nRoots + doIce = .true. + else ! FUSE methods need soil column derivatives, will compute unused ice derivatives for layers beyond root zone + nLayers = nSoil + doIce = .true. + end if + end if ! (if ixInfRateMax) + end if ! (if homegrown_SE) + + if (nLayers > 0) then + select case(ixRichards) ! form of Richards' equation + case(moisture) + dVolFracLiq_dWat(:) = 1._rkind + dVolFracIce_dWat(:) = mLayerdPsi_dTheta(:) - 1._rkind + case(mixdform) + do iLayer=1,nLayers + Tcrit = crit_soilT( mLayerMatricHead(iLayer) ) + if (mLayerTemp(iLayer) < Tcrit) then + dVolFracLiq_dWat(iLayer) = 0._rkind + if(doIce) dVolFracIce_dWat(iLayer) = dTheta_dPsi(iLayer) + else + dVolFracLiq_dWat(iLayer) = dTheta_dPsi(iLayer) + if(doIce) dVolFracIce_dWat(iLayer) = 0._rkind + end if + end do + case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return_flag=.true.; return + end select + dVolFracLiq_dTk(:) = dTheta_dTk(:) !already zeroed out if not below critical temperature + if(doIce) dVolFracIce_dTk(:) = -dVolFracLiq_dTk(:) !often can and will simplify one of these terms out end if - case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return - - end select - - ! if derivatives are not desired, then set values to missing - if(.not.deriv_desired)then - dHydCond_dVolLiq = realMissing ! not used, so cause problems - dDiffuse_dVolLiq = realMissing ! not used, so cause problems - dHydCond_dMatric = realMissing ! not used, so cause problems - end if - - end subroutine diagv_node - - - ! *************************************************************************************************************** - ! private subroutine surfaceFlx: compute the surface flux and its derivative - ! *************************************************************************************************************** - subroutine surfaceFlx(& - ! input: model control - doInfiltration, & ! intent(in): flag indicating if desire to compute infiltration - deriv_desired, & ! intent(in): flag indicating if derivatives are desired - ixRichards, & ! intent(in): index defining the form of Richards' equation (moisture or mixdform) - bc_upper, & ! intent(in): index defining the type of boundary conditions (neumann or diriclet) - nRoots, & ! intent(in): number of layers that contain roots - ixIce, & ! intent(in): index of lowest ice layer - ! input: state variables - scalarMatricHead, & ! intent(in): matric head in the upper-most soil layer (m) - scalarVolFracLiq, & ! intent(in): volumetric liquid water content in the upper-most soil layer (-) - mLayerVolFracLiq, & ! intent(in): volumetric liquid water content in each soil layer (-) - mLayerVolFracIce, & ! intent(in): volumetric ice content in each soil layer (-) - ! input: depth of upper-most soil layer (m) - mLayerDepth, & ! intent(in): depth of each soil layer (m) - iLayerHeight, & ! intent(in): height at the interface of each layer (m) - ! input: boundary conditions - upperBoundHead, & ! intent(in): upper boundary condition (m) - upperBoundTheta, & ! intent(in): upper boundary condition (-) - ! input: flux at the upper boundary - scalarRainPlusMelt, & ! intent(in): rain plus melt (m s-1) - ! input: transmittance - surfaceSatHydCond, & ! intent(in): saturated hydraulic conductivity at the surface (m s-1) - dHydCond_dTemp, & ! intent(in): derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) - iceImpedeFac, & ! intent(in): ice impedence factor in the upper-most soil layer (-) - ! input: soil parameters - vGn_alpha, & ! intent(in): van Genutchen "alpha" parameter (m-1) - vGn_n, & ! intent(in): van Genutchen "n" parameter (-) - VGn_m, & ! intent(in): van Genutchen "m" parameter (-) - theta_sat, & ! intent(in): soil porosity (-) - theta_res, & ! intent(in): soil residual volumetric water content (-) - qSurfScale, & ! intent(in): scaling factor in the surface runoff parameterization (-) - zScale_TOPMODEL, & ! intent(in): scaling factor used to describe decrease in hydraulic conductivity with depth (m) - rootingDepth, & ! intent(in): rooting depth (m) - wettingFrontSuction, & ! intent(in): Green-Ampt wetting front suction (m) - soilIceScale, & ! intent(in): soil ice scaling factor in Gamma distribution used to define frozen area (m) - soilIceCV, & ! intent(in): soil ice CV in Gamma distribution used to define frozen area (-) - ! input-output: hydraulic conductivity and diffusivity at the surface - surfaceHydCond, & ! intent(inout): hydraulic conductivity at the surface (m s-1) - surfaceDiffuse, & ! intent(inout): hydraulic diffusivity at the surface (m2 s-1) - ! input-output: fluxes at layer interfaces and surface runoff - xMaxInfilRate, & ! intent(inout): maximum infiltration rate (m s-1) - scalarInfilArea, & ! intent(inout): fraction of unfrozen area where water can infiltrate (-) - scalarFrozenArea, & ! intent(inout): fraction of area that is considered impermeable due to soil ice (-) - scalarSurfaceRunoff, & ! intent(out): surface runoff (m s-1) - scalarSurfaceInfiltration, & ! intent(out): surface infiltration (m s-1) - ! input-output: deriavtives in surface infiltration w.r.t. volumetric liquid water (m s-1) and matric head (s-1) in the upper-most soil layer - dq_dHydState, & ! intent(inout): derivative in surface infiltration w.r.t. state variable in the upper-most soil layer (m s-1 or s-1) - dq_dNrgState, & ! intent(out): derivative in surface infiltration w.r.t. energy state variable in the upper-most soil layer (m s-1 K-1) - ! output: error control - err,message) ! intent(out): error control - USE soil_utils_module,only:volFracLiq ! compute volumetric fraction of liquid water as a function of matric head (-) - USE soil_utils_module,only:hydCond_psi ! compute hydraulic conductivity as a function of matric head (m s-1) - USE soil_utils_module,only:hydCond_liq ! compute hydraulic conductivity as a function of volumetric liquid water content (m s-1) - USE soil_utils_module,only:dPsi_dTheta ! compute derivative of the soil moisture characteristic w.r.t. theta (m) - USE soil_utils_module,only:gammp ! compute the cumulative probabilty based on the Gamma distribution - ! compute infiltraton at the surface and its derivative w.r.t. mass in the upper soil layer - implicit none - ! ----------------------------------------------------------------------------------------------------------------------------- - ! input: model control - logical(lgt),intent(in) :: doInfiltration ! flag indicating if desire to compute infiltration - logical(lgt),intent(in) :: deriv_desired ! flag to indicate if derivatives are desired - integer(i4b),intent(in) :: bc_upper ! index defining the type of boundary conditions - integer(i4b),intent(in) :: ixRichards ! index defining the option for Richards' equation (moisture or mixdform) - integer(i4b),intent(in) :: nRoots ! number of layers that contain roots - integer(i4b),intent(in) :: ixIce ! index of lowest ice layer - ! input: state and diagnostic variables - real(rkind),intent(in) :: scalarMatricHead ! matric head in the upper-most soil layer (m) - real(rkind),intent(in) :: scalarVolFracLiq ! volumetric liquid water content in the upper-most soil layer (-) - real(rkind),intent(in) :: mLayerVolFracLiq(:) ! volumetric liquid water content in each soil layer (-) - real(rkind),intent(in) :: mLayerVolFracIce(:) ! volumetric ice content in each soil layer (-) - ! input: depth of upper-most soil layer (m) - real(rkind),intent(in) :: mLayerDepth(:) ! depth of upper-most soil layer (m) - real(rkind),intent(in) :: iLayerHeight(0:) ! height at the interface of each layer (m) - ! input: diriclet boundary conditions - real(rkind),intent(in) :: upperBoundHead ! upper boundary condition for matric head (m) - real(rkind),intent(in) :: upperBoundTheta ! upper boundary condition for volumetric liquid water content (-) - ! input: flux at the upper boundary - real(rkind),intent(in) :: scalarRainPlusMelt ! rain plus melt, used as input to the soil zone before computing surface runoff (m s-1) - ! input: transmittance - real(rkind),intent(in) :: surfaceSatHydCond ! saturated hydraulic conductivity at the surface (m s-1) - real(rkind),intent(in) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) - real(rkind),intent(in) :: iceImpedeFac ! ice impedence factor in the upper-most soil layer (-) - ! input: soil parameters - real(rkind),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) - real(rkind),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) - real(rkind),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) - real(rkind),intent(in) :: theta_sat ! soil porosity (-) - real(rkind),intent(in) :: theta_res ! soil residual volumetric water content (-) - real(rkind),intent(in) :: qSurfScale ! scaling factor in the surface runoff parameterization (-) - real(rkind),intent(in) :: zScale_TOPMODEL ! scaling factor used to describe decrease in hydraulic conductivity with depth (m) - real(rkind),intent(in) :: rootingDepth ! rooting depth (m) - real(rkind),intent(in) :: wettingFrontSuction ! Green-Ampt wetting front suction (m) - real(rkind),intent(in) :: soilIceScale ! soil ice scaling factor in Gamma distribution used to define frozen area (m) - real(rkind),intent(in) :: soilIceCV ! soil ice CV in Gamma distribution used to define frozen area (-) - ! ----------------------------------------------------------------------------------------------------------------------------- - ! input-output: hydraulic conductivity and diffusivity at the surface - ! NOTE: intent(inout) because infiltration may only be computed for the first iteration - real(rkind),intent(inout) :: surfaceHydCond ! hydraulic conductivity (m s-1) - real(rkind),intent(inout) :: surfaceDiffuse ! hydraulic diffusivity at the surface (m - ! output: surface runoff and infiltration flux (m s-1) - real(rkind),intent(inout) :: xMaxInfilRate ! maximum infiltration rate (m s-1) - real(rkind),intent(inout) :: scalarInfilArea ! fraction of unfrozen area where water can infiltrate (-) - real(rkind),intent(inout) :: scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) - real(rkind),intent(out) :: scalarSurfaceRunoff ! surface runoff (m s-1) - real(rkind),intent(out) :: scalarSurfaceInfiltration ! surface infiltration (m s-1) - ! output: deriavtives in surface infiltration w.r.t. volumetric liquid water (m s-1) and matric head (s-1) in the upper-most soil layer - real(rkind),intent(out) :: dq_dHydState ! derivative in surface infiltration w.r.t. state variable in the upper-most soil layer (m s-1 or s-1) - real(rkind),intent(out) :: dq_dNrgState ! derivative in surface infiltration w.r.t. energy state variable in the upper-most soil layer (m s-1 K-1) - ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! ----------------------------------------------------------------------------------------------------------------------------- - ! local variables - ! (general) - integer(i4b) :: iLayer ! index of soil layer - ! (head boundary condition) - real(rkind) :: cFlux ! capillary flux (m s-1) - real(rkind) :: dNum ! numerical derivative - ! (simplified Green-Ampt infiltration) - real(rkind) :: rootZoneLiq ! depth of liquid water in the root zone (m) - real(rkind) :: rootZoneIce ! depth of ice in the root zone (m) - real(rkind) :: availCapacity ! available storage capacity in the root zone (m) - real(rkind) :: depthWettingFront ! depth to the wetting front (m) - real(rkind) :: hydCondWettingFront ! hydraulic conductivity at the wetting front (m s-1) - ! (saturated area associated with variable storage capacity) - real(rkind) :: fracCap ! fraction of pore space filled with liquid water and ice (-) - real(rkind) :: fInfRaw ! infiltrating area before imposing solution constraints (-) - real(rkind),parameter :: maxFracCap=0.995_rkind ! maximum fraction capacity -- used to avoid numerical problems associated with an enormous derivative - real(rkind),parameter :: scaleFactor=0.000001_rkind ! scale factor for the smoothing function (-) - real(rkind),parameter :: qSurfScaleMax=1000._rkind ! maximum surface runoff scaling factor (-) - ! (fraction of impermeable area associated with frozen ground) - real(rkind) :: alpha ! shape parameter in the Gamma distribution - real(rkind) :: xLimg ! upper limit of the integral - ! initialize error control - err=0; message="surfaceFlx/" - - ! compute derivative in the energy state - ! NOTE: revisit the need to do this - dq_dNrgState = 0._rkind - - ! ***** - ! compute the surface flux and its derivative - select case(bc_upper) - - ! ***** - ! head condition - case(prescribedHead) + end associate + end subroutine update_volFracLiq_derivatives + + subroutine update_surfaceFlx_liquidFlux_derivatives + ! **** Updates the derivatives for the liquid flux upper hydrology boundary condition if needed **** + associate(& + ! input: flux at the upper boundary + scalarRainPlusMelt => in_surfaceFlx % scalarRainPlusMelt , & ! rain plus melt, used as input to the soil zone before computing surface runoff (m s-1) + ! input: surface runoff and infiltration flux (m s-1) + xMaxInfilRate => io_surfaceFlx % xMaxInfilRate , & ! maximum infiltration rate (m s-1) + scalarInfilArea => io_surfaceFlx % scalarInfilArea , & ! fraction of area where water can infiltrate, may be frozen (-) + scalarFrozenArea => io_surfaceFlx % scalarFrozenArea , & ! fraction of area that is considered impermeable due to soil ice (-) + ! output: derivatives in surface infiltration w.r.t. ... + dq_dHydStateVec => out_surfaceFlx % dq_dHydStateVec, & ! ... hydrology state in above soil snow or canopy and every soil layer (m s-1 or s-1) + dq_dNrgStateVec => out_surfaceFlx % dq_dNrgStateVec, & ! ... energy state in above soil snow or canopy and every soil layer (m s-1 K-1) + ! output: error control + err => out_surfaceFlx % err , & ! error code + message => out_surfaceFlx % message & ! error message + &) + + ! Compute total runoff derivatives, do w.r.t. infiltration only, scalarRainPlusMelt accounted for in computJacob* module + ! Do not need to break into IE and SE components since they are never used separately in the Jacobian assembly + dq_dHydStateVec(:) = (1._rkind - scalarFrozenArea)& + * ( dInfilArea_dWat(:)*min(scalarRainPlusMelt,xMaxInfilRate) + scalarInfilArea*dInfilRate_dWat(:) )& + + (-dFrozenArea_dWat(:))*scalarInfilArea*min(scalarRainPlusMelt,xMaxInfilRate) + ! energy state variable is temperature (transformed outside soilLiqFlx_module if needed) + dq_dNrgStateVec(:) = (1._rkind - scalarFrozenArea)& + * ( dInfilArea_dTk(:) *min(scalarRainPlusMelt,xMaxInfilRate) + scalarInfilArea*dInfilRate_dTk(:) )& + + (-dFrozenArea_dTk(:)) *scalarInfilArea*min(scalarRainPlusMelt,xMaxInfilRate) + + end associate + end subroutine update_surfaceFlx_liquidFlux_derivatives + + subroutine update_surfaceFlx_FUSE_PRMS_infilArea + ! **** Update operations for surfaceFlx: surface runoff from Clark et al. (2008, doi:10.1029/2007WR006735) -- PRMS **** + use soil_utils_module,only:LogSumExp ! smooth max/min + use soil_utils_module,only:SoftArgMax ! smooth arg max/min (for derivatives of LogSumExp) + + ! local variables + real(rkind) :: dS1_dLiq(1:in_surfaceFlx % nSoil) ! derivative of S1 w.r.t. liquid water content + real(rkind) :: S1_T_derivatives(1:2) ! array of derivatives for S1_T + real(rkind) :: dS1_T_dS1 ! derivative of S1_T w.r.t S1 + real(rkind) :: dS1_T_dLiq(1:in_surfaceFlx % nSoil) ! derivative of S1_T w.r.t liquid water content + + associate(& + nSoil => in_surfaceFlx % nSoil, & ! number of soil layers + mLayerVolFracLiq => in_surfaceFlx % mLayerVolFracLiq, & ! volumetric liquid water content in each soil layer (-) + mLayerDepth => in_surfaceFlx % mLayerDepth, & ! depth of soil layers (m) + iLayerHeight => in_surfaceFlx % iLayerHeight, & ! height at the interface of each layer for soil layers only (m) + theta_sat => in_surfaceFlx % theta_sat, & ! soil porosity (-) + ! output: error control + err => out_surfaceFlx % err , & ! error code + message => out_surfaceFlx % message & ! error message + &) + + ! validation of parameters + SatArea_max = in_surfaceFlx % FUSE_Ac_max + phi_tens = in_surfaceFlx % FUSE_phi_tens + ! validate input parameters + if ((SatArea_max<0._rkind).or.(SatArea_max>1._rkind)) then + err=10; message=trim(message)//"FUSE PRMS surface runoff error: invalid SatArea_max (max saturated area) value"; return_flag=.true.; return + end if + if ((phi_tens<0._rkind).or.(phi_tens>1._rkind)) then + err=10; message=trim(message)//"FUSE PRMS surface runoff error: invalid phi_tens (tension storage fraction) value"; return_flag=.true.; return + end if + + ! compute water content in upper FUSE layer + S1 = sum( mLayerDepth(:) * mLayerVolFracLiq(:) ) ! total water content in upper FUSE layer (m) + if (S1 <= 0._rkind) then; io_surfaceFlx % scalarInfilArea = 1._rkind; return; end if ! if no water, unsaturated and all area infiltrates + S1_max = iLayerHeight(nSoil) * theta_sat ! max water storage for upper FUSE layer (m) + + ! compute tension water content + S1_T_max = phi_tens * S1_max + S1_T = LogSumExp(-alpha_LSE,[S1,S1_T_max],err) ! smooth approximation to S1_T=min(S1,S1_T_max) + if(err/=0)then; err=10; message=trim(message)//"FUSE PRMS surface runoff: error in LogSumExp"; return_flag=.true.; return; end if + if (S1_T < 0._rkind) then ! check for errors + err=10; message=trim(message)//"FUSE PRMS surface runoff: S1_T is negative (may need to adjust magnitude of alpha_LSE)"; return_flag=.true.; return + end if + + ! define the infiltrating area and derivatives for the non-frozen part of the cell/basin + io_surfaceFlx % scalarInfilArea = 1._rkind - (S1_T/S1_T_max)*SatArea_max + ! define the derivatives + if(updateInfil)then + dS1_dLiq = mLayerDepth(:) + S1_T_derivatives = SoftArgMax(-alpha_LSE,[S1,S1_T_max]) + dS1_T_dS1 = S1_T_derivatives(1) + dS1_T_dLiq = dS1_T_dS1 * dS1_dLiq(:) + dInfilArea_dWat(:) = -(dS1_T_dLiq(:)/S1_T_max)*SatArea_max * dVolFracLiq_dWat(:) + dInfilArea_dTk(:) = -(dS1_T_dLiq(:)/S1_T_max)*SatArea_max * dVolFracLiq_dTk(:) + endif ! else derivatives are zero + end associate + + end subroutine update_surfaceFlx_FUSE_PRMS_infilArea + + subroutine update_surfaceFlx_FUSE_ARNO_VIC_infilArea + ! **** Update operations for surfaceFlx: surface runoff from Clark et al. (2008, doi:10.1029/2007WR006735) -- ARNO/VIC **** + use soil_utils_module,only:LogSumExp ! smooth max/min + use soil_utils_module,only:SoftArgMax ! smooth arg max/min (for derivatives of LogSumExp) + + ! local variables + real(rkind) :: dS1_dLiq(1:in_surfaceFlx % nSoil) ! derivative of S1 w.r.t. liquid water content + real(rkind) :: dS1_star_dS1 ! derivative in S1_star w.r.t S1 + real(rkind) :: dbase_dS1 ! derivative of base w.r.t S1 + real(rkind) :: S1_star_derivatives(1:2) ! array of derivatives for S1_star from SoftArgMax function + + associate(& + nSoil => in_surfaceFlx % nSoil, & ! number of soil layers + mLayerVolFracLiq => in_surfaceFlx % mLayerVolFracLiq, & ! volumetric liquid water content in each soil layer (-) + mLayerDepth => in_surfaceFlx % mLayerDepth, & ! depth of soil layers (m) + iLayerHeight => in_surfaceFlx % iLayerHeight, & ! height at the interface of each layer for soil layers only (m) + theta_sat => in_surfaceFlx % theta_sat, & ! soil porosity (-) + ! output: error control + err => out_surfaceFlx % err , & ! error code + message => out_surfaceFlx % message & ! error message + &) + + ! validation of input parameters + b_arnovic = in_surfaceFlx % FUSE_b ! interface ARNO/VIC exponent + if ((b_arnovic < 0.001_rkind).or.(b_arnovic > 3._rkind)) then + err=10; message=trim(message)//"FUSE ARNO/VIC exponent must be between 0.001 and 3"; return_flag=.true.; return + end if + + ! compute water content in FUSE layers + S1 = sum( mLayerDepth(:) * mLayerVolFracLiq(:) ) ! total water content in FUSE layers (m) + if (S1 <= 0._rkind) then; io_surfaceFlx % scalarInfilArea = 1._rkind; return; end if ! if no water, unsaturated and all area infiltrates + S1_max = iLayerHeight(nSoil) * theta_sat ! max water storage for FUSE layers (m) + + ! Original FUSE: SatArea = 1 - (1-S1/S1_max)**b_arnovic + ! Optional: smoothed to prevent negative bases using a smooth approximation of S1_star = min(S1,S1_max) + ! (Smoothed SatArea) = 1 - (1-S1_star/S1_max)**b_arnovic + if (smoother) then ! with smooth approximation of min(S1,S1_max) + S1_star = LogSumExp(-alpha_LSE,[S1,S1_max],err) ! smooth approximation of min(S1,S1_max) to prevent negative bases + if(err/=0)then; err=10; message=trim(message)//"FUSE ARNO/VIC surface runoff: error in LogSumExp"; return_flag=.true.; return; end if + else ! no smoothing + S1_star = S1 + end if + if (S1_star < 0._rkind) then ! check for errors + err=10; message=trim(message)//& + &"FUSE ARNO/VIC surface runoff: S1_star is negative (may need to apply smoothing or increase magnitude of alpha_LSE)";return_flag=.true.; return + end if + + ! compute base value + base = 1._rkind - S1_star/S1_max + + ! validate base value and add tolerance for round-off error + if (base < -roundoff_tolerance) then ! if below zero outside of tolerance + err=10; message=trim(message)//"FUSE ARNO/VIC base value is negative"; return_flag=.true.; return + else if (base < 0._rkind) then ! if below zero within tolerance + base = 0._rkind + end if + + ! define the infiltrating area and derivatives for the non-frozen part of the cell/basin + io_surfaceFlx % scalarInfilArea = base**b_arnovic + + ! define the derivatives + if(updateInfil)then + ! compute derivatives needed for infiltration derivative + dS1_dLiq = mLayerDepth(:) + if (smoother) then ! with smooth approximation of min(S1,S1_max) + S1_star_derivatives = SoftArgMax(-alpha_LSE,[S1,S1_max]) + dS1_star_dS1 = S1_star_derivatives(1) + else ! no smoothing + dS1_star_dS1 = 1._rkind ! S1_star = S1 if no smoothing + end if + dbase_dS1 = -1._rkind/S1_max * dS1_star_dS1 + dInfilArea_dWat(:) = b_arnovic*base**(b_arnovic-1._rkind)*dbase_dS1*dS1_dLiq(:) * dVolFracLiq_dWat(:) + dInfilArea_dTk(:) = b_arnovic*base**(b_arnovic-1._rkind)*dbase_dS1*dS1_dLiq(:) * dVolFracLiq_dTk(:) + endif ! else derivatives are zero + end associate + + end subroutine update_surfaceFlx_FUSE_ARNO_VIC_infilArea + + + subroutine update_surfaceFlx_FUSE_TOPMODEL_infilArea + ! **** Update operations for surfaceFlx: surface runoff from Clark et al. (2008, doi:10.1029/2007WR006735) -- TOPMODEL **** + ! local variables + complex(rkind) :: F1,F2 ! temporary storage for regularized lower incomplete gamma function values + real(rkind) :: dS1_dLiq(1:in_surfaceFlx % nSoil) ! derivative in S1 w.r.t liquid water content + real(rkind) :: dzeta_crit_n_dS1 ! derivative of zeta_crit_n w.r.t S1 + real(rkind) :: dzeta_crit_dzeta_crit_n ! derivative of zeta_crit w.r.t zeta_crit_n + real(rkind) :: dx_crit_dzeta_crit ! derivative of x_crit w.r.t zeta_crit + real(rkind) :: dx_crit_dS1 ! derivative of x_crit w.r.t S1 + real(rkind) :: dgammp_dx_crit ! derivative of gammp function in SatArea w.r.t x_crit + + associate(& + nSoil => in_surfaceFlx % nSoil, & ! number of soil layers + mLayerVolFracLiq => in_surfaceFlx % mLayerVolFracLiq, & ! volumetric liquid water content in each soil layer (-) + mLayerDepth => in_surfaceFlx % mLayerDepth, & ! depth of soil layers (m) + iLayerHeight => in_surfaceFlx % iLayerHeight, & ! height at the interface of each layer for soil layers only (m) + theta_sat => in_surfaceFlx % theta_sat, & ! soil porosity (-) + ! output: error control + err => out_surfaceFlx % err , & ! error code + message => out_surfaceFlx % message & ! error message + &) + + ! interface FUSE input parameters + lambda = in_surfaceFlx % FUSE_lambda + chi_topmodel = in_surfaceFlx % FUSE_chi + mu = in_surfaceFlx % FUSE_mu + n_topmodel = in_surfaceFlx % FUSE_n + + ! compute water content in lower FUSE layer, here the entire soil column is used + S1 = sum( mLayerDepth(:) * mLayerVolFracLiq(:) ) ! total water content in lower FUSE layer (m) + if (S1 <= 0._rkind) then; io_surfaceFlx % scalarInfilArea = 1._rkind; return; end if ! if no water, unsaturated and all area infiltrates + S1_max = iLayerHeight(nSoil) * theta_sat ! max water storage for lower FUSE layer (m) + + ! validate of parameters + if ((lambda < 5._rkind ).or.(lambda > 10._rkind)) then + err=10; message=trim(message)//"FUSE TOPMODEL lambda value must be between 5 and 10"; return_flag=.true.; return + end if + if (lambda <= mu) then + err=10; message=trim(message)//"FUSE TOPMODEL lambda value must be greater than mu value"; return_flag=.true.; return + end if + if ((chi_topmodel < 2._rkind ).or.(chi_topmodel > 5._rkind)) then + err=10; message=trim(message)//"FUSE TOPMODEL chi_topmodel value must be between 2 and 5"; return_flag=.true.; return + end if + if ((mu < 2.5_rkind ).or.(mu > 3.5_rkind)) then + err=10; message=trim(message)//"FUSE TOPMODEL mu value must be between 2.5 and 3.5"; return_flag=.true.; return + end if + if ((n_topmodel < 3.5_rkind).or.(n_topmodel > 10._rkind)) then ! validate TOPMODEL exponent to avoid divergence of lambda_n + err=10; message=trim(message)//"FUSE TOPMODEL exponent must be between 3.5 and 10"; return_flag=.true.; return + end if + ! validate water content values, these should be guaranteed by earlier checks but just in case + if (S1 < 0._rkind) then; err=10; message=trim(message)//"negative water content value detected in lower FUSE layer"; return_flag=.true.; return; end if + if (S1 > S1_max) then; err=10; message=trim(message)//"water content in lower FUSE layer exceeds max storage"; return_flag=.true.; return; end if + + ! check water content in lower FUSE layer + if (S1 > 0._rkind) then ! if some water is stored in lower FUSE layer + ! set FUSE parameters - input parameters are lambda, chi_topmodel, and mu + alpha_topmodel=(lambda-mu)/chi_topmodel + + ! * compute the mean power-transformed topographic index * + ! compute regularized lower incomplete Gamma function values + F1=gammp_complex(alpha_topmodel,(-(mu*n_topmodel - mu*chi_topmodel - (n_topmodel - chi_topmodel)*zeta_upper)/n_topmodel)/chi_topmodel) + F2=gammp_complex(alpha_topmodel,(-(mu*n_topmodel - mu*chi_topmodel)/n_topmodel)/chi_topmodel) + + ! mean power-transformed topographic index (translated to Fortran from SageMath) + lambda_n=(cmplx(-mu + zeta_upper,0._rkind,rkind)**alpha_topmodel*(F1 - 1)*exp(mu/n_topmodel)*gamma(alpha_topmodel)/cmplx(-(mu*n_topmodel - mu*chi_topmodel - & + &(n_topmodel - chi_topmodel)*zeta_upper)/(n_topmodel*chi_topmodel),0._rkind,rkind)**alpha_topmodel - cmplx(-mu,0._rkind,rkind)**alpha_topmodel*(F2 - 1)*exp(mu/n_topmodel)*gamma(alpha_topmodel)/& + &cmplx(-(mu*n_topmodel - mu*chi_topmodel)/(n_topmodel*chi_topmodel),0._rkind,rkind)**alpha_topmodel)/(cmplx(chi_topmodel,0._rkind,rkind)**alpha_topmodel*gamma(alpha_topmodel)) + + ! compute critical zeta value + ! note: to obtain physical topography values, only the real part of lambda_n is used + zeta_crit_n=lambda_n%re*S1_max/S1 ! power-transformed critical topographic index + if (zeta_crit_n <= 0._rkind) then; err=10; message=trim(message)//"FUSE TOPMODEL zeta_crit_n <= 0"; return_flag=.true.; return; end if + + zeta_crit=n_topmodel*log(zeta_crit_n) ! critical topographic index in log space + + ! transform to x random variable and validate result + x_crit=zeta_crit-mu + if (x_crit < -roundoff_tolerance) then ! less than zero outside tolerance + err=10; message=trim(message)//"FUSE TOPMODEL zeta_crit must be greater or equal to mu, try increasing lambda or decreasing mu";return_flag=.true.; return + else if (x_crit < 0._rkind) then ! less than zero but within tolerance + x_crit = 0._rkind + end if + + ! define the infiltrating area and derivatives for the non-frozen part of the cell/basin + io_surfaceFlx % scalarInfilArea = gammp(alpha_topmodel,x_crit/chi_topmodel) + + else ! if (S1 == 0) no water is stored in lower FUSE layer (based on asymptotic behaviour of integral in eq. 9c of Clark et al. (2008)) + io_surfaceFlx % scalarInfilArea = 1._rkind + end if + + ! define the derivatives + if(updateInfil)then + dS1_dLiq = mLayerDepth(:) + dzeta_crit_n_dS1 = -lambda_n%re*S1_max/S1**2_i4b + dzeta_crit_dzeta_crit_n = ( n_topmodel*zeta_crit_n**(n_topmodel-1._rkind) ) / zeta_crit_n**n_topmodel + dx_crit_dzeta_crit = 1._rkind + dx_crit_dS1 = dx_crit_dzeta_crit * dzeta_crit_dzeta_crit_n * dzeta_crit_n_dS1 + dgammp_dx_crit = ( (x_crit/chi_topmodel)**(alpha_topmodel-1._rkind) * exp(-x_crit/chi_topmodel) )/chi_topmodel/gamma(alpha_topmodel) + dInfilArea_dWat(:) = dgammp_dx_crit * dx_crit_dS1 * dS1_dLiq(:) * dVolFracLiq_dWat(:) + dInfilArea_dTk(:) = dgammp_dx_crit * dx_crit_dS1 * dS1_dLiq(:) * dVolFracLiq_dTk(:) + endif ! else derivatives are zero + end associate + + end subroutine update_surfaceFlx_FUSE_TOPMODEL_infilArea + + subroutine update_surfaceFlx_prescribedHead + ! **** Update operations for surfaceFlx: prescribed pressure head condition **** + associate(& + ! input: model control + ixRichards => in_surfaceFlx % ixRichards , & ! index defining the option for Richards' equation (moisture or mixdform) + ! input: state and diagnostic variables + scalarMatricHeadLiq => in_surfaceFlx % scalarMatricHeadLiq , & ! liquid matric head in the upper-most soil layer (m) + scalarVolFracLiq => in_surfaceFlx % scalarVolFracLiq , & ! volumetric liquid water content in the upper-most soil layer (-) + ! input: depth of each soil layer (m) + mLayerDepth => in_surfaceFlx % mLayerDepth , & ! depth of each soil layer (m) + ! input: diriclet boundary conditions + upperBoundHead => in_surfaceFlx % upperBoundHead , & ! upper boundary condition for matric head (m) + upperBoundTheta => in_surfaceFlx % upperBoundTheta , & ! upper boundary condition for volumetric liquid water content (-) + ! input: transmittance + surfaceSatHydCond => in_surfaceFlx % surfaceSatHydCond , & ! saturated hydraulic conductivity at the surface (m s-1) + dHydCond_dTemp => in_surfaceFlx % dHydCond_dTemp , & ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + iceImpedeFac => in_surfaceFlx % iceImpedeFac , & ! ice impedence factor in the upper-most soil layer (-) + ! input: soil parameters + vGn_alpha => in_surfaceFlx % vGn_alpha , & ! van Genuchten "alpha" parameter (m-1) + vGn_n => in_surfaceFlx % vGn_n , & ! van Genuchten "n" parameter (-) + vGn_m => in_surfaceFlx % vGn_m , & ! van Genuchten "m" parameter (-) + theta_sat => in_surfaceFlx % theta_sat , & ! soil porosity (-) + theta_res => in_surfaceFlx % theta_res , & ! soil residual volumetric water content (-) + ! input-output: hydraulic conductivity and diffusivity at the surface + ! NOTE: intent(inout) because infiltration may only be computed for the first iteration + surfaceHydCond => io_surfaceFlx % surfaceHydCond , & ! hydraulic conductivity (m s-1) + surfaceDiffuse => io_surfaceFlx % surfaceDiffuse , & ! hydraulic diffusivity at the surface (m2 s-1) + ! output: runoff and infiltration + scalarSurfaceRunoff => out_surfaceFlx % scalarSurfaceRunoff , & ! surface runoff (m s-1) + scalarSurfaceRunoff_IE => out_surfaceFlx % scalarSurfaceRunoff_IE , & ! infiltration excess surface runoff (m s-1) + scalarSurfaceRunoff_SE => out_surfaceFlx % scalarSurfaceRunoff_SE , & ! saturation excess surface runoff (m s-1) + scalarSurfaceInfiltration => out_surfaceFlx % scalarSurfaceInfiltration , & ! surface infiltration (m s-1) + ! output: derivatives in surface infiltration w.r.t. ... + scalarSoilControl => io_surfaceFlx % scalarSoilControl , & ! soil control on infiltration for derivative + dq_dHydStateVec => out_surfaceFlx % dq_dHydStateVec , & ! ... hydrology state in above soil snow or canopy and every soil layer (m s-1 or s-1) + dq_dNrgStateVec => out_surfaceFlx % dq_dNrgStateVec , & ! ... energy state in above soil snow or canopy and every soil layer (m s-1 K-1) + ! output: error control + err => out_surfaceFlx % err , & ! error code + message => out_surfaceFlx % message & ! error message + &) ! surface runoff iz zero for the head condition - scalarSurfaceRunoff = 0._rkind + scalarSurfaceRunoff_IE = 0._rkind ! infiltration excess runoff + scalarSurfaceRunoff_SE = 0._rkind ! saturation excess runoff + scalarSurfaceRunoff = 0._rkind ! compute transmission and the capillary flux - select case(ixRichards) ! (form of Richards' equation) - case(moisture) - ! compute the hydraulic conductivity and diffusivity at the boundary - surfaceHydCond = hydCond_liq(upperBoundTheta,surfaceSatHydCond,theta_res,theta_sat,vGn_m) * iceImpedeFac - surfaceDiffuse = dPsi_dTheta(upperBoundTheta,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) * surfaceHydCond - ! compute the capillary flux - cflux = -surfaceDiffuse*(scalarVolFracLiq - upperBoundTheta) / (mLayerDepth(1)*0.5_rkind) - case(mixdform) - ! compute the hydraulic conductivity and diffusivity at the boundary - surfaceHydCond = hydCond_psi(upperBoundHead,surfaceSatHydCond,vGn_alpha,vGn_n,vGn_m) * iceImpedeFac - surfaceDiffuse = realMissing - ! compute the capillary flux - cflux = -surfaceHydCond*(scalarMatricHead - upperBoundHead) / (mLayerDepth(1)*0.5_rkind) - case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return - end select ! (form of Richards' eqn) + select case(ixRichards) ! select form of Richards' equation + case(moisture) + ! compute the hydraulic conductivity and diffusivity at the boundary + surfaceHydCond = hydCond_liq(upperBoundTheta,surfaceSatHydCond,theta_res,theta_sat,vGn_m) * iceImpedeFac + surfaceDiffuse = dPsi_dTheta(upperBoundTheta,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) * surfaceHydCond + ! compute the capillary flux + cflux = -surfaceDiffuse*(scalarVolFracLiq - upperBoundTheta) / (mLayerDepth(1)*0.5_rkind) + case(mixdform) + ! compute the hydraulic conductivity and diffusivity at the boundary + surfaceHydCond = hydCond_psi(upperBoundHead,surfaceSatHydCond,vGn_alpha,vGn_n,vGn_m) * iceImpedeFac + surfaceDiffuse = realMissing + ! compute the capillary flux + cflux = -surfaceHydCond*(scalarMatricHeadLiq - upperBoundHead) / (mLayerDepth(1)*0.5_rkind) + case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return_flag=.true.; return + end select ! end select form of Richards' eqn + ! compute the total flux scalarSurfaceInfiltration = cflux + surfaceHydCond - ! compute the derivative - if(deriv_desired)then - ! compute the hydrology derivative - select case(ixRichards) ! (form of Richards' equation) - case(moisture); dq_dHydState = -surfaceDiffuse/(mLayerDepth(1)/2._rkind) - case(mixdform); dq_dHydState = -surfaceHydCond/(mLayerDepth(1)/2._rkind) - case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return - end select - ! compute the energy derivative - dq_dNrgState = -(dHydCond_dTemp/2._rkind)*(scalarMatricHead - upperBoundHead)/(mLayerDepth(1)*0.5_rkind) + dHydCond_dTemp/2._rkind - ! compute the numerical derivative - !cflux = -surfaceHydCond*((scalarMatricHead+dx) - upperBoundHead) / (mLayerDepth(1)*0.5_rkind) - !surfaceInfiltration1 = cflux + surfaceHydCond - !dNum = (surfaceInfiltration1 - scalarSurfaceInfiltration)/dx - else - dq_dHydState = 0._rkind - dNum = 0._rkind + scalarSoilControl = 0._rkind + + ! compute the derivatives at the surface, only has a non-zero value for the upper-most soil layer + if(updateInfil)then + select case(ixRichards) ! select form of Richards' equation + case(moisture); dq_dHydStateVec(1) = -surfaceDiffuse/(mLayerDepth(1)/2._rkind) + case(mixdform); dq_dHydStateVec(1) = -surfaceHydCond/(mLayerDepth(1)/2._rkind) + case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return_flag=.true.; return + end select + ! note: energy state variable is temperature (transformed outside soilLiqFlx_module if needed) + dq_dNrgStateVec(1) = -(dHydCond_dTemp/2._rkind)*(scalarMatricHeadLiq - upperBoundHead)/(mLayerDepth(1)*0.5_rkind) + dHydCond_dTemp/2._rkind end if - !write(*,'(a,1x,10(e30.20,1x))') 'scalarMatricHead, scalarSurfaceInfiltration, dq_dHydState, dNum = ', & - ! scalarMatricHead, scalarSurfaceInfiltration, dq_dHydState, dNum - ! ***** - ! flux condition - case(liquidFlux) - - ! force infiltration to be constant over the iterations - if(doInfiltration)then - - ! define the storage in the root zone (m) - rootZoneLiq = 0._rkind - rootZoneIce = 0._rkind - ! (process layers where the roots extend to the bottom of the layer) - if(nRoots > 1)then + ! * additional assignment statements for surfaceFlx input-output object based on presribed head values * + ! the infiltration is always constrained by the prescribed head so the maximum infiltration rate is set to missing + io_surfaceFlx % xMaxInfilRate = realMissing ! maximum infiltration rate (m s-1) + ! no soil ice assumed for prescribed head condition + io_surfaceFlx % scalarFrozenArea = 0._rkind ! fraction of area that is considered impermeable due to soil ice (-) + ! all area is available for infiltration, and to complement this saturated area (i.e., part where saturation excess runoff occurs) is set to zero + io_surfaceFlx % scalarInfilArea = 1._rkind ! fraction of area where water can infiltrate, may be frozen (-) + io_surfaceFlx % scalarSaturatedArea = 0._rkind ! fraction of area that is considered saturated (-) + + end associate + end subroutine update_surfaceFlx_prescribedHead + + subroutine update_surfaceFlx_homegrown_infilArea + ! **** Update operations for surfaceFlx: homegrown saturation excess runoff condition **** + call update_surfaceFlx_liquidFlux_computation_root_layers + call update_surfaceFlx_liquidFlux_computation_available_capacity; if (return_flag) return + call update_surfaceFlx_liquidFlux_computation_homegrown ! this calculates infiltration area ignoring if frozen or not, depends on available capacity (depends on ice and root zone) + end subroutine update_surfaceFlx_homegrown_infilArea + + subroutine update_surfaceFlx_liquidFlux_noinfratemax + ! **** Update operations for surfaceFlx: no infiltration excess**** + associate(& + ! input: model control + surfRun_SE => in_surfaceFlx % surfRun_SE & ! index defining the saturation excess surface runoff method + &) + io_surfaceFlx % xMaxInfilRate = veryBig ! set to a very large number so rainPlusMelt never exceeds this + if (surfRun_SE /= homegrown_SE) then ! frozen area (depends on ice and root zone) + call update_surfaceFlx_liquidFlux_computation_root_layers + end if + end associate + ! -- main computations - these always need to run + call update_surfaceFlx_liquidFlux_computation_frozen_area + end subroutine update_surfaceFlx_liquidFlux_noinfratemax + + subroutine update_surfaceFlx_liquidFlux_calculate_infratemax + ! **** Update operations for surfaceFlx: infiltration excess possible - calculate max infiltration rate **** + associate(& + ! input: model control + surfRun_SE => in_surfaceFlx % surfRun_SE & ! index defining the saturation excess surface runoff method + &) + if (surfRun_SE /= homegrown_SE) then ! infiltration rate max depends on available capacity (depends on ice and root zone) and frozen area (depends on ice and root zone) + call update_surfaceFlx_liquidFlux_computation_root_layers + call update_surfaceFlx_liquidFlux_computation_available_capacity; if (return_flag) return + end if + end associate + ! -- main computations - these always need to run + call update_surfaceFlx_liquidFlux_computation_frozen_area + call update_surfaceFlx_liquidFlux_computation_max_infiltration_rate + end subroutine update_surfaceFlx_liquidFlux_calculate_infratemax + + subroutine update_surfaceFlx_liquidFlux_computation_root_layers + ! **** Update operations for surfaceFlx: root layer water computation **** + associate(& + ! input: model control + nRoots => in_surfaceFlx % nRoots , & ! number of soil layers with roots (-) + ! input: state and diagnostic variables + mLayerVolFracLiq => in_surfaceFlx % mLayerVolFracLiq , & ! volumetric liquid water content in each soil layer (-) + mLayerVolFracIce => in_surfaceFlx % mLayerVolFracIce , & ! volumetric ice content in each soil layer (-) + ! input: depth of soil layers (m) + mLayerDepth => in_surfaceFlx % mLayerDepth , & ! depth of each soil layer (m) + iLayerHeight => in_surfaceFlx % iLayerHeight , & ! height at the interface of each layer for soil layers only (m) + rootingDepth => in_surfaceFlx % rootingDepth & ! rooting depth (m) + &) + + ! define the storage in the root zone (m) and derivatives, first initialize + rootZoneLiq = 0._rkind + rootZoneIce = 0._rkind + dRootZoneLiq_dWat(:) = 0._rkind + dRootZoneIce_dWat(:) = 0._rkind + dRootZoneLiq_dTk(:) = 0._rkind + dRootZoneIce_dTk(:) = 0._rkind + + ! process layers where the roots extend to the bottom of the layer + if (nRoots > 1) then do iLayer=1,nRoots-1 - rootZoneLiq = rootZoneLiq + mLayerVolFracLiq(iLayer)*mLayerDepth(iLayer) - rootZoneIce = rootZoneIce + mLayerVolFracIce(iLayer)*mLayerDepth(iLayer) + rootZoneLiq = rootZoneLiq + mLayerVolFracLiq(iLayer)*mLayerDepth(iLayer) + rootZoneIce = rootZoneIce + mLayerVolFracIce(iLayer)*mLayerDepth(iLayer) + if(updateInfil)then + dRootZoneLiq_dWat(iLayer) = dVolFracLiq_dWat(iLayer)*mLayerDepth(iLayer) + dRootZoneIce_dWat(iLayer) = dVolFracIce_dWat(iLayer)*mLayerDepth(iLayer) + dRootZoneLiq_dTk(iLayer) = dVolFracLiq_dTk(iLayer) *mLayerDepth(iLayer) + dRootZoneIce_dTk(iLayer) = dVolFracIce_dTk(iLayer) *mLayerDepth(iLayer) + end if end do - end if - ! (process layers where the roots end in the current layer) - rootZoneLiq = rootZoneLiq + mLayerVolFracLiq(nRoots)*(rootingDepth - iLayerHeight(nRoots-1)) - rootZoneIce = rootZoneIce + mLayerVolFracIce(nRoots)*(rootingDepth - iLayerHeight(nRoots-1)) - - ! define available capacity to hold water (m) - availCapacity = theta_sat*rootingDepth - rootZoneIce - if(rootZoneLiq > availCapacity+verySmall)then - message=trim(message)//'liquid water in the root zone exceeds capacity' - err=20; return - end if - - ! define the depth to the wetting front (m) - depthWettingFront = (rootZoneLiq/availCapacity)*rootingDepth - - ! define the hydraulic conductivity at depth=depthWettingFront (m s-1) - hydCondWettingFront = surfaceSatHydCond * ( (1._rkind - depthWettingFront/sum(mLayerDepth))**(zScale_TOPMODEL - 1._rkind) ) - - ! define the maximum infiltration rate (m s-1) - xMaxInfilRate = hydCondWettingFront*( (wettingFrontSuction + depthWettingFront)/depthWettingFront ) ! maximum infiltration rate (m s-1) - !write(*,'(a,1x,f9.3,1x,10(e20.10,1x))') 'depthWettingFront, surfaceSatHydCond, hydCondWettingFront, xMaxInfilRate = ', depthWettingFront, surfaceSatHydCond, hydCondWettingFront, xMaxInfilRate - - ! define the infiltrating area for the non-frozen part of the cell/basin - if(qSurfScale < qSurfScaleMax)then + end if + ! process layers where the roots end in the current layer + rootZoneLiq = rootZoneLiq + mLayerVolFracLiq(nRoots)*min(mLayerDepth(nRoots),rootingDepth - iLayerHeight(nRoots-1)) + rootZoneIce = rootZoneIce + mLayerVolFracIce(nRoots)*min(mLayerDepth(nRoots),rootingDepth - iLayerHeight(nRoots-1)) + if(updateInfil)then + dRootZoneLiq_dWat(nRoots) = dVolFracLiq_dWat(nRoots)*min(mLayerDepth(nRoots),rootingDepth - iLayerHeight(nRoots-1)) + dRootZoneIce_dWat(nRoots) = dVolFracIce_dWat(nRoots)*min(mLayerDepth(nRoots),rootingDepth - iLayerHeight(nRoots-1)) + dRootZoneLiq_dTk(nRoots) = dVolFracLiq_dTk(nRoots)* min(mLayerDepth(nRoots),rootingDepth - iLayerHeight(nRoots-1)) + dRootZoneIce_dTk(nRoots) = dVolFracIce_dTk(nRoots)* min(mLayerDepth(nRoots),rootingDepth - iLayerHeight(nRoots-1)) + endif + + end associate + end subroutine update_surfaceFlx_liquidFlux_computation_root_layers + + subroutine update_surfaceFlx_liquidFlux_computation_available_capacity + ! **** Update operations for surfaceFlx: compute and check available capacity to hold water **** + associate(& + ! input: soil parameters + theta_sat => in_surfaceFlx % theta_sat , & ! soil porosity (-) + rootingDepth => in_surfaceFlx % rootingDepth , & ! rooting depth (m) + ! output: error control + err => out_surfaceFlx % err , & ! error code + message => out_surfaceFlx % message & ! error message + &) + availCapacity = theta_sat*rootingDepth - rootZoneIce + if (rootZoneLiq > availCapacity+verySmaller) then + err=20; message=trim(message)//'liquid water in the root zone exceeds capacity'; return_flag=.true.; return + end if + + end associate + end subroutine update_surfaceFlx_liquidFlux_computation_available_capacity + + subroutine update_surfaceFlx_liquidFlux_computation_max_infiltration_rate + ! **** Update operations for surfaceFlx: max infiltration rate and derivatives **** + associate(& + ! input: model control + ixInfRateMax => in_surfaceFlx % ixInfRateMax , & ! index defining the maximum infiltration rate method (GreenAmpt, topmodel_GA, noInfiltrationExcess) + ! input: transmittance + surfaceSatHydCond => in_surfaceFlx % surfaceSatHydCond , & ! saturated hydraulic conductivity at the surface (m s-1) + ! input: soil parameters + zScale_TOPMODEL => in_surfaceFlx % zScale_TOPMODEL , & ! scaling factor used to describe decrease in hydraulic conductivity with depth (m) + rootingDepth => in_surfaceFlx % rootingDepth , & ! rooting depth (m) + wettingFrontSuction => in_surfaceFlx % wettingFrontSuction , & ! Green-Ampt wetting front suction (m) + mLayerDepth => in_surfaceFlx % mLayerDepth , & ! depth of each soil layer (m) + ! input-output: surface runoff and infiltration flux (m s-1) + xMaxInfilRate => io_surfaceFlx % xMaxInfilRate & ! maximum infiltration rate (m s-1) + &) + ! define the depth to the wetting front (m) and derivatives + total_soil_depth = sum(mLayerDepth(:)) + depthWettingFront = (rootZoneLiq/availCapacity)*min(rootingDepth,total_soil_depth) + if(updateInfil)then + dDepthWettingFront_dWat(:)=( dRootZoneLiq_dWat(:)*min(rootingDepth,total_soil_depth) + dRootZoneIce_dWat(:)*depthWettingFront )/availCapacity + dDepthWettingFront_dTk(:) =( dRootZoneLiq_dTk(:) *min(rootingDepth,total_soil_depth) + dRootZoneIce_dTk(:)*depthWettingFront )/availCapacity + end if + + ! process hydraulic conductivity-controlled infiltration rate + select case(ixInfRateMax) ! maximum infiltration rate parameterization (noInfExcess set in update_surfaceFlx) + case(topmodel_GA) + ! define the hydraulic conductivity at depth=depthWettingFront (m s-1) + hydCondWettingFront = surfaceSatHydCond * ( (1._rkind - depthWettingFront/total_soil_depth)**(zScale_TOPMODEL - 1._rkind) ) + ! define the maximum infiltration rate (m s-1) + xMaxInfilRate = hydCondWettingFront*( (wettingFrontSuction + depthWettingFront)/depthWettingFront ) ! maximum infiltration rate (m s-1) + ! define the derivatives + if(updateInfil)then + fPart1 = hydCondWettingFront + fPart2 = (wettingFrontSuction + depthWettingFront)/depthWettingFront + dPart1(:) = surfaceSatHydCond*(zScale_TOPMODEL - 1._rkind) * ( (1._rkind - depthWettingFront/total_soil_depth)**(zScale_TOPMODEL - 2._rkind) ) * (-dDepthWettingFront_dWat(:))/total_soil_depth + dPart2(:) = -dDepthWettingFront_dWat(:)*wettingFrontSuction / (depthWettingFront**2_i4b) + dxMaxInfilRate_dWat(:) = fPart1*dPart2(:) + fPart2*dPart1(:) + dPart1(:) = surfaceSatHydCond*(zScale_TOPMODEL - 1._rkind) * ( (1._rkind - depthWettingFront/total_soil_depth)**(zScale_TOPMODEL - 2._rkind) ) * (-dDepthWettingFront_dTk(:))/total_soil_depth + dPart2(:) = -dDepthWettingFront_dTk(:)*wettingFrontSuction / (depthWettingFront**2_i4b) + dxMaxInfilRate_dTk(:) = fPart1*dPart2(:) + fPart2*dPart1(:) + endif + case(GreenAmpt) + ! define the hydraulic conductivity at depth=depthWettingFront (m s-1) + hydCondWettingFront = surfaceSatHydCond ! Green-Ampt assumes homogeneous soil, therefore the whole soil column has the same hydraulic conductivity + ! define the maximum infiltration rate (m s-1) + xMaxInfilRate = hydCondWettingFront * (1._rkind + (1._rkind - depthWettingFront/total_soil_depth) * wettingFrontSuction/depthWettingFront) ! Ks * (1 + (Md) * S/F) + ! define the derivatives + if(updateInfil)then + dxMaxInfilRate_dWat(:) = -hydCondWettingFront*wettingFrontSuction*dDepthWettingFront_dWat(:)/depthWettingFront**2_i4b + dxMaxInfilRate_dTk(:) = -hydCondWettingFront*wettingFrontSuction*dDepthWettingFront_dTk(:)/depthWettingFront**2_i4b + endif + end select + end associate + end subroutine update_surfaceFlx_liquidFlux_computation_max_infiltration_rate + + subroutine update_surfaceFlx_liquidFlux_computation_homegrown + ! **** Update operations for surfaceFlx: infiltrating area (ignoring frozen area) for homegrown saturation excess condition **** + associate(& + ! input: model control + nSoil => in_surfaceFlx % nSoil , & ! number of soil layers + nRoots => in_surfaceFlx % nRoots , & ! number of layers that contain roots + ixIce => in_surfaceFlx % ixIce , & ! index of lowest ice layer + mLayerVolFracLiq => in_surfaceFlx % mLayerVolFracLiq , & ! volumetric liquid water content in each soil layer (-) + mLayerDepth => in_surfaceFlx % mLayerDepth , & ! depth of each soil layer (m) + ! input: soil parameters + theta_sat => in_surfaceFlx % theta_sat , & ! soil porosity (-) + qSurfScale => in_surfaceFlx % qSurfScale , & ! scaling factor in the surface runoff parameterization (-) + ! input-output: surface runoff and infiltration flux (m s-1) + scalarInfilArea => io_surfaceFlx % scalarInfilArea & ! fraction of area where water can infiltrate, may be frozen (-) + &) + ! define the infiltrating area and derivatives for the ignoring if frozen or not + if (qSurfScale < qSurfScaleMax) then fracCap = rootZoneLiq/(maxFracCap*availCapacity) ! fraction of available root zone filled with water fInfRaw = 1._rkind - exp(-qSurfScale*(1._rkind - fracCap)) ! infiltrating area -- allowed to violate solution constraints - scalarInfilArea = min(0.5_rkind*(fInfRaw + sqrt(fInfRaw**2._rkind + scaleFactor)), 1._rkind) ! infiltrating area -- constrained - else - scalarInfilArea = 1._rkind - endif - - ! check to ensure we are not infiltrating into a fully saturated column - if(ixIce 0.9999_rkind*theta_sat*sum(mLayerDepth(ixIce+1:nRoots))) scalarInfilArea=0._rkind - !print*, 'ixIce, nRoots, scalarInfilArea = ', ixIce, nRoots, scalarInfilArea - !print*, 'sum(mLayerVolFracLiq(ixIce+1:nRoots)*mLayerDepth(ixIce+1:nRoots)) = ', sum(mLayerVolFracLiq(ixIce+1:nRoots)*mLayerDepth(ixIce+1:nRoots)) - !print*, 'theta_sat*sum(mLayerDepth(ixIce+1:nRoots)) = ', theta_sat*sum(mLayerDepth(ixIce+1:nRoots)) - endif - - ! define the impermeable area due to frozen ground - if(rootZoneIce > tiny(rootZoneIce))then ! (avoid divide by zero) - alpha = 1._rkind/(soilIceCV**2._rkind) ! shape parameter in the Gamma distribution - xLimg = alpha*soilIceScale/rootZoneIce ! upper limit of the integral + scalarInfilArea = min(0.5_rkind*(fInfRaw + sqrt(fInfRaw**2_i4b + scaleFactor)), 1._rkind) ! infiltrating area -- constrained + ! define the derivatives + if(updateInfil)then + if (0.5_rkind*(fInfRaw + sqrt(fInfRaw**2_i4b + scaleFactor))< 1._rkind) then + dfracCap(:) = ( dRootZoneLiq_dWat(:)/maxFracCap + dRootZoneIce_dWat(:)*fracCap )/availCapacity + dfInfRaw(:) = -qSurfScale*dfracCap(:) * exp(-qSurfScale*(1._rkind - fracCap)) + dInfilArea_dWat(:) = 0.5_rkind*dfInfRaw(:) * (1._rkind + fInfRaw/sqrt(fInfRaw**2_i4b + scaleFactor)) + dfracCap(:) = ( dRootZoneLiq_dTk(:)/maxFracCap + dRootZoneIce_dTk(:)*fracCap )/availCapacity + dfInfRaw(:) = -qSurfScale*dfracCap(:) * exp(-qSurfScale*(1._rkind - fracCap)) + dInfilArea_dTk(:) = 0.5_rkind*dfInfRaw(:) * (1._rkind + fInfRaw/sqrt(fInfRaw**2_i4b + scaleFactor)) + endif ! else derivatives are zero + endif + else + scalarInfilArea = 1._rkind ! derivatives are zero + end if + + ! check to ensure we are not infiltrating into a fully saturated column + if (ixIce 0.9999_rkind*theta_sat*sum(mLayerDepth(ixIce+1:nRoots))) then + scalarInfilArea = 0._rkind + dInfilArea_dWat(:) = 0._rkind + dInfilArea_dTk(:) = 0._rkind + end if + end if + end associate + end subroutine update_surfaceFlx_liquidFlux_computation_homegrown + + subroutine update_surfaceFlx_liquidFlux_computation_frozen_area + ! **** Update operations for surfaceFlx: get impermeable area due to soil freezing **** + associate(& + ! input: soil parameters + soilIceScale => in_surfaceFlx % soilIceScale , & ! soil ice scaling factor in Gamma distribution used to define frozen area (m) + soilIceCV => in_surfaceFlx % soilIceCV , & ! soil ice CV in Gamma distribution used to define frozen area (-) + ! output: frozen area + scalarFrozenArea => io_surfaceFlx % scalarFrozenArea & ! fraction of area that is considered impermeable due to soil ice (-) + &) + ! define the impermeable area and derivatives due to frozen ground + if (rootZoneIce > tiny(rootZoneIce)) then ! (avoid divide by zero) + alpha = 1._rkind/(soilIceCV**2_i4b) ! shape parameter in the Gamma distribution + xLimg = alpha*soilIceScale/rootZoneIce ! upper limit of the integral + !if we use this, we will have a derivative of scalarFrozenArea w.r.t. water and temperature in each layer (through mLayerVolFracIce) + ! Should fix to deal with frozen area in the root zone, calculations would be expensive !scalarFrozenArea = 1._rkind - gammp(alpha,xLimg) ! fraction of frozen area + !if(updateInfil)then + ! dFrozenArea_dWat(:) = -dgammp_dx(alpha,xLimg)*(-alpha*soilIceScale/rootZoneIce**2_i4b)*dRootZoneIce_dWat(:) + ! dFrozenArea_dTk(:) = -dgammp_dx(alpha,xLimg)*(-alpha*soilIceScale/rootZoneIce**2_i4b)*dRootZoneIce_dTk(:) + !end if scalarFrozenArea = 0._rkind - else + else scalarFrozenArea = 0._rkind - end if - !print*, 'scalarFrozenArea, rootZoneIce = ', scalarFrozenArea, rootZoneIce + end if + end associate + end subroutine update_surfaceFlx_liquidFlux_computation_frozen_area + + subroutine update_surfaceFlx_liquidFlux_infiltration + ! **** Update operations for surfaceFlx: final infiltration and runoff calculations **** + ! local variables + real(rkind) :: scalarInfilArea_unfrozen ! infiltration area that is not frozen + + ! compute infiltration and runoff + associate(& + ! input: flux at the upper boundary + scalarRainPlusMelt => in_surfaceFlx % scalarRainPlusMelt, & ! rain plus melt, used as input to the soil zone before computing surface runoff (m s-1) + ! input-output: surface runoff and infiltration flux (m s-1) + xMaxInfilRate => io_surfaceFlx % xMaxInfilRate , & ! maximum infiltration rate (m s-1) + scalarInfilArea => io_surfaceFlx % scalarInfilArea , & ! fraction of area where water can infiltrate, may be frozen (-) + scalarSaturatedArea => io_surfaceFlx % scalarSaturatedArea, & ! fraction of area that is saturated (-) + scalarSoilControl => io_surfaceFlx % scalarSoilControl, & ! soil control on infiltration for derivative + scalarFrozenArea => io_surfaceFlx % scalarFrozenArea, & ! fraction of area that is considered impermeable due to soil ice (-) + ! output: runoff and infiltration + scalarSurfaceRunoff_IE => out_surfaceFlx % scalarSurfaceRunoff_IE, & ! infiltration excess surface runoff (m s-1) + scalarSurfaceRunoff_SE => out_surfaceFlx % scalarSurfaceRunoff_SE, & ! saturation excess surface runoff (m s-1) + scalarSurfaceRunoff => out_surfaceFlx % scalarSurfaceRunoff, & ! surface runoff (m s-1) + scalarSurfaceInfiltration => out_surfaceFlx % scalarSurfaceInfiltration & ! surface infiltration (m s-1) + &) + ! unfrozen infiltration area + scalarInfilArea_unfrozen=(1._rkind - scalarFrozenArea)*scalarInfilArea + ! soil control on infiltration for derivative if dependent on scalarRainPlusMelt (needed to compute scalarRainPlusMelt derivative inside computJacob*) + scalarSoilControl = 0._rkind + if (updateInfil .and. xMaxInfilRate > scalarRainPlusMelt) then + scalarSoilControl = scalarInfilArea_unfrozen + end if - end if ! (if desire to compute infiltration) + ! infiltration rate derivatives, will stay at zero if no infiltration excess or if infiltration not being updated + if(updateInfil)then + if (xMaxInfilRate < scalarRainPlusMelt) then ! = dxMaxInfilRate_d, dependent on layers not at surface + dInfilRate_dWat(:) = dxMaxInfilRate_dWat(:) + dInfilRate_dTk(:) = dxMaxInfilRate_dTk(:) + end if + end if ! compute infiltration (m s-1) - scalarSurfaceInfiltration = (1._rkind - scalarFrozenArea)*scalarInfilArea*min(scalarRainPlusMelt,xMaxInfilRate) - + scalarSurfaceInfiltration = scalarInfilArea_unfrozen * min(scalarRainPlusMelt,xMaxInfilRate) ! rain+melt falling on unfrozen unsaturated area, and smaller than max infiltration rate + ! compute surface runoff (m s-1) scalarSurfaceRunoff = scalarRainPlusMelt - scalarSurfaceInfiltration - !print*, 'scalarRainPlusMelt, xMaxInfilRate = ', scalarRainPlusMelt, xMaxInfilRate - !print*, 'scalarSurfaceInfiltration, scalarSurfaceRunoff = ', scalarSurfaceInfiltration, scalarSurfaceRunoff - !print*, '(1._rkind - scalarFrozenArea), (1._rkind - scalarFrozenArea)*scalarInfilArea = ', (1._rkind - scalarFrozenArea), (1._rkind - scalarFrozenArea)*scalarInfilArea - - ! set surface hydraulic conductivity and diffusivity to missing (not used for flux condition) + if (scalarRainPlusMelt.gt.xMaxInfilRate) then ! infiltration excess surface runoff occurs + ! saturation excess surface runoff computed by one of the saturation excess methods, remaining surface runoff is infiltration excess + scalarSurfaceRunoff_IE = scalarSurfaceRunoff - scalarSurfaceRunoff_SE ! infiltration excess surface runoff + else ! infiltration excess runoff does not occur + scalarSurfaceRunoff_SE = scalarSurfaceRunoff ! saturation excess surface runoff + scalarSurfaceRunoff_IE = 0._rkind ! infiltration excess surface runoff + end if + end associate + + ! set surface hydraulic conductivity and diffusivity to missing (not used for flux condition) + associate(& + ! input-output: hydraulic conductivity and diffusivity at the surface + ! NOTE: intent(inout) because infiltration may only be computed for the first iteration + surfaceHydCond => io_surfaceFlx % surfaceHydCond , & ! hydraulic conductivity (m s-1) + surfaceDiffuse => io_surfaceFlx % surfaceDiffuse & ! hydraulic diffusivity at the surface (m2 s-1) + &) surfaceHydCond = realMissing surfaceDiffuse = realMissing + end associate + + end subroutine update_surfaceFlx_liquidFlux_infiltration + + subroutine finalize_surfaceFlx + ! **** Finalize operations for surfaceFlx **** + ! final error check + associate(& + err => out_surfaceFlx % err , & ! error code + message => out_surfaceFlx % message & ! error message + &) + if(err/=0)then; message=trim(message)//'unanticipated error in surfaceFlx subroutine'; return_flag=.true.; return; end if + end associate + end subroutine finalize_surfaceFlx + +end subroutine surfaceFlx + +! *************************************************************************************************************** +! private subroutine iLayerFlux: compute the fluxes and derivatives at layer interfaces +! *************************************************************************************************************** +subroutine iLayerFlux(in_iLayerFlux,out_iLayerFlux) + ! --------------------------------------------------------------------------------------------------------------------------- + ! input: model control, state variables, coordinate variables, temperature derivatives, transmittance variables + type(in_type_iLayerFlux),intent(in) :: in_iLayerFlux ! class object for input data + ! output: transmittance variables and vertical flux at layer interface, derivatives, and error control + type(out_type_iLayerFlux),intent(out) :: out_iLayerFlux ! class object for output data + ! --------------------------------------------------------------------------------------------------------------------------- + ! local variables (named variables to provide index of 2-element vectors) + integer(i4b),parameter :: ixUpper=1 ! index of upper node in the 2-element vectors + integer(i4b),parameter :: ixLower=2 ! index of lower node in the 2-element vectors + logical(lgt),parameter :: useGeometric=.false. ! switch between the arithmetic and geometric mean + ! local variables (Darcy flux) + real(rkind) :: dPsi ! spatial difference in matric head (m) + real(rkind) :: dLiq ! spatial difference in volumetric liquid water (-) + real(rkind) :: dz ! spatial difference in layer mid-points (m) + real(rkind) :: cflux ! capillary flux (m s-1) + ! error control + logical(lgt) :: return_flag ! flag for return statements + ! --------------------------------------------------------------------------------------------------------------------------- + + call initialize_iLayerFlux + + call update_iLayerFlux; if (return_flag) return + + call finalize_iLayerFlux; if (return_flag) return - ! set numerical derivative to zero - ! NOTE 1: Depends on multiple soil layers and does not jive with the current tridiagonal matrix - ! NOTE 2: Need to define the derivative at every call, because intent(out) - dq_dHydState = 0._rkind - dq_dNrgState = 0._rkind - - ! ***** error check - case default; err=20; message=trim(message)//'unknown upper boundary condition for soil hydrology'; return - - end select ! (type of upper boundary condition) - - end subroutine surfaceFlx - - - ! *************************************************************************************************************** - ! private subroutine iLayerFlux: compute the fluxes and derivatives at layer interfaces - ! *************************************************************************************************************** - subroutine iLayerFlux(& - ! input: model control - deriv_desired, & ! intent(in): flag indicating if derivatives are desired - ixRichards, & ! intent(in): index defining the form of Richards' equation (moisture or mixdform) - ! input: state variables (adjacent layers) - nodeMatricHeadTrial, & ! intent(in): matric head at the soil nodes (m) - nodeVolFracLiqTrial, & ! intent(in): volumetric liquid water content at the soil nodes (-) - ! input: model coordinate variables (adjacent layers) - nodeHeight, & ! intent(in): height of the soil nodes (m) - ! input: temperature derivatives - dPsiLiq_dTemp, & ! intent(in): derivative in liquid water matric potential w.r.t. temperature (m K-1) - dHydCond_dTemp, & ! intent(in): derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) - ! input: transmittance (adjacent layers) - nodeHydCondTrial, & ! intent(in): hydraulic conductivity at the soil nodes (m s-1) - nodeDiffuseTrial, & ! intent(in): hydraulic diffusivity at the soil nodes (m2 s-1) - ! input: transmittance derivatives (adjacent layers) - dHydCond_dVolLiq, & ! intent(in): derivative in hydraulic conductivity w.r.t. change in volumetric liquid water content (m s-1) - dDiffuse_dVolLiq, & ! intent(in): derivative in hydraulic diffusivity w.r.t. change in volumetric liquid water content (m2 s-1) - dHydCond_dMatric, & ! intent(in): derivative in hydraulic conductivity w.r.t. change in matric head (s-1) - ! output: tranmsmittance at the layer interface (scalars) - iLayerHydCond, & ! intent(out): hydraulic conductivity at the interface between layers (m s-1) - iLayerDiffuse, & ! intent(out): hydraulic diffusivity at the interface between layers (m2 s-1) - ! output: vertical flux at the layer interface (scalars) - iLayerLiqFluxSoil, & ! intent(out): vertical flux of liquid water at the layer interface (m s-1) - ! output: derivatives in fluxes w.r.t. state variables -- matric head or volumetric lquid water -- in the layer above and layer below (m s-1 or s-1) - dq_dHydStateAbove, & ! intent(out): derivatives in the flux w.r.t. matric head or volumetric lquid water in the layer above (m s-1 or s-1) - dq_dHydStateBelow, & ! intent(out): derivatives in the flux w.r.t. matric head or volumetric lquid water in the layer below (m s-1 or s-1) - ! output: derivatives in fluxes w.r.t. energy state variables -- now just temperature -- in the layer above and layer below (m s-1 K-1) - dq_dNrgStateAbove, & ! intent(out): derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) - dq_dNrgStateBelow, & ! intent(out): derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) - ! output: error control - err,message) ! intent(out): error control - ! ------------------------------------------------------------------------------------------------------------------------------------------------------------------------ - ! input: model control - logical(lgt),intent(in) :: deriv_desired ! flag indicating if derivatives are desired - integer(i4b),intent(in) :: ixRichards ! index defining the option for Richards' equation (moisture or mixdform) - ! input: state variables - real(rkind),intent(in) :: nodeMatricHeadTrial(:) ! matric head at the soil nodes (m) - real(rkind),intent(in) :: nodeVolFracLiqTrial(:) ! volumetric fraction of liquid water at the soil nodes (-) - ! input: model coordinate variables - real(rkind),intent(in) :: nodeHeight(:) ! height at the mid-point of the lower layer (m) - ! input: temperature derivatives - real(rkind),intent(in) :: dPsiLiq_dTemp(:) ! derivative in liquid water matric potential w.r.t. temperature (m K-1) - real(rkind),intent(in) :: dHydCond_dTemp(:) ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) - ! input: transmittance - real(rkind),intent(in) :: nodeHydCondTrial(:) ! hydraulic conductivity at layer mid-points (m s-1) - real(rkind),intent(in) :: nodeDiffuseTrial(:) ! diffusivity at layer mid-points (m2 s-1) - ! input: transmittance derivatives - real(rkind),intent(in) :: dHydCond_dVolLiq(:) ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) - real(rkind),intent(in) :: dDiffuse_dVolLiq(:) ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) - real(rkind),intent(in) :: dHydCond_dMatric(:) ! derivative in hydraulic conductivity w.r.t matric head (m s-1) - ! output: tranmsmittance at the layer interface (scalars) - real(rkind),intent(out) :: iLayerHydCond ! hydraulic conductivity at the interface between layers (m s-1) - real(rkind),intent(out) :: iLayerDiffuse ! hydraulic diffusivity at the interface between layers (m2 s-1) - ! output: vertical flux at the layer interface (scalars) - real(rkind),intent(out) :: iLayerLiqFluxSoil ! vertical flux of liquid water at the layer interface (m s-1) - ! output: derivatives in fluxes w.r.t. state variables -- matric head or volumetric lquid water -- in the layer above and layer below (m s-1 or s-1) - real(rkind),intent(out) :: dq_dHydStateAbove ! derivatives in the flux w.r.t. matric head or volumetric lquid water in the layer above (m s-1 or s-1) - real(rkind),intent(out) :: dq_dHydStateBelow ! derivatives in the flux w.r.t. matric head or volumetric lquid water in the layer below (m s-1 or s-1) - ! output: derivatives in fluxes w.r.t. energy state variables -- now just temperature -- in the layer above and layer below (m s-1 K-1) - real(rkind),intent(out) :: dq_dNrgStateAbove ! derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) - real(rkind),intent(out) :: dq_dNrgStateBelow ! derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) - ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! ------------------------------------------------------------------------------------------------------------------------------------------------------------------------ - ! local variables (named variables to provide index of 2-element vectors) - integer(i4b),parameter :: ixUpper=1 ! index of upper node in the 2-element vectors - integer(i4b),parameter :: ixLower=2 ! index of lower node in the 2-element vectors - logical(lgt),parameter :: useGeometric=.false. ! switch between the arithmetic and geometric mean - ! local variables (Darcy flux) - real(rkind) :: dPsi ! spatial difference in matric head (m) - real(rkind) :: dLiq ! spatial difference in volumetric liquid water (-) - real(rkind) :: dz ! spatial difference in layer mid-points (m) - real(rkind) :: cflux ! capillary flux (m s-1) - ! local variables (derivative in Darcy's flux) - real(rkind) :: dHydCondIface_dVolLiqAbove ! derivative in hydraulic conductivity at layer interface w.r.t. volumetric liquid water content in layer above - real(rkind) :: dHydCondIface_dVolLiqBelow ! derivative in hydraulic conductivity at layer interface w.r.t. volumetric liquid water content in layer below - real(rkind) :: dDiffuseIface_dVolLiqAbove ! derivative in hydraulic diffusivity at layer interface w.r.t. volumetric liquid water content in layer above - real(rkind) :: dDiffuseIface_dVolLiqBelow ! derivative in hydraulic diffusivity at layer interface w.r.t. volumetric liquid water content in layer below - real(rkind) :: dHydCondIface_dMatricAbove ! derivative in hydraulic conductivity at layer interface w.r.t. matric head in layer above - real(rkind) :: dHydCondIface_dMatricBelow ! derivative in hydraulic conductivity at layer interface w.r.t. matric head in layer below - ! ------------------------------------------------------------------------------------------------------------------------------------------------------------------------ - ! initialize error control - err=0; message="iLayerFlux/" - - ! ***** - ! compute the vertical flux of liquid water - ! compute the hydraulic conductivity at the interface - if(useGeometric)then - iLayerHydCond = (nodeHydCondTrial(ixLower) * nodeHydCondTrial(ixUpper))**0.5_rkind - else - iLayerHydCond = (nodeHydCondTrial(ixLower) + nodeHydCondTrial(ixUpper))*0.5_rkind - end if - !write(*,'(a,1x,5(e20.10,1x))') 'in iLayerFlux: iLayerHydCond, iLayerHydCondMP = ', iLayerHydCond, iLayerHydCondMP - ! compute the height difference between nodes - dz = nodeHeight(ixLower) - nodeHeight(ixUpper) - ! compute the capillary flux - select case(ixRichards) ! (form of Richards' equation) - case(moisture) - iLayerDiffuse = (nodeDiffuseTrial(ixLower) * nodeDiffuseTrial(ixUpper))**0.5_rkind - dLiq = nodeVolFracLiqTrial(ixLower) - nodeVolFracLiqTrial(ixUpper) - cflux = -iLayerDiffuse * dLiq/dz - case(mixdform) - iLayerDiffuse = realMissing - dPsi = nodeMatricHeadTrial(ixLower) - nodeMatricHeadTrial(ixUpper) - cflux = -iLayerHydCond * dPsi/dz - case default; err=10; message=trim(message)//"unable to identify option for Richards' equation"; return - end select - ! compute the total flux (add gravity flux, positive downwards) - iLayerLiqFluxSoil = cflux + iLayerHydCond - !write(*,'(a,1x,10(e20.10,1x))') 'iLayerLiqFluxSoil, dPsi, dz, cflux, iLayerHydCond = ', & - ! iLayerLiqFluxSoil, dPsi, dz, cflux, iLayerHydCond - - ! ** compute the derivatives - if(deriv_desired)then - select case(ixRichards) ! (form of Richards' equation) - case(moisture) - ! still need to implement arithmetric mean for the moisture-based form - if(.not.useGeometric)then - message=trim(message)//'only currently implemented for geometric mean -- change local flag' - err=20; return - end if - ! derivatives in hydraulic conductivity at the layer interface (m s-1) - dHydCondIface_dVolLiqAbove = dHydCond_dVolLiq(ixUpper)*nodeHydCondTrial(ixLower) * 0.5_rkind/max(iLayerHydCond,verySmall) - dHydCondIface_dVolLiqBelow = dHydCond_dVolLiq(ixLower)*nodeHydCondTrial(ixUpper) * 0.5_rkind/max(iLayerHydCond,verySmall) - ! derivatives in hydraulic diffusivity at the layer interface (m2 s-1) - dDiffuseIface_dVolLiqAbove = dDiffuse_dVolLiq(ixUpper)*nodeDiffuseTrial(ixLower) * 0.5_rkind/max(iLayerDiffuse,verySmall) - dDiffuseIface_dVolLiqBelow = dDiffuse_dVolLiq(ixLower)*nodeDiffuseTrial(ixUpper) * 0.5_rkind/max(iLayerDiffuse,verySmall) - ! derivatives in the flux w.r.t. volumetric liquid water content - dq_dHydStateAbove = -dDiffuseIface_dVolLiqAbove*dLiq/dz + iLayerDiffuse/dz + dHydCondIface_dVolLiqAbove - dq_dHydStateBelow = -dDiffuseIface_dVolLiqBelow*dLiq/dz - iLayerDiffuse/dz + dHydCondIface_dVolLiqBelow - case(mixdform) - ! derivatives in hydraulic conductivity - if(useGeometric)then - dHydCondIface_dMatricAbove = dHydCond_dMatric(ixUpper)*nodeHydCondTrial(ixLower) * 0.5_rkind/max(iLayerHydCond,verySmall) - dHydCondIface_dMatricBelow = dHydCond_dMatric(ixLower)*nodeHydCondTrial(ixUpper) * 0.5_rkind/max(iLayerHydCond,verySmall) - else - dHydCondIface_dMatricAbove = dHydCond_dMatric(ixUpper)/2._rkind - dHydCondIface_dMatricBelow = dHydCond_dMatric(ixLower)/2._rkind - end if - ! derivatives in the flux w.r.t. matric head - dq_dHydStateAbove = -dHydCondIface_dMatricAbove*dPsi/dz + iLayerHydCond/dz + dHydCondIface_dMatricAbove - dq_dHydStateBelow = -dHydCondIface_dMatricBelow*dPsi/dz - iLayerHydCond/dz + dHydCondIface_dMatricBelow - ! derivative in the flux w.r.t. temperature - dq_dNrgStateAbove = -(dHydCond_dTemp(ixUpper)/2._rkind)*dPsi/dz + iLayerHydCond*dPsiLiq_dTemp(ixUpper)/dz + dHydCond_dTemp(ixUpper)/2._rkind - dq_dNrgStateBelow = -(dHydCond_dTemp(ixLower)/2._rkind)*dPsi/dz - iLayerHydCond*dPsiLiq_dTemp(ixLower)/dz + dHydCond_dTemp(ixLower)/2._rkind - case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return - end select - else - dq_dHydStateAbove = realMissing - dq_dHydStateBelow = realMissing - end if - - end subroutine iLayerFlux - - - ! *************************************************************************************************************** - ! private subroutine qDrainFlux: compute the drainage flux from the bottom of the soil profile and its derivative - ! *************************************************************************************************************** - subroutine qDrainFlux(& - ! input: model control - deriv_desired, & ! intent(in): flag indicating if derivatives are desired - ixRichards, & ! intent(in): index defining the form of Richards' equation (moisture or mixdform) - bc_lower, & ! intent(in): index defining the type of boundary conditions - ! input: state variables - nodeMatricHead, & ! intent(in): matric head in the lowest unsaturated node (m) - nodeVolFracLiq, & ! intent(in): volumetric liquid water content the lowest unsaturated node (-) - ! input: model coordinate variables - nodeDepth, & ! intent(in): depth of the lowest unsaturated soil layer (m) - nodeHeight, & ! intent(in): height of the lowest unsaturated soil node (m) - ! input: boundary conditions - lowerBoundHead, & ! intent(in): lower boundary condition (m) - lowerBoundTheta, & ! intent(in): lower boundary condition (-) - ! input: derivative in soil water characteristix - node__dPsi_dTheta, & ! intent(in): derivative of the soil moisture characteristic w.r.t. theta (m) - ! input: transmittance - surfaceSatHydCond, & ! intent(in): saturated hydraulic conductivity at the surface (m s-1) - bottomSatHydCond, & ! intent(in): saturated hydraulic conductivity at the bottom of the unsaturated zone (m s-1) - nodeHydCond, & ! intent(in): hydraulic conductivity at the node itself (m s-1) - iceImpedeFac, & ! intent(in): ice impedence factor in the lower-most soil layer (-) - ! input: transmittance derivatives - dHydCond_dVolLiq, & ! intent(in): derivative in hydraulic conductivity w.r.t. volumetric liquid water content (m s-1) - dHydCond_dMatric, & ! intent(in): derivative in hydraulic conductivity w.r.t. matric head (s-1) - dHydCond_dTemp, & ! intent(in): derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) - ! input: soil parameters - vGn_alpha, & ! intent(in): van Genutchen "alpha" parameter (m-1) - vGn_n, & ! intent(in): van Genutchen "n" parameter (-) - VGn_m, & ! intent(in): van Genutchen "m" parameter (-) - theta_sat, & ! intent(in): soil porosity (-) - theta_res, & ! intent(in): soil residual volumetric water content (-) - kAnisotropic, & ! intent(in): anisotropy factor for lateral hydraulic conductivity (-) - zScale_TOPMODEL, & ! intent(in): TOPMODEL scaling factor (m) - ! output: hydraulic conductivity and diffusivity at the surface - bottomHydCond, & ! intent(out): hydraulic conductivity at the bottom of the unsatuarted zone (m s-1) - bottomDiffuse, & ! intent(out): hydraulic diffusivity at the bottom of the unsatuarted zone (m2 s-1) - ! output: drainage flux from the bottom of the soil profile - scalarDrainage, & ! intent(out): drainage flux from the bottom of the soil profile (m s-1) - ! output: derivatives in drainage flux - dq_dHydStateUnsat, & ! intent(out): change in drainage flux w.r.t. change in hydrology state variable in lowest unsaturated node (m s-1 or s-1) - dq_dNrgStateUnsat, & ! intent(out): change in drainage flux w.r.t. change in energy state variable in lowest unsaturated node (m s-1 K-1) - ! output: error control - err,message) ! intent(out): error control - USE soil_utils_module,only:volFracLiq ! compute volumetric fraction of liquid water as a function of matric head (-) - USE soil_utils_module,only:matricHead ! compute matric head as a function of volumetric fraction of liquid water (m) - USE soil_utils_module,only:hydCond_psi ! compute hydraulic conductivity as a function of matric head (m s-1) - USE soil_utils_module,only:hydCond_liq ! compute hydraulic conductivity as a function of volumetric liquid water content (m s-1) - USE soil_utils_module,only:dPsi_dTheta ! compute derivative of the soil moisture characteristic w.r.t. theta (m) - ! compute infiltraton at the surface and its derivative w.r.t. mass in the upper soil layer - implicit none - ! ----------------------------------------------------------------------------------------------------------------------------- - ! input: model control - logical(lgt),intent(in) :: deriv_desired ! flag to indicate if derivatives are desired - integer(i4b),intent(in) :: ixRichards ! index defining the option for Richards' equation (moisture or mixdform) - integer(i4b),intent(in) :: bc_lower ! index defining the type of boundary conditions - ! input: state and diagnostic variables - real(rkind),intent(in) :: nodeMatricHead ! matric head in the lowest unsaturated node (m) - real(rkind),intent(in) :: nodeVolFracLiq ! volumetric liquid water content in the lowest unsaturated node (-) - ! input: model coordinate variables - real(rkind),intent(in) :: nodeDepth ! depth of the lowest unsaturated soil layer (m) - real(rkind),intent(in) :: nodeHeight ! height of the lowest unsaturated soil node (m) - ! input: diriclet boundary conditions - real(rkind),intent(in) :: lowerBoundHead ! lower boundary condition for matric head (m) - real(rkind),intent(in) :: lowerBoundTheta ! lower boundary condition for volumetric liquid water content (-) - ! input: derivative in soil water characteristix - real(rkind),intent(in) :: node__dPsi_dTheta ! derivative of the soil moisture characteristic w.r.t. theta (m) - ! input: transmittance - real(rkind),intent(in) :: surfaceSatHydCond ! saturated hydraulic conductivity at the surface (m s-1) - real(rkind),intent(in) :: bottomSatHydCond ! saturated hydraulic conductivity at the bottom of the unsaturated zone (m s-1) - real(rkind),intent(in) :: nodeHydCond ! hydraulic conductivity at the node itself (m s-1) - real(rkind),intent(in) :: iceImpedeFac ! ice impedence factor in the upper-most soil layer (-) - ! input: transmittance derivatives - real(rkind),intent(in) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t. volumetric liquid water content (m s-1) - real(rkind),intent(in) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t. matric head (s-1) - real(rkind),intent(in) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) - ! input: soil parameters - real(rkind),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) - real(rkind),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) - real(rkind),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) - real(rkind),intent(in) :: theta_sat ! soil porosity (-) - real(rkind),intent(in) :: theta_res ! soil residual volumetric water content (-) - real(rkind),intent(in) :: kAnisotropic ! anisotropy factor for lateral hydraulic conductivity (-) - real(rkind),intent(in) :: zScale_TOPMODEL ! scale factor for TOPMODEL-ish baseflow parameterization (m) - ! ----------------------------------------------------------------------------------------------------------------------------- - ! output: hydraulic conductivity at the bottom of the unsaturated zone - real(rkind),intent(out) :: bottomHydCond ! hydraulic conductivity at the bottom of the unsaturated zone (m s-1) - real(rkind),intent(out) :: bottomDiffuse ! hydraulic diffusivity at the bottom of the unsatuarted zone (m2 s-1) - ! output: drainage flux from the bottom of the soil profile - real(rkind),intent(out) :: scalarDrainage ! drainage flux from the bottom of the soil profile (m s-1) - ! output: derivatives in drainage flux - real(rkind),intent(out) :: dq_dHydStateUnsat ! change in drainage flux w.r.t. change in state variable in lowest unsaturated node (m s-1 or s-1) - real(rkind),intent(out) :: dq_dNrgStateUnsat ! change in drainage flux w.r.t. change in energy state variable in lowest unsaturated node (m s-1 K-1) - ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! ----------------------------------------------------------------------------------------------------------------------------- - ! local variables - real(rkind) :: zWater ! effective water table depth (m) - real(rkind) :: nodePsi ! matric head in the lowest unsaturated node (m) - real(rkind) :: cflux ! capillary flux (m s-1) - ! ----------------------------------------------------------------------------------------------------------------------------- - ! initialize error control - err=0; message="qDrainFlux/" - - ! determine lower boundary condition - select case(bc_lower) - - ! --------------------------------------------------------------------------------------------- - ! * prescribed head - ! --------------------------------------------------------------------------------------------- - case(prescribedHead) - - ! compute fluxes - select case(ixRichards) ! (moisture-based form of Richards' equation) - case(moisture) - ! compute the hydraulic conductivity and diffusivity at the boundary - bottomHydCond = hydCond_liq(lowerBoundTheta,bottomSatHydCond,theta_res,theta_sat,vGn_m) * iceImpedeFac - bottomDiffuse = dPsi_dTheta(lowerBoundTheta,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) * bottomHydCond - ! compute the capillary flux - cflux = -bottomDiffuse*(lowerBoundTheta - nodeVolFracLiq) / (nodeDepth*0.5_rkind) - case(mixdform) - ! compute the hydraulic conductivity and diffusivity at the boundary - bottomHydCond = hydCond_psi(lowerBoundHead,bottomSatHydCond,vGn_alpha,vGn_n,vGn_m) * iceImpedeFac - bottomDiffuse = realMissing - ! compute the capillary flux - cflux = -bottomHydCond*(lowerBoundHead - nodeMatricHead) / (nodeDepth*0.5_rkind) - case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return - end select ! (form of Richards' eqn) - scalarDrainage = cflux + bottomHydCond +contains - ! compute derivatives - if(deriv_desired)then - ! hydrology derivatives - select case(ixRichards) ! (form of Richards' equation) - case(moisture); dq_dHydStateUnsat = bottomDiffuse/(nodeDepth/2._rkind) - case(mixdform); dq_dHydStateUnsat = bottomHydCond/(nodeDepth/2._rkind) - case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return - end select - ! energy derivatives - dq_dNrgStateUnsat = -(dHydCond_dTemp/2._rkind)*(lowerBoundHead - nodeMatricHead)/(nodeDepth*0.5_rkind) + dHydCond_dTemp/2._rkind - else ! (do not desire derivatives) - dq_dHydStateUnsat = realMissing - dq_dNrgStateUnsat = realMissing + subroutine initialize_iLayerFlux + ! **** Initialize operations for iLayerFlux **** + return_flag=.false. ! initialize return flag + associate(& + err => out_iLayerFlux % err , & ! error code + message => out_iLayerFlux % message & ! error message + &) + ! initialize error control + err=0; message="iLayerFlux/" ! initialize error control + end associate + end subroutine initialize_iLayerFlux + + subroutine update_iLayerFlux + ! **** Update operations for iLayerFlux **** + + ! ** compute the fluxes + call update_iLayerFlux_fluxes; if (return_flag) return + + ! ** compute the derivatives + call update_iLayerFlux_derivatives; if (return_flag) return + + end subroutine update_iLayerFlux + + subroutine update_iLayerFlux_fluxes + ! **** Update operations for iLayerFlux: compute fluxes **** + associate(& + ! input: model control + ixRichards => in_iLayerFlux % ixRichards , & ! index defining the option for Richards' equation (moisture or mixdform) + ! input: state variables + nodeMatricHeadLiqTrial => in_iLayerFlux % nodeMatricHeadLiqTrial, & ! liquid matric head at the soil nodes (m) + nodeVolFracLiqTrial => in_iLayerFlux % nodeVolFracLiqTrial , & ! volumetric fraction of liquid water at the soil nodes (-) + ! input: model coordinate variables + nodeHeight => in_iLayerFlux % nodeHeight, & ! height at the mid-point of the lower layer (m) + ! input: transmittance + nodeHydCondTrial => in_iLayerFlux % nodeHydCondTrial, & ! hydraulic conductivity at layer mid-points (m s-1) + nodeDiffuseTrial => in_iLayerFlux % nodeDiffuseTrial, & ! diffusivity at layer mid-points (m2 s-1) + ! output: tranmsmittance at the layer interface (scalars) + iLayerHydCond => out_iLayerFlux % iLayerHydCond, & ! hydraulic conductivity at the interface between layers (m s-1) + iLayerDiffuse => out_iLayerFlux % iLayerDiffuse, & ! hydraulic diffusivity at the interface between layers (m2 s-1) + ! output: vertical flux at the layer interface (scalars) + iLayerLiqFluxSoil => out_iLayerFlux % iLayerLiqFluxSoil, & ! vertical flux of liquid water at the layer interface (m s-1) + ! output: error control + err => out_iLayerFlux % err , & ! error code + message => out_iLayerFlux % message & ! error message + &) + + ! compute the vertical flux of liquid water + ! compute the hydraulic conductivity at the interface + if (useGeometric) then + iLayerHydCond = sqrt(nodeHydCondTrial(ixLower) * nodeHydCondTrial(ixUpper)) + else + iLayerHydCond = (nodeHydCondTrial(ixLower) + nodeHydCondTrial(ixUpper))*0.5_rkind end if + + dz = nodeHeight(ixLower) - nodeHeight(ixUpper) + ! compute the capillary flux + select case(ixRichards) ! select form of Richards' equation + case(moisture) + iLayerDiffuse = sqrt(nodeDiffuseTrial(ixLower) * nodeDiffuseTrial(ixUpper)) + dLiq = nodeVolFracLiqTrial(ixLower) - nodeVolFracLiqTrial(ixUpper) + cflux = -iLayerDiffuse * dLiq/dz + case(mixdform) + iLayerDiffuse = realMissing + dPsi = nodeMatricHeadLiqTrial(ixLower) - nodeMatricHeadLiqTrial(ixUpper) + cflux = -iLayerHydCond * dPsi/dz + case default; err=10; message=trim(message)//"unable to identify option for Richards' equation"; return_flag=.true.; return + end select + ! compute the total flux (add gravity flux, positive downwards) + iLayerLiqFluxSoil = cflux + iLayerHydCond + + end associate + end subroutine update_iLayerFlux_fluxes + + subroutine update_iLayerFlux_derivatives + ! **** Update operations for iLayerFlux: compute derivatives **** + ! * local variables (derivative in Darcy's flux) * + ! deriviatives at the layer interface + real(rkind) :: dHydCondIface_dVolLiqAbove ! hydraulic conductivity w.r.t. volumetric liquid water content in layer above + real(rkind) :: dHydCondIface_dVolLiqBelow ! hydraulic conductivity w.r.t. volumetric liquid water content in layer below + real(rkind) :: dDiffuseIface_dVolLiqAbove ! hydraulic diffusivity w.r.t. volumetric liquid water content in layer above + real(rkind) :: dDiffuseIface_dVolLiqBelow ! hydraulic diffusivity w.r.t. volumetric liquid water content in layer below + real(rkind) :: dHydCondIface_dMatricAbove ! hydraulic conductivity w.r.t. matric head in layer above + real(rkind) :: dHydCondIface_dMatricBelow ! hydraulic conductivity w.r.t. matric head in layer below + associate(& + ! input: model control + ixRichards => in_iLayerFlux % ixRichards , & ! index defining the option for Richards' equation (moisture or mixdform) + ! input: temperature derivatives + dPsiLiq_dTemp => in_iLayerFlux % dPsiLiq_dTemp , & ! derivative in liquid water matric potential w.r.t. temperature (m K-1) + dHydCond_dTemp => in_iLayerFlux % dHydCond_dTemp, & ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + ! input: transmittance + nodeHydCondTrial => in_iLayerFlux % nodeHydCondTrial, & ! hydraulic conductivity at layer mid-points (m s-1) + nodeDiffuseTrial => in_iLayerFlux % nodeDiffuseTrial, & ! diffusivity at layer mid-points (m2 s-1) + ! input: transmittance derivatives + dHydCond_dVolLiq => in_iLayerFlux % dHydCond_dVolLiq, & ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) + dDiffuse_dVolLiq => in_iLayerFlux % dDiffuse_dVolLiq, & ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) + dHydCond_dMatric => in_iLayerFlux % dHydCond_dMatric, & ! derivative in hydraulic conductivity w.r.t matric head (m s-1) + ! output: tranmsmittance at the layer interface (scalars) + iLayerHydCond => out_iLayerFlux % iLayerHydCond, & ! hydraulic conductivity at the interface between layers (m s-1) + iLayerDiffuse => out_iLayerFlux % iLayerDiffuse, & ! hydraulic diffusivity at the interface between layers (m2 s-1) + ! output: derivatives in fluxes w.r.t. ... + dq_dHydStateAbove => out_iLayerFlux % dq_dHydStateAbove, & ! ... matric head or volumetric liquid water in the layer above (m s-1 or s-1) + dq_dHydStateBelow => out_iLayerFlux % dq_dHydStateBelow, & ! ... matric head or volumetric liquid water in the layer below (m s-1 or s-1) + ! output: derivatives in fluxes w.r.t. energy state variables -- now just temperature -- in the layer above and layer below (m s-1 K-1) + dq_dNrgStateAbove => out_iLayerFlux % dq_dNrgStateAbove, & ! derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) + dq_dNrgStateBelow => out_iLayerFlux % dq_dNrgStateBelow, & ! derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) + ! output: error control + err => out_iLayerFlux % err , & ! error code + message => out_iLayerFlux % message & ! error message + &) + + select case(ixRichards) ! select form of Richards' equation + case(moisture) + ! still need to implement arithmetric mean for the moisture-based form + if (.not.useGeometric) then + err=20; message=trim(message)//'only currently implemented for geometric mean -- change local flag'; return_flag=.true.; return + end if + ! derivatives in hydraulic conductivity at the layer interface (m s-1) + dHydCondIface_dVolLiqAbove = dHydCond_dVolLiq(ixUpper)*nodeHydCondTrial(ixLower) * 0.5_rkind/max(iLayerHydCond,verySmaller) + dHydCondIface_dVolLiqBelow = dHydCond_dVolLiq(ixLower)*nodeHydCondTrial(ixUpper) * 0.5_rkind/max(iLayerHydCond,verySmaller) + ! derivatives in hydraulic diffusivity at the layer interface (m2 s-1) + dDiffuseIface_dVolLiqAbove = dDiffuse_dVolLiq(ixUpper)*nodeDiffuseTrial(ixLower) * 0.5_rkind/max(iLayerDiffuse,verySmaller) + dDiffuseIface_dVolLiqBelow = dDiffuse_dVolLiq(ixLower)*nodeDiffuseTrial(ixUpper) * 0.5_rkind/max(iLayerDiffuse,verySmaller) + ! derivatives in the flux w.r.t. volumetric liquid water content + dq_dHydStateAbove = -dDiffuseIface_dVolLiqAbove*dLiq/dz + iLayerDiffuse/dz + dHydCondIface_dVolLiqAbove + dq_dHydStateBelow = -dDiffuseIface_dVolLiqBelow*dLiq/dz - iLayerDiffuse/dz + dHydCondIface_dVolLiqBelow + case(mixdform) + ! derivatives in hydraulic conductivity + if (useGeometric) then + dHydCondIface_dMatricAbove = dHydCond_dMatric(ixUpper)*nodeHydCondTrial(ixLower) * 0.5_rkind/max(iLayerHydCond,verySmaller) + dHydCondIface_dMatricBelow = dHydCond_dMatric(ixLower)*nodeHydCondTrial(ixUpper) * 0.5_rkind/max(iLayerHydCond,verySmaller) + else + dHydCondIface_dMatricAbove = dHydCond_dMatric(ixUpper)/2._rkind + dHydCondIface_dMatricBelow = dHydCond_dMatric(ixLower)/2._rkind + end if + ! derivatives in the flux w.r.t. matric head + dq_dHydStateAbove = -dHydCondIface_dMatricAbove*dPsi/dz + iLayerHydCond/dz + dHydCondIface_dMatricAbove + dq_dHydStateBelow = -dHydCondIface_dMatricBelow*dPsi/dz - iLayerHydCond/dz + dHydCondIface_dMatricBelow + ! derivative in the flux w.r.t. temperature + dq_dNrgStateAbove = -(dHydCond_dTemp(ixUpper)/2._rkind)*dPsi/dz + iLayerHydCond*dPsiLiq_dTemp(ixUpper)/dz + dHydCond_dTemp(ixUpper)/2._rkind + dq_dNrgStateBelow = -(dHydCond_dTemp(ixLower)/2._rkind)*dPsi/dz - iLayerHydCond*dPsiLiq_dTemp(ixLower)/dz + dHydCond_dTemp(ixLower)/2._rkind + case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return_flag=.true.; return + end select - ! --------------------------------------------------------------------------------------------- - ! * function of matric head in the bottom layer - ! --------------------------------------------------------------------------------------------- - case(funcBottomHead) + end associate + end subroutine update_iLayerFlux_derivatives + + subroutine finalize_iLayerFlux + ! **** Finalize operations for iLayerFlux **** + associate(& + err => out_iLayerFlux % err , & ! error code + message => out_iLayerFlux % message & ! error message + &) + ! final error check + if(err/=0)then; message=trim(message)//'unanticipated error in iLayerFlux'; return_flag=.true.; return; end if + end associate + end subroutine finalize_iLayerFlux + +end subroutine iLayerFlux + +! *************************************************************************************************************** +! private subroutine qDrainFlux: compute the drainage flux from the bottom of the soil profile and its derivative +! *************************************************************************************************************** +subroutine qDrainFlux(in_qDrainFlux,out_qDrainFlux) + USE soil_utils_module,only:volFracLiq ! compute volumetric fraction of liquid water as a function of matric head (-) + USE soil_utils_module,only:matricHead ! compute matric head as a function of volumetric fraction of liquid water (m) + USE soil_utils_module,only:hydCond_psi ! compute hydraulic conductivity as a function of matric head (m s-1) + USE soil_utils_module,only:hydCond_liq ! compute hydraulic conductivity as a function of volumetric liquid water content (m s-1) + USE soil_utils_module,only:dPsi_dTheta ! compute derivative of the soil moisture characteristic w.r.t. theta (m) + ! compute infiltraton at the surface and its derivative w.r.t. mass in the upper soil layer + implicit none + ! ----------------------------------------------------------------------------------------------------------------------------- + ! input: model control, variables, boundary conditions, transmittance variables, and soil parameters + type(in_type_qDrainFlux) ,intent(in) :: in_qDrainFlux ! object for qDrainFlux input data + ! output: hydraulic conductivity and diffusivity, drainage fluxes and derivatives, and error control + type(out_type_qDrainFlux),intent(out) :: out_qDrainFlux ! object for qDrainFlux output data + ! ----------------------------------------------------------------------------------------------------------------------------- + ! local variables + real(rkind) :: zWater ! effective water table depth (m) + real(rkind) :: nodePsi ! matric head in the lowest unsaturated node (m) + real(rkind) :: cflux ! capillary flux (m s-1) + ! error control + logical(lgt) :: return_flag ! flag for return statements + ! ----------------------------------------------------------------------------------------------------------------------------- + + call initialize_qDrainFlux + + call update_qDrainFlux; if (return_flag) return + + call finalize_qDrainFlux; if (return_flag) return - ! compute fluxes +contains + + subroutine initialize_qDrainFlux + ! ** Initialize operations for qDrainFlux ** + return_flag=.false. ! initialize return flag + associate(& + ! output: error control + err => out_qDrainFlux % err , & ! error code + message => out_qDrainFlux % message & ! error message + &) + ! initialize error control + err=0; message="qDrainFlux/" + end associate + end subroutine initialize_qDrainFlux + + subroutine update_qDrainFlux + ! ** Update operations for qDrainFlux ** + associate(& + ! input: model control + bc_lower => in_qDrainFlux % bc_lower, & ! index defining the type of boundary conditions + ! output: error control + err => out_qDrainFlux % err , & ! error code + message => out_qDrainFlux % message & ! error message + &) + + ! determine lower boundary condition + select case(bc_lower) + case(prescribedHead) ! specified matric head value + call update_qDrainFlux_prescribedHead; if (return_flag) return + case(funcBottomHead) ! specified matric head function + call update_qDrainFlux_funcBottomHead; if (return_flag) return + case(freeDrainage) ! free drainage + call update_qDrainFlux_freeDrainage; if (return_flag) return + case(zeroFlux) ! zero flux + call update_qDrainFlux_zeroFlux; if (return_flag) return + case default; err=20; message=trim(message)//'unknown lower boundary condition for soil hydrology'; return_flag=.true.; return + end select + + end associate + end subroutine update_qDrainFlux + + subroutine update_qDrainFlux_prescribedHead + ! ** Update operations for qDrainFlux: prescribed pressure head value at bottom boundary ** + associate(& + ! input: model control + ixRichards => in_qDrainFlux % ixRichards , & ! index defining the option for Richards' equation (moisture or mixdform) + ! input: state and diagnostic variables + nodeMatricHeadLiq => in_qDrainFlux % nodeMatricHeadLiq, & ! liquid matric head in the lowest unsaturated node (m) + nodeVolFracLiq => in_qDrainFlux % nodeVolFracLiq , & ! volumetric liquid water content in the lowest unsaturated node (-) + ! input: model coordinate variables + nodeDepth => in_qDrainFlux % nodeDepth , & ! depth of the lowest unsaturated soil layer (m) + ! input: diriclet boundary conditions + lowerBoundHead => in_qDrainFlux % lowerBoundHead , & ! lower boundary condition for matric head (m) + lowerBoundTheta => in_qDrainFlux % lowerBoundTheta, & ! lower boundary condition for volumetric liquid water content (-) + ! input: transmittance + bottomSatHydCond => in_qDrainFlux % bottomSatHydCond , & ! saturated hydraulic conductivity at the bottom of the unsaturated zone (m s-1) + iceImpedeFac => in_qDrainFlux % iceImpedeFac , & ! ice impedence factor in the upper-most soil layer (-) + ! input: transmittance derivatives + dHydCond_dTemp => in_qDrainFlux % dHydCond_dTemp , & ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + ! input: soil parameters + vGn_alpha => in_qDrainFlux % vGn_alpha , & ! van Genuchten "alpha" parameter (m-1) + vGn_n => in_qDrainFlux % vGn_n , & ! van Genuchten "n" parameter (-) + vGn_m => in_qDrainFlux % vGn_m , & ! van Genuchten "m" parameter (-) + theta_sat => in_qDrainFlux % theta_sat , & ! soil porosity (-) + theta_res => in_qDrainFlux % theta_res , & ! soil residual volumetric water content (-) + ! output: hydraulic conductivity at the bottom of the unsaturated zone + bottomHydCond => out_qDrainFlux % bottomHydCond, & ! hydraulic conductivity at the bottom of the unsaturated zone (m s-1) + bottomDiffuse => out_qDrainFlux % bottomDiffuse, & ! hydraulic diffusivity at the bottom of the unsatuarted zone (m2 s-1) + ! output: drainage flux from the bottom of the soil profile + scalarDrainage => out_qDrainFlux % scalarDrainage, & ! drainage flux from the bottom of the soil profile (m s-1) + ! output: derivatives in drainage flux w.r.t. ... + dq_dHydStateUnsat => out_qDrainFlux % dq_dHydStateUnsat, & ! ... state variable in lowest unsaturated node (m s-1 or s-1) + dq_dNrgStateUnsat => out_qDrainFlux % dq_dNrgStateUnsat, & ! ... energy state variable in lowest unsaturated node (m s-1 K-1) + ! output: error control + err => out_qDrainFlux % err , & ! error code + message => out_qDrainFlux % message & ! error message + &) + + ! compute flux select case(ixRichards) - case(moisture); nodePsi = matricHead(nodeVolFracLiq,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) - case(mixdform); nodePsi = nodeMatricHead + case(moisture) ! moisture-based form of Richards' equation + ! compute the hydraulic conductivity and diffusivity at the boundary + bottomHydCond = hydCond_liq(lowerBoundTheta,bottomSatHydCond,theta_res,theta_sat,vGn_m) * iceImpedeFac + bottomDiffuse = dPsi_dTheta(lowerBoundTheta,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) * bottomHydCond + ! compute the capillary flux + cflux = -bottomDiffuse*(lowerBoundTheta - nodeVolFracLiq) / (nodeDepth*0.5_rkind) + case(mixdform) ! mixed form of Richards' equation + ! compute the hydraulic conductivity and diffusivity at the boundary + bottomHydCond = hydCond_psi(lowerBoundHead,bottomSatHydCond,vGn_alpha,vGn_n,vGn_m) * iceImpedeFac + bottomDiffuse = realMissing + ! compute the capillary flux + cflux = -bottomHydCond*(lowerBoundHead - nodeMatricHeadLiq) / (nodeDepth*0.5_rkind) + case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return_flag=.true.; return + end select + scalarDrainage = cflux + bottomHydCond + + ! hydrology derivatives + select case(ixRichards) ! select form of Richards' equation + case(moisture); dq_dHydStateUnsat = bottomDiffuse/(nodeDepth/2._rkind) + case(mixdform); dq_dHydStateUnsat = bottomHydCond/(nodeDepth/2._rkind) + case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return_flag=.true.; return + end select + ! energy derivatives + dq_dNrgStateUnsat = -(dHydCond_dTemp/2._rkind)*(lowerBoundHead - nodeMatricHeadLiq)/(nodeDepth*0.5_rkind)& + & + dHydCond_dTemp/2._rkind + + end associate + end subroutine update_qDrainFlux_prescribedHead + + subroutine update_qDrainFlux_funcBottomHead + ! ** Update operations for qDrainFlux: prescribed pressure head function at bottom boundary ** + associate(& + ! input: model control + ixRichards => in_qDrainFlux % ixRichards , & ! index defining the option for Richards' equation (moisture or mixdform) + ! input: state and diagnostic variables + nodeMatricHeadLiq => in_qDrainFlux % nodeMatricHeadLiq, & ! liquid matric head in the lowest unsaturated node (m) + nodeVolFracLiq => in_qDrainFlux % nodeVolFracLiq , & ! volumetric liquid water content in the lowest unsaturated node (-) + ! input: model coordinate variables + nodeHeight => in_qDrainFlux % nodeHeight, & ! height of the lowest unsaturated soil node (m) + ! input: derivative in soil water characteristic + node_dPsi_dTheta => in_qDrainFlux % node_dPsi_dTheta , & ! derivative of the soil moisture characteristic w.r.t. theta (m) + node_dPsiLiq_dTemp => in_qDrainFlux % node_dPsiLiq_dTemp , & ! derivative in liquid water matric potential w.r.t. temperature (m K-1) + ! input: transmittance + surfaceSatHydCond => in_qDrainFlux % surfaceSatHydCond, & ! saturated hydraulic conductivity at the surface (m s-1) + ! input: soil parameters + vGn_alpha => in_qDrainFlux % vGn_alpha , & ! van Genuchten "alpha" parameter (m-1) + vGn_n => in_qDrainFlux % vGn_n , & ! van Genuchten "n" parameter (-) + vGn_m => in_qDrainFlux % vGn_m , & ! van Genuchten "m" parameter (-) + theta_sat => in_qDrainFlux % theta_sat , & ! soil porosity (-) + theta_res => in_qDrainFlux % theta_res , & ! soil residual volumetric water content (-) + kAnisotropic => in_qDrainFlux % kAnisotropic , & ! anisotropy factor for lateral hydraulic conductivity (-) + zScale_TOPMODEL => in_qDrainFlux % zScale_TOPMODEL, & ! scale factor for TOPMODEL-ish baseflow parameterization (m) + ! output: drainage flux from the bottom of the soil profile + scalarDrainage => out_qDrainFlux % scalarDrainage, & ! drainage flux from the bottom of the soil profile (m s-1) + ! output: derivatives in drainage flux w.r.t. ... + dq_dHydStateUnsat => out_qDrainFlux % dq_dHydStateUnsat, & ! ... state variable in lowest unsaturated node (m s-1 or s-1) + dq_dNrgStateUnsat => out_qDrainFlux % dq_dNrgStateUnsat, & ! ... energy state variable in lowest unsaturated node (m s-1 K-1) + ! output: error control + err => out_qDrainFlux % err , & ! error code + message => out_qDrainFlux % message & ! error message + &) + + ! compute flux + select case(ixRichards) ! select form of Richards' equation + case(moisture); nodePsi = matricHead(nodeVolFracLiq,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) + case(mixdform); nodePsi = nodeMatricHeadLiq end select zWater = nodeHeight - nodePsi scalarDrainage = kAnisotropic*surfaceSatHydCond * exp(-zWater/zScale_TOPMODEL) - ! compute derivatives - if(deriv_desired)then - ! hydrology derivatives - select case(ixRichards) ! (form of Richards' equation) - case(moisture); dq_dHydStateUnsat = kAnisotropic*surfaceSatHydCond * node__dPsi_dTheta*exp(-zWater/zScale_TOPMODEL)/zScale_TOPMODEL + ! hydrology derivatives + select case(ixRichards) ! select form of Richards' equation + case(moisture); dq_dHydStateUnsat = kAnisotropic*surfaceSatHydCond * node_dPsi_dTheta*exp(-zWater/zScale_TOPMODEL)/zScale_TOPMODEL case(mixdform); dq_dHydStateUnsat = kAnisotropic*surfaceSatHydCond * exp(-zWater/zScale_TOPMODEL)/zScale_TOPMODEL - case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return - end select - ! energy derivatives - err=20; message=trim(message)//"not yet implemented energy derivatives"; return - else ! (do not desire derivatives) - dq_dHydStateUnsat = realMissing - dq_dNrgStateUnsat = realMissing - end if - - ! --------------------------------------------------------------------------------------------- - ! * free drainage - ! --------------------------------------------------------------------------------------------- - case(freeDrainage) - - ! compute flux - scalarDrainage = nodeHydCond*kAnisotropic - - ! compute derivatives - if(deriv_desired)then - ! hydrology derivatives - select case(ixRichards) ! (form of Richards' equation) + case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return_flag=.true.; return + end select + ! energy derivatives + dq_dNrgStateUnsat = kAnisotropic*surfaceSatHydCond * exp(-zWater/zScale_TOPMODEL)*node_dPsiLiq_dTemp/zScale_TOPMODEL + + end associate + end subroutine update_qDrainFlux_funcBottomHead + + subroutine update_qDrainFlux_freeDrainage + ! ** Update operations for qDrainFlux: free drainage at bottom boundary ** + associate(& + ! input: model control + ixRichards => in_qDrainFlux % ixRichards , & ! index defining the option for Richards' equation (moisture or mixdform) + ! input: transmittance + nodeHydCond => in_qDrainFlux % nodeHydCond , & ! hydraulic conductivity at the node itself (m s-1) + ! input: transmittance derivatives + dHydCond_dVolLiq => in_qDrainFlux % dHydCond_dVolLiq, & ! derivative in hydraulic conductivity w.r.t. volumetric liquid water content (m s-1) + dHydCond_dMatric => in_qDrainFlux % dHydCond_dMatric, & ! derivative in hydraulic conductivity w.r.t. matric head (s-1) + dHydCond_dTemp => in_qDrainFlux % dHydCond_dTemp , & ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + ! input: soil parameters + kAnisotropic => in_qDrainFlux % kAnisotropic , & ! anisotropy factor for lateral hydraulic conductivity (-) + ! output: drainage flux from the bottom of the soil profile + scalarDrainage => out_qDrainFlux % scalarDrainage, & ! drainage flux from the bottom of the soil profile (m s-1) + ! output: derivatives in drainage flux w.r.t. ... + dq_dHydStateUnsat => out_qDrainFlux % dq_dHydStateUnsat, & ! ... state variable in lowest unsaturated node (m s-1 or s-1) + dq_dNrgStateUnsat => out_qDrainFlux % dq_dNrgStateUnsat, & ! ... energy state variable in lowest unsaturated node (m s-1 K-1) + ! output: error control + err => out_qDrainFlux % err , & ! error code + message => out_qDrainFlux % message & ! error message + &) + + scalarDrainage = nodeHydCond*kAnisotropic ! compute flux + + ! hydrology derivatives + select case(ixRichards) ! select form of Richards' equation case(moisture); dq_dHydStateUnsat = dHydCond_dVolLiq*kAnisotropic case(mixdform); dq_dHydStateUnsat = dHydCond_dMatric*kAnisotropic - case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return - end select - ! energy derivatives - dq_dNrgStateUnsat = dHydCond_dTemp*kAnisotropic - else ! (do not desire derivatives) - dq_dHydStateUnsat = realMissing - dq_dNrgStateUnsat = realMissing - end if - + case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return_flag=.true.; return + end select + ! energy derivatives + dq_dNrgStateUnsat = dHydCond_dTemp*kAnisotropic + + end associate + end subroutine update_qDrainFlux_freeDrainage + + subroutine update_qDrainFlux_zeroFlux + ! ** Update operations for qDrainFlux: zero flux condition at bottom boundary ** + associate(& + ! output: drainage flux from the bottom of the soil profile + scalarDrainage => out_qDrainFlux % scalarDrainage, & ! drainage flux from the bottom of the soil profile (m s-1) + ! output: derivatives in drainage flux w.r.t. ... + dq_dHydStateUnsat => out_qDrainFlux % dq_dHydStateUnsat, & ! ... state variable in lowest unsaturated node (m s-1 or s-1) + dq_dNrgStateUnsat => out_qDrainFlux % dq_dNrgStateUnsat & ! ... energy state variable in lowest unsaturated node (m s-1 K-1) + &) - ! --------------------------------------------------------------------------------------------- - ! * zero flux - ! --------------------------------------------------------------------------------------------- - case(zeroFlux) scalarDrainage = 0._rkind - if(deriv_desired)then - dq_dHydStateUnsat = 0._rkind - dq_dNrgStateUnsat = 0._rkind - else - dq_dHydStateUnsat = realMissing - dq_dNrgStateUnsat = realMissing - end if - - ! --------------------------------------------------------------------------------------------- - ! * error check - ! --------------------------------------------------------------------------------------------- - case default; err=20; message=trim(message)//'unknown lower boundary condition for soil hydrology'; return - - end select ! (type of boundary condition) - - end subroutine qDrainFlux - - - ! ******************************************************************************************************************************************************************************* - ! ******************************************************************************************************************************************************************************* - + dq_dHydStateUnsat = 0._rkind + dq_dNrgStateUnsat = 0._rkind + + end associate + end subroutine update_qDrainFlux_zeroFlux + + subroutine finalize_qDrainFlux + ! ** Finalize operations for qDrainFlux ** + associate(& + ! output: error control + err => out_qDrainFlux % err , & ! error code + message => out_qDrainFlux % message & ! error message + &) + ! final error check + if(err/=0)then; message=trim(message)//'unanticipated error in qDrainFlux'; return_flag=.true.; return; end if + end associate + end subroutine finalize_qDrainFlux + +end subroutine qDrainFlux end module soilLiqFlx_module diff --git a/build/source/engine/soil_utils.f90 b/build/source/engine/soil_utils.f90 old mode 100755 new mode 100644 index 4a854f6d6..5ef922bd8 --- a/build/source/engine/soil_utils.f90 +++ b/build/source/engine/soil_utils.f90 @@ -49,669 +49,861 @@ module soil_utils_module public::dTheta_dTk public::crit_soilT public::liquidHead -public::gammp +public::gammp,gammp_complex +public::LogSumExp +public::SoftArgMax ! constant parameters -real(rkind),parameter :: valueMissing=-9999._rkind ! missing value parameter -real(rkind),parameter :: verySmall=epsilon(1.0_rkind) ! a very small number (used to avoid divide by zero) real(rkind),parameter :: dx=-1.e-12_rkind ! finite difference increment contains - ! ****************************************************************************************************************************** - ! public subroutine iceImpede: compute the ice impedence factor - ! ****************************************************************************************************************************** - subroutine iceImpede(volFracIce,f_impede, & ! input - iceImpedeFactor,dIceImpede_dLiq) ! output - ! computes the ice impedence factor (separate function, as used multiple times) - implicit none - ! input variables - real(rkind),intent(in) :: volFracIce ! volumetric fraction of ice (-) - real(rkind),intent(in) :: f_impede ! ice impedence parameter (-) - ! output variables - real(rkind) :: iceImpedeFactor ! ice impedence factor (-) - real(rkind) :: dIceImpede_dLiq ! derivative in ice impedence factor w.r.t. volumetric liquid water content (-) - ! compute ice impedance factor as a function of volumetric ice content - iceImpedeFactor = 10._rkind**(-f_impede*volFracIce) - dIceImpede_dLiq = 0._rkind - - end subroutine iceImpede - - - ! ****************************************************************************************************************************** - ! public subroutine dIceImpede_dTemp: compute the derivative in the ice impedence factor w.r.t. temperature - ! ****************************************************************************************************************************** - subroutine dIceImpede_dTemp(volFracIce,dTheta_dT,f_impede,dIceImpede_dT) - ! computes the derivative in the ice impedance factor w.r.t. temperature - implicit none - ! input variables - real(rkind),intent(in) :: volFracIce ! volumetric fraction of ice (-) - real(rkind),intent(in) :: dTheta_dT ! derivative in volumetric liquid water content w.r.t temperature (K-1) - real(rkind),intent(in) :: f_impede ! ice impedence parameter (-) - ! output variables - real(rkind) :: dIceImpede_dT ! derivative in the ice impedance factor w.r.t. temperature (K-1) - ! -- - dIceImpede_dT = log(10._rkind)*f_impede*(10._rkind**(-f_impede*volFracIce))*dTheta_dT - end subroutine dIceImpede_dTemp - - - ! ****************************************************************************************************************************** - ! public subroutine: compute the liquid water matric potential (and the derivatives w.r.t. total matric potential and temperature) - ! ****************************************************************************************************************************** - subroutine liquidHead(& - ! input - matricHeadTotal ,& ! intent(in) : total water matric potential (m) - volFracLiq ,& ! intent(in) : volumetric fraction of liquid water (-) - volFracIce ,& ! intent(in) : volumetric fraction of ice (-) - vGn_alpha,vGn_n,theta_sat,theta_res,vGn_m,& ! intent(in) : soil parameters - dVolTot_dPsi0 ,& ! intent(in) : derivative in the soil water characteristic (m-1) - dTheta_dT ,& ! intent(in) : derivative in volumetric total water w.r.t. temperature (K-1) - ! output - matricHeadLiq ,& ! intent(out) : liquid water matric potential (m) - dPsiLiq_dPsi0 ,& ! intent(out) : derivative in the liquid water matric potential w.r.t. the total water matric potential (-) - dPsiLiq_dTemp ,& ! intent(out) : derivative in the liquid water matric potential w.r.t. temperature (m K-1) - err,message) ! intent(out) : error control - ! computes the liquid water matric potential (and the derivatives w.r.t. total matric potential and temperature) - implicit none - ! input - real(rkind),intent(in) :: matricHeadTotal ! total water matric potential (m) - real(rkind),intent(in) :: volFracLiq ! volumetric fraction of liquid water (-) - real(rkind),intent(in) :: volFracIce ! volumetric fraction of ice (-) - real(rkind),intent(in) :: vGn_alpha,vGn_n,theta_sat,theta_res,vGn_m ! soil parameters - real(rkind),intent(in) ,optional :: dVolTot_dPsi0 ! derivative in the soil water characteristic (m-1) - real(rkind),intent(in) ,optional :: dTheta_dT ! derivative in volumetric total water w.r.t. temperature (K-1) - ! output - real(rkind),intent(out) :: matricHeadLiq ! liquid water matric potential (m) - real(rkind),intent(out) ,optional :: dPsiLiq_dPsi0 ! derivative in the liquid water matric potential w.r.t. the total water matric potential (-) - real(rkind),intent(out) ,optional :: dPsiLiq_dTemp ! derivative in the liquid water matric potential w.r.t. temperature (m K-1) - ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! local - real(rkind) :: xNum,xDen ! temporary variables (numeratir, denominator) - real(rkind) :: effSat ! effective saturation (-) - real(rkind) :: dPsiLiq_dEffSat ! derivative in liquid water matric potential w.r.t. effective saturation (m) - real(rkind) :: dEffSat_dTemp ! derivative in effective saturation w.r.t. temperature (K-1) - ! ------------------------------------------------------------------------------------------------------------------------------ - ! initialize error control - err=0; message='liquidHead/' - - ! ** partially frozen soil - if(volFracIce > verySmall .and. matricHeadTotal < 0._rkind)then ! check that ice exists and that the soil is unsaturated - - ! ----- - ! - compute liquid water matric potential... - ! ------------------------------------------ - - ! - compute effective saturation - ! NOTE: include ice content as part of the solid porosity - major effect of ice is to reduce the pore size; ensure that effSat=1 at saturation - ! (from Zhao et al., J. Hydrol., 1997: Numerical analysis of simultaneous heat and mass transfer...) - xNum = volFracLiq - theta_res - xDen = theta_sat - volFracIce - theta_res - effSat = xNum/xDen ! effective saturation - - ! - matric head associated with liquid water - matricHeadLiq = matricHead(effSat,vGn_alpha,0._rkind,1._rkind,vGn_n,vGn_m) ! argument is effective saturation, so theta_res=0 and theta_sat=1 - - ! compute derivative in liquid water matric potential w.r.t. effective saturation (m) - if(present(dPsiLiq_dPsi0).or.present(dPsiLiq_dTemp))then - dPsiLiq_dEffSat = dPsi_dTheta(effSat,vGn_alpha,0._rkind,1._rkind,vGn_n,vGn_m) - endif - - ! ----- - ! - compute derivative in the liquid water matric potential w.r.t. the total water matric potential... - ! ---------------------------------------------------------------------------------------------------- - - ! check if the derivative is desired - if(present(dPsiLiq_dTemp))then - - ! (check required input derivative is present) - if(.not.present(dVolTot_dPsi0))then - message=trim(message)//'dVolTot_dPsi0 argument is missing' - err=20; return - endif - - ! (compute derivative in the liquid water matric potential w.r.t. the total water matric potential) - dPsiLiq_dPsi0 = dVolTot_dPsi0*dPsiLiq_dEffSat*xNum/(xDen**2._rkind) - - endif ! if dPsiLiq_dTemp is desired - - ! ----- - ! - compute the derivative in the liquid water matric potential w.r.t. temperature... - ! ----------------------------------------------------------------------------------- - - ! check if the derivative is desired - if(present(dPsiLiq_dTemp))then - - ! (check required input derivative is present) - if(.not.present(dTheta_dT))then - message=trim(message)//'dTheta_dT argument is missing' - err=20; return - endif - - ! (compute the derivative in the liquid water matric potential w.r.t. temperature) - dEffSat_dTemp = -dTheta_dT*xNum/(xDen**2._rkind) + dTheta_dT/xDen - dPsiLiq_dTemp = dPsiLiq_dEffSat*dEffSat_dTemp - - endif ! if dPsiLiq_dTemp is desired - - ! ** unfrozen soil - else ! (no ice) - matricHeadLiq = matricHeadTotal - if(present(dPsiLiq_dTemp)) dPsiLiq_dPsi0 = 1._rkind ! derivative=1 because values are identical - if(present(dPsiLiq_dTemp)) dPsiLiq_dTemp = 0._rkind ! derivative=0 because no impact of temperature for unfrozen conditions - end if ! (if ice exists) - - end subroutine liquidHead - - ! ****************************************************************************************************************************** - ! public function hydCondMP_liq: compute the hydraulic conductivity of macropores as a function of liquid water content (m s-1) - ! ****************************************************************************************************************************** - function hydCondMP_liq(volFracLiq,theta_sat,theta_mp,mpExp,satHydCond_ma,satHydCond_mi) - ! computes hydraulic conductivity given volFracLiq and soil hydraulic parameters - ! theta_sat, theta_mp, mpExp, satHydCond_ma, and satHydCond_mi - implicit none - ! dummies - real(rkind),intent(in) :: volFracLiq ! volumetric liquid water content (-) - real(rkind),intent(in) :: theta_sat ! soil porosity (-) - real(rkind),intent(in) :: theta_mp ! minimum volumetric liquid water content for macropore flow (-) - real(rkind),intent(in) :: mpExp ! empirical exponent in macropore flow equation (-) - real(rkind),intent(in) :: satHydCond_ma ! saturated hydraulic conductivity for macropores (m s-1) - real(rkind),intent(in) :: satHydCond_mi ! saturated hydraulic conductivity for micropores (m s-1) - real(rkind) :: hydCondMP_liq ! hydraulic conductivity (m s-1) - ! locals - real(rkind) :: theta_e ! effective soil moisture - if(volFracLiq > theta_mp)then +! ****************************************************************************************************************************** +! public subroutine iceImpede: compute the ice impedence factor +! ****************************************************************************************************************************** +subroutine iceImpede(volFracIce,f_impede, & ! input + iceImpedeFactor,dIceImpede_dLiq) ! output + ! computes the ice impedence factor (separate function, as used multiple times) + implicit none + ! input variables + real(rkind),intent(in) :: volFracIce ! volumetric fraction of ice (-) + real(rkind),intent(in) :: f_impede ! ice impedence parameter (-) + ! output variables + real(rkind) :: iceImpedeFactor ! ice impedence factor (-) + real(rkind) :: dIceImpede_dLiq ! derivative in ice impedence factor w.r.t. volumetric liquid water content (-) + ! compute ice impedance factor as a function of volumetric ice content + iceImpedeFactor = 10._rkind**(-f_impede*volFracIce) + dIceImpede_dLiq = 0._rkind + +end subroutine iceImpede + + +! ****************************************************************************************************************************** +! public subroutine dIceImpede_dTemp: compute the derivative in the ice impedence factor w.r.t. temperature +! ****************************************************************************************************************************** +subroutine dIceImpede_dTemp(volFracIce,dTheta_dT,f_impede,dIceImpede_dT) + ! computes the derivative in the ice impedance factor w.r.t. temperature + implicit none + ! input variables + real(rkind),intent(in) :: volFracIce ! volumetric fraction of ice (-) + real(rkind),intent(in) :: dTheta_dT ! derivative in volumetric liquid water content w.r.t temperature (K-1) + real(rkind),intent(in) :: f_impede ! ice impedence parameter (-) + ! output variables + real(rkind) :: dIceImpede_dT ! derivative in the ice impedance factor w.r.t. temperature (K-1) + ! -- + dIceImpede_dT = log(10._rkind)*f_impede*(10._rkind**(-f_impede*volFracIce))*dTheta_dT +end subroutine dIceImpede_dTemp + + +! ****************************************************************************************************************************** +! public subroutine: compute the liquid water matric potential (and the derivatives w.r.t. total matric potential and temperature) +! ****************************************************************************************************************************** +subroutine liquidHead(& + ! input + matricHeadTotal ,& ! intent(in) : total water matric potential (m) + volFracLiq ,& ! intent(in) : volumetric fraction of liquid water (-) + volFracIce ,& ! intent(in) : volumetric fraction of ice (-) + vGn_alpha,vGn_n,theta_sat,theta_res,vGn_m,& ! intent(in) : soil parameters + dVolTot_dPsi0 ,& ! intent(in) : derivative in the soil water characteristic (m-1) + dTheta_dT ,& ! intent(in) : derivative in volumetric total water w.r.t. temperature (K-1) + ! output + matricHeadLiq ,& ! intent(out) : liquid water matric potential (m) + dPsiLiq_dPsi0 ,& ! intent(out) : derivative in the liquid water matric potential w.r.t. the total water matric potential (-) + dPsiLiq_dTemp ,& ! intent(out) : derivative in the liquid water matric potential w.r.t. temperature (m K-1) + err,message) ! intent(out) : error control + ! computes the liquid water matric potential (and the derivatives w.r.t. total matric potential and temperature) + implicit none + ! input + real(rkind),intent(in) :: matricHeadTotal ! total water matric potential (m) + real(rkind),intent(in) :: volFracLiq ! volumetric fraction of liquid water (-) + real(rkind),intent(in) :: volFracIce ! volumetric fraction of ice (-) + real(rkind),intent(in) :: vGn_alpha,vGn_n,theta_sat,theta_res,vGn_m ! soil parameters + real(rkind),intent(in) ,optional :: dVolTot_dPsi0 ! derivative in the soil water characteristic (m-1) + real(rkind),intent(in) ,optional :: dTheta_dT ! derivative in volumetric total water w.r.t. temperature (K-1) + ! output + real(rkind),intent(out) :: matricHeadLiq ! liquid water matric potential (m) + real(rkind),intent(out) ,optional :: dPsiLiq_dPsi0 ! derivative in the liquid water matric potential w.r.t. the total water matric potential (-) + real(rkind),intent(out) ,optional :: dPsiLiq_dTemp ! derivative in the liquid water matric potential w.r.t. temperature (m K-1) + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! local + real(rkind) :: xNum,xDen ! temporary variables (numeratir, denominator) + real(rkind) :: effSat ! effective saturation (-) + real(rkind) :: dPsiLiq_dEffSat ! derivative in liquid water matric potential w.r.t. effective saturation (m) + real(rkind) :: dEffSat_dTemp ! derivative in effective saturation w.r.t. temperature (K-1) + ! ------------------------------------------------------------------------------------------------------------------------------ + ! initialize error control + err=0; message='liquidHead/' + + ! ** partially frozen soil + if(volFracIce > epsilon(1._rkind) .and. matricHeadTotal < 0._rkind)then ! check that ice exists and that the soil is unsaturated + + ! ----- + ! - compute liquid water matric potential... + ! ------------------------------------------ + + ! - compute effective saturation + ! NOTE: include ice content as part of the solid porosity - major effect of ice is to reduce the pore size; ensure that effSat=1 at saturation + ! (from Zhao et al., J. Hydrol., 1997: Numerical analysis of simultaneous heat and mass transfer...) + xNum = volFracLiq - theta_res + xDen = theta_sat - volFracIce - theta_res + effSat = xNum/xDen ! effective saturation + + ! - matric head associated with liquid water + matricHeadLiq = matricHead(effSat,vGn_alpha,0._rkind,1._rkind,vGn_n,vGn_m) ! argument is effective saturation, so theta_res=0 and theta_sat=1 + + ! compute derivative in liquid water matric potential w.r.t. effective saturation (m) + if(present(dPsiLiq_dPsi0).or.present(dPsiLiq_dTemp))then + dPsiLiq_dEffSat = dPsi_dTheta(effSat,vGn_alpha,0._rkind,1._rkind,vGn_n,vGn_m) + endif + + ! ----- + ! - compute derivative in the liquid water matric potential w.r.t. the total water matric potential... + ! ---------------------------------------------------------------------------------------------------- + + ! check if the derivative is desired + if(present(dPsiLiq_dPsi0))then + ! (check required input derivative is present) + if(.not.present(dVolTot_dPsi0))then + message=trim(message)//'dVolTot_dPsi0 argument is missing' + err=20; return + endif + ! (compute derivative in the liquid water matric potential w.r.t. the total water matric potential) + dPsiLiq_dPsi0 = dVolTot_dPsi0*dPsiLiq_dEffSat*xNum/(xDen**2_i4b) + endif ! if dPsiLiq_dTemp is desired + + ! ----- + ! - compute the derivative in the liquid water matric potential w.r.t. temperature... + ! ----------------------------------------------------------------------------------- + + ! check if the derivative is desired + if(present(dPsiLiq_dTemp))then + ! (check required input derivative is present) + if(.not.present(dTheta_dT))then + message=trim(message)//'dTheta_dT argument is missing' + err=20; return + endif + ! (compute the derivative in the liquid water matric potential w.r.t. temperature) + dEffSat_dTemp = -dTheta_dT*xNum/(xDen**2_i4b) + dTheta_dT/xDen + dPsiLiq_dTemp = dPsiLiq_dEffSat*dEffSat_dTemp + endif ! if dPsiLiq_dTemp is desired + + ! ** unfrozen soil + else ! (no ice) + matricHeadLiq = matricHeadTotal + if(present(dPsiLiq_dPsi0)) dPsiLiq_dPsi0 = 1._rkind ! derivative=1 because values are identical + if(present(dPsiLiq_dTemp)) dPsiLiq_dTemp = 0._rkind ! derivative=0 because no impact of temperature for unfrozen conditions + end if ! (if ice exists) + +end subroutine liquidHead + +! ****************************************************************************************************************************** +! public function hydCondMP_liq: compute the hydraulic conductivity of macropores as a function of liquid water content (m s-1) +! ****************************************************************************************************************************** +function hydCondMP_liq(volFracLiq,theta_sat,theta_mp,mpExp,satHydCond_ma,satHydCond_mi) + ! computes hydraulic conductivity given volFracLiq and soil hydraulic parameters + ! theta_sat, theta_mp, mpExp, satHydCond_ma, and satHydCond_mi + implicit none + ! dummies + real(rkind),intent(in) :: volFracLiq ! volumetric liquid water content (-) + real(rkind),intent(in) :: theta_sat ! soil porosity (-) + real(rkind),intent(in) :: theta_mp ! minimum volumetric liquid water content for macropore flow (-) + real(rkind),intent(in) :: mpExp ! empirical exponent in macropore flow equation (-) + real(rkind),intent(in) :: satHydCond_ma ! saturated hydraulic conductivity for macropores (m s-1) + real(rkind),intent(in) :: satHydCond_mi ! saturated hydraulic conductivity for micropores (m s-1) + real(rkind) :: hydCondMP_liq ! hydraulic conductivity (m s-1) + ! locals + real(rkind) :: theta_e ! effective soil moisture + if(volFracLiq > theta_mp)then theta_e = (volFracLiq - theta_mp) / (theta_sat - theta_mp) hydCondMP_liq = (satHydCond_ma - satHydCond_mi) * (theta_e**mpExp) - else + else hydCondMP_liq = 0._rkind - end if - !write(*,'(a,4(f9.3,1x),2(e20.10))') 'in soil_utils: theta_mp, theta_sat, volFracLiq, hydCondMP_liq, satHydCond_ma, satHydCond_mi = ', & - ! theta_mp, theta_sat, volFracLiq, hydCondMP_liq, satHydCond_ma, satHydCond_mi - end function hydCondMP_liq - - - ! ****************************************************************************************************************************** - ! public function hydCond_psi: compute the hydraulic conductivity as a function of matric head (m s-1) - ! ****************************************************************************************************************************** - function hydCond_psi(psi,k_sat,alpha,n,m) - ! computes hydraulic conductivity given psi and soil hydraulic parameters k_sat, alpha, n, and m - implicit none - ! dummies - real(rkind),intent(in) :: psi ! soil water suction (m) - real(rkind),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) - real(rkind),intent(in) :: alpha ! scaling parameter (m-1) - real(rkind),intent(in) :: n ! vGn "n" parameter (-) - real(rkind),intent(in) :: m ! vGn "m" parameter (-) - real(rkind) :: hydCond_psi ! hydraulic conductivity (m s-1) - if(psi<0._rkind)then + end if +end function hydCondMP_liq + + +! ****************************************************************************************************************************** +! public function hydCond_psi: compute the hydraulic conductivity as a function of matric head (m s-1) +! ****************************************************************************************************************************** +function hydCond_psi(psi,k_sat,alpha,n,m) + ! computes hydraulic conductivity given psi and soil hydraulic parameters k_sat, alpha, n, and m + implicit none + ! dummies + real(rkind),intent(in) :: psi ! soil water suction (m) + real(rkind),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) + real(rkind),intent(in) :: alpha ! scaling parameter (m-1) + real(rkind),intent(in) :: n ! vGn "n" parameter (-) + real(rkind),intent(in) :: m ! vGn "m" parameter (-) + real(rkind) :: hydCond_psi ! hydraulic conductivity (m s-1) + if(psi<0._rkind)then hydCond_psi = k_sat * & - ( ( (1._rkind - (psi*alpha)**(n-1._rkind) * (1._rkind + (psi*alpha)**n)**(-m))**2._rkind ) & - / ( (1._rkind + (psi*alpha)**n)**(m/2._rkind) ) ) - else + ( ( (1._rkind - (psi*alpha)**(n-1._rkind) * (1._rkind + (psi*alpha)**n)**(-m))**2_i4b ) & + / ( (1._rkind + (psi*alpha)**n)**(m/2._rkind) ) ) + else hydCond_psi = k_sat - end if - end function hydCond_psi - - - ! ****************************************************************************************************************************** - ! public function hydCond_liq: compute the hydraulic conductivity as a function of volumetric liquid water content (m s-1) - ! ****************************************************************************************************************************** - function hydCond_liq(volFracLiq,k_sat,theta_res,theta_sat,m) - ! computes hydraulic conductivity given volFracLiq and soil hydraulic parameters k_sat, theta_sat, theta_res, and m - implicit none - ! dummies - real(rkind),intent(in) :: volFracLiq ! volumetric liquid water content (-) - real(rkind),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) - real(rkind),intent(in) :: theta_res ! residual volumetric liquid water content (-) - real(rkind),intent(in) :: theta_sat ! soil porosity (-) - real(rkind),intent(in) :: m ! vGn "m" parameter (-) - real(rkind) :: hydCond_liq ! hydraulic conductivity (m s-1) - ! locals - real(rkind) :: theta_e ! effective soil moisture - if(volFracLiq < theta_sat)then + end if +end function hydCond_psi + + +! ****************************************************************************************************************************** +! public function hydCond_liq: compute the hydraulic conductivity as a function of volumetric liquid water content (m s-1) +! ****************************************************************************************************************************** +function hydCond_liq(volFracLiq,k_sat,theta_res,theta_sat,m) + ! computes hydraulic conductivity given volFracLiq and soil hydraulic parameters k_sat, theta_sat, theta_res, and m + implicit none + ! dummies + real(rkind),intent(in) :: volFracLiq ! volumetric liquid water content (-) + real(rkind),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) + real(rkind),intent(in) :: theta_res ! residual volumetric liquid water content (-) + real(rkind),intent(in) :: theta_sat ! soil porosity (-) + real(rkind),intent(in) :: m ! vGn "m" parameter (-) + real(rkind) :: hydCond_liq ! hydraulic conductivity (m s-1) + ! locals + real(rkind) :: theta_e ! effective soil moisture + if(volFracLiq < theta_sat)then theta_e = (volFracLiq - theta_res) / (theta_sat - theta_res) - hydCond_liq = k_sat*theta_e**(1._rkind/2._rkind) * (1._rkind - (1._rkind - theta_e**(1._rkind/m) )**m)**2._rkind - else + hydCond_liq = k_sat*theta_e**(1._rkind/2._rkind) * (1._rkind - (1._rkind - theta_e**(1._rkind/m) )**m)**2_i4b + else hydCond_liq = k_sat - end if - end function hydCond_liq - - - ! ****************************************************************************************************************************** - ! public function volFracLiq: compute the volumetric liquid water content (-) - ! ****************************************************************************************************************************** - function volFracLiq(psi,alpha,theta_res,theta_sat,n,m) - ! computes the volumetric liquid water content given psi and soil hydraulic parameters theta_res, theta_sat, alpha, n, and m - implicit none - real(rkind),intent(in) :: psi ! soil water suction (m) - real(rkind),intent(in) :: alpha ! scaling parameter (m-1) - real(rkind),intent(in) :: theta_res ! residual volumetric water content (-) - real(rkind),intent(in) :: theta_sat ! porosity (-) - real(rkind),intent(in) :: n ! vGn "n" parameter (-) - real(rkind),intent(in) :: m ! vGn "m" parameter (-) - real(rkind) :: volFracLiq ! volumetric liquid water content (-) - if(psi<0._rkind)then + end if +end function hydCond_liq + + +! ****************************************************************************************************************************** +! public function volFracLiq: compute the volumetric liquid water content (-) +! ****************************************************************************************************************************** +function volFracLiq(psi,alpha,theta_res,theta_sat,n,m) + ! computes the volumetric liquid water content given psi and soil hydraulic parameters theta_res, theta_sat, alpha, n, and m + implicit none + real(rkind),intent(in) :: psi ! soil water suction (m) + real(rkind),intent(in) :: alpha ! scaling parameter (m-1) + real(rkind),intent(in) :: theta_res ! residual volumetric water content (-) + real(rkind),intent(in) :: theta_sat ! porosity (-) + real(rkind),intent(in) :: n ! vGn "n" parameter (-) + real(rkind),intent(in) :: m ! vGn "m" parameter (-) + real(rkind) :: volFracLiq ! volumetric liquid water content (-) + if(psi<0._rkind)then volFracLiq = theta_res + (theta_sat - theta_res)*(1._rkind + (alpha*psi)**n)**(-m) - else + else volFracLiq = theta_sat - end if - end function volFracLiq - - - ! ****************************************************************************************************************************** - ! public function matricHead: compute the matric head (m) based on the volumetric liquid water content - ! ****************************************************************************************************************************** - function matricHead(theta,alpha,theta_res,theta_sat,n,m) - ! computes the volumetric liquid water content given psi and soil hydraulic parameters theta_res, theta_sat, alpha, n, and m - implicit none - ! dummy variables - real(rkind),intent(in) :: theta ! volumetric liquid water content (-) - real(rkind),intent(in) :: alpha ! scaling parameter (m-1) - real(rkind),intent(in) :: theta_res ! residual volumetric water content (-) - real(rkind),intent(in) :: theta_sat ! porosity (-) - real(rkind),intent(in) :: n ! vGn "n" parameter (-) - real(rkind),intent(in) :: m ! vGn "m" parameter (-) - real(rkind) :: matricHead ! matric head (m) - ! local variables - real(rkind) :: effSat ! effective saturation (-) - real(rkind),parameter :: verySmall=epsilon(1._rkind) ! a very small number (avoid effective saturation of zero) - ! compute effective saturation - effSat = max(verySmall, (theta - theta_res) / (theta_sat - theta_res)) - ! compute matric head - if (effSat < 1._rkind .and. effSat > 0._rkind)then + end if +end function volFracLiq + + +! ****************************************************************************************************************************** +! public function matricHead: compute the matric head (m) based on the volumetric liquid water content +! ****************************************************************************************************************************** +function matricHead(theta,alpha,theta_res,theta_sat,n,m) + ! computes the volumetric liquid water content given psi and soil hydraulic parameters theta_res, theta_sat, alpha, n, and m + implicit none + ! dummy variables + real(rkind),intent(in) :: theta ! volumetric liquid water content (-) + real(rkind),intent(in) :: alpha ! scaling parameter (m-1) + real(rkind),intent(in) :: theta_res ! residual volumetric water content (-) + real(rkind),intent(in) :: theta_sat ! porosity (-) + real(rkind),intent(in) :: n ! vGn "n" parameter (-) + real(rkind),intent(in) :: m ! vGn "m" parameter (-) + real(rkind) :: matricHead ! matric head (m) + ! local variables + real(rkind) :: effSat ! effective saturation (-) + real(rkind),parameter :: eps=epsilon(1._rkind) ! a very small number (avoid effective saturation of zero) + ! compute effective saturation + effSat = max(eps, (theta - theta_res) / (theta_sat - theta_res)) + ! compute matric head + if (effSat < 1._rkind .and. effSat > 0._rkind)then matricHead = (1._rkind/alpha)*( effSat**(-1._rkind/m) - 1._rkind)**(1._rkind/n) - else + else matricHead = 0._rkind - end if - end function matricHead - - - ! ****************************************************************************************************************************** - ! public function dTheta_dPsi: compute the derivative of the soil water characteristic (m-1) - ! ****************************************************************************************************************************** - function dTheta_dPsi(psi,alpha,theta_res,theta_sat,n,m) - implicit none - real(rkind),intent(in) :: psi ! soil water suction (m) - real(rkind),intent(in) :: alpha ! scaling parameter (m-1) - real(rkind),intent(in) :: theta_res ! residual volumetric water content (-) - real(rkind),intent(in) :: theta_sat ! porosity (-) - real(rkind),intent(in) :: n ! vGn "n" parameter (-) - real(rkind),intent(in) :: m ! vGn "m" parameter (-) - real(rkind) :: dTheta_dPsi ! derivative of the soil water characteristic (m-1) - if(psi<=0._rkind)then - dTheta_dPsi = (theta_sat-theta_res) * & - (-m*(1._rkind + (psi*alpha)**n)**(-m-1._rkind)) * n*(psi*alpha)**(n-1._rkind) * alpha - if(abs(dTheta_dPsi) < epsilon(psi)) dTheta_dPsi = epsilon(psi) - else - dTheta_dPsi = epsilon(psi) - end if - end function dTheta_dPsi - - - ! ****************************************************************************************************************************** - ! public function dPsi_dTheta: compute the derivative of the soil water characteristic (m-1) - ! ****************************************************************************************************************************** - function dPsi_dTheta(volFracLiq,alpha,theta_res,theta_sat,n,m) - implicit none - ! dummies - real(rkind),intent(in) :: volFracLiq ! volumetric liquid water content (-) - real(rkind),intent(in) :: alpha ! scaling parameter (m-1) - real(rkind),intent(in) :: theta_res ! residual volumetric water content (-) - real(rkind),intent(in) :: theta_sat ! porosity (-) - real(rkind),intent(in) :: n ! vGn "n" parameter (-) - real(rkind),intent(in) :: m ! vGn "m" parameter (-) - real(rkind) :: dPsi_dTheta ! derivative of the soil water characteristic (m) - ! locals - real(rkind) :: y1,d1 ! 1st function and derivative - real(rkind) :: y2,d2 ! 2nd function and derivative - real(rkind) :: theta_e ! effective soil moisture - ! check if less than saturation - if(volFracLiq < theta_sat)then - ! compute effective water content - theta_e = max(0.001,(volFracLiq - theta_res) / (theta_sat - theta_res)) - ! compute the 1st function and derivative - y1 = theta_e**(-1._rkind/m) - 1._rkind - d1 = (-1._rkind/m)*theta_e**(-1._rkind/m - 1._rkind) / (theta_sat - theta_res) - ! compute the 2nd function and derivative - y2 = y1**(1._rkind/n) - d2 = (1._rkind/n)*y1**(1._rkind/n - 1._rkind) - ! compute the final function value - dPsi_dTheta = d1*d2/alpha - else - dPsi_dTheta = 0._rkind - end if - end function dPsi_dTheta - - - ! ****************************************************************************************************************************** - ! public function dPsi_dTheta2: compute the derivative of dPsi_dTheta (m-1) - ! ****************************************************************************************************************************** - function dPsi_dTheta2(volFracLiq,alpha,theta_res,theta_sat,n,m,lTangent) - implicit none - ! dummies - real(rkind),intent(in) :: volFracLiq ! volumetric liquid water content (-) - real(rkind),intent(in) :: alpha ! scaling parameter (m-1) - real(rkind),intent(in) :: theta_res ! residual volumetric water content (-) - real(rkind),intent(in) :: theta_sat ! porosity (-) - real(rkind),intent(in) :: n ! vGn "n" parameter (-) - real(rkind),intent(in) :: m ! vGn "m" parameter (-) - logical(lgt),intent(in) :: lTangent ! method used to compute derivative (.true. = analytical) - real(rkind) :: dPsi_dTheta2 ! derivative of the soil water characteristic (m) - ! locals for analytical derivatives - real(rkind) :: xx ! temporary variable - real(rkind) :: y1,d1 ! 1st function and derivative - real(rkind) :: y2,d2 ! 2nd function and derivative - real(rkind) :: theta_e ! effective soil moisture - ! locals for numerical derivative - real(rkind) :: func0,func1 ! function evaluations - ! check if less than saturation - if(volFracLiq < theta_sat)then + end if +end function matricHead + + +! ****************************************************************************************************************************** +! public function dTheta_dPsi: compute the derivative of the soil water characteristic (m-1) +! ****************************************************************************************************************************** +function dTheta_dPsi(psi,alpha,theta_res,theta_sat,n,m) + implicit none + real(rkind),intent(in) :: psi ! soil water suction (m) + real(rkind),intent(in) :: alpha ! scaling parameter (m-1) + real(rkind),intent(in) :: theta_res ! residual volumetric water content (-) + real(rkind),intent(in) :: theta_sat ! porosity (-) + real(rkind),intent(in) :: n ! vGn "n" parameter (-) + real(rkind),intent(in) :: m ! vGn "m" parameter (-) + real(rkind) :: dTheta_dPsi ! derivative of the soil water characteristic (m-1) + if(psi<=0._rkind)then + dTheta_dPsi = (theta_sat-theta_res) * & + (-m*(1._rkind + (psi*alpha)**n)**(-m-1._rkind)) * n*(psi*alpha)**(n-1._rkind) * alpha + if(abs(dTheta_dPsi) < epsilon(psi)) dTheta_dPsi = epsilon(psi) + else + dTheta_dPsi = epsilon(psi) + end if +end function dTheta_dPsi + + +! ****************************************************************************************************************************** +! public function dPsi_dTheta: compute the derivative of the soil water characteristic (m) +! ****************************************************************************************************************************** +function dPsi_dTheta(volFracLiq,alpha,theta_res,theta_sat,n,m) + implicit none + ! dummies + real(rkind),intent(in) :: volFracLiq ! volumetric liquid water content (-) + real(rkind),intent(in) :: alpha ! scaling parameter (m-1) + real(rkind),intent(in) :: theta_res ! residual volumetric water content (-) + real(rkind),intent(in) :: theta_sat ! porosity (-) + real(rkind),intent(in) :: n ! vGn "n" parameter (-) + real(rkind),intent(in) :: m ! vGn "m" parameter (-) + real(rkind) :: dPsi_dTheta ! derivative of the soil water characteristic (m) + ! locals + real(rkind) :: y1,d1 ! 1st function and derivative + real(rkind) :: y2,d2 ! 2nd function and derivative + real(rkind) :: theta_e ! effective soil moisture + real(rkind),parameter :: theta_e_min=0.001_rkind ! minimum effective soil moisture + real(rkind),parameter :: y1_min=10._rkind*epsilon(1._rkind) ! minimum y1 value (to avoid division by zero and complex values) + + ! check if less than saturation + if(volFracLiq < theta_sat)then + ! compute effective water content + theta_e = max(theta_e_min,(volFracLiq - theta_res) / (theta_sat - theta_res)) + ! compute the 1st function and derivative + y1 = theta_e**(-1._rkind/m) - 1._rkind + d1 = (-1._rkind/m)*theta_e**(-1._rkind/m - 1._rkind) / (theta_sat - theta_res) + ! compute the 2nd function and derivative + ! note: impose a minimum value for y1 to avoid divison by zero and complex values + !y2 = y1**(1._rkind/n) ! original expression + !d2 = (1._rkind/n)*y1**(1._rkind/n - 1._rkind) ! original expression + y2 = max(y1_min,y1)**(1._rkind/n) + d2 = (1._rkind/n)*max(y1_min,y1)**(1._rkind/n - 1._rkind) ! impose a minimum value for y1 to avoid divison by zero and complex values + ! compute the final function value + dPsi_dTheta = d1*d2/alpha + else + dPsi_dTheta = 0._rkind + end if +end function dPsi_dTheta + + +! ****************************************************************************************************************************** +! public function dPsi_dTheta2: compute the derivative of dPsi_dTheta (m-1) +! ****************************************************************************************************************************** +function dPsi_dTheta2(volFracLiq,alpha,theta_res,theta_sat,n,m,lTangent) + implicit none + ! dummies + real(rkind),intent(in) :: volFracLiq ! volumetric liquid water content (-) + real(rkind),intent(in) :: alpha ! scaling parameter (m-1) + real(rkind),intent(in) :: theta_res ! residual volumetric water content (-) + real(rkind),intent(in) :: theta_sat ! porosity (-) + real(rkind),intent(in) :: n ! vGn "n" parameter (-) + real(rkind),intent(in) :: m ! vGn "m" parameter (-) + logical(lgt),intent(in) :: lTangent ! method used to compute derivative (.true. = analytical) + real(rkind) :: dPsi_dTheta2 ! derivative of the soil water characteristic (m) + ! locals for analytical derivatives + real(rkind) :: xx ! temporary variable + real(rkind) :: y1,d1 ! 1st function and derivative + real(rkind) :: y2,d2 ! 2nd function and derivative + real(rkind) :: theta_e ! effective soil moisture + ! locals for numerical derivative + real(rkind) :: func0,func1 ! function evaluations + ! check if less than saturation + if(volFracLiq < theta_sat)then ! ***** compute analytical derivatives if(lTangent)then - ! compute the effective saturation - theta_e = (volFracLiq - theta_res) / (theta_sat - theta_res) - ! get the first function and derivative - y1 = (-1._rkind/m)*theta_e**(-1._rkind/m - 1._rkind) / (theta_sat - theta_res) - d1 = ( (m + 1._rkind) / (m**2._rkind * (theta_sat - theta_res)**2._rkind) ) * theta_e**(-1._rkind/m - 2._rkind) - ! get the second function and derivative - xx = theta_e**(-1._rkind/m) - 1._rkind - y2 = (1._rkind/n)*xx**(1._rkind/n - 1._rkind) - d2 = ( -(1._rkind - n)/((theta_sat - theta_res)*m*n**2._rkind) ) * xx**(1._rkind/n - 2._rkind) * theta_e**(-1._rkind/m - 1._rkind) - ! return the derivative - dPsi_dTheta2 = (d1*y2 + y1*d2)/alpha + ! compute the effective saturation + theta_e = (volFracLiq - theta_res) / (theta_sat - theta_res) + ! get the first function and derivative + y1 = (-1._rkind/m)*theta_e**(-1._rkind/m - 1._rkind) / (theta_sat - theta_res) + d1 = ( (m + 1._rkind) / (m**2_i4b * (theta_sat - theta_res)**2_i4b) ) * theta_e**(-1._rkind/m - 2._rkind) + ! get the second function and derivative + xx = theta_e**(-1._rkind/m) - 1._rkind + y2 = (1._rkind/n)*xx**(1._rkind/n - 1._rkind) + d2 = ( -(1._rkind - n)/((theta_sat - theta_res)*m*n**2_i4b) ) * xx**(1._rkind/n - 2._rkind) * theta_e**(-1._rkind/m - 1._rkind) + ! return the derivative + dPsi_dTheta2 = (d1*y2 + y1*d2)/alpha ! ***** compute numerical derivatives else - func0 = dPsi_dTheta(volFracLiq, alpha,theta_res,theta_sat,n,m) - func1 = dPsi_dTheta(volFracLiq+dx,alpha,theta_res,theta_sat,n,m) - dPsi_dTheta2 = (func1 - func0)/dx + func0 = dPsi_dTheta(volFracLiq, alpha,theta_res,theta_sat,n,m) + func1 = dPsi_dTheta(volFracLiq+dx,alpha,theta_res,theta_sat,n,m) + dPsi_dTheta2 = (func1 - func0)/dx end if - ! (case where volumetric liquid water content exceeds porosity) - else + ! (case where volumetric liquid water content exceeds porosity) + else dPsi_dTheta2 = 0._rkind - end if - end function dPsi_dTheta2 - - - ! ****************************************************************************************************************************** - ! public function dHydCond_dPsi: compute the derivative in hydraulic conductivity w.r.t. matric head (s-1) - ! ****************************************************************************************************************************** - function dHydCond_dPsi(psi,k_sat,alpha,n,m,lTangent) - ! computes the derivative in hydraulic conductivity w.r.t matric head, - ! given psi and soil hydraulic parameters k_sat, alpha, n, and m - implicit none - ! dummies - real(rkind),intent(in) :: psi ! soil water suction (m) - real(rkind),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) - real(rkind),intent(in) :: alpha ! scaling parameter (m-1) - real(rkind),intent(in) :: n ! vGn "n" parameter (-) - real(rkind),intent(in) :: m ! vGn "m" parameter (-) - logical(lgt),intent(in) :: lTangent ! method used to compute derivative (.true. = analytical) - real(rkind) :: dHydCond_dPsi ! derivative in hydraulic conductivity w.r.t. matric head (s-1) - ! locals for analytical derivatives - real(rkind) :: f_x1 ! f(x) for part of the numerator - real(rkind) :: f_x2 ! f(x) for part of the numerator - real(rkind) :: f_nm ! f(x) for the numerator - real(rkind) :: f_dm ! f(x) for the denominator - real(rkind) :: d_x1 ! df(x)/dpsi for part of the numerator - real(rkind) :: d_x2 ! df(x)/dpsi for part of the numerator - real(rkind) :: d_nm ! df(x)/dpsi for the numerator - real(rkind) :: d_dm ! df(x)/dpsi for the denominator - ! locals for numerical derivatives - real(rkind) :: hydCond0 ! hydraulic condictivity value for base case - real(rkind) :: hydCond1 ! hydraulic condictivity value for perturbed case - ! derivative is zero if saturated - if(psi<0._rkind)then + end if +end function dPsi_dTheta2 + + +! ****************************************************************************************************************************** +! public function dHydCond_dPsi: compute the derivative in hydraulic conductivity w.r.t. matric head (s-1) +! ****************************************************************************************************************************** +function dHydCond_dPsi(psi,k_sat,alpha,n,m,lTangent) + ! computes the derivative in hydraulic conductivity w.r.t matric head, + ! given psi and soil hydraulic parameters k_sat, alpha, n, and m + implicit none + ! dummies + real(rkind),intent(in) :: psi ! soil water suction (m) + real(rkind),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) + real(rkind),intent(in) :: alpha ! scaling parameter (m-1) + real(rkind),intent(in) :: n ! vGn "n" parameter (-) + real(rkind),intent(in) :: m ! vGn "m" parameter (-) + logical(lgt),intent(in) :: lTangent ! method used to compute derivative (.true. = analytical) + real(rkind) :: dHydCond_dPsi ! derivative in hydraulic conductivity w.r.t. matric head (s-1) + ! locals for analytical derivatives + real(rkind) :: f_x1 ! f(x) for part of the numerator + real(rkind) :: f_x2 ! f(x) for part of the numerator + real(rkind) :: f_nm ! f(x) for the numerator + real(rkind) :: f_dm ! f(x) for the denominator + real(rkind) :: d_x1 ! df(x)/dpsi for part of the numerator + real(rkind) :: d_x2 ! df(x)/dpsi for part of the numerator + real(rkind) :: d_nm ! df(x)/dpsi for the numerator + real(rkind) :: d_dm ! df(x)/dpsi for the denominator + ! locals for numerical derivatives + real(rkind) :: hydCond0 ! hydraulic condictivity value for base case + real(rkind) :: hydCond1 ! hydraulic condictivity value for perturbed case + ! derivative is zero if saturated + if(psi<0._rkind)then ! ***** compute analytical derivatives if(lTangent)then - ! compute the derivative for the numerator - f_x1 = (psi*alpha)**(n - 1._rkind) - f_x2 = (1._rkind + (psi*alpha)**n)**(-m) - d_x1 = alpha * (n - 1._rkind)*(psi*alpha)**(n - 2._rkind) - d_x2 = alpha * n*(psi*alpha)**(n - 1._rkind) * (-m)*(1._rkind + (psi*alpha)**n)**(-m - 1._rkind) - f_nm = (1._rkind - f_x1*f_x2)**2._rkind - d_nm = (-d_x1*f_x2 - f_x1*d_x2) * 2._rkind*(1._rkind - f_x1*f_x2) - ! compute the derivative for the denominator - f_dm = (1._rkind + (psi*alpha)**n)**(m/2._rkind) - d_dm = alpha * n*(psi*alpha)**(n - 1._rkind) * (m/2._rkind)*(1._rkind + (psi*alpha)**n)**(m/2._rkind - 1._rkind) - ! and combine - dHydCond_dPsi = k_sat*(d_nm*f_dm - d_dm*f_nm) / (f_dm**2._rkind) + ! compute the derivative for the numerator + f_x1 = (psi*alpha)**(n - 1._rkind) + f_x2 = (1._rkind + (psi*alpha)**n)**(-m) + d_x1 = alpha * (n - 1._rkind)*(psi*alpha)**(n - 2._rkind) + d_x2 = alpha * n*(psi*alpha)**(n - 1._rkind) * (-m)*(1._rkind + (psi*alpha)**n)**(-m - 1._rkind) + f_nm = (1._rkind - f_x1*f_x2)**2_i4b + d_nm = (-d_x1*f_x2 - f_x1*d_x2) * 2._rkind*(1._rkind - f_x1*f_x2) + ! compute the derivative for the denominator + f_dm = (1._rkind + (psi*alpha)**n)**(m/2._rkind) + d_dm = alpha * n*(psi*alpha)**(n - 1._rkind) * (m/2._rkind)*(1._rkind + (psi*alpha)**n)**(m/2._rkind - 1._rkind) + ! and combine + dHydCond_dPsi = k_sat*(d_nm*f_dm - d_dm*f_nm) / (f_dm**2_i4b) else - ! ***** compute numerical derivatives - hydcond0 = hydCond_psi(psi, k_sat,alpha,n,m) - hydcond1 = hydCond_psi(psi+dx,k_sat,alpha,n,m) - dHydCond_dPsi = (hydcond1 - hydcond0)/dx + ! ***** compute numerical derivatives + hydcond0 = hydCond_psi(psi, k_sat,alpha,n,m) + hydcond1 = hydCond_psi(psi+dx,k_sat,alpha,n,m) + dHydCond_dPsi = (hydcond1 - hydcond0)/dx end if - else + else dHydCond_dPsi = 0._rkind - end if - end function dHydCond_dPsi - - - ! ****************************************************************************************************************************** - ! public function dHydCond_dLiq: compute the derivative in hydraulic conductivity w.r.t. volumetric liquid water content (m s-1) - ! ****************************************************************************************************************************** - ! computes the derivative in hydraulic conductivity w.r.t the volumetric fraction of liquid water, - ! given volFracLiq and soil hydraulic parameters k_sat, theta_sat, theta_res, and m - ! ****************************************************************************************************************************** - function dHydCond_dLiq(volFracLiq,k_sat,theta_res,theta_sat,m,lTangent) - implicit none - ! dummies - real(rkind),intent(in) :: volFracLiq ! volumetric fraction of liquid water (-) - real(rkind),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) - real(rkind),intent(in) :: theta_res ! soil residual volumetric water content (-) - real(rkind),intent(in) :: theta_sat ! soil porosity (-) - real(rkind),intent(in) :: m ! vGn "m" parameter (-) - logical(lgt),intent(in) :: lTangent ! method used to compute derivative (.true. = analytical) - real(rkind) :: dHydCond_dLiq ! derivative in hydraulic conductivity w.r.t. matric head (s-1) - ! locals for analytical derivatives - real(rkind) :: theta_e ! effective soil moisture - real(rkind) :: f1 ! f(x) for the first function - real(rkind) :: d1 ! df(x)/dLiq for the first function - real(rkind) :: x1,x2 ! f(x) for different parts of the second function - real(rkind) :: p1,p2,p3 ! df(x)/dLiq for different parts of the second function - real(rkind) :: f2 ! f(x) for the second function - real(rkind) :: d2 ! df(x)/dLiq for the second function - ! locals for numerical derivatives - real(rkind) :: hydCond0 ! hydraulic condictivity value for base case - real(rkind) :: hydCond1 ! hydraulic condictivity value for perturbed case - ! derivative is zero if super-saturated - if(volFracLiq < theta_sat)then + end if +end function dHydCond_dPsi + + +! ****************************************************************************************************************************** +! public function dHydCond_dLiq: compute the derivative in hydraulic conductivity w.r.t. volumetric liquid water content (m s-1) +! ****************************************************************************************************************************** +! computes the derivative in hydraulic conductivity w.r.t the volumetric fraction of liquid water, +! given volFracLiq and soil hydraulic parameters k_sat, theta_sat, theta_res, and m +! ****************************************************************************************************************************** +function dHydCond_dLiq(volFracLiq,k_sat,theta_res,theta_sat,m,lTangent) + implicit none + ! dummies + real(rkind),intent(in) :: volFracLiq ! volumetric fraction of liquid water (-) + real(rkind),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) + real(rkind),intent(in) :: theta_res ! soil residual volumetric water content (-) + real(rkind),intent(in) :: theta_sat ! soil porosity (-) + real(rkind),intent(in) :: m ! vGn "m" parameter (-) + logical(lgt),intent(in) :: lTangent ! method used to compute derivative (.true. = analytical) + real(rkind) :: dHydCond_dLiq ! derivative in hydraulic conductivity w.r.t. matric head (s-1) + ! locals for analytical derivatives + real(rkind) :: theta_e ! effective soil moisture + real(rkind) :: f1 ! f(x) for the first function + real(rkind) :: d1 ! df(x)/dLiq for the first function + real(rkind) :: x1,x2 ! f(x) for different parts of the second function + real(rkind) :: p1,p2,p3 ! df(x)/dLiq for different parts of the second function + real(rkind) :: f2 ! f(x) for the second function + real(rkind) :: d2 ! df(x)/dLiq for the second function + ! locals for numerical derivatives + real(rkind) :: hydCond0 ! hydraulic condictivity value for base case + real(rkind) :: hydCond1 ! hydraulic condictivity value for perturbed case + ! derivative is zero if super-saturated + if(volFracLiq < theta_sat)then ! ***** compute analytical derivatives if(lTangent)then - ! compute the effective saturation - theta_e = (volFracLiq - theta_res) / (theta_sat - theta_res) - ! compute the function and derivative of the first fuction - f1 = k_sat*theta_e**0.5_rkind - d1 = k_sat*0.5_rkind*theta_e**(-0.5_rkind) / (theta_sat - theta_res) - ! compute the function and derivative of the second function - ! (first part) - x1 = 1._rkind - theta_e**(1._rkind/m) - p1 = (-1._rkind/m)*theta_e**(1._rkind/m - 1._rkind) / (theta_sat - theta_res) ! differentiate (1.d - theta_e**(1.d/m) - ! (second part) - x2 = x1**m - p2 = m*x1**(m - 1._rkind) - ! (final) - f2 = (1._rkind - x2)**2._rkind - p3 = -2._rkind*(1._rkind - x2) - ! (combine) - d2 = p1*p2*p3 - ! pull it all together - dHydCond_dLiq = (d1*f2 + d2*f1) + ! compute the effective saturation + theta_e = (volFracLiq - theta_res) / (theta_sat - theta_res) + ! compute the function and derivative of the first fuction + f1 = k_sat*sqrt(theta_e) + d1 = k_sat*0.5_rkind*theta_e**(-0.5_rkind) / (theta_sat - theta_res) + ! compute the function and derivative of the second function + ! (first part) + x1 = 1._rkind - theta_e**(1._rkind/m) + p1 = (-1._rkind/m)*theta_e**(1._rkind/m - 1._rkind) / (theta_sat - theta_res) ! differentiate (1.d - theta_e**(1.d/m) + ! (second part) + x2 = x1**m + p2 = m*x1**(m - 1._rkind) + ! (final) + f2 = (1._rkind - x2)**2_i4b + p3 = -2._rkind*(1._rkind - x2) + ! (combine) + d2 = p1*p2*p3 + ! pull it all together + dHydCond_dLiq = (d1*f2 + d2*f1) else - ! ***** compute numerical derivatives - hydcond0 = hydCond_liq(volFracLiq, k_sat,theta_res,theta_sat,m) - hydcond1 = hydCond_liq(volFracLiq+dx,k_sat,theta_res,theta_sat,m) - dHydCond_dLiq = (hydcond1 - hydcond0)/dx + ! ***** compute numerical derivatives + hydcond0 = hydCond_liq(volFracLiq, k_sat,theta_res,theta_sat,m) + hydcond1 = hydCond_liq(volFracLiq+dx,k_sat,theta_res,theta_sat,m) + dHydCond_dLiq = (hydcond1 - hydcond0)/dx end if - else + else dHydCond_dLiq = 0._rkind - end if - end function dHydCond_dLiq - - - ! ****************************************************************************************************************************** - ! public function RH_soilair: compute relative humidity of air in soil pore space - ! ****************************************************************************************************************************** - function RH_soilair(matpot,Tk) - implicit none - real(rkind),intent(in) :: matpot ! soil water suction -- matric potential (m) - real(rkind),intent(in) :: Tk ! temperature (K) - real(rkind) :: RH_soilair ! relative humidity of air in soil pore space - ! compute relative humidity (UNITS NOTE: Pa = kg m-1 s-2, so R_wv units = m2 s-2 K-1) - RH_soilair = exp( (gravity*matpot) / (R_wv*Tk) ) - end function RH_soilair - - - ! ****************************************************************************************************************************** - ! public function crit_soilT: compute the critical temperature above which all water is unfrozen - ! ****************************************************************************************************************************** - function crit_soilT(psi) - implicit none - real(rkind),intent(in) :: psi ! matric head (m) - real(rkind) :: crit_soilT ! critical soil temperature (K) - crit_soilT = Tfreeze + min(psi,0._rkind)*gravity*Tfreeze/LH_fus - end function crit_soilT - - - ! ****************************************************************************************************************************** - ! public function dTheta_dTk: differentiate the freezing curve w.r.t. temperature - ! ****************************************************************************************************************************** - function dTheta_dTk(Tk,theta_res,theta_sat,alpha,n,m) - implicit none - real(rkind),intent(in) :: Tk ! temperature (K) - real(rkind),intent(in) :: theta_res ! residual liquid water content (-) - real(rkind),intent(in) :: theta_sat ! porosity (-) - real(rkind),intent(in) :: alpha ! vGn scaling parameter (m-1) - real(rkind),intent(in) :: n ! vGn "n" parameter (-) - real(rkind),intent(in) :: m ! vGn "m" parameter (-) - real(rkind) :: dTheta_dTk ! derivative of the freezing curve w.r.t. temperature (K-1) - ! local variables - real(rkind) :: kappa ! constant (m K-1) - real(rkind) :: xtemp ! alpha*kappa*(Tk-Tfreeze) -- dimensionless variable (used more than once) - ! compute kappa (m K-1) - kappa = LH_fus/(gravity*Tfreeze) ! NOTE: J = kg m2 s-2 - ! define a tempory variable that is used more than once (-) - xtemp = alpha*kappa*(Tk-Tfreeze) - ! differentiate the freezing curve w.r.t. temperature -- making use of the chain rule - dTheta_dTk = (alpha*kappa) * n*xtemp**(n - 1._rkind) * (-m)*(1._rkind + xtemp**n)**(-m - 1._rkind) * (theta_sat - theta_res) - end function dTheta_dTk - - - ! ****************************************************************************************************************************** - ! public function gammp: compute cumulative probability using the Gamma distribution - ! ****************************************************************************************************************************** - FUNCTION gammp(a,x) - IMPLICIT NONE - real(rkind), INTENT(IN) :: a,x - real(rkind) :: gammp - if (x ITMAX) stop 'a too large, ITMAX too small in gcf' - if (present(gln)) then - gln=gammln(a) - gcf=exp(-x+a*log(x)-gln)*h - else - gcf=exp(-x+a*log(x)-gammln(a))*h - end if - END FUNCTION gcf - - - ! ****************************************************************************************************************************** - ! private function gser: series development of the incomplete Gamma function - ! ****************************************************************************************************************************** - FUNCTION gser(a,x,gln) - IMPLICIT NONE - real(rkind), INTENT(IN) :: a,x - real(rkind), OPTIONAL, INTENT(OUT) :: gln - real(rkind) :: gser - INTEGER(I4B), PARAMETER :: ITMAX=100 - real(rkind), PARAMETER :: EPS=epsilon(x) - INTEGER(I4B) :: n - real(rkind) :: ap,del,summ - if (x == 0.0) then - gser=0.0 - RETURN - end if - ap=a - summ=1.0_rkind/a - del=summ - do n=1,ITMAX - ap=ap+1.0_rkind - del=del*x/ap - summ=summ+del - if (abs(del) < abs(summ)*EPS) exit - end do - if (n > ITMAX) stop 'a too large, ITMAX too small in gser' - if (present(gln)) then - gln=gammln(a) - gser=summ*exp(-x+a*log(x)-gln) - else - gser=summ*exp(-x+a*log(x)-gammln(a)) - end if - END FUNCTION gser - - - ! ****************************************************************************************************************************** - ! private function gammln: gamma function - ! ****************************************************************************************************************************** - FUNCTION gammln(xx) - USE nr_utility_module,only:arth ! use to build vectors with regular increments - IMPLICIT NONE - real(rkind), INTENT(IN) :: xx - real(rkind) :: gammln - real(rkind) :: tmp,x - real(rkind) :: stp = 2.5066282746310005_rkind - real(rkind), DIMENSION(6) :: coef = (/76.18009172947146_rkind,& - -86.50532032941677_rkind,24.01409824083091_rkind,& - -1.231739572450155_rkind,0.1208650973866179e-2_rkind,& - -0.5395239384953e-5_rkind/) - if(xx <= 0._rkind) stop 'xx > 0 in gammln' - x=xx - tmp=x+5.5_rkind - tmp=(x+0.5_rkind)*log(tmp)-tmp - gammln=tmp+log(stp*(1.000000000190015_rkind+& - sum(coef(:)/arth(x+1.0_rkind,1.0_rkind,size(coef))))/x) - END FUNCTION gammln + end if +end function dHydCond_dLiq + + +! ****************************************************************************************************************************** +! public function RH_soilair: compute relative humidity of air in soil pore space +! ****************************************************************************************************************************** +function RH_soilair(matpot,Tk) + implicit none + real(rkind),intent(in) :: matpot ! soil water suction -- matric potential (m) + real(rkind),intent(in) :: Tk ! temperature (K) + real(rkind) :: RH_soilair ! relative humidity of air in soil pore space + ! compute relative humidity (UNITS NOTE: Pa = kg m-1 s-2, so R_wv units = m2 s-2 K-1) + RH_soilair = exp( (gravity*matpot) / (R_wv*Tk) ) +end function RH_soilair + + +! ****************************************************************************************************************************** +! public function crit_soilT: compute the critical temperature above which all water is unfrozen +! ****************************************************************************************************************************** +function crit_soilT(psi) + implicit none + real(rkind),intent(in) :: psi ! matric head (m) + real(rkind) :: crit_soilT ! critical soil temperature (K) + crit_soilT = Tfreeze + min(psi,0._rkind)*gravity*Tfreeze/LH_fus +end function crit_soilT + + +! ****************************************************************************************************************************** +! public function dTheta_dTk: differentiate the freezing curve w.r.t. temperature +! ****************************************************************************************************************************** +function dTheta_dTk(Tk,theta_res,theta_sat,alpha,n,m) + implicit none + real(rkind),intent(in) :: Tk ! temperature (K) + real(rkind),intent(in) :: theta_res ! residual liquid water content (-) + real(rkind),intent(in) :: theta_sat ! porosity (-) + real(rkind),intent(in) :: alpha ! vGn scaling parameter (m-1) + real(rkind),intent(in) :: n ! vGn "n" parameter (-) + real(rkind),intent(in) :: m ! vGn "m" parameter (-) + real(rkind) :: dTheta_dTk ! derivative of the freezing curve w.r.t. temperature (K-1) + ! local variables + real(rkind) :: kappa ! constant (m K-1) + real(rkind) :: xtemp ! alpha*kappa*(Tk-Tfreeze) -- dimensionless variable (used more than once) + ! compute kappa (m K-1) + kappa = LH_fus/(gravity*Tfreeze) ! NOTE: J = kg m2 s-2 + ! define a tempory variable that is used more than once (-) + xtemp = alpha*kappa*(Tk-Tfreeze) + ! differentiate the freezing curve w.r.t. temperature -- making use of the chain rule + dTheta_dTk = (alpha*kappa) * n*xtemp**(n - 1._rkind) * (-m)*(1._rkind + xtemp**n)**(-m - 1._rkind) * (theta_sat - theta_res) +end function dTheta_dTk + + +! ****************************************************************************************************************************** +! public function gammp: compute cumulative probability using the Gamma distribution (Gamma CDF) +! ****************************************************************************************************************************** +function gammp(a,x) + implicit none + ! input + real(rkind), intent(in) :: a,x + ! output + real(rkind) :: gammp + ! validation + if (a < 0._rkind) then + stop "Error in gammp: a >= 0 required." + end if + if (x < 0._rkind) then + stop "Error in gammp: x >= 0 required." + end if + ! computation + if (x ITMAX) stop 'a too large, ITMAX too small in gcf' + if (present(gln)) then + gln=log_gamma(a) + gcf=exp(-x+a*log(x)-gln)*h + else + gcf=exp(-x+a*log(x)-log_gamma(a))*h + end if +end function gcf + +! ****************************************************************************************************************************** +! private function gser: series development of the incomplete Gamma function +! ****************************************************************************************************************************** +function gser(a,x,gln) + implicit none + ! input + real(rkind), intent(in) :: a,x + ! output + real(rkind), optional, intent(out) :: gln + real(rkind) :: gser + ! local variables + integer(i4b), parameter :: ITMAX=100 + real(rkind), parameter :: EPS=epsilon(x) + integer(i4b) :: n + real(rkind) :: ap,del,summ + if (x == 0.0_rkind) then + gser=0.0_rkind + return + end if + ap=a + summ=1.0_rkind/a + del=summ + do n=1,ITMAX + ap=ap+1.0_rkind + del=del*x/ap + summ=summ+del + if (abs(del) < abs(summ)*EPS) exit + end do + if (n > ITMAX) stop 'a too large, ITMAX too small in gser' + if (present(gln)) then + gln=log_gamma(a) + gser=summ*exp(-x+a*log(x)-gln) + else + gser=summ*exp(-x+a*log(x)-log_gamma(a)) + end if +end function gser + +! ****************************************************************************************************************************** +! public function gammp_complex: regularized lower incomplete gamma function (complex output) +! ****************************************************************************************************************************** +! Note: input parameters are real but output may have non-zero imaginary parts +function gammp_complex(a,x) + implicit none + ! input + real(rkind), intent(in) :: a,x + ! output + complex(rkind) :: gammp_complex + ! validation + if (a < 0._rkind) then + stop "Error in gammp_complex: a >= 0 required." + end if + ! computation + if (x ITMAX) stop 'a too large, ITMAX too small in gcf' + if (present(gln)) then + gln=log_gamma(a) + gcf_complex=exp(-x-gln)*cmplx(x,0._rkind,rkind)**a*h ! allows x<0 + else + gcf_complex=exp(-x-log_gamma(a))*cmplx(x,0._rkind,rkind)**a*h ! allows x<0 + end if +end function gcf_complex + + +! ****************************************************************************************************************************** +! private function gser_complex: series development of the incomplete Gamma function (complex output) +! ****************************************************************************************************************************** +function gser_complex(a,x,gln) + implicit none + ! input + real(rkind), intent(in) :: a,x + ! output + real(rkind), optional, intent(out) :: gln + complex(rkind) :: gser_complex + ! local variables + integer(i4b), parameter :: ITMAX=100 + real(rkind), parameter :: EPS=epsilon(x) + integer(i4b) :: n + real(rkind) :: ap,del,summ + if (x == 0.0_rkind) then + gser_complex=(0.0_rkind,0.0_rkind) + return + end if + ap=a + summ=1.0_rkind/a + del=summ + do n=1,ITMAX + ap=ap+1.0_rkind + del=del*x/ap + summ=summ+del + if (abs(del) < abs(summ)*EPS) exit + end do + if (n > ITMAX) stop 'a too large, ITMAX too small in gser' + if (present(gln)) then + gln=log_gamma(a) + gser_complex=summ*exp(-x-gln)*cmplx(x,0._rkind,rkind)**a ! allows x<0 + else + gser_complex=summ*exp(-x-log_gamma(a))*cmplx(x,0._rkind,rkind)**a ! allows x<0 + end if +end function gser_complex + +! ****************************************************************************************************************************** +! public function LogSumExp: LSE (or RealSoftMax) function used for smooth approximations of max or min functions +! ****************************************************************************************************************************** +function LogSumExp(alpha,x,err) result(LSE) + use, intrinsic :: ieee_arithmetic,only:ieee_value,ieee_is_normal,ieee_quiet_nan + use, intrinsic :: iso_fortran_env,only:real128 + implicit none + ! input + real(rkind),intent(in) :: alpha ! smoothness parameter (LSE --> max as alpha --> +Inf, LSE --> min as alpha --> -Inf) + real(rkind),intent(in) :: x(:) ! vector of input values + ! output + real(rkind) :: LSE ! LogSumExp value + integer(i4b),intent(out) :: err ! error code + ! local variables + real(real128),allocatable :: x_qp(:) ! quadruple precision x vector + real(real128) :: x_star ! quadruple precision shift value for numerical stability + real(real128) :: alpha_qp ! quadruple precision alpha + real(real128) :: LSE_qp ! quadruple precision LSE value + + err = 0_i4b ! initialize error code + + ! validation of input parameters + if (alpha == 0._rkind) then + err = 20_i4b ! positive error code to indicate failure + LSE = ieee_value(0._rkind,ieee_quiet_nan) ! assign NaN return value + return + end if + ! use quadruple precision variables to prevent over/underflow + alpha_qp = real(alpha,real128) + allocate(x_qp(size(x))) + x_qp = real(x,real128) + + ! shift value to improve numerical stability + x_star = maxval(abs(x_qp)) + + LSE_qp= x_star + log(sum(exp(alpha_qp*(x_qp-x_star))))/alpha_qp + LSE=real(LSE_qp,rkind) + + ! check if value is normal (not NaN, -Infinity, or +Infinity) + ! note: mainly to account for overflow/underflow that may occur in extreme cases + if (ieee_is_normal(LSE)) then ! return if value is not NaN or infinity + return + else ! revert to analytic max/min function as a failsafe (accurate but not smoothed) + if (alpha < 0._rkind) then ! min + LSE = minval(x) + else ! max (alpha cannot be zero) + LSE = maxval(x) + end if + end if + +end function LogSumExp + +! ****************************************************************************************************************************** +! public function SoftArgMax: SoftArgMax (aliases: softmax, normalized exponential) function for smooth approximations to argument max or min +! ****************************************************************************************************************************** +! Note: Can be used to evaluate the derivatives of LogSumExp +! dLogSumExp(alpha,x)_dx(i) = SoftArgMax(alpha,x) +function SoftArgMax(alpha,x) result(SAM) + use, intrinsic :: ieee_arithmetic,only:ieee_is_normal + use, intrinsic :: iso_fortran_env,only:real128 + implicit none + ! input + real(rkind),intent(in) :: alpha ! smoothness parameter (SAM --> arg max as alpha --> +Inf, SAM --> arg min as alpha --> -Inf) + real(rkind),intent(in) :: x(:) ! vector of input values + ! output + real(rkind),allocatable :: SAM(:) ! SoftArgMax value + ! local variables + real(real128) :: alpha_qp ! quadruple precision alpha + real(real128) :: x_star ! quadruple precision shift value for numerical stability + real(real128),allocatable :: x_qp(:) ! quadruple precision x vector + real(real128),allocatable :: SAM_qp(:) ! quadruple precision SAM value + + ! use quadruple precision variables to prevent over/underflow + alpha_qp = real(alpha,real128) + allocate(x_qp(size(x))) + x_qp = real(x,real128) + + ! shift value to improve numerical stability + x_star = maxval(abs(x_qp)) + + allocate(SAM_qp(size(x))) + SAM_qp = exp(alpha_qp*(x_qp-x_star)) / sum(exp(alpha_qp*(x_qp-x_star))) + SAM = real(SAM_qp,rkind) + + ! check if all values are normal (not NaN, -Infinity, or +Infinity) + ! note: mainly to account for overflow/underflow that may occur in extreme cases + if (all(ieee_is_normal(SAM))) then ! return if value is not NaN or infinity + return + else ! revert to analytic arg max/min function in one-hot representation as a failsafe (accurate but not smoothed) + SAM(:) = 0._rkind + if (alpha < 0._rkind) then ! arg min + SAM(minloc(x)) = 1._rkind + else ! arg max + SAM(maxloc(x)) = 1._rkind + end if + end if +end function end module soil_utils_module diff --git a/build/source/engine/soil_utilsAddPrime.f90 b/build/source/engine/soil_utilsAddPrime.f90 new file mode 100644 index 000000000..bf7d8b0b4 --- /dev/null +++ b/build/source/engine/soil_utilsAddPrime.f90 @@ -0,0 +1,192 @@ +! SUMMA - Structure for Unifying Multiple Modeling Alternatives +! Copyright (C) 2014-2015 NCAR/RAL +! +! This file is part of SUMMA +! +! For more information see: http://www.ral.ucar.edu/projects/summa +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see . + +module soil_utilsAddPrime_module + +! data types +USE nrtype + +USE multiconst,only: gravity, & ! acceleration of gravity (m s-2) + Tfreeze, & ! temperature at freezing (K) + LH_fus, & ! latent heat of fusion (J kg-1, or m2 s-2) + R_wv ! gas constant for water vapor (J kg-1 K-1; [J = Pa m3]) + +! missing values +USE globalData,only:realMissing ! missing real number + +USE soil_utils_module,only:matricHead +USE soil_utils_module,only:dPsi_dTheta +USE soil_utils_module,only:volFracLiq +USE soil_utils_module,only:dTheta_dPsi + +! privacy +implicit none +private + +! routines to make public + +public::liquidHeadPrime +public::d2Theta_dPsi2 +public::d2Theta_dTk2 +contains + + +! ****************************************************************************************************************************** +! public subroutine: compute the liquid water matric potential (and the derivatives w.r.t. total matric potential and temperature) +! ****************************************************************************************************************************** +subroutine liquidHeadPrime(& + ! input + matricHeadTotal ,& ! intent(in) : total water matric potential (m) + matricHeadTotalPrime ,& ! intent(in) : total water matric potential time derivative (m s-1) + volFracLiq ,& ! intent(in) : volumetric fraction of liquid water (-) + volFracIce ,& ! intent(in) : volumetric fraction of ice (-) + vGn_alpha,vGn_n,theta_sat,theta_res,vGn_m,& ! intent(in) : soil parameters + dVolTot_dPsi0 ,& ! intent(in) : derivative in the soil water characteristic (m-1) + dTheta_dT ,& ! intent(in) : derivative in volumetric total water w.r.t. temperature (K-1) + volFracLiqPrime ,& ! intent(in) : volumetric fraction of liquid water time derivative (-) + volFracIcePrime ,& ! intent(in) : volumetric fraction of ice time derivative (-) + ! output + matricHeadLiq ,& ! intent(out) : liquid water matric potential (m) + matricHeadLiqPrime ,& ! intent(out) : liquid water matric potential time derivative (m s-1) + dPsiLiq_dPsi0 ,& ! intent(out) : derivative in the liquid water matric potential w.r.t. the total water matric potential (-) + dPsiLiq_dTemp ,& ! intent(out) : derivative in the liquid water matric potential w.r.t. temperature (m K-1) + err,message) ! intent(out) : error control + ! computes the liquid water matric potential (and the derivatives w.r.t. total matric potential and temperature) + implicit none + ! input + real(rkind),intent(in) :: matricHeadTotal ! total water matric potential (m) + real(rkind),intent(in) :: matricHeadTotalPrime ! total water matric potential time derivative (m s-1) + real(rkind),intent(in) :: volFracLiq ! volumetric fraction of liquid water (-) + real(rkind),intent(in) :: volFracIce ! volumetric fraction of ice (-) + real(rkind),intent(in) :: vGn_alpha,vGn_n,theta_sat,theta_res,vGn_m ! soil parameters + real(rkind),intent(in) :: dVolTot_dPsi0 ! derivative in the soil water characteristic (m-1) + real(rkind),intent(in) :: dTheta_dT ! derivative in volumetric total water w.r.t. temperature (K-1) + real(rkind),intent(in) :: volFracLiqPrime ! volumetric fraction of liquid water time derivative () + real(rkind),intent(in) :: volFracIcePrime ! volumetric fraction of ice time derivative () + ! output + real(rkind),intent(out) :: matricHeadLiq ! liquid water matric potential (m) + real(rkind),intent(out) :: matricHeadLiqPrime ! liquid water matric potential time derivative (m s-1) + real(rkind),intent(out) :: dPsiLiq_dPsi0 ! derivative in the liquid water matric potential w.r.t. the total water matric potential (-) + real(rkind),intent(out) :: dPsiLiq_dTemp ! derivative in the liquid water matric potential w.r.t. temperature (m K-1) + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! local + real(rkind) :: xNum,xDen ! temporary variables (numeratir, denominator) + real(rkind) :: effSat ! effective saturation (-) + real(rkind) :: dPsiLiq_dEffSat ! derivative in liquid water matric potential w.r.t. effective saturation (m) + real(rkind) :: dEffSat_dTemp ! derivative in effective saturation w.r.t. temperature (K-1) + real(rkind) :: effSatPrime ! effective saturation time derivative (-) + ! ------------------------------------------------------------------------------------------------------------------------------ + ! initialize error control + err=0; message='liquidHeadPrime/' + + ! ** partially frozen soil + if(volFracIce > epsilon(1._rkind) .and. matricHeadTotal < 0._rkind)then ! check that ice exists and that the soil is unsaturated + ! ----- + ! - compute liquid water matric potential... + ! ------------------------------------------ + + ! - compute effective saturation + ! NOTE: include ice content as part of the solid porosity - major effect of ice is to reduce the pore size; ensure that effSat=1 at saturation + ! (from Zhao et al., J. Hydrol., 1997: Numerical analysis of simultaneous heat and mass transfer...) + xNum = volFracLiq - theta_res + xDen = theta_sat - volFracIce - theta_res + effSat = xNum/xDen ! effective saturation + + ! - matric head associated with liquid water + matricHeadLiq = matricHead(effSat,vGn_alpha,0._rkind,1._rkind,vGn_n,vGn_m) ! argument is effective saturation, so theta_res=0 and theta_sat=1 + if (effSat < 1._rkind .and. effSat > 0._rkind .and. volFracLiqPrime.ne.realMissing .and. volFracIcePrime.ne.realMissing)then + effSatPrime = (volFracLiqPrime * xDen + volFracIcePrime * xNum) / xDen**2_i4b + matricHeadLiqPrime = -( 1._rkind/(vGn_alpha*vGn_n*vGn_m) ) * effSat**(-1._rkind-1._rkind/vGn_m) * ( effSat**(-1._rkind/vGn_m) - 1._rkind )**(-1._rkind+1._rkind/vGn_n) * effSatPrime + else + matricHeadLiqPrime = 0._rkind + endif + + ! derivative in liquid water matric potential w.r.t. effective saturation (m) + dPsiLiq_dEffSat = dPsi_dTheta(effSat,vGn_alpha,0._rkind,1._rkind,vGn_n,vGn_m) + ! derivative in the liquid water matric potential w.r.t. the total water matric potential + dPsiLiq_dPsi0 = dVolTot_dPsi0*dPsiLiq_dEffSat*xNum/(xDen**2_i4b) + ! derivative in the liquid water matric potential w.r.t. temperature + dEffSat_dTemp = -dTheta_dT*xNum/(xDen**2_i4b) + dTheta_dT/xDen + dPsiLiq_dTemp = dPsiLiq_dEffSat*dEffSat_dTemp + + ! ** unfrozen soil + else ! (no ice) + matricHeadLiq = matricHeadTotal + matricHeadLiqPrime = matricHeadTotalPrime + dPsiLiq_dPsi0 = 1._rkind ! derivative=1 because values are identical + dPsiLiq_dTemp = 0._rkind ! derivative=0 because no impact of temperature for unfrozen conditions + end if ! (if ice exists) + + if(volFracLiqPrime==realMissing .or. volFracIcePrime==realMissing) matricHeadLiqPrime = realMissing + +end subroutine liquidHeadPrime + +! ****************************************************************************************************************************** +! public function d2Theta_dPsi2: compute the second derivative of the soil water characteristic (m-1) +! ****************************************************************************************************************************** +function d2Theta_dPsi2(psi,alpha,theta_res,theta_sat,n,m) + implicit none + real(rkind),intent(in) :: psi ! soil water suction (m) + real(rkind),intent(in) :: alpha ! scaling parameter (m-1) + real(rkind),intent(in) :: theta_res ! residual volumetric water content (-) + real(rkind),intent(in) :: theta_sat ! porosity (-) + real(rkind),intent(in) :: n ! vGn "n" parameter (-) + real(rkind),intent(in) :: m ! vGn "m" parameter (-) + real(rkind) :: d2Theta_dPsi2 ! derivative of the soil water characteristic (m-1) + real(rkind) :: mult_fcn + real(rkind) :: mult_fcnp + if(psi<0._rkind)then + mult_fcn = (-m*n*alpha*(alpha*psi)**(n-1._rkind)) * ( 1._rkind + (psi*alpha)**n )**(-1._rkind) + mult_fcnp = -m*n*alpha*(n-1._rkind)*alpha*(alpha*psi)**(n-2._rkind)*( 1._rkind + (psi*alpha)**n )**(-1._rkind) - & + ( n*alpha*(alpha*psi)**(n-1._rkind)*(1._rkind + (psi*alpha)**n)**(-2._rkind) ) * ( -m*n*alpha*(alpha*psi)**(n-1._rkind) ) + d2Theta_dPsi2 = mult_fcn * dTheta_dPsi(psi,alpha,theta_res,theta_sat,n,m) + & + mult_fcnp * ( volFracLiq(psi,alpha,theta_res,theta_sat,n,m) - theta_res ) + else + d2Theta_dPsi2 = 0._rkind + end if +end function d2Theta_dPsi2 + +! ****************************************************************************************************************************** +! public function d2Theta_dTk2: differentiate the freezing curve w.r.t. temperature +! ****************************************************************************************************************************** +function d2Theta_dTk2(Tk,theta_res,theta_sat,alpha,n,m) + implicit none + real(rkind),intent(in) :: Tk ! temperature (K) + real(rkind),intent(in) :: theta_res ! residual liquid water content (-) + real(rkind),intent(in) :: theta_sat ! porosity (-) + real(rkind),intent(in) :: alpha ! vGn scaling parameter (m-1) + real(rkind),intent(in) :: n ! vGn "n" parameter (-) + real(rkind),intent(in) :: m ! vGn "m" parameter (-) + real(rkind) :: d2Theta_dTk2 ! derivative of the freezing curve w.r.t. temperature (K-1) + ! local variables + real(rkind) :: kappa ! constant (m K-1) + real(rkind) :: xtemp ! alpha*kappa*(Tk-Tfreeze) -- dimensionless variable (used more than once) + ! compute kappa (m K-1) + kappa = LH_fus/(gravity*Tfreeze) ! NOTE: J = kg m2 s-2 + ! define a tempory variable that is used more than once (-) + xtemp = alpha*kappa*(Tk-Tfreeze) + ! differentiate the freezing curve w.r.t. temperature -- making use of the chain rule + d2Theta_dTk2 = (-alpha*kappa*m*n*alpha*kappa)* (theta_sat - theta_res) * ( (n-1)*xtemp**(n - 2._rkind) * (1._rkind + xtemp**n)**(-m - 1._rkind) & + + n*(-m-1)*xtemp**(2*n - 2._rkind) * (1._rkind + xtemp**n)**(-m - 2._rkind) ) +end function d2Theta_dTk2 + +end module soil_utilsAddPrime_module diff --git a/build/source/engine/spline_int.f90 b/build/source/engine/spline_int.f90 old mode 100755 new mode 100644 index 28efd3bf2..2141c0fe6 --- a/build/source/engine/spline_int.f90 +++ b/build/source/engine/spline_int.f90 @@ -57,19 +57,19 @@ SUBROUTINE spline(x,y,yp1,ypn,y2,err,message) END SUBROUTINE spline ! ************************************************************* - ! new subroutine: splint + ! new subroutine: splint and local derivative with x ! ************************************************************* - SUBROUTINE splint(xa,ya,y2a,x,y,err,message) + SUBROUTINE splint(xa,ya,y2a,x,y,dy,err,message) IMPLICIT NONE ! declare dummy variables real(rkind), DIMENSION(:), INTENT(IN) :: xa,ya,y2a real(rkind), INTENT(IN) :: x - real(rkind), INTENT(OUT) :: y - integer(i4b),intent(out) :: err - character(*),intent(out) :: message + real(rkind), INTENT(OUT) :: y, dy + integer(i4b),intent(out) :: err + character(*),intent(out) :: message ! declare local variables INTEGER(I4B) :: khi,klo,n - real(rkind) :: a,b,h + real(rkind) :: a,b,h,da,db ! check size of input vectors if (size(xa)==size(ya) .and. size(ya)==size(y2a)) then n=size(xa) @@ -83,7 +83,10 @@ SUBROUTINE splint(xa,ya,y2a,x,y,err,message) if (h == 0.0_rkind) then; err=20; message="f-splint/badXinput"; return; end if a=(xa(khi)-x)/h b=(x-xa(klo))/h + da = -1.0_rkind/h + db = 1.0_rkind/h y=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.0_rkind + dy = da*ya(klo)+db*ya(khi)+((3.0_rkind*da*a**2-da)*y2a(klo)+(3.0_rkind*db*b**2-db)*y2a(khi))*(h**2)/6.0_rkind END SUBROUTINE splint ! ************************************************************* diff --git a/build/source/engine/ssdNrgFlux.f90 b/build/source/engine/ssdNrgFlux.f90 old mode 100755 new mode 100644 index f1be8ebea..1405a78ca --- a/build/source/engine/ssdNrgFlux.f90 +++ b/build/source/engine/ssdNrgFlux.f90 @@ -24,32 +24,25 @@ module ssdNrgFlux_module USE nrtype ! data types -USE data_types,only:var_d ! x%var(:) (dp) -USE data_types,only:var_dlength ! x%var(:)%dat (dp) -USE data_types,only:var_ilength ! x%var(:)%dat (i4b) +USE data_types,only:var_d ! x%var(:) [rkind] +USE data_types,only:var_dlength ! x%var(:)%dat [rkind] +USE data_types,only:var_ilength ! x%var(:)%dat [i4b] +USE data_types,only:in_type_ssdNrgFlux ! intent(in) arguments for ssdNrgFlux +USE data_types,only:io_type_ssdNrgFlux ! intent(inout) arguments for ssdNrgFlux +USE data_types,only:out_type_ssdNrgFlux ! intent(out) arguments for ssdNrgFlux ! physical constants USE multiconst,only:& - sb, & ! Stefan Boltzman constant (W m-2 K-4) - Em_Sno, & ! emissivity of snow (-) - Cp_air, & ! specific heat of air (J kg-1 K-1) - Cp_water, & ! specifric heat of water (J kg-1 K-1) - LH_fus, & ! latent heat of fusion (J kg-1) - LH_vap, & ! latent heat of vaporization (J kg-1) - LH_sub, & ! latent heat of sublimation (J kg-1) - gravity, & ! gravitational acceleteration (m s-2) - Tfreeze, & ! freezing point of pure water (K) - iden_air, & ! intrinsic density of air (kg m-3) - iden_ice, & ! intrinsic density of ice (kg m-3) - iden_water ! intrinsic density of water (kg m-3) + iden_water, & ! intrinsic density of water (kg m-3) + Cp_water ! specific heat of liquid water (J kg-1 K-1) ! missing values USE globalData,only:integerMissing ! missing integer USE globalData,only:realMissing ! missing real number ! named variables for snow and soil -USE globalData,only:iname_snow ! named variables for snow -USE globalData,only:iname_soil ! named variables for soil +USE globalData,only:iname_snow ! named variables for snow +USE globalData,only:iname_soil ! named variables for soil ! named variables USE var_lookup,only:iLookPROG ! named variables for structure elements @@ -59,239 +52,239 @@ module ssdNrgFlux_module USE var_lookup,only:iLookINDEX ! named variables for structure elements ! model decisions -USE globalData,only:model_decisions ! model decision structure -USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure +USE globalData,only:model_decisions ! model decision structure +USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure ! provide access to look-up values for model decisions USE mDecisions_module,only: & ! look-up values for method used to compute derivative - numerical, & ! numerical solution - analytical, & ! analytical solution + numerical, & ! numerical solution + analytical, & ! analytical solution ! look-up values for choice of boundary conditions for thermodynamics - prescribedTemp, & ! prescribed temperature - energyFlux, & ! energy flux - zeroFlux, & ! zero flux - ! look-up values for choice of boundary conditions for soil hydrology - prescribedHead ! prescribed head - + prescribedTemp, & ! prescribed temperature + energyFlux, & ! energy flux + zeroFlux ! zero flux ! ------------------------------------------------------------------------------------------------- implicit none private -public::ssdNrgFlux +public :: ssdNrgFlux ! global parameters -real(rkind),parameter :: dx=1.e-10_rkind ! finite difference increment (K) -real(rkind),parameter :: valueMissing=-9999._rkind ! missing value parameter +real(rkind),parameter :: dx=1.e-10_rkind ! finite difference increment (K) contains - - ! ************************************************************************************************ - ! public subroutine ssdNrgFlux: compute energy fluxes and derivatives at layer interfaces - ! ************************************************************************************************ - subroutine ssdNrgFlux(& - ! input: model control - scalarSolution, & ! intent(in): flag to indicate the scalar solution - ! input: fluxes and derivatives at the upper boundary - groundNetFlux, & ! intent(in): total flux at the ground surface (W m-2) - dGroundNetFlux_dGroundTemp, & ! intent(in): derivative in total ground surface flux w.r.t. ground temperature (W m-2 K-1) - ! input: liquid water fluxes - iLayerLiqFluxSnow, & ! intent(in): liquid flux at the interface of each snow layer (m s-1) - iLayerLiqFluxSoil, & ! intent(in): liquid flux at the interface of each soil layer (m s-1) - ! input: trial value of model state variabes - mLayerTempTrial, & ! intent(in): trial temperature at the current iteration (K) - ! input-output: data structures - mpar_data, & ! intent(in): model parameters - indx_data, & ! intent(in): model indices - prog_data, & ! intent(in): model prognostic variables for a local HRU - diag_data, & ! intent(in): model diagnostic variables for a local HRU - flux_data, & ! intent(inout): model fluxes for a local HRU - ! output: fluxes and derivatives at all layer interfaces - iLayerNrgFlux, & ! intent(out): energy flux at the layer interfaces (W m-2) - dFlux_dTempAbove, & ! intent(out): derivatives in the flux w.r.t. temperature in the layer above (W m-2 K-1) - dFlux_dTempBelow, & ! intent(out): derivatives in the flux w.r.t. temperature in the layer below (W m-2 K-1) - ! output: error control - err,message) ! intent(out): error control - implicit none - ! input: model control - logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution - ! input: fluxes and derivatives at the upper boundary - real(rkind),intent(in) :: groundNetFlux ! net energy flux for the ground surface (W m-2) - real(rkind),intent(in) :: dGroundNetFlux_dGroundTemp ! derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) - ! input: liquid water fluxes - real(rkind),intent(in) :: iLayerLiqFluxSnow(0:) ! intent(in): liquid flux at the interface of each snow layer (m s-1) - real(rkind),intent(in) :: iLayerLiqFluxSoil(0:) ! intent(in): liquid flux at the interface of each soil layer (m s-1) - ! input: trial value of model state variables - real(rkind),intent(in) :: mLayerTempTrial(:) ! trial temperature of each snow/soil layer at the current iteration (K) - ! input-output: data structures - type(var_dlength),intent(in) :: mpar_data ! model parameters - type(var_ilength),intent(in) :: indx_data ! state vector geometry - type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU - type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU - type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU - ! output: fluxes and derivatives at all layer interfaces - real(rkind),intent(out) :: iLayerNrgFlux(0:) ! energy flux at the layer interfaces (W m-2) - real(rkind),intent(out) :: dFlux_dTempAbove(0:) ! derivatives in the flux w.r.t. temperature in the layer above (J m-2 s-1 K-1) - real(rkind),intent(out) :: dFlux_dTempBelow(0:) ! derivatives in the flux w.r.t. temperature in the layer below (J m-2 s-1 K-1) - ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! ------------------------------------------------------------------------------------------------------------------------------------------------------ - ! local variables - integer(i4b) :: iLayer ! index of model layers - integer(i4b) :: ixLayerDesired(1) ! layer desired (scalar solution) - integer(i4b) :: ixTop ! top layer in subroutine call - integer(i4b) :: ixBot ! bottom layer in subroutine call - real(rkind) :: qFlux ! liquid flux at layer interfaces (m s-1) - real(rkind) :: dz ! height difference (m) - real(rkind) :: flux0,flux1,flux2 ! fluxes used to calculate derivatives (W m-2) - ! ------------------------------------------------------------------------------------------------------------------------------------------------------ - ! make association of local variables with information in the data structures - associate(& - ix_fDerivMeth => model_decisions(iLookDECISIONS%fDerivMeth)%iDecision, & ! intent(in): method used to calculate flux derivatives - ix_bcLowrTdyn => model_decisions(iLookDECISIONS%bcLowrTdyn)%iDecision, & ! intent(in): method used to calculate the lower boundary condition for thermodynamics - ! input: model coordinates - nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1), & ! intent(in): number of snow layers - nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1), & ! intent(in): total number of layers - layerType => indx_data%var(iLookINDEX%layerType)%dat, & ! intent(in): layer type (iname_soil or iname_snow) - ixLayerState => indx_data%var(iLookINDEX%ixLayerState)%dat, & ! intent(in): list of indices for all model layers - ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat, & ! intent(in): index in the state subset for energy state variables in the snow+soil domain - ! input: thermal properties - mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat, & ! intent(in): depth of each layer (m) - mLayerHeight => prog_data%var(iLookPROG%mLayerHeight)%dat, & ! intent(in): height at the mid-point of each layer (m) - iLayerThermalC => diag_data%var(iLookDIAG%iLayerThermalC)%dat, & ! intent(in): thermal conductivity at the interface of each layer (W m-1 K-1) - lowerBoundTemp => mpar_data%var(iLookPARAM%lowerBoundTemp)%dat(1), & ! intent(in): temperature of the lower boundary (K) - ! output: diagnostic fluxes - iLayerConductiveFlux => flux_data%var(iLookFLUX%iLayerConductiveFlux)%dat, & ! intent(out): conductive energy flux at layer interfaces at end of time step (W m-2) - iLayerAdvectiveFlux => flux_data%var(iLookFLUX%iLayerAdvectiveFlux)%dat & ! intent(out): advective energy flux at layer interfaces at end of time step (W m-2) - ) ! association of local variables with information in the data structures - ! ------------------------------------------------------------------------------------------------------------------------------------------------------ - ! initialize error control - err=0; message='ssdNrgFlux/' - - ! set conductive and advective fluxes to missing in the upper boundary - ! NOTE: advective flux at the upper boundary is included in the ground heat flux - iLayerConductiveFlux(0) = valueMissing - iLayerAdvectiveFlux(0) = valueMissing - - ! get the indices for the snow+soil layers - if(scalarSolution)then - ixLayerDesired = pack(ixLayerState, ixSnowSoilNrg/=integerMissing) - ixTop = ixLayerDesired(1) - ixBot = ixLayerDesired(1) - else - ixTop = 1 - ixBot = nLayers - endif - - ! ------------------------------------------------------------------------------------------------------------------------- - ! ***** compute the conductive fluxes at layer interfaces ***** - ! ------------------------------------------------------------------------------------------------------------------------- - do iLayer=ixTop,ixBot ! (loop through model layers) - - ! compute fluxes at the lower boundary -- positive downwards - if(iLayer==nLayers)then - ! flux depends on the type of lower boundary condition - select case(ix_bcLowrTdyn) ! (identify the lower boundary condition for thermodynamics - case(prescribedTemp); iLayerConductiveFlux(nLayers) = -iLayerThermalC(iLayer)*(lowerBoundTemp - mLayerTempTrial(iLayer))/(mLayerDepth(iLayer)*0.5_rkind) - case(zeroFlux); iLayerConductiveFlux(nLayers) = 0._rkind - case default; err=20; message=trim(message)//'unable to identify lower boundary condition for thermodynamics'; return - end select ! (identifying the lower boundary condition for thermodynamics) - - ! compute fluxes within the domain -- positive downwards - else - iLayerConductiveFlux(iLayer) = -iLayerThermalC(iLayer)*(mLayerTempTrial(iLayer+1) - mLayerTempTrial(iLayer)) / & - (mLayerHeight(iLayer+1) - mLayerHeight(iLayer)) - - !write(*,'(a,i4,1x,2(f9.3,1x))') 'iLayer, iLayerConductiveFlux(iLayer), iLayerThermalC(iLayer) = ', iLayer, iLayerConductiveFlux(iLayer), iLayerThermalC(iLayer) - end if ! (the type of layer) - end do - - ! ------------------------------------------------------------------------------------------------------------------------- - ! ***** compute the advective fluxes at layer interfaces ***** - ! ------------------------------------------------------------------------------------------------------------------------- - do iLayer=ixTop,ixBot - ! get the liquid flux at layer interfaces - select case(layerType(iLayer)) - case(iname_snow); qFlux = iLayerLiqFluxSnow(iLayer) - case(iname_soil); qFlux = iLayerLiqFluxSoil(iLayer-nSnow) - case default; err=20; message=trim(message)//'unable to identify layer type'; return - end select - ! compute fluxes at the lower boundary -- positive downwards - if(iLayer==nLayers)then - iLayerAdvectiveFlux(iLayer) = -Cp_water*iden_water*qFlux*(lowerBoundTemp - mLayerTempTrial(iLayer)) - ! compute fluxes within the domain -- positive downwards - else - iLayerAdvectiveFlux(iLayer) = -Cp_water*iden_water*qFlux*(mLayerTempTrial(iLayer+1) - mLayerTempTrial(iLayer)) - end if - end do ! looping through layers - - ! ------------------------------------------------------------------------------------------------------------------------- - ! ***** compute the total fluxes at layer interfaces ***** - ! ------------------------------------------------------------------------------------------------------------------------- - ! NOTE: ignore advective fluxes for now - iLayerNrgFlux(0) = groundNetFlux - iLayerNrgFlux(ixTop:ixBot) = iLayerConductiveFlux(ixTop:ixBot) - !print*, 'iLayerNrgFlux(0:4) = ', iLayerNrgFlux(0:4) - - ! ------------------------------------------------------------------------------------------------------------------------- - ! ***** compute the derivative in fluxes at layer interfaces w.r.t temperature in the layer above and the layer below ***** - ! ------------------------------------------------------------------------------------------------------------------------- - - ! initialize un-used elements - dFlux_dTempBelow(nLayers) = -huge(lowerBoundTemp) ! don't expect this to be used, so deliberately set to a ridiculous value to cause problems - - ! ***** the upper boundary - dFlux_dTempBelow(0) = dGroundNetFlux_dGroundTemp - - ! loop through INTERFACES... - do iLayer=ixTop,ixBot - - ! ***** the lower boundary - if(iLayer==nLayers)then ! (lower boundary) - - ! identify the lower boundary condition - select case(ix_bcLowrTdyn) - - ! * prescribed temperature at the lower boundary - case(prescribedTemp) - - dz = mLayerDepth(iLayer)*0.5_rkind - if(ix_fDerivMeth==analytical)then ! ** analytical derivatives - dFlux_dTempAbove(iLayer) = iLayerThermalC(iLayer)/dz - else ! ** numerical derivatives - flux0 = -iLayerThermalC(iLayer)*(lowerBoundTemp - (mLayerTempTrial(iLayer) ))/dz - flux1 = -iLayerThermalC(iLayer)*(lowerBoundTemp - (mLayerTempTrial(iLayer)+dx))/dz - dFlux_dTempAbove(iLayer) = (flux1 - flux0)/dx - end if - - ! * zero flux at the lower boundary - case(zeroFlux) - dFlux_dTempAbove(iLayer) = 0._rkind - - case default; err=20; message=trim(message)//'unable to identify lower boundary condition for thermodynamics'; return - - end select ! (identifying the lower boundary condition for thermodynamics) - - ! ***** internal layers - else - dz = (mLayerHeight(iLayer+1) - mLayerHeight(iLayer)) - if(ix_fDerivMeth==analytical)then ! ** analytical derivatives - dFlux_dTempAbove(iLayer) = iLayerThermalC(iLayer)/dz - dFlux_dTempBelow(iLayer) = -iLayerThermalC(iLayer)/dz - else ! ** numerical derivatives - flux0 = -iLayerThermalC(iLayer)*( mLayerTempTrial(iLayer+1) - mLayerTempTrial(iLayer) ) / dz - flux1 = -iLayerThermalC(iLayer)*( mLayerTempTrial(iLayer+1) - (mLayerTempTrial(iLayer)+dx)) / dz - flux2 = -iLayerThermalC(iLayer)*((mLayerTempTrial(iLayer+1)+dx) - mLayerTempTrial(iLayer) ) / dz - dFlux_dTempAbove(iLayer) = (flux1 - flux0)/dx - dFlux_dTempBelow(iLayer) = (flux2 - flux0)/dx - end if - - end if ! type of layer (upper, internal, or lower) - - end do ! (looping through layers) - - ! end association of local variables with information in the data structures - end associate - - end subroutine ssdNrgFlux +! ********************************************************************************************************** +! public subroutine ssdNrgFlux: compute energy fluxes and derivatives at layer interfaces +! ********************************************************************************************************** +subroutine ssdNrgFlux(& + ! input: model control, fluxes, trial variables, and derivatives + in_ssdNrgFlux, & ! intent(in): model control, fluxes, trial variables, and derivatives + ! input-output: data structures and derivatives + mpar_data, & ! intent(in): model parameters + indx_data, & ! intent(in): model indices + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(in): model diagnostic variables for a local HRU + flux_data, & ! intent(inout): model fluxes for a local HRU + io_ssdNrgFlux, & ! intent(inout): derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) + ! output: fluxes and derivatives at all layer interfaces and error control + out_ssdNrgFlux) ! intent(out): derivatives and error control + ! ------------------------------------------------------------------------------------------------------------------------------------------------- + implicit none + ! input: model control, fluxes, trial variables, and derivatives + type(in_type_ssdNrgFlux),intent(in) :: in_ssdNrgFlux ! input ssdNrgFlux arguments + ! input-output: data structures + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_ilength),intent(in) :: indx_data ! state vector geometry + type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU + type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU + ! input-output: derivatives + type(io_type_ssdNrgFlux),intent(inout) :: io_ssdNrgFlux ! input-output ssdNrgFlux arguments + ! output: fluxes and derivatives at all layer interfaces + type(out_type_ssdNrgFlux),intent(inout) :: out_ssdNrgFlux ! output ssdNrgFlux arguments + ! ------------------------------------------------------------------------------------------------------------------------------------------------------ + ! local variables + !character(LEN=256) :: cmessage ! error message of downwind routine + integer(i4b) :: nLayers ! number of model layers + integer(i4b) :: iLayer ! index of model layers + integer(i4b) :: ixLayerDesired(1) ! layer desired (scalar solution) + integer(i4b) :: ixTop ! top layer in subroutine call + integer(i4b) :: ixBot ! bottom layer in subroutine call + real(rkind) :: qFlux ! liquid flux at layer interfaces (m s-1) + real(rkind) :: dz ! height difference (m) + ! ------------------------------------------------------------------------------------------------------------------------------------------------------ + ! allocate intent(out) data structure components + nLayers=indx_data%var(iLookINDEX%nLayers)%dat(1) + allocate(& + out_ssdNrgFlux % iLayerNrgFlux(0:nLayers), & ! energy flux at the layer interfaces (W m-2) + out_ssdNrgFlux % dNrgFlux_dTempAbove(0:nLayers), & ! derivatives in the flux w.r.t. temperature in the layer above (J m-2 s-1 K-1) + out_ssdNrgFlux % dNrgFlux_dTempBelow(0:nLayers), & ! derivatives in the flux w.r.t. temperature in the layer below (J m-2 s-1 K-1) + out_ssdNrgFlux % dNrgFlux_dWatAbove(0:nLayers), & ! derivatives in the flux w.r.t. water state in the layer above (J m-2 s-1 K-1) + out_ssdNrgFlux % dNrgFlux_dWatBelow(0:nLayers)) ! derivatives in the flux w.r.t. water state in the layer below (J m-2 s-1 K-1) + ! make association of local variables with information in the data structures + associate(& + ! input: model control + scalarSolution => in_ssdNrgFlux % scalarSolution, & ! intent(in): flag to denote if implementing the scalar solution + ! input: fluxes and derivatives at the upper boundary + groundNetFlux => in_ssdNrgFlux % scalarGroundNetNrgFlux, & ! intent(in): net energy flux for the ground surface (W m-2) + dGroundNetFlux_dGroundTemp => io_ssdNrgFlux % dGroundNetFlux_dGroundTemp, & ! intent(inout): derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) + ! input: liquid water fluxes + iLayerLiqFluxSnow => in_ssdNrgFlux % iLayerLiqFluxSnow, & ! intent(in): liquid flux at the interface of each snow layer (m s-1) + iLayerLiqFluxSoil => in_ssdNrgFlux % iLayerLiqFluxSoil, & ! intent(in): liquid flux at the interface of each soil layer (m s-1) + ! input: trial model state variables + mLayerTempTrial => in_ssdNrgFlux % mLayerTempTrial, & ! intent(in): temperature in each layer at the current iteration (m) + ! input: derivatives + dThermalC_dWatAbove => in_ssdNrgFlux % dThermalC_dWatAbove, & ! intent(in): derivative in the thermal conductivity w.r.t. water state in the layer above + dThermalC_dWatBelow => in_ssdNrgFlux % dThermalC_dWatBelow, & ! intent(in): derivative in the thermal conductivity w.r.t. water state in the layer above + dThermalC_dTempAbove => in_ssdNrgFlux % dThermalC_dTempAbove, & ! intent(in): derivative in the thermal conductivity w.r.t. energy state in the layer above + dThermalC_dTempBelow => in_ssdNrgFlux % dThermalC_dTempBelow, & ! intent(in): derivative in the thermal conductivity w.r.t. energy state in the layer above + ! input: boundary conditions + ix_bcUpprTdyn => model_decisions(iLookDECISIONS%bcUpprTdyn)%iDecision, & ! intent(in): method used to calculate the upper boundary condition for thermodynamics + ix_bcLowrTdyn => model_decisions(iLookDECISIONS%bcLowrTdyn)%iDecision, & ! intent(in): method used to calculate the lower boundary condition for thermodynamics + ! input: coordinate variables + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1), & ! intent(in): number of snow layers + layerType => indx_data%var(iLookINDEX%layerType)%dat, & ! intent(in): layer type (iname_soil or iname_snow) + ixLayerState => indx_data%var(iLookINDEX%ixLayerState)%dat, & ! intent(in): list of indices for all model layers + ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat, & ! intent(in): index in the state subset for energy state variables in the snow+soil domain + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat, & ! intent(in): depth of each layer (m) + mLayerHeight => prog_data%var(iLookPROG%mLayerHeight)%dat, & ! intent(in): height at the mid-point of each layer (m) + ! input: thermal properties + upperBoundTemp => mpar_data%var(iLookPARAM%upperBoundTemp)%dat(1), & ! intent(in): temperature of the upper boundary (K) + lowerBoundTemp => mpar_data%var(iLookPARAM%lowerBoundTemp)%dat(1), & ! intent(in): temperature of the lower boundary (K) + iLayerThermalC => diag_data%var(iLookDIAG%iLayerThermalC)%dat, & ! intent(in): thermal conductivity at the interface of each layer (W m-1 K-1) + ! output: diagnostic fluxes + iLayerConductiveFlux => flux_data%var(iLookFLUX%iLayerConductiveFlux)%dat, & ! intent(out): conductive energy flux at layer interfaces at end of time step (W m-2) + iLayerAdvectiveFlux => flux_data%var(iLookFLUX%iLayerAdvectiveFlux)%dat, & ! intent(out): advective energy flux at layer interfaces at end of time step (W m-2) + ! output: fluxes and derivatives at all layer interfaces + iLayerNrgFlux => out_ssdNrgFlux % iLayerNrgFlux, & ! intent(out): energy flux at the layer interfaces (W m-2) + dFlux_dTempAbove => out_ssdNrgFlux % dNrgFlux_dTempAbove, & ! intent(out): derivatives in the flux w.r.t. temperature in the layer above (J m-2 s-1 K-1) + dFlux_dTempBelow => out_ssdNrgFlux % dNrgFlux_dTempBelow, & ! intent(out): derivatives in the flux w.r.t. temperature in the layer below (J m-2 s-1 K-1) + dFlux_dWatAbove => out_ssdNrgFlux % dNrgFlux_dWatAbove, & ! intent(out): derivatives in the flux w.r.t. water state in the layer above (J m-2 s-1 K-1) + dFlux_dWatBelow => out_ssdNrgFlux % dNrgFlux_dWatBelow, & ! intent(out): derivatives in the flux w.r.t. water state in the layer below (J m-2 s-1 K-1) + ! output: error control + err => out_ssdNrgFlux % err, & ! intent(out): error code + message => out_ssdNrgFlux % cmessage & ! intent(out): error message + ) ! end association of local variables with information in the data structures + ! ------------------------------------------------------------------------------------------------------------------------------------------------------ + ! initialize error control + err=0; message='ssdNrgFlux/' + + ! set conductive and advective fluxes to missing in the upper boundary + iLayerConductiveFlux(0) = realMissing + iLayerAdvectiveFlux(0) = realMissing !included in the ground heat flux + + ! get the indices for the snow+soil layers + if (scalarSolution) then + ixLayerDesired = pack(ixLayerState, ixSnowSoilNrg/=integerMissing) + ixTop = ixLayerDesired(1) + ixBot = ixLayerDesired(1) + else + ixTop = 1 + ixBot = nLayers + end if + + ! ------------------------------------------------------------------------------------------------------------------------- + ! ***** compute the conductive fluxes at layer interfaces ***** + ! ------------------------------------------------------------------------------------------------------------------------- + do iLayer=ixTop,ixBot + if (iLayer==nLayers) then ! lower boundary fluxes -- positive downwards + ! flux depends on the type of lower boundary condition + select case(ix_bcLowrTdyn) ! identify the lower boundary condition for thermodynamics + case(prescribedTemp); iLayerConductiveFlux(iLayer) = -iLayerThermalC(iLayer)*(lowerBoundTemp - mLayerTempTrial(iLayer))/(mLayerDepth(iLayer)*0.5_rkind) + case(zeroFlux); iLayerConductiveFlux(iLayer) = 0._rkind + end select ! identifying the lower boundary condition for thermodynamics + else ! domain boundary fluxes -- positive downwards + iLayerConductiveFlux(iLayer) = -iLayerThermalC(iLayer)*(mLayerTempTrial(iLayer+1) - mLayerTempTrial(iLayer)) / & + (mLayerHeight(iLayer+1) - mLayerHeight(iLayer)) + end if ! the type of layer + end do ! end looping through layers + + ! ------------------------------------------------------------------------------------------------------------------------- + ! ***** compute the advective fluxes at layer interfaces ***** + ! ------------------------------------------------------------------------------------------------------------------------- + do iLayer=ixTop,ixBot + select case(layerType(iLayer)) ! get the liquid flux at layer interfaces + case(iname_snow); qFlux = iLayerLiqFluxSnow(iLayer) + case(iname_soil); qFlux = iLayerLiqFluxSoil(iLayer-nSnow) + case default; err=20; message=trim(message)//'unable to identify layer type'; return + end select + if (iLayer==nLayers) then ! compute fluxes at the lower boundary -- positive downwards + iLayerAdvectiveFlux(iLayer) = -Cp_water*iden_water*qFlux*(lowerBoundTemp - mLayerTempTrial(iLayer)) + else ! compute fluxes within the domain -- positive downwards + iLayerAdvectiveFlux(iLayer) = -Cp_water*iden_water*qFlux*(mLayerTempTrial(iLayer+1) - mLayerTempTrial(iLayer)) + end if + end do ! end looping through layers + + ! ------------------------------------------------------------------------------------------------------------------------- + ! ***** compute the total fluxes at layer interfaces ***** + ! ------------------------------------------------------------------------------------------------------------------------- + ! NOTE: ignore advective fluxes for now + iLayerNrgFlux(0) = groundNetFlux ! from vegNrgFlux module + iLayerNrgFlux(ixTop:ixBot) = iLayerConductiveFlux(ixTop:ixBot) + + ! ------------------------------------------------------------------------------------------------------------------- + ! ***** compute the derivative in fluxes at layer interfaces w.r.t state in the layer above and the layer below ***** + ! ------------------------------------------------------------------------------------------------------------------- + + ! initialize un-used elements + ! ***** the upper boundary + dFlux_dTempAbove(0) = 0._rkind ! this will be in canopy + dFlux_dWatAbove(0) = 0._rkind ! this will be in canopy + + ! ***** the lower boundary + dFlux_dTempBelow(nLayers) = -huge(lowerBoundTemp) ! don't expect this to be used, so deliberately set to a ridiculous value to cause problems + dFlux_dWatBelow(nLayers) = -huge(lowerBoundTemp) ! don't expect this to be used, so deliberately set to a ridiculous value to cause problems + + ! ***** the upper boundary, always do + select case(ix_bcUpprTdyn) + + ! * prescribed temperature at the upper boundary + case(prescribedTemp) + dz = mLayerHeight(1)*0.5_rkind + dFlux_dWatBelow(0) = -dThermalC_dWatBelow(0) * ( mLayerTempTrial(1) - upperBoundTemp )/dz + dFlux_dTempBelow(0) = -dThermalC_dTempBelow(0) * ( mLayerTempTrial(1) - upperBoundTemp )/dz - iLayerThermalC(0)/dz + + ! * zero flux at the upper boundary + case(zeroFlux) + dFlux_dWatBelow(0) = 0._rkind + dFlux_dTempBelow(0) = 0._rkind + + ! * compute flux inside vegetation energy flux routine, use here + case(energyFlux) + dFlux_dWatBelow(0) = 0._rkind + dFlux_dTempBelow(0) = dGroundNetFlux_dGroundTemp + + case default; err=20; message=trim(message)//'unable to identify upper boundary condition for thermodynamics'; return + + end select ! end identifying the upper boundary condition for thermodynamics + dGroundNetFlux_dGroundTemp = dFlux_dTempBelow(0) ! may need this in vegNrgFlux + + ! loop through INTERFACES... + do iLayer=ixTop,ixBot + ! ***** the lower boundary + if (iLayer==nLayers) then ! if lower boundary + ! identify the lower boundary condition + select case(ix_bcLowrTdyn) ! prescribed temperature at the lower boundary + case(prescribedTemp) + dz = mLayerDepth(iLayer)*0.5_rkind + dFlux_dWatAbove(iLayer) = -dThermalC_dWatAbove(iLayer) * ( lowerBoundTemp - mLayerTempTrial(iLayer) )/dz + dFlux_dTempAbove(iLayer) = -dThermalC_dTempAbove(iLayer) * ( lowerBoundTemp - mLayerTempTrial(iLayer) )/dz + iLayerThermalC(iLayer)/dz + case(zeroFlux) ! zero flux at the lower boundary + dFlux_dWatAbove(iLayer) = 0._rkind + dFlux_dTempAbove(iLayer) = 0._rkind + case default; err=20; message=trim(message)//'unable to identify lower boundary condition for thermodynamics'; return + end select ! end identifying the lower boundary condition for thermodynamics + ! ***** internal layers + else + dz = (mLayerHeight(iLayer+1) - mLayerHeight(iLayer)) + dFlux_dWatAbove(iLayer) = -dThermalC_dWatAbove(iLayer) * ( mLayerTempTrial(iLayer+1) - mLayerTempTrial(iLayer) )/dz + dFlux_dWatBelow(iLayer) = -dThermalC_dWatBelow(iLayer) * ( mLayerTempTrial(iLayer+1) - mLayerTempTrial(iLayer) )/dz + dFlux_dTempAbove(iLayer) = -dThermalC_dTempAbove(iLayer) * ( mLayerTempTrial(iLayer+1) - mLayerTempTrial(iLayer) )/dz + iLayerThermalC(iLayer)/dz + dFlux_dTempBelow(iLayer) = -dThermalC_dTempBelow(iLayer) * ( mLayerTempTrial(iLayer+1) - mLayerTempTrial(iLayer) )/dz - iLayerThermalC(iLayer)/dz + end if ! type of layer (upper, internal, or lower) + end do ! end looping through layers + + end associate ! end association of local variables with information in the data structures + +end subroutine ssdNrgFlux end module ssdNrgFlux_module diff --git a/build/source/engine/stomResist.f90 b/build/source/engine/stomResist.f90 old mode 100755 new mode 100644 index cf852679d..65ae98e18 --- a/build/source/engine/stomResist.f90 +++ b/build/source/engine/stomResist.f90 @@ -22,6 +22,7 @@ module stomResist_module ! data types USE nrtype +USE globalData,only:realMissing ! missing real number ! physical constants USE multiconst, only: Rgas ! universal gas constant (J mol-1 K-1) @@ -31,8 +32,8 @@ module stomResist_module ! derived types to define the data structures USE data_types,only:& var_i, & ! data vector (i4b) - var_d, & ! data vector (dp) - var_dlength, & ! data vector with variable length dimension (dp) + var_d, & ! data vector (rkind) + var_dlength, & ! data vector with variable length dimension (rkind) model_options ! defines the model decisions ! indices that define elements of the data structures @@ -41,7 +42,7 @@ module stomResist_module USE var_lookup,only:iLookFLUX ! named variables for structure elements USE var_lookup,only:iLookFORCE ! named variables for structure elements USE var_lookup,only:iLookPARAM ! named variables for structure elements -USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure +USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure ! look-up values for the stomatal resistance formulation USE mDecisions_module,only: & @@ -90,14 +91,10 @@ module stomResist_module implicit none private public::stomResist -! spatial indices -integer(i4b),parameter :: iLoc = 1 ! i-location -integer(i4b),parameter :: jLoc = 1 ! j-location ! conversion factors real(rkind),parameter :: joule2umolConv=4.6_rkind ! conversion factor from joules to umol photons (umol J-1) ! algorithmic parameters -real(rkind),parameter :: missingValue=-9999._rkind ! missing value, used when diagnostic or state variables are undefined -real(rkind),parameter :: mpe=1.e-6_rkind ! prevents overflow error if division by zero +real(rkind),parameter :: mpe=1.e-6_rkind ! prevents overflow error if division by zero, from NOAH mpe value real(rkind),parameter :: dx=1.e-6_rkind ! finite difference increment contains @@ -131,22 +128,22 @@ subroutine stomResist(& real(rkind),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) real(rkind),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) ! input: data structures - type(var_i),intent(in) :: type_data ! type of vegetation and soil - type(var_d),intent(in) :: forc_data ! model forcing data - type(var_dlength),intent(in) :: mpar_data ! model parameters - type(model_options),intent(in) :: model_decisions(:) ! model decisions + type(var_i),intent(in) :: type_data ! type of vegetation and soil + type(var_d),intent(in) :: forc_data ! model forcing data + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(model_options),intent(in) :: model_decisions(:) ! model decisions ! input-output: data structures - type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU - type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! ------------------------------------------------------------------------------------------------------------------------------------------------------ + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! ----------------------------------------------------------------------------------------------------------------------------------------------------- ! local variables - character(LEN=256) :: cmessage ! error message of downwind routine - integer(i4b),parameter :: ixSunlit=1 ! named variable for sunlit leaves - integer(i4b),parameter :: ixShaded=2 ! named variable for shaded leaves - integer(i4b) :: iSunShade ! index defining sunlit or shaded leaves + character(LEN=256) :: cmessage ! error message of downwind routine + integer(i4b),parameter :: ixSunlit=1 ! named variable for sunlit leaves + integer(i4b),parameter :: ixShaded=2 ! named variable for shaded leaves + integer(i4b) :: iSunShade ! index defining sunlit or shaded leaves real(rkind) :: absorbedPAR ! absorbed PAR (W m-2) real(rkind) :: scalarStomResist ! stomatal resistance (s m-1) real(rkind) :: scalarPhotosynthesis ! photosynthesis (umol CO2 m-2 s-1) @@ -206,8 +203,8 @@ subroutine stomResist(& scalarStomResistSunlit = minStomatalResistance/scalarTranspireLim scalarStomResistShaded = scalarStomResistSunlit ! set photosynthesis to missing (not computed) - scalarPhotosynthesisSunlit = missingValue - scalarPhotosynthesisShaded = missingValue + scalarPhotosynthesisSunlit = realMissing + scalarPhotosynthesisShaded = realMissing ! ******************************************************************************************************************************************* @@ -266,9 +263,6 @@ subroutine stomResist(& case default; err=20; message=trim(message)//'unable to identify case for sunlit/shaded leaves'; return end select - ! print progress - !write(*,'(a,1x,20(f12.5,1x))') 'leafTemp, par, psn, rs = ', scalarVegetationTemp, absorbedPAR, scalarPhotosynthesis, scalarStomResist - end do ! looping through sunlit and shaded leaves @@ -281,7 +275,6 @@ subroutine stomResist(& ix_stomResist, & ! intent(in): choice of function for stomatal resistance ! input (local attributes) vegTypeIndex, & ! intent(in): vegetation type index - iLoc, jLoc, & ! intent(in): spatial location indices ! input (forcing) airtemp, & ! intent(in): air temperature at some height above the surface (K) airpres, & ! intent(in): air pressure at some height above the surface (Pa) @@ -313,13 +306,6 @@ subroutine stomResist(& ! ******************************************************************************************************************************************* end select ! (identifying option for stomatal resistance) - - ! print progress - !write(*,'(a,1x,L1,1x,20(f16.8,1x))') 'ix_StomResist==BallBerryFlex, scalarPhotosynthesisSunlit, scalarPhotosynthesisShaded, scalarStomResistSunlit, scalarPhotosynthesisShaded = ', & - ! ix_StomResist==BallBerryFlex, scalarPhotosynthesisSunlit, scalarPhotosynthesisShaded, scalarStomResistSunlit, scalarPhotosynthesisShaded - !pause - - ! end association to variables in the data structures end associate end subroutine stomResist @@ -356,35 +342,35 @@ subroutine stomResist_flex(& ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! input: state and diagnostic variables - real(rkind),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) - real(rkind),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) - real(rkind),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) - real(rkind),intent(in) :: absorbedPAR ! absorbed PAR (W m-2) + real(rkind),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) + real(rkind),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) + real(rkind),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) + real(rkind),intent(in) :: absorbedPAR ! absorbed PAR (W m-2) ! input: data structures - type(var_d),intent(in) :: forc_data ! model forcing data - type(var_dlength),intent(in) :: mpar_data ! model parameters - type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU - type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU - type(model_options),intent(in) :: model_decisions(:) ! model decisions + type(var_d),intent(in) :: forc_data ! model forcing data + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU + type(model_options),intent(in) :: model_decisions(:) ! model decisions ! output: stomatal resistance and photosynthesis - real(rkind),intent(inout) :: ci ! intercellular co2 partial pressure (Pa) - real(rkind),intent(out) :: scalarStomResist ! stomatal resistance (s m-1) - real(rkind),intent(out) :: scalarPhotosynthesis ! photosynthesis (umol CO2 m-2 s-1) + real(rkind),intent(inout) :: ci ! intercellular co2 partial pressure (Pa) + real(rkind),intent(out) :: scalarStomResist ! stomatal resistance (s m-1) + real(rkind),intent(out) :: scalarPhotosynthesis ! photosynthesis (umol CO2 m-2 s-1) ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! general local variables - logical(lgt),parameter :: testDerivs=.false. ! flag to test the derivatives - real(rkind) :: unitConv ! unit conversion factor (mol m-3, convert m s-1 --> mol H20 m-2 s-1) - real(rkind) :: rlb ! leaf boundary layer rersistance (umol-1 m2 s) - real(rkind) :: x0,x1,x2 ! temporary variables - real(rkind) :: co2compPt ! co2 compensation point (Pa) - real(rkind) :: fHum ! humidity function, fraction [0,1] + logical(lgt),parameter :: testDerivs=.false. ! flag to test the derivatives + real(rkind) :: unitConv ! unit conversion factor (mol m-3, convert m s-1 --> mol H20 m-2 s-1) + real(rkind) :: rlb ! leaf boundary layer rersistance (umol-1 m2 s) + real(rkind) :: x0,x1,x2 ! temporary variables + real(rkind) :: co2compPt ! co2 compensation point (Pa) + real(rkind) :: fHum ! humidity function, fraction [0,1] ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! fixed parameters - integer(i4b),parameter :: maxiter=20 ! maximum number of iterations - integer(i4b),parameter :: maxiter_noahMP=3 ! maximum number of iterations for Noah-MP + integer(i4b),parameter :: maxiter=20 ! maximum number of iterations + integer(i4b),parameter :: maxiter_noahMP=3 ! maximum number of iterations for Noah-MP real(rkind),parameter :: convToler=0.0001_rkind ! convergence tolerance (Pa) real(rkind),parameter :: umol_per_mol=1.e+6_rkind ! factor to relate umol to mol real(rkind),parameter :: o2scaleFactor=0.105_rkind ! scaling factor used to compute co2 compesation point (0.21/2) @@ -396,45 +382,44 @@ subroutine stomResist_flex(& real(rkind),parameter :: fnf=0.6666666667_rkind ! foliage nitrogen factor (-) ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! photosynthesis - real(rkind) :: Kc,Ko ! Michaelis-Menten constants for co2 and o2 (Pa) - real(rkind) :: vcmax25 ! maximum Rubisco carboxylation rate at 25 deg C (umol m-2 s-1) - real(rkind) :: jmax25 ! maximum electron transport rate at 25 deg C (umol m-2 s-1) - real(rkind) :: vcmax ! maximum Rubisco carboxylation rate (umol m-2 s-1) - real(rkind) :: jmax ! maximum electron transport rate (umol m-2 s-1) - real(rkind) :: aQuad ! the quadratic coefficient in the quadratic equation - real(rkind) :: bQuad ! the linear coefficient in the quadratic equation - real(rkind) :: cQuad ! the constant in the quadratic equation - real(rkind) :: bSign ! sign of the linear coeffcient - real(rkind) :: xTemp ! temporary variable in the quadratic equation - real(rkind) :: qQuad ! the "q" term in the quadratic equation - real(rkind) :: root1,root2 ! roots of the quadratic function - real(rkind) :: Js ! scaled electron transport rate (umol co2 m-2 s-1) - real(rkind) :: I_ps2 ! PAR absorbed by PS2 (umol photon m-2 s-1) - real(rkind) :: awb ! Michaelis-Menten control (Pa) - real(rkind) :: cp2 ! additional controls in light-limited assimilation (Pa) - real(rkind) :: psn ! leaf gross photosynthesis rate (umol co2 m-2 s-1) - real(rkind) :: dA_dc ! derivative in photosynthesis w.r.t. intercellular co2 concentration + real(rkind) :: Kc,Ko ! Michaelis-Menten constants for co2 and o2 (Pa) + real(rkind) :: vcmax25 ! maximum Rubisco carboxylation rate at 25 deg C (umol m-2 s-1) + real(rkind) :: jmax25 ! maximum electron transport rate at 25 deg C (umol m-2 s-1) + real(rkind) :: vcmax ! maximum Rubisco carboxylation rate (umol m-2 s-1) + real(rkind) :: jmax ! maximum electron transport rate (umol m-2 s-1) + real(rkind) :: aQuad ! the quadratic coefficient in the quadratic equation + real(rkind) :: bQuad ! the linear coefficient in the quadratic equation + real(rkind) :: cQuad ! the constant in the quadratic equation + real(rkind) :: bSign ! sign of the linear coeffcient + real(rkind) :: xTemp ! temporary variable in the quadratic equation + real(rkind) :: qQuad ! the "q" term in the quadratic equation + real(rkind) :: root1,root2 ! roots of the quadratic function + real(rkind) :: Js ! scaled electron transport rate (umol co2 m-2 s-1) + real(rkind) :: I_ps2 ! PAR absorbed by PS2 (umol photon m-2 s-1) + real(rkind) :: awb ! Michaelis-Menten control (Pa) + real(rkind) :: cp2 ! additional controls in light-limited assimilation (Pa) + real(rkind) :: psn ! leaf gross photosynthesis rate (umol co2 m-2 s-1) + real(rkind) :: dA_dc ! derivative in photosynthesis w.r.t. intercellular co2 concentration ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! stomatal resistance - real(rkind) :: gMin ! scaled minimum conductance (umol m-2 s-1) - real(rkind) :: cs ! co2 partial pressure at leaf surface (Pa) - real(rkind) :: csx ! control of co2 partial pressure at leaf surface on stomatal conductance (Pa) - real(rkind) :: g0 ! stomatal conductance in the absence of humidity controls (umol m-2 s-1) - real(rkind) :: ci_old ! intercellular co2 partial pressure (Pa) - real(rkind) :: rs ! stomatal resistance (umol-1 m2 s) - real(rkind) :: dg0_dc ! derivative in g0 w.r.t intercellular co2 concentration (umol m-2 s-1 Pa-1) - real(rkind) :: drs_dc ! derivative in stomatal resistance w.r.t. intercellular co2 concentration - real(rkind) :: dci_dc ! final derivative (-) + real(rkind) :: gMin ! scaled minimum conductance (umol m-2 s-1) + real(rkind) :: cs ! co2 partial pressure at leaf surface (Pa) + real(rkind) :: csx ! control of co2 partial pressure at leaf surface on stomatal conductance (Pa) + real(rkind) :: g0 ! stomatal conductance in the absence of humidity controls (umol m-2 s-1) + real(rkind) :: ci_old ! intercellular co2 partial pressure (Pa) + real(rkind) :: rs ! stomatal resistance (umol-1 m2 s) + real(rkind) :: dg0_dc ! derivative in g0 w.r.t intercellular co2 concentration (umol m-2 s-1 Pa-1) + real(rkind) :: drs_dc ! derivative in stomatal resistance w.r.t. intercellular co2 concentration + real(rkind) :: dci_dc ! final derivative (-) ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! iterative solution - real(rkind) :: func1,func2 ! functions for numerical derivative calculation - real(rkind) :: cMin,cMax ! solution brackets - real(rkind) :: xInc ! iteration increment (Pa) - integer(i4b) :: iter ! iteration index + real(rkind) :: func1,func2 ! functions for numerical derivative calculation + real(rkind) :: cMin,cMax ! solution brackets + real(rkind) :: xInc ! iteration increment (Pa) + integer(i4b) :: iter ! iteration index ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! associate variables in the data structure associate(& - ! input: model decisions ix_bbTempFunc => model_decisions(iLookDECISIONS%bbTempFunc)%iDecision, & ! intent(in): [i4b] leaf temperature controls on photosynthesis + stomatal resistance ix_bbHumdFunc => model_decisions(iLookDECISIONS%bbHumdFunc)%iDecision, & ! intent(in): [i4b] humidity controls on stomatal resistance @@ -443,7 +428,6 @@ subroutine stomResist_flex(& ix_bbNumerics => model_decisions(iLookDECISIONS%bbNumerics)%iDecision, & ! intent(in): [i4b] iterative numerical solution method used in the Ball-Berry parameterization ix_bbAssimFnc => model_decisions(iLookDECISIONS%bbAssimFnc)%iDecision, & ! intent(in): [i4b] controls on carbon assimilation (min function, or colimitation) ix_bbCanIntg8 => model_decisions(iLookDECISIONS%bbCanIntg8)%iDecision, & ! intent(in): [i4b] scaling of photosynthesis from the leaf to the canopy - ! input: model parameters Kc25 => mpar_data%var(iLookPARAM%Kc25)%dat(1), & ! intent(in): [dp] Michaelis-Menten constant for CO2 at 25 degrees C (umol mol-1) Ko25 => mpar_data%var(iLookPARAM%Ko25)%dat(1), & ! intent(in): [dp] Michaelis-Menten constant for O2 at 25 degrees C (mol mol-1) @@ -466,27 +450,22 @@ subroutine stomResist_flex(& vpScaleFactor => mpar_data%var(iLookPARAM%vpScaleFactor)%dat(1), & ! intent(in): [dp] vapor pressure scaling factor in stomatal conductance function (Pa) cond2photo_slope => mpar_data%var(iLookPARAM%cond2photo_slope)%dat(1), & ! intent(in): [dp] slope of conductance-photosynthesis relationship (-) minStomatalConductance => mpar_data%var(iLookPARAM%minStomatalConductance)%dat(1), & ! intent(in): [dp] mimimum stomatal conductance (umol H2O m-2 s-1) - ! input: forcing at the upper boundary airtemp => forc_data%var(iLookFORCE%airtemp), & ! intent(in): [dp] air temperature at some height above the surface (K) airpres => forc_data%var(iLookFORCE%airpres), & ! intent(in): [dp] air pressure at some height above the surface (Pa) scalarO2air => diag_data%var(iLookDIAG%scalarO2air)%dat(1), & ! intent(in): [dp] atmospheric o2 concentration (Pa) scalarCO2air => diag_data%var(iLookDIAG%scalarCO2air)%dat(1), & ! intent(in): [dp] atmospheric co2 concentration (Pa) - ! input: state and diagnostic variables scalarExposedLAI => diag_data%var(iLookDIAG%scalarExposedLAI)%dat(1), & ! intent(in): [dp] exposed LAI (m2 m-2) scalarGrowingSeasonIndex => diag_data%var(iLookDIAG%scalarGrowingSeasonIndex)%dat(1), & ! intent(in): [dp] growing season index (0=off, 1=on) scalarFoliageNitrogenFactor => diag_data%var(iLookDIAG%scalarFoliageNitrogenFactor)%dat(1), & ! intent(in): [dp] foliage nitrogen concentration (1.0 = saturated) scalarTranspireLim => diag_data%var(iLookDIAG%scalarTranspireLim)%dat(1), & ! intent(in): [dp] weighted average of the transpiration limiting factor (-) scalarLeafResistance => flux_data%var(iLookFLUX%scalarLeafResistance)%dat(1) & ! intent(in): [dp] mean leaf boundary layer resistance per unit leaf area (s m-1) - ) ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! initialize error control err=0; message="stomResist_flex/" - !print*, '**' - ! ***** ! * preliminaries... ! ****************** @@ -567,7 +546,6 @@ subroutine stomResist_flex(& ! linear model, as used in CLM4 and Noah-MP case(linear) Js = quantamYield*joule2umolConv*absorbedPAR - !write(*,'(a,1x,10(f20.10,1x))') 'quantamYield, joule2umolConv, absorbedPAR = ', quantamYield, joule2umolConv, absorbedPAR ! linear function of qmax, as used in Cable [Wang et al., Ag Forest Met 1998, eq D5] case(linearJmax) @@ -626,23 +604,11 @@ subroutine stomResist_flex(& else ci = 0.7_rkind*scalarCO2air ! always initialize if not NR end if - !write(*,'(a,1x,10(f20.10,1x))') 'Kc25, Kc_qFac, Ko25, Ko_qFac = ', Kc25, Kc_qFac, Ko25, Ko_qFac - !write(*,'(a,1x,10(f20.10,1x))') 'scalarCO2air, ci, co2compPt, Kc, Ko = ', scalarCO2air, ci, co2compPt, Kc, Ko - + ! initialize brackets for the solution cMin = 0._rkind cMax = scalarCO2air - ! ********************************************************************************************************************************* - ! ********************************************************************************************************************************* - ! ********************************************************************************************************************************* - ! ********************************************************************************************************************************* - ! ********************************************************************************************************************************* - ! ********************************************************************************************************************************* - - !print *, '**' - !print *, '**' - ! *** ! iterate do iter=1,maxiter @@ -679,12 +645,6 @@ subroutine stomResist_flex(& x2 = h2o_co2__stomPores * airpres ! Pa ci = max(cs - x2*psn*rs, 0._rkind) ! Pa - ! print progress - !if(ix_bbNumerics==NoahMPsolution)then - ! write(*,'(a,1x,10(f20.10,1x))') 'psn, rs, ci, cs, scalarVegetationTemp, vcmax, Js = ', & - ! psn, rs, ci, cs, scalarVegetationTemp, vcmax, Js - !end if - ! final derivative if(ci > tiny(ci))then dci_dc = -x1*dA_dc - x2*(psn*drs_dc + rs*dA_dc) @@ -731,10 +691,6 @@ subroutine stomResist_flex(& ci = 0.5_rkind * (cMin + cMax) end if - ! print progress - !write(*,'(a,1x,i4,1x,20(f12.7,1x))') 'iter, psn, rs, ci, cs, cMin, cMax, co2compPt, scalarCO2air, xInc = ', & - ! iter, psn, rs, ci, cs, cMin, cMax, co2compPt, scalarCO2air, xInc - ! check for convergence if(abs(xInc) < convToler) exit if(iter==maxIter)then @@ -743,7 +699,6 @@ subroutine stomResist_flex(& end if end do ! iterating - !pause 'iterating' ! assign output variables scalarStomResist = unitConv*umol_per_mol*rs ! umol-1 m2 s --> s/m @@ -754,8 +709,6 @@ subroutine stomResist_flex(& contains ! ****************************************************** - ! ****************************************************** - ! internal function used to test derivatives function testFunc(ci, cond2photo_slope, airpres, scalarCO2air, ix_bbHumdFunc, ix_bbCO2point, ix_bbAssimFnc) real(rkind),intent(in) :: ci, cond2photo_slope, airpres, scalarCO2air @@ -844,9 +797,6 @@ subroutine photosynthesis(desireDeriv, ix_bbAssimFnc, ci, co2compPt, awb, cp2, v xFac(ixExport) = 0.5_rkind xPSN(ixExport) = xFac(ixExport)*vcmax ! umol co2 m-2 s-1 - ! print progress - !write(*,'(a,1x,10(f20.10,1x))') 'xPSN, vcmax, Js = ', xPSN, vcmax, Js - ! select function used for carbon assimilation select case(ix_bbAssimFnc) @@ -940,8 +890,8 @@ end subroutine photosynthesis subroutine quadResist(desireDeriv,ix_bbHumdFunc,rlb,fHum,gMin,g0,dg0_dc,rs,drs_dc) implicit none ! dummy variables - logical(lgt),intent(in) :: desireDeriv ! flag to denote if the derivative is desired - integer(i4b),intent(in) :: ix_bbHumdFunc ! option for humidity control on stomatal resistance + logical(lgt),intent(in) :: desireDeriv ! flag to denote if the derivative is desired + integer(i4b),intent(in) :: ix_bbHumdFunc ! option for humidity control on stomatal resistance real(rkind),intent(in) :: rlb ! leaf boundary layer resistance (umol-1 m2 s) real(rkind),intent(in) :: fHum ! scaled humidity function (-) real(rkind),intent(in) :: gMin ! scaled minimum stomatal consuctance (umol m-2 s-1) @@ -982,11 +932,6 @@ subroutine quadResist(desireDeriv,ix_bbHumdFunc,rlb,fHum,gMin,g0,dg0_dc,rs,drs_d root2 = cQuad / qQuad rs = max(root1,root2) - ! check - !write(*,'(a,1x,10(f20.5,1x))') 'root1, root2, rs = ', root1, root2, rs - !write(*,'(a,1x,10(f20.5,1x))') 'g0, fHum, aquad, bquad, cquad, qquad = ', & - ! g0, fHum, aquad, bquad, cquad, qquad - ! compute derivatives if(desireDeriv)then @@ -1082,7 +1027,6 @@ end subroutine quadSmooth ! ***** ! * temperature functions... ! ************************** - ! q10 function for temperature dependence function q10(a,T,Tmid,Tscale) implicit none @@ -1123,7 +1067,6 @@ subroutine stomResist_NoahMP(& ixStomResist, & ! intent(in): choice of function for stomatal resistance ! input (local attributes) vegTypeIndex, & ! intent(in): vegetation type index - iLoc, jLoc, & ! intent(in): spatial location indices ! input (forcing) airtemp, & ! intent(in): air temperature at some height above the surface (K) airpres, & ! intent(in): air pressure at some height above the surface (Pa) @@ -1159,7 +1102,6 @@ subroutine stomResist_NoahMP(& integer(i4b),intent(in) :: ixStomResist ! choice of function for stomatal resistance ! input (local attributes) integer(i4b),intent(in) :: vegTypeIndex ! vegetation type index - integer(i4b),intent(in) :: iLoc, jLoc ! spatial location indices ! input (forcing) real(rkind),intent(in) :: airtemp ! measured air temperature at some height above the surface (K) real(rkind),intent(in) :: airpres ! measured air pressure at some height above the surface (Pa) @@ -1213,7 +1155,6 @@ subroutine stomResist_NoahMP(& mpe, & ! intent(in): prevents overflow error if division by zero PAR, & ! intent(in): average absorbed par (w m-2) scalarFoliageNitrogenFactor, & ! intent(in): foliage nitrogen concentration (1=saturated) - iLoc, jLoc, & ! intent(in): spatial location indices scalarVegetationTemp, & ! intent(in): vegetation temperature (K) scalarSatVP_VegTemp, & ! intent(in): saturation vapor pressure at vegetation temperature (Pa) scalarVP_CanopyAir, & ! intent(in): canopy air vapor pressure (Pa) @@ -1239,9 +1180,7 @@ subroutine stomResist_NoahMP(& airpres, & ! intent(in): air pressure at some height above the surface (Pa) ! output scalarStomResist, & ! intent(out): stomatal resistance (s m-1) - scalarPhotosynthesis, & ! intent(out): photosynthesis (umolco2 m-2 s-1) - ! location indices (input) - iLoc, jLoc ) ! intent(in): spatial location indices + scalarPhotosynthesis ) ! intent(out): photosynthesis (umolco2 m-2 s-1) ! check identified an option case default; err=20; message=trim(message)//'unable to identify case for stomatal resistance'; return @@ -1265,8 +1204,5 @@ end subroutine stomResist_NoahMP ! -- end private subroutines - ! ------------------------------------------------------------------------------------------------------------ - ! ------------------------------------------------------------------------------------------------------------ - ! ------------------------------------------------------------------------------------------------------------ end module stomResist_module diff --git a/build/source/engine/summaSolve.f90 b/build/source/engine/summaSolve.f90 deleted file mode 100755 index 1e75ac937..000000000 --- a/build/source/engine/summaSolve.f90 +++ /dev/null @@ -1,1354 +0,0 @@ -! SUMMA - Structure for Unifying Multiple Modeling Alternatives -! Copyright (C) 2014-2020 NCAR/RAL; University of Saskatchewan; University of Washington -! -! This file is part of SUMMA -! -! For more information see: http://www.ral.ucar.edu/projects/summa -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see . - -module summaSolve_module - -! data types -USE nrtype - -! constants -USE multiconst,only:Tfreeze ! freezing point of pure water (K) -USE multiconst,only:iden_water ! intrinsic density of liquid water (kg m-3) - -! access the global print flag -USE globalData,only:globalPrintFlag - -! access missing values -USE globalData,only:integerMissing ! missing integer -USE globalData,only:realMissing ! missing double precision number -USE globalData,only:quadMissing ! missing quadruple precision number - -! access named variables to describe the form and structure of the matrices used in the numerical solver -USE globalData,only: ku ! number of super-diagonal bands -USE globalData,only: kl ! number of sub-diagonal bands -USE globalData,only: nBands ! length of the leading dimension of the band diagonal matrix -USE globalData,only: ixFullMatrix ! named variable for the full Jacobian matrix -USE globalData,only: ixBandMatrix ! named variable for the band diagonal matrix -USE globalData,only: iJac1 ! first layer of the Jacobian to print -USE globalData,only: iJac2 ! last layer of the Jacobian to print - -! named variables to describe the state variable type -USE globalData,only:iname_nrgCanair ! named variable defining the energy of the canopy air space -USE globalData,only:iname_nrgCanopy ! named variable defining the energy of the vegetation canopy -USE globalData,only:iname_watCanopy ! named variable defining the mass of water on the vegetation canopy -USE globalData,only:iname_nrgLayer ! named variable defining the energy state variable for snow+soil layers -USE globalData,only:iname_watLayer ! named variable defining the total water state variable for snow+soil layers -USE globalData,only:iname_liqLayer ! named variable defining the liquid water state variable for snow+soil layers -USE globalData,only:iname_matLayer ! named variable defining the matric head state variable for soil layers -USE globalData,only:iname_lmpLayer ! named variable defining the liquid matric potential state variable for soil layers - -! indices of elements of data structure -USE var_lookup,only:iLookFLUX ! named variables for structure elements -USE var_lookup,only:iLookPROG ! named variables for structure elements -USE var_lookup,only:iLookPARAM ! named variables for structure elements -USE var_lookup,only:iLookINDEX ! named variables for structure elements -USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure - -! provide access to the derived types to define the data structures -USE data_types,only:& - var_i, & ! data vector (i4b) - var_d, & ! data vector (dp) - var_ilength, & ! data vector with variable length dimension (i4b) - var_dlength, & ! data vector with variable length dimension (dp) - model_options ! defines the model decisions - -! look-up values for the choice of groundwater parameterization -USE mDecisions_module,only: & - qbaseTopmodel,& ! TOPMODEL-ish baseflow parameterization - bigBucket, & ! a big bucket (lumped aquifer model) - noExplicit ! no explicit groundwater parameterization - -implicit none -private -public::summaSolve -contains - - ! ********************************************************************************************************* - ! public subroutine summaSolve: calculate the iteration increment, evaluate the new state, and refine if necessary - ! ********************************************************************************************************* - subroutine summaSolve(& - ! input: model control - dt, & ! intent(in): length of the time step (seconds) - iter, & ! intent(in): iteration index - nSnow, & ! intent(in): number of snow layers - nSoil, & ! intent(in): number of soil layers - nLayers, & ! intent(in): total number of layers - nLeadDim, & ! intent(in): length of the leading dimension of the Jacobian matrix (either nBands or nState) - nState, & ! intent(in): total number of state variables - ixMatrix, & ! intent(in): type of matrix (full or band diagonal) - firstSubStep, & ! intent(in): flag to indicate if we are processing the first sub-step - firstFluxCall, & ! intent(inout): flag to indicate if we are processing the first flux call - computeVegFlux, & ! intent(in): flag to indicate if we need to compute fluxes over vegetation - scalarSolution, & ! intent(in): flag to indicate the scalar solution - ! input: state vectors - stateVecTrial, & ! intent(in): trial state vector - xMin,xMax, & ! intent(inout): brackets of the root - fScale, & ! intent(in): function scaling vector - xScale, & ! intent(in): "variable" scaling vector, i.e., for state variables - rVec, & ! intent(in): residual vector - sMul, & ! intent(in): state vector multiplier (used in the residual calculations) - dMat, & ! intent(inout): diagonal matrix (excludes flux derivatives) - fOld, & ! intent(in): old function evaluation - ! input: data structures - model_decisions, & ! intent(in): model decisions - type_data, & ! intent(in): type of vegetation and soil - attr_data, & ! intent(in): spatial attributes - mpar_data, & ! intent(in): model parameters - forc_data, & ! intent(in): model forcing data - bvar_data, & ! intent(in): average model variables for the entire basin - prog_data, & ! intent(in): model prognostic variables for a local HRU - ! input-output: data structures - indx_data, & ! intent(inout): index data - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - flux_data, & ! intent(inout): model fluxes for a local HRU - deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables - ! input-output: baseflow - ixSaturation, & ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) - dBaseflow_dMatric, & ! intent(inout): derivative in baseflow w.r.t. matric head (s-1) - ! output - stateVecNew, & ! intent(out): new state vector - fluxVecNew, & ! intent(out): new flux vector - resSinkNew, & ! intent(out): additional (sink) terms on the RHS of the state equation - resVecNew, & ! intent(out): new residual vector - fNew, & ! intent(out): new function evaluation - converged, & ! intent(out): convergence flag - err,message) ! intent(out): error control - USE computJacob_module, only: computJacob - USE matrixOper_module, only: lapackSolv - USE matrixOper_module, only: scaleMatrices - implicit none - ! -------------------------------------------------------------------------------------------------------------------------------- - ! input: model control - real(rkind),intent(in) :: dt ! length of the time step (seconds) - integer(i4b),intent(in) :: iter ! interation index - integer(i4b),intent(in) :: nSnow ! number of snow layers - integer(i4b),intent(in) :: nSoil ! number of soil layers - integer(i4b),intent(in) :: nLayers ! total number of layers - integer(i4b),intent(in) :: nLeadDim ! length of the leading dimension of the Jacobian matrix (nBands or nState) - integer(i4b),intent(in) :: nState ! total number of state variables - integer(i4b),intent(in) :: ixMatrix ! type of matrix (full or band diagonal) - logical(lgt),intent(in) :: firstSubStep ! flag to indicate if we are processing the first sub-step - logical(lgt),intent(inout) :: firstFluxCall ! flag to indicate if we are processing the first flux call - logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation - logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution - ! input: state vectors - real(rkind),intent(in) :: stateVecTrial(:) ! trial state vector - real(rkind),intent(inout) :: xMin,xMax ! brackets of the root - real(rkind),intent(in) :: fScale(:) ! function scaling vector - real(rkind),intent(in) :: xScale(:) ! "variable" scaling vector, i.e., for state variables - real(rkind),intent(in) :: rVec(:) ! NOTE: qp ! residual vector - real(rkind),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) - real(rkind),intent(inout) :: dMat(:) ! diagonal matrix (excludes flux derivatives) - real(rkind),intent(in) :: fOld ! old function evaluation - ! input: data structures - type(model_options),intent(in) :: model_decisions(:) ! model decisions - type(var_i), intent(in) :: type_data ! type of vegetation and soil - type(var_d), intent(in) :: attr_data ! spatial attributes - type(var_dlength), intent(in) :: mpar_data ! model parameters - type(var_d), intent(in) :: forc_data ! model forcing data - type(var_dlength), intent(in) :: bvar_data ! model variables for the local basin - type(var_dlength), intent(in) :: prog_data ! prognostic variables for a local HRU - ! output: data structures - type(var_ilength),intent(inout) :: indx_data ! indices defining model states and layers - type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU - type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU - type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables - ! input-output: baseflow - integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) - real(rkind),intent(inout) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) - ! output: flux and residual vectors - real(rkind),intent(out) :: stateVecNew(:) ! new state vector - real(rkind),intent(out) :: fluxVecNew(:) ! new flux vector - real(rkind),intent(out) :: resSinkNew(:) ! sink terms on the RHS of the flux equation - real(rkind),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector - real(rkind),intent(out) :: fNew ! new function evaluation - logical(lgt),intent(out) :: converged ! convergence flag - ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! -------------------------------------------------------------------------------------------------------------------------------- - ! local variables - ! -------------------------------------------------------------------------------------------------------------------------------- - ! Jacobian matrix - logical(lgt),parameter :: doNumJacobian=.false. ! flag to compute the numerical Jacobian matrix - logical(lgt),parameter :: testBandDiagonal=.false. ! flag to test the band diagonal Jacobian matrix - real(rkind) :: nJac(nState,nState) ! numerical Jacobian matrix - real(rkind) :: aJac(nLeadDim,nState) ! Jacobian matrix - real(rkind) :: aJacScaled(nLeadDim,nState) ! Jacobian matrix (scaled) - real(rkind) :: aJacScaledTemp(nLeadDim,nState) ! Jacobian matrix (scaled) -- temporary copy since decomposed in lapack - ! solution/step vectors - real(rkind),dimension(nState) :: rVecScaled ! residual vector (scaled) - real(rkind),dimension(nState) :: newtStepScaled ! full newton step (scaled) - ! step size refinement - logical(lgt) :: doRefine ! flag for step refinement - integer(i4b),parameter :: ixLineSearch=1001 ! step refinement = line search - integer(i4b),parameter :: ixTrustRegion=1002 ! step refinement = trust region - integer(i4b),parameter :: ixStepRefinement=ixLineSearch ! decision for the numerical solution - ! general - integer(i4b) :: mSoil ! number of soil layers in solution vector - integer(i4b) :: iLayer ! row index - integer(i4b) :: jLayer ! column index - logical(lgt) :: globalPrintFlagInit ! initial global print flag - character(LEN=256) :: cmessage ! error message of downwind routine - ! -------------------------------------------------------------------------------------------------------------------------------- - ! associations to information in data structures - associate(ixGroundwater => model_decisions(iLookDECISIONS%groundwatr)%iDecision) ! intent(in): [i4b] groundwater parameterization - ! -------------------------------------------------------------------------------------------------------------------------------- - ! initialize error control - err=0; message='summaSolve/' - - ! get the number of soil layers in the solution vector - mSoil = size(indx_data%var(iLookINDEX%ixMatOnly)%dat) - - ! initialize the global print flag - globalPrintFlagInit=globalPrintFlag - - ! ----- - ! * compute the Jacobian matrix... - ! -------------------------------- - - ! compute the analytical Jacobian matrix - ! NOTE: The derivatives were computed in the previous call to computFlux - ! This occurred either at the call to eval8summa at the start of systemSolv - ! or in the call to eval8summa in the previous iteration (within lineSearchRefinement or trustRegionRefinement) - call computJacob(& - ! input: model control - dt, & ! intent(in): length of the time step (seconds) - nSnow, & ! intent(in): number of snow layers - nSoil, & ! intent(in): number of soil layers - nLayers, & ! intent(in): total number of layers - computeVegFlux, & ! intent(in): flag to indicate if we need to compute fluxes over vegetation - (ixGroundwater==qbaseTopmodel), & ! intent(in): flag to indicate if we need to compute baseflow - ixMatrix, & ! intent(in): form of the Jacobian matrix - ! input: data structures - indx_data, & ! intent(in): index data - prog_data, & ! intent(in): model prognostic variables for a local HRU - diag_data, & ! intent(in): model diagnostic variables for a local HRU - deriv_data, & ! intent(in): derivatives in model fluxes w.r.t. relevant state variables - dBaseflow_dMatric, & ! intent(in): derivative in baseflow w.r.t. matric head (s-1) - ! input-output: Jacobian and its diagonal - dMat, & ! intent(inout): diagonal of the Jacobian matrix - aJac, & ! intent(out): Jacobian matrix - ! output: error control - err,cmessage) ! intent(out): error code and error message - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - - ! compute the numerical Jacobian matrix - if(doNumJacobian)then - globalPrintFlag=.false. - call numJacobian(stateVecTrial,dMat,nJac,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - globalPrintFlag=globalPrintFlagInit - endif - - ! test the band diagonal matrix - if(testBandDiagonal)then - call testBandMat(check=.true.,err=err,message=cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - endif - - ! ----- - ! * solve linear system... - ! ------------------------ - - ! scale the residual vector - rVecScaled(1:nState) = fScale(:)*real(rVec(:), rkind) ! NOTE: residual vector is in quadruple precision - - ! scale matrices - call scaleMatrices(ixMatrix,nState,aJac,fScale,xScale,aJacScaled,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - - if(globalPrintFlag .and. ixMatrix==ixBandMatrix)then - print*, '** SCALED banded analytical Jacobian:' - write(*,'(a4,1x,100(i17,1x))') 'xCol', (iLayer, iLayer=iJac1,iJac2) - do iLayer=kl+1,nBands - write(*,'(i4,1x,100(e17.10,1x))') iLayer, (aJacScaled(iLayer,jLayer),jLayer=min(iJac1,nState),min(iJac2,nState)) - end do - end if - - ! copy the scaled matrix, since it is decomposed in lapackSolv - aJacScaledTemp = aJacScaled - - ! compute the newton step: use the lapack routines to solve the linear system A.X=B - call lapackSolv(ixMatrix,nState,aJacScaledTemp,-rVecScaled,newtStepScaled,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - - if(globalPrintFlag)& - write(*,'(a,1x,10(e17.10,1x))') 'newtStepScaled = ', newtStepScaled(min(iJac1,nState):min(iJac2,nState)) - !print*, 'PAUSE'; read(*,*) - - ! ----- - ! * update, evaluate, and refine the state vector... - ! -------------------------------------------------- - - ! initialize the flag for step refinement - doRefine=.true. - - ! * case 1: state vector - ! compute the flux vector and the residual, and (if necessary) refine the iteration increment - ! NOTE: in 99.9% of cases newtStep will be used (no refinement) - if(size(stateVecTrial)>1)then - - ! try to backtrack - select case(ixStepRefinement) - case(ixLineSearch); call lineSearchRefinement( doRefine,stateVecTrial,newtStepScaled,aJacScaled,rVecScaled,fOld,stateVecNew,fluxVecNew,resVecNew,fNew,converged,err,cmessage) - case(ixTrustRegion); call trustRegionRefinement(doRefine,stateVecTrial,newtStepScaled,aJacScaled,rVecScaled,fOld,stateVecNew,fluxVecNew,resVecNew,fNew,converged,err,cmessage) - case default; err=20; message=trim(message)//'unable to identify numerical solution'; return - end select - - ! check warnings: negative error code = warning; in this case back-tracked to the original value - ! NOTE: Accept the full newton step if back-tracked to the original value - if(err<0)then - doRefine=.false.; call lineSearchRefinement( doRefine,stateVecTrial,newtStepScaled,aJacScaled,rVecScaled,fOld,stateVecNew,fluxVecNew,resVecNew,fNew,converged,err,cmessage) - end if - - ! * case 2: scalar - else - call safeRootfinder(stateVecTrial,rVecScaled,newtStepScaled,stateVecNew,fluxVecNew,resVecNew,fNew,converged,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - endif - - ! check errors - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - - ! end association to info in data structures - end associate - - contains - - ! ********************************************************************************************************* - ! * internal subroutine lineSearchRefinement: refine the iteration increment using line searches - ! ********************************************************************************************************* - subroutine lineSearchRefinement(doLineSearch,stateVecTrial,newtStepScaled,aJacScaled,rVecScaled,fOld,stateVecNew,fluxVecNew,resVecNew,fNew,converged,err,message) - ! provide access to the matrix routines - USE matrixOper_module, only: computeGradient - implicit none - ! input - logical(lgt),intent(in) :: doLineSearch ! flag to do the line search - real(rkind),intent(in) :: stateVecTrial(:) ! trial state vector - real(rkind),intent(in) :: newtStepScaled(:) ! scaled newton step - real(rkind),intent(in) :: aJacScaled(:,:) ! scaled jacobian matrix - real(rkind),intent(in) :: rVecScaled(:) ! scaled residual vector - real(rkind),intent(in) :: fOld ! old function value - ! output - real(rkind),intent(out) :: stateVecNew(:) ! new state vector - real(rkind),intent(out) :: fluxVecNew(:) ! new flux vector - real(rkind),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector - real(rkind),intent(out) :: fNew ! new function evaluation - logical(lgt),intent(out) :: converged ! convergence flag - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! -------------------------------------------------------------------------------------------------------- - ! local - character(len=256) :: cmessage ! error message of downwind routine - real(rkind) :: gradScaled(nState) ! scaled gradient - real(rkind) :: xInc(nState) ! iteration increment (re-scaled to original units of the state vector) - logical(lgt) :: feasible ! flag to denote the feasibility of the solution - integer(i4b) :: iLine ! line search index - integer(i4b),parameter :: maxLineSearch=5 ! maximum number of backtracks - real(rkind),parameter :: alpha=1.e-4_rkind ! check on gradient - real(rkind) :: xLambda ! backtrack magnitude - real(rkind) :: xLambdaTemp ! temporary backtrack magnitude - real(rkind) :: slopeInit ! initial slope - real(rkind) :: rhs1,rhs2 ! rhs used to compute the cubic - real(rkind) :: aCoef,bCoef ! coefficients in the cubic - real(rkind) :: disc ! temporary variable used in cubic - real(rkind) :: xLambdaPrev ! previous lambda value (used in the cubic) - real(rkind) :: fPrev ! previous function evaluation (used in the cubic) - ! -------------------------------------------------------------------------------------------------------- - ! initialize error control - err=0; message='lineSearchRefinement/' - - ! check the need to compute the line search - if(doLineSearch)then - - ! compute the gradient of the function vector - call computeGradient(ixMatrix,nState,aJacScaled,rVecScaled,gradScaled,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - - ! compute the initial slope - slopeInit = dot_product(gradScaled,newtStepScaled) - - end if ! if computing the line search - - ! initialize lambda - xLambda=1._rkind - - ! ***** LINE SEARCH LOOP... - lineSearch: do iLine=1,maxLineSearch ! try to refine the function by shrinking the step size - - ! back-track along the search direction - ! NOTE: start with back-tracking the scaled step - xInc(:) = xLambda*newtStepScaled(:) - - ! re-scale the iteration increment - xInc(:) = xInc(:)*xScale(:) - - ! if enthalpy, then need to convert the iteration increment to temperature - !if(nrgFormulation==ix_enthalpy) xInc(ixNrgOnly) = xInc(ixNrgOnly)/dMat(ixNrgOnly) - - ! impose solution constraints - ! NOTE: we may not need to do this (or at least, do ALL of this), as we can probably rely on the line search here - ! (especially the feasibility check) - call imposeConstraints(stateVecTrial,xInc,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - - ! compute the iteration increment - stateVecNew = stateVecTrial + xInc - - ! compute the residual vector and function - ! NOTE: This calls eval8summa in an internal subroutine - ! The internal sub routine has access to all data - ! Hence, we only need to include the variables of interest in lineSearch - call eval8summa_wrapper(stateVecNew,fluxVecNew,resVecNew,fNew,feasible,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - - ! check line search - if(globalPrintFlag)then - write(*,'(a,1x,i4,1x,e17.10)' ) 'iLine, xLambda = ', iLine, xLambda - write(*,'(a,1x,10(e17.10,1x))') 'fOld,fNew = ', fOld,fNew - write(*,'(a,1x,10(e17.10,1x))') 'fold + alpha*slopeInit*xLambda = ', fold + alpha*slopeInit*xLambda - write(*,'(a,1x,10(e17.10,1x))') 'resVecNew = ', resVecNew(min(iJac1,nState):min(iJac2,nState)) - write(*,'(a,1x,10(e17.10,1x))') 'xInc = ', xInc(min(iJac1,nState):min(iJac2,nState)) - end if - - ! check feasibility - if(.not.feasible) cycle - - ! check convergence - ! NOTE: some efficiency gains possible by scaling the full newton step outside the line search loop - converged = checkConv(resVecNew,newtStepScaled*xScale,stateVecNew) - if(converged) return - - ! early return if not computing the line search - if(.not.doLineSearch) return - - ! check if the function is accepted - if(fNew < fold + alpha*slopeInit*xLambda) return - - ! *** - ! *** IF GET TO HERE WE BACKTRACK - ! --> all remaining code simply computes the restricted step multiplier (xLambda) - - ! first backtrack: use quadratic - if(iLine==1)then - xLambdaTemp = -slopeInit / (2._rkind*(fNew - fOld - slopeInit) ) - if(xLambdaTemp > 0.5_rkind*xLambda) xLambdaTemp = 0.5_rkind*xLambda - - ! subsequent backtracks: use cubic - else - - ! check that we did not back-track all the way back to the original value - if(iLine==maxLineSearch)then - message=trim(message)//'backtracked all the way back to the original value' - err=-20; return - end if - - ! define rhs - rhs1 = fNew - fOld - xLambda*slopeInit - rhs2 = fPrev - fOld - xLambdaPrev*slopeInit - - ! define coefficients - aCoef = (rhs1/(xLambda*xLambda) - rhs2/(xLambdaPrev*xLambdaPrev))/(xLambda - xLambdaPrev) - bCoef = (-xLambdaPrev*rhs1/(xLambda*xLambda) + xLambda*rhs2/(xLambdaPrev*xLambdaPrev)) / (xLambda - xLambdaPrev) - - ! check if a quadratic - if(aCoef==0._rkind)then - xLambdaTemp = -slopeInit/(2._rkind*bCoef) - - ! calculate cubic - else - disc = bCoef*bCoef - 3._rkind*aCoef*slopeInit - if(disc < 0._rkind)then - xLambdaTemp = 0.5_rkind*xLambda - else - xLambdaTemp = (-bCoef + sqrt(disc))/(3._rkind*aCoef) - end if - end if ! calculating cubic - - ! constrain to <= 0.5*xLambda - if(xLambdaTemp > 0.5_rkind*xLambda) xLambdaTemp=0.5_rkind*xLambda - - end if ! subsequent backtracks - - ! save results - xLambdaPrev = xLambda - fPrev = fNew - - ! constrain lambda - xLambda = max(xLambdaTemp, 0.1_rkind*xLambda) - - end do lineSearch ! backtrack loop - - end subroutine lineSearchRefinement - - - ! ********************************************************************************************************* - ! * internal subroutine trustRegionRefinement: refine the iteration increment using trust regions - ! ********************************************************************************************************* - subroutine trustRegionRefinement(doTrustRefinement,stateVecTrial,newtStepScaled,aJacScaled,rVecScaled,fOld,stateVecNew,fluxVecNew,resVecNew,fNew,converged,err,message) - ! provide access to the matrix routines - USE matrixOper_module, only: lapackSolv - USE matrixOper_module, only: computeGradient - implicit none - ! input - logical(lgt),intent(in) :: doTrustRefinement ! flag to refine using trust regions - real(rkind),intent(in) :: stateVecTrial(:) ! trial state vector - real(rkind),intent(in) :: newtStepScaled(:) ! scaled newton step - real(rkind),intent(in) :: aJacScaled(:,:) ! scaled jacobian matrix - real(rkind),intent(in) :: rVecScaled(:) ! scaled residual vector - real(rkind),intent(in) :: fOld ! old function value - ! output - real(rkind),intent(out) :: stateVecNew(:) ! new state vector - real(rkind),intent(out) :: fluxVecNew(:) ! new flux vector - real(rkind),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector - real(rkind),intent(out) :: fNew ! new function evaluation - logical(lgt),intent(out) :: converged ! convergence flag - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! -------------------------------------------------------------------------------------------------------- - ! local variables - - ! .. needed .. - - - ! -------------------------------------------------------------------------------------------------------- - err=0; message='trustRegionRefinement/' - - ! check the need to refine the step - if(doTrustRefinement)then - - ! (check vectors) - if(size(stateVecTrial)/=nState .or. size(newtStepScaled)/=nState .or. size(rVecScaled)/=nState)then - message=trim(message)//'unexpected size of input vectors' - err=20; return - endif - - ! (check matrix) - if(size(aJacScaled,1)/=nState .or. size(aJacScaled,2)/=nState)then - message=trim(message)//'unexpected size of Jacobian matrix' - err=20; return - endif - - ! dummy check for the function - if(fold==realMissing) print*, 'missing' - - ! dummy - stateVecNew = realMissing - fluxVecNew = realMissing - resVecNew = quadMissing - fNew = realMissing - converged = .true. - - - endif ! if doing the trust region refinement - - message=trim(message)//'routine not implemented yet' - err=20; return - - - - end subroutine trustRegionRefinement - - - ! ********************************************************************************************************* - ! * internal subroutine safeRootfinder: refine the 1-d iteration increment using brackets - ! ********************************************************************************************************* - subroutine safeRootfinder(stateVecTrial,rVecscaled,newtStepScaled,stateVecNew,fluxVecNew,resVecNew,fNew,converged,err,message) - USE,intrinsic :: ieee_arithmetic,only:ieee_is_nan ! IEEE arithmetic (check NaN) - USE globalData,only:dNaN ! double precision NaN - implicit none - ! input - real(rkind),intent(in) :: stateVecTrial(:) ! trial state vector - real(rkind),intent(in) :: rVecScaled(:) ! scaled residual vector - real(rkind),intent(in) :: newtStepScaled(:) ! scaled newton step - ! output - real(rkind),intent(out) :: stateVecNew(:) ! new state vector - real(rkind),intent(out) :: fluxVecNew(:) ! new flux vector - real(rkind),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector - real(rkind),intent(out) :: fNew ! new function evaluation - logical(lgt),intent(out) :: converged ! convergence flag - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! -------------------------------------------------------------------------------------------------------- - ! local variables - character(len=256) :: cmessage ! error message of downwind routine - real(rkind),parameter :: relTolerance=0.005_rkind ! force bi-section if trial is slightly larger than (smaller than) xmin (xmax) - real(rkind) :: xTolerance ! relTolerance*(xmax-xmin) - real(rkind) :: xInc(nState) ! iteration increment (re-scaled to original units of the state vector) - real(rkind) :: rVec(nState) ! residual vector (re-scaled to original units of the state equation) - logical(lgt) :: feasible ! feasibility of the solution - logical(lgt) :: doBisection ! flag to do the bi-section - logical(lgt) :: bracketsDefined ! flag to define if the brackets are defined - !integer(i4b) :: iCheck ! check the model state variables (not used) - integer(i4b),parameter :: nCheck=100 ! number of times to check the model state variables - real(rkind),parameter :: delX=1._rkind ! trial increment - !real(rkind) :: xIncrement(nState) ! trial increment (not used) - ! -------------------------------------------------------------------------------------------------------- - err=0; message='safeRootfinder/' - - ! check scalar - if(size(stateVecTrial)/=1 .or. size(rVecScaled)/=1 .or. size(newtStepScaled)/=1)then - message=trim(message)//'unexpected size of input vectors' - err=20; return - endif - - ! initialize brackets to rkind precision NaN - if(iter==1)then - xMax = dNaN - xMin = dNaN - endif - - ! get the residual vector - rVec = real(rVecScaled, rkind)*real(fScale, rkind) - - ! update brackets - if(rVec(1)<0._rkind)then - xMin = stateVecTrial(1) - else - xMax = stateVecTrial(1) - endif - - ! get the iteration increment - xInc = newtStepScaled*xScale - - ! ***** - ! * case 1: the iteration increment is the same sign as the residual vector - if(xInc(1)*rVec(1) > 0._rkind)then - - ! get brackets if they do not exist - if( ieee_is_nan(xMin) .or. ieee_is_nan(xMax) )then - call getBrackets(stateVecTrial,stateVecNew,xMin,xMax,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - endif - - ! use bi-section - stateVecNew(1) = 0.5_rkind*(xMin + xMax) - - ! ***** - ! * case 2: the iteration increment is the correct sign - else - - ! impose solution constraints - call imposeConstraints(stateVecTrial,xInc,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - - ! compute the iteration increment - stateVecNew = stateVecTrial + xInc - - endif ! if the iteration increment is the same sign as the residual vector - - ! bi-section - bracketsDefined = ( .not.ieee_is_nan(xMin) .and. .not.ieee_is_nan(xMax) ) ! check that the brackets are defined - if(bracketsDefined)then - xTolerance = relTolerance*(xMax-xMin) - doBisection = (stateVecNew(1)xMax-xTolerance) - if(doBisection) stateVecNew(1) = 0.5_rkind*(xMin+xMax) - endif - - ! evaluate summa - call eval8summa_wrapper(stateVecNew,fluxVecNew,resVecNew,fNew,feasible,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - - ! check feasibility (should be feasible because of the call to imposeConstraints - if(.not.feasible)then; err=20; message=trim(message)//'infeasible solution'; return; endif - - ! check convergence - converged = checkConv(resVecNew,xInc,stateVecNew) - - !write(*,'(a,1x,2(L1,1x),5(e20.8,1x))') 'bracketsDefined, doBisection, xMin, xMax, stateVecTrial, stateVecNew, xInc = ', & - ! bracketsDefined, doBisection, xMin, xMax, stateVecTrial, stateVecNew, xInc - !print*, 'PAUSE'; read(*,*) - - end subroutine safeRootfinder - - ! ********************************************************************************************************* - ! * internal subroutine getBrackets: get the brackets - ! ********************************************************************************************************* - subroutine getBrackets(stateVecTrial,stateVecNew,xMin,xMax,err,message) - USE,intrinsic :: ieee_arithmetic,only:ieee_is_nan ! IEEE arithmetic (check NaN) - implicit none - ! dummies - real(rkind),intent(in) :: stateVecTrial(:) ! trial state vector - real(rkind),intent(out) :: stateVecNew(:) ! new state vector - real(rkind),intent(out) :: xMin,xMax ! constraints - integer(i4b),intent(inout) :: err ! error code - character(*),intent(out) :: message ! error message - ! locals - integer(i4b) :: iCheck ! check the model state variables - integer(i4b),parameter :: nCheck=100 ! number of times to check the model state variables - logical(lgt) :: feasible ! feasibility of the solution - real(rkind),parameter :: delX=1._rkind ! trial increment - real(rkind) :: xIncrement(nState) ! trial increment - ! initialize - err=0; message='getBrackets/' - - ! initialize state vector - stateVecNew = stateVecTrial - - ! get xIncrement - xIncrement = -sign((/delX/),rVec) - - ! try the increment a few times - do iCheck=1,nCheck - - ! impose solution constraints - call imposeConstraints(stateVecNew,xIncrement,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - - ! increment state vector - stateVecNew = stateVecNew + xIncrement - - ! evaluate summa - call eval8summa_wrapper(stateVecNew,fluxVecNew,resVecNew,fNew,feasible,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - - ! check that the trial value is feasible (should not happen because of the call to impose constraints) - if(.not.feasible)then; message=trim(message)//'state vector is not feasible'; err=20; return; endif - - ! update brackets - if(real(resVecNew(1), rkind)<0._rkind)then - xMin = stateVecNew(1) - else - xMax = stateVecNew(1) - endif - - ! print progress - !print*, 'xMin, xMax, stateVecTrial, stateVecNew, resVecNew, xIncrement = ', & - ! xMin, xMax, stateVecTrial, stateVecNew, resVecNew, xIncrement - - ! check that the brackets are defined - if( .not.ieee_is_nan(xMin) .and. .not.ieee_is_nan(xMax) ) exit - - ! check that we found the brackets - if(iCheck==nCheck)then - message=trim(message)//'could not fix the problem where residual and iteration increment are of the same sign' - err=20; return - endif - - end do ! multiple checks - - end subroutine getBrackets - - - ! ********************************************************************************************************* - ! * internal subroutine numJacobian: compute the numerical Jacobian matrix - ! ********************************************************************************************************* - subroutine numJacobian(stateVec,dMat,nJac,err,message) - implicit none - ! dummies - real(rkind),intent(in) :: stateVec(:) ! trial state vector - real(rkind),intent(in) :: dMat(:) ! diagonal matrix - ! output - real(rkind),intent(out) :: nJac(:,:) ! numerical Jacobian - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! ---------------------------------------------------------------------------------------------------------- - ! local - character(len=256) :: cmessage ! error message of downwind routine - real(rkind),parameter :: dx=1.e-8_rkind ! finite difference increment - real(rkind),dimension(nState) :: stateVecPerturbed ! perturbed state vector - real(rkind),dimension(nState) :: fluxVecInit,fluxVecJac ! flux vector (mized units) - real(rkind),dimension(nState) :: resVecInit,resVecJac ! qp ! residual vector (mixed units) - real(rkind) :: func ! function value - logical(lgt) :: feasible ! flag to denote the feasibility of the solution - integer(i4b) :: iJac ! index of row of the Jacobian matrix - integer(i4b),parameter :: ixNumFlux=1001 ! named variable for the flux-based form of the numerical Jacobian - integer(i4b),parameter :: ixNumRes=1002 ! named variable for the residual-based form of the numerical Jacobian - integer(i4b) :: ixNumType=ixNumRes ! method used to calculate the numerical Jacobian - ! ---------------------------------------------------------------------------------------------------------- - ! initialize error control - err=0; message='numJacobian/' - - ! compute initial function evaluation - call eval8summa_wrapper(stateVec,fluxVecInit,resVecInit,func,feasible,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - if(.not.feasible)then; message=trim(message)//'initial state vector not feasible'; err=20; return; endif - - ! get a copy of the state vector to perturb - stateVecPerturbed(:) = stateVec(:) - - ! loop through state variables - do iJac=1,nState - - !print*, 'iJac = ', iJac - !globalPrintFlag = merge(.true.,.false., iJac==1) - - ! perturb state vector - stateVecPerturbed(iJac) = stateVec(iJac) + dx - - ! compute function evaluation - call eval8summa_wrapper(stateVecPerturbed,fluxVecJac,resVecJac,func,feasible,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - if(.not.feasible)then; message=trim(message)//'state vector not feasible'; err=20; return; endif - !write(*,'(a,1x,2(f30.20,1x))') 'resVecJac(101:102) = ', resVecJac(101:102) - - ! compute the row of the Jacobian matrix - select case(ixNumType) - case(ixNumRes); nJac(:,iJac) = real(resVecJac - resVecInit, kind(rkind) )/dx ! Jacobian based on residuals - case(ixNumFlux); nJac(:,iJac) = -dt*(fluxVecJac(:) - fluxVecInit(:))/dx ! Jacobian based on fluxes - case default; err=20; message=trim(message)//'Jacobian option not found'; return - end select - - ! if flux option then add in the diagonal matrix - if(ixNumType==ixNumFlux) nJac(iJac,iJac) = nJac(iJac,iJac) + dMat(iJac) - - ! set the state back to the input value - stateVecPerturbed(iJac) = stateVec(iJac) - - end do ! (looping through state variables) - - ! print the Jacobian - print*, '** numerical Jacobian:', ixNumType==ixNumRes - write(*,'(a4,1x,100(i12,1x))') 'xCol', (iLayer, iLayer=min(iJac1,nState),min(iJac2,nState)) - do iLayer=min(iJac1,nState),min(iJac2,nState) - write(*,'(i4,1x,100(e12.5,1x))') iLayer, nJac(min(iJac1,nState):min(iJac2,nState),iLayer) - end do - !print*, 'PAUSE: testing Jacobian'; read(*,*) - - end subroutine numJacobian - - ! ********************************************************************************************************* - ! * internal subroutine testBandMat: compute the full Jacobian matrix and decompose into a band matrix - ! ********************************************************************************************************* - - subroutine testBandMat(check,err,message) - ! dummy variables - logical(lgt),intent(in) :: check ! flag to pause - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! local variables - real(rkind) :: fullJac(nState,nState) ! full Jacobian matrix - real(rkind) :: bandJac(nLeadDim,nState) ! band Jacobian matrix - integer(i4b) :: iState,jState ! indices of the state vector - character(LEN=256) :: cmessage ! error message of downwind routine - ! initialize error control - err=0; message='testBandMat/' - - ! check - if(nLeadDim==nState)then - message=trim(message)//'do not expect nLeadDim==nState: check that are computing the band diagonal matrix'//& - ' (is forceFullMatrix==.true.?)' - err=20; return - endif - - ! compute the full Jacobian matrix - call computJacob(& - ! input: model control - dt, & ! intent(in): length of the time step (seconds) - nSnow, & ! intent(in): number of snow layers - nSoil, & ! intent(in): number of soil layers - nLayers, & ! intent(in): total number of layers - computeVegFlux, & ! intent(in): flag to indicate if we need to compute fluxes over vegetation - .false., & ! intent(in): flag to indicate if we need to compute baseflow - ixFullMatrix, & ! intent(in): force full Jacobian matrix - ! input: data structures - indx_data, & ! intent(in): index data - prog_data, & ! intent(in): model prognostic variables for a local HRU - diag_data, & ! intent(in): model diagnostic variables for a local HRU - deriv_data, & ! intent(in): derivatives in model fluxes w.r.t. relevant state variables - dBaseflow_dMatric, & ! intent(in): derivative in baseflow w.r.t. matric head (s-1) - ! input-output: Jacobian and its diagonal - dMat, & ! intent(inout): diagonal of the Jacobian matrix - fullJac, & ! intent(out): full Jacobian matrix - ! output: error control - err,cmessage) ! intent(out): error code and error message - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - - ! initialize band matrix - bandJac(:,:) = 0._rkind - - ! transfer into the lapack band diagonal structure - do iState=1,nState - do jState=max(1,iState-ku),min(nState,iState+kl) - bandJac(kl + ku + 1 + jState - iState, iState) = fullJac(jState,iState) - end do - end do - - ! print results - print*, '** test banded analytical Jacobian:' - write(*,'(a4,1x,100(i17,1x))') 'xCol', (iState, iState=iJac1,iJac2) - do iState=kl+1,nLeadDim; write(*,'(i4,1x,100(e17.10,1x))') iState, bandJac(iState,iJac1:iJac2); end do - - ! check if the need to pause - if(check)then - print*, 'PAUSE: testing banded analytical Jacobian' - read(*,*) - endif - - end subroutine testBandMat - - - - ! ********************************************************************************************************* - ! * internal subroutine eval8summa_wrapper: compute the right-hand-side vector - ! ********************************************************************************************************* - ! NOTE: This is simply a wrapper routine for eval8summa, to reduce the number of calling arguments - ! An internal subroutine, so have access to all data in the main subroutine - subroutine eval8summa_wrapper(stateVecNew,fluxVecNew,resVecNew,fNew,feasible,err,message) - USE eval8summa_module,only:eval8summa ! simulation of fluxes and residuals given a trial state vector - implicit none - ! input - real(rkind),intent(in) :: stateVecNew(:) ! updated state vector - ! output - real(rkind),intent(out) :: fluxVecNew(:) ! updated flux vector - real(rkind),intent(out) :: resVecNew(:) ! NOTE: qp ! updated residual vector - real(rkind),intent(out) :: fNew ! new function value - logical(lgt),intent(out) :: feasible ! flag to denote the feasibility of the solution - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! ---------------------------------------------------------------------------------------------------------- - ! local - character(len=256) :: cmessage ! error message of downwind routine - ! ---------------------------------------------------------------------------------------------------------- - ! initialize error control - err=0; message='eval8summa_wrapper/' - - ! compute the flux and the residual vector for a given state vector - call eval8summa(& - ! input: model control - dt, & ! intent(in): length of the time step (seconds) - nSnow, & ! intent(in): number of snow layers - nSoil, & ! intent(in): number of soil layers - nLayers, & ! intent(in): total number of layers - nState, & ! intent(in): total number of state variables - firstSubStep, & ! intent(in): flag to indicate if we are processing the first sub-step - firstFluxCall, & ! intent(inout): flag to indicate if we are processing the first flux call - .false., & ! intent(in): flag to indicate if we are processing the first iteration in a splitting operation - computeVegFlux, & ! intent(in): flag to indicate if we need to compute fluxes over vegetation - scalarSolution, & ! intent(in): flag to indicate the scalar solution - ! input: state vectors - stateVecNew, & ! intent(in): updated model state vector - fScale, & ! intent(in): function scaling vector - sMul, & ! intent(in): state vector multiplier (used in the residual calculations) - ! input: data structures - model_decisions, & ! intent(in): model decisions - type_data, & ! intent(in): type of vegetation and soil - attr_data, & ! intent(in): spatial attributes - mpar_data, & ! intent(in): model parameters - forc_data, & ! intent(in): model forcing data - bvar_data, & ! intent(in): average model variables for the entire basin - prog_data, & ! intent(in): model prognostic variables for a local HRU - indx_data, & ! intent(in): index data - ! input-output: data structures - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - flux_data, & ! intent(inout): model fluxes for a local HRU - deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables - ! input-output: baseflow - ixSaturation, & ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) - dBaseflow_dMatric, & ! intent(out): derivative in baseflow w.r.t. matric head (s-1) - ! output - feasible, & ! intent(out): flag to denote the feasibility of the solution - fluxVecNew, & ! intent(out): new flux vector - resSinkNew, & ! intent(out): additional (sink) terms on the RHS of the state equation - resVecNew, & ! intent(out): new residual vector - fNew, & ! intent(out): new function evaluation - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - - end subroutine eval8summa_wrapper - - - ! ********************************************************************************************************* - ! internal function checkConv: check convergence based on the residual vector - ! ********************************************************************************************************* - function checkConv(rVec,xInc,xVec) - implicit none - ! dummies - real(rkind),intent(in) :: rVec(:) ! residual vector (mixed units) - real(rkind),intent(in) :: xInc(:) ! iteration increment (mixed units) - real(rkind),intent(in) :: xVec(:) ! state vector (mixed units) - logical(lgt) :: checkConv ! flag to denote convergence - ! locals - real(rkind),dimension(mSoil) :: psiScale ! scaling factor for matric head - real(rkind),parameter :: xSmall=1.e-0_rkind ! a small offset - real(rkind),parameter :: scalarTighten=0.1_rkind ! scaling factor for the scalar solution - real(rkind) :: soilWatbalErr ! error in the soil water balance - real(rkind) :: canopy_max ! absolute value of the residual in canopy water (kg m-2) - real(rkind),dimension(1) :: energy_max ! maximum absolute value of the energy residual (J m-3) - real(rkind),dimension(1) :: liquid_max ! maximum absolute value of the volumetric liquid water content residual (-) - real(rkind),dimension(1) :: matric_max ! maximum absolute value of the matric head iteration increment (m) - real(rkind) :: aquifer_max ! absolute value of the residual in aquifer water (m) - logical(lgt) :: canopyConv ! flag for canopy water balance convergence - logical(lgt) :: watbalConv ! flag for soil water balance convergence - logical(lgt) :: liquidConv ! flag for residual convergence - logical(lgt) :: matricConv ! flag for matric head convergence - logical(lgt) :: energyConv ! flag for energy convergence - logical(lgt) :: aquiferConv ! flag for aquifer water balance convergence - ! ------------------------------------------------------------------------------------------------------------------------------------------------- - ! association to variables in the data structures - associate(& - ! convergence parameters - absConvTol_liquid => mpar_data%var(iLookPARAM%absConvTol_liquid)%dat(1) ,& ! intent(in): [dp] absolute convergence tolerance for vol frac liq water (-) - absConvTol_matric => mpar_data%var(iLookPARAM%absConvTol_matric)%dat(1) ,& ! intent(in): [dp] absolute convergence tolerance for matric head (m) - absConvTol_energy => mpar_data%var(iLookPARAM%absConvTol_energy)%dat(1) ,& ! intent(in): [dp] absolute convergence tolerance for energy (J m-3) - ! layer depth - mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat ,& ! intent(in): [dp(:)] depth of each layer in the snow-soil sub-domain (m) - ! model indices - ixAqWat => indx_data%var(iLookINDEX%ixAqWat)%dat(1) ,& ! intent(in): [i4b] index of aquifer storage state variable - ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy air space energy state variable - ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable - ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) - ixNrgOnly => indx_data%var(iLookINDEX%ixNrgOnly)%dat ,& ! intent(in): [i4b(:)] list of indices for all energy states - ixHydOnly => indx_data%var(iLookINDEX%ixHydOnly)%dat ,& ! intent(in): [i4b(:)] list of indices for all hydrology states - ixMatOnly => indx_data%var(iLookINDEX%ixMatOnly)%dat ,& ! intent(in): [i4b(:)] list of indices for matric head state variables in the state vector - ixMatricHead => indx_data%var(iLookINDEX%ixMatricHead)%dat & ! intent(in): [i4b(:)] list of indices for matric head in the soil vector - - ) ! making associations with variables in the data structures - ! ------------------------------------------------------------------------------------------------------------------------------------------------- - - ! check convergence based on the canopy water balance - if(ixVegHyd/=integerMissing)then - canopy_max = real(abs(rVec(ixVegHyd)), rkind)*iden_water - canopyConv = (canopy_max < absConvTol_liquid) ! absolute error in canopy water balance (mm) - else - canopy_max = realMissing - canopyConv = .true. - endif - - ! check convergence based on the residuals for energy (J m-3) - if(size(ixNrgOnly)>0)then - energy_max = real(maxval(abs( rVec(ixNrgOnly) )), rkind) - energyConv = (energy_max(1) < absConvTol_energy) ! (based on the residual) - else - energy_max = realMissing - energyConv = .true. - endif - - ! check convergence based on the residuals for volumetric liquid water content (-) - if(size(ixHydOnly)>0)then - liquid_max = real(maxval(abs( rVec(ixHydOnly) ) ), rkind) - ! (tighter convergence for the scalar solution) - if(scalarSolution)then - liquidConv = (liquid_max(1) < absConvTol_liquid*scalarTighten) ! (based on the residual) - else - liquidConv = (liquid_max(1) < absConvTol_liquid) ! (based on the residual) - endif - else - liquid_max = realMissing - liquidConv = .true. - endif - - ! check convergence based on the iteration increment for matric head - ! NOTE: scale by matric head to avoid unnecessairly tight convergence when there is no water - if(size(ixMatOnly)>0)then - psiScale = abs( xVec(ixMatOnly) ) + xSmall ! avoid divide by zero - matric_max = maxval(abs( xInc(ixMatOnly)/psiScale ) ) - matricConv = (matric_max(1) < absConvTol_matric) ! NOTE: based on iteration increment - else - matric_max = realMissing - matricConv = .true. - endif - - ! check convergence based on the soil water balance error (m) - if(size(ixMatOnly)>0)then - soilWatBalErr = sum( real(rVec(ixMatOnly), rkind)*mLayerDepth(nSnow+ixMatricHead) ) - watbalConv = (abs(soilWatbalErr) < absConvTol_liquid) ! absolute error in total soil water balance (m) - else - soilWatbalErr = realMissing - watbalConv = .true. - endif - - ! check convergence based on the aquifer storage - if(ixAqWat/=integerMissing)then - aquifer_max = real(abs(rVec(ixAqWat)), rkind)*iden_water - aquiferConv = (aquifer_max < absConvTol_liquid) ! absolute error in aquifer water balance (mm) - else - aquifer_max = realMissing - aquiferConv = .true. - endif - - ! final convergence check - checkConv = (canopyConv .and. watbalConv .and. matricConv .and. liquidConv .and. energyConv .and. aquiferConv) - - ! print progress towards solution - if(globalPrintFlag)then - write(*,'(a,1x,i4,1x,7(e15.5,1x),7(L1,1x))') 'check convergence: ', iter, & - fNew, matric_max(1), liquid_max(1), energy_max(1), canopy_max, aquifer_max, soilWatBalErr, matricConv, liquidConv, energyConv, watbalConv, canopyConv, aquiferConv, watbalConv - endif - - ! end associations with variables in the data structures - end associate - - end function checkConv - - - ! ********************************************************************************************************* - ! internal subroutine imposeConstraints: impose solution constraints - ! ********************************************************************************************************* - subroutine imposeConstraints(stateVecTrial,xInc,err,message) - ! external functions - USE snow_utils_module,only:fracliquid ! compute the fraction of liquid water at a given temperature (snow) - USE soil_utils_module,only:crit_soilT ! compute the critical temperature below which ice exists - implicit none - ! dummies - real(rkind),intent(in) :: stateVecTrial(:) ! trial state vector - real(rkind),intent(inout) :: xInc(:) ! iteration increment - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! ----------------------------------------------------------------------------------------------------- - ! temporary variables for model constraints - real(rkind) :: cInc ! constrained temperature increment (K) -- simplified bi-section - real(rkind) :: xIncFactor ! scaling factor for the iteration increment (-) - integer(i4b) :: iMax(1) ! index of maximum temperature - real(rkind) :: scalarTemp ! temperature of an individual snow layer (K) - real(rkind) :: volFracLiq ! volumetric liquid water content of an individual snow layer (-) - logical(lgt),dimension(nSnow) :: drainFlag ! flag to denote when drainage exceeds available capacity - logical(lgt),dimension(nSoil) :: crosFlag ! flag to denote temperature crossing from unfrozen to frozen (or vice-versa) - logical(lgt) :: crosTempVeg ! flag to denoote where temperature crosses the freezing point - real(rkind) :: xPsi00 ! matric head after applying the iteration increment (m) - real(rkind) :: TcSoil ! critical point when soil begins to freeze (K) - real(rkind) :: critDiff ! temperature difference from critical (K) - real(rkind),parameter :: epsT=1.e-7_rkind ! small interval above/below critical (K) - real(rkind),parameter :: zMaxTempIncrement=1._rkind ! maximum temperature increment (K) - ! indices of model state variables - integer(i4b) :: iState ! index of state within a specific variable type - integer(i4b) :: ixNrg,ixLiq ! index of energy and mass state variables in full state vector - ! indices of model layers - integer(i4b) :: iLayer ! index of model layer - ! ----------------------------------------------------------------------------------------------------- - ! associate variables with indices of model state variables - associate(& - ixNrgOnly => indx_data%var(iLookINDEX%ixNrgOnly)%dat ,& ! intent(in): [i4b(:)] list of indices in the state subset for energy states - ixHydOnly => indx_data%var(iLookINDEX%ixHydOnly)%dat ,& ! intent(in): [i4b(:)] list of indices in the state subset for hydrology states - ixMatOnly => indx_data%var(iLookINDEX%ixMatOnly)%dat ,& ! intent(in): [i4b(:)] list of indices in the state subset for matric head states - ixMassOnly => indx_data%var(iLookINDEX%ixMassOnly)%dat ,& ! intent(in): [i4b(:)] list of indices in the state subset for canopy storage states - ixStateType_subset => indx_data%var(iLookINDEX%ixStateType_subset)%dat ,& ! intent(in): [i4b(:)] named variables defining the states in the subset - ! indices for specific state variables - ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy air space energy state variable - ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable - ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) - ixTopNrg => indx_data%var(iLookINDEX%ixTopNrg)%dat(1) ,& ! intent(in): [i4b] index of upper-most energy state in the snow-soil subdomain - ixTopHyd => indx_data%var(iLookINDEX%ixTopHyd)%dat(1) ,& ! intent(in): [i4b] index of upper-most hydrology state in the snow-soil subdomain - ! vector of energy indices for the snow and soil domains - ! NOTE: states not in the subset are equal to integerMissing - ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the snow+soil domain - ixSnowOnlyNrg => indx_data%var(iLookINDEX%ixSnowOnlyNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the snow domain - ixSoilOnlyNrg => indx_data%var(iLookINDEX%ixSoilOnlyNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the soil domain - ! vector of hydrology indices for the snow and soil domains - ! NOTE: states not in the subset are equal to integerMissing - ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the snow+soil domain - ixSnowOnlyHyd => indx_data%var(iLookINDEX%ixSnowOnlyHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the snow domain - ixSoilOnlyHyd => indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the soil domain - ! number of state variables of a specific type - nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg )%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow+soil domain - nSnowOnlyNrg => indx_data%var(iLookINDEX%nSnowOnlyNrg )%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow domain - nSoilOnlyNrg => indx_data%var(iLookINDEX%nSoilOnlyNrg )%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the soil domain - nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the snow+soil domain - nSnowOnlyHyd => indx_data%var(iLookINDEX%nSnowOnlyHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the snow domain - nSoilOnlyHyd => indx_data%var(iLookINDEX%nSoilOnlyHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the soil domain - ! state variables at the start of the time step - mLayerMatricHead => prog_data%var(iLookPROG%mLayerMatricHead)%dat & ! intent(in): [dp(:)] matric head (m) - ) ! associating variables with indices of model state variables - ! ----------------------------------------------------------------------------------------------------- - ! initialize error control - err=0; message='imposeConstraints/' - - ! ** limit temperature increment to zMaxTempIncrement - if(any(abs(xInc(ixNrgOnly)) > zMaxTempIncrement))then - iMax = maxloc( abs(xInc(ixNrgOnly)) ) ! index of maximum temperature increment - xIncFactor = abs( zMaxTempIncrement/xInc(ixNrgOnly(iMax(1))) ) ! scaling factor for the iteration increment (-) - xInc = xIncFactor*xInc - end if - - ! ** impose solution constraints for vegetation - ! (stop just above or just below the freezing point if crossing) - ! -------------------------------------------------------------------------------------------------------------------- - ! canopy temperatures - - if(ixVegNrg/=integerMissing)then - - ! initialize - critDiff = Tfreeze - stateVecTrial(ixVegNrg) - crosTempVeg = .false. - - ! initially frozen (T < Tfreeze) - if(critDiff > 0._rkind)then - if(xInc(ixVegNrg) > critDiff)then - crosTempVeg = .true. - cInc = critDiff + epsT ! constrained temperature increment (K) - end if - - ! initially unfrozen (T > Tfreeze) - else - if(xInc(ixVegNrg) < critDiff)then - crosTempVeg = .true. - cInc = critDiff - epsT ! constrained temperature increment (K) - end if - - end if ! switch between frozen and unfrozen - - ! scale iterations - if(crosTempVeg)then - xIncFactor = cInc/xInc(ixVegNrg) ! scaling factor for the iteration increment (-) - xInc = xIncFactor*xInc ! scale iteration increments - endif - - endif ! if the state variable for canopy temperature is included within the state subset - - ! -------------------------------------------------------------------------------------------------------------------- - ! canopy liquid water - - if(ixVegHyd/=integerMissing)then - - ! check if new value of storage will be negative - if(stateVecTrial(ixVegHyd)+xInc(ixVegHyd) < 0._rkind)then - ! scale iteration increment - cInc = -0.5_rkind*stateVecTrial(ixVegHyd) ! constrained iteration increment (K) -- simplified bi-section - xIncFactor = cInc/xInc(ixVegHyd) ! scaling factor for the iteration increment (-) - xInc = xIncFactor*xInc ! new iteration increment - end if - - endif ! if the state variable for canopy water is included within the state subset - - ! -------------------------------------------------------------------------------------------------------------------- - ! ** impose solution constraints for snow - if(nSnowOnlyNrg > 0)then - - ! loop through snow layers - checksnow: do iLayer=1,nSnow ! necessary to ensure that NO layers rise above Tfreeze - - ! check of the data is mising - if(ixSnowOnlyNrg(iLayer)==integerMissing) cycle - - ! check temperatures, and, if necessary, scale iteration increment - iState = ixSnowOnlyNrg(iLayer) - if(stateVecTrial(iState) + xInc(iState) > Tfreeze)then - ! scale iteration increment - cInc = 0.5_rkind*(Tfreeze - stateVecTrial(iState) ) ! constrained temperature increment (K) -- simplified bi-section - xIncFactor = cInc/xInc(iState) ! scaling factor for the iteration increment (-) - xInc = xIncFactor*xInc - end if ! if snow temperature > freezing - - end do checkSnow - - endif ! if there are state variables for energy in the snow domain - - ! -------------------------------------------------------------------------------------------------------------------- - ! - check if drain more than what is available - ! NOTE: change in total water is only due to liquid flux - if(nSnowOnlyHyd>0)then - - ! loop through snow layers - do iLayer=1,nSnow - - ! * check if the layer is included - if(ixSnowOnlyHyd(iLayer)==integerMissing) cycle - - ! * get the layer temperature (from stateVecTrial if ixSnowOnlyNrg(iLayer) is within the state vector - if(ixSnowOnlyNrg(iLayer)/=integerMissing)then - scalarTemp = stateVecTrial( ixSnowOnlyNrg(iLayer) ) - - ! * get the layer temperature from the last update - else - scalarTemp = prog_data%var(iLookPROG%mLayerTemp)%dat(iLayer) - endif - - ! * get the volumetric fraction of liquid water - select case( ixStateType_subset( ixSnowOnlyHyd(iLayer) ) ) - case(iname_watLayer); volFracLiq = fracliquid(scalarTemp,mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1)) * stateVecTrial(ixSnowOnlyHyd(iLayer)) - case(iname_liqLayer); volFracLiq = stateVecTrial(ixSnowOnlyHyd(iLayer)) - case default; err=20; message=trim(message)//'expect ixStateType_subset to be iname_watLayer or iname_liqLayer for snow hydrology'; return - end select - - ! * check that the iteration increment does not exceed volumetric liquid water content - if(-xInc(ixSnowOnlyHyd(iLayer)) > volFracLiq)then - drainFlag(iLayer) = .true. - xInc(ixSnowOnlyHyd(iLayer)) = -0.5_rkind*volFracLiq - endif - - end do ! looping through snow layers - - endif ! if there are state variables for liquid water in the snow domain - - ! -------------------------------------------------------------------------------------------------------------------- - ! ** impose solution constraints for soil temperature - if(nSoilOnlyNrg>0)then - do iLayer=1,nSoil - - ! - check if energy state is included - if(ixSoilOnlyNrg(iLayer)==integerMissing) cycle - - ! - define index of the state variables within the state subset - ixNrg = ixSoilOnlyNrg(iLayer) - ixLiq = ixSoilOnlyHyd(iLayer) - - ! get the matric potential of total water - if(ixLiq/=integerMissing)then - xPsi00 = stateVecTrial(ixLiq) + xInc(ixLiq) - else - xPsi00 = mLayerMatricHead(iLayer) - endif - - ! identify the critical point when soil begins to freeze (TcSoil) - TcSoil = crit_soilT(xPsi00) - - ! get the difference from the current state and the crossing point (K) - critDiff = TcSoil - stateVecTrial(ixNrg) - - ! * initially frozen (T < TcSoil) - if(critDiff > 0._rkind)then - - ! (check crossing above zero) - if(xInc(ixNrg) > critDiff)then - crosFlag(iLayer) = .true. - xInc(ixNrg) = critDiff + epsT ! set iteration increment to slightly above critical temperature - endif - - ! * initially unfrozen (T > TcSoil) - else - - ! (check crossing below zero) - if(xInc(ixNrg) < critDiff)then - crosFlag(iLayer) = .true. - xInc(ixNrg) = critDiff - epsT ! set iteration increment to slightly below critical temperature - endif - - endif ! (switch between initially frozen and initially unfrozen) - - end do ! (loop through soil layers) - endif ! (if there are both energy and liquid water state variables) - - ! ** impose solution constraints matric head - if(size(ixMatOnly)>0)then - do iState=1,size(ixMatOnly) - - ! - define index of the hydrology state variable within the state subset - ixLiq = ixMatOnly(iState) - - ! - place constraint for matric head - if(xInc(ixLiq) > 1._rkind .and. stateVecTrial(ixLiq) > 0._rkind)then - xInc(ixLiq) = 1._rkind - endif ! if constraining matric head - - end do ! (loop through soil layers) - endif ! (if there are both energy and liquid water state variables) - - ! end association with variables with indices of model state variables - end associate - - end subroutine imposeConstraints - - end subroutine summaSolve - - - - -end module summaSolve_module diff --git a/build/source/engine/summaSolve4homegrown.f90 b/build/source/engine/summaSolve4homegrown.f90 new file mode 100644 index 000000000..4d602f590 --- /dev/null +++ b/build/source/engine/summaSolve4homegrown.f90 @@ -0,0 +1,1231 @@ +! SUMMA - Structure for Unifying Multiple Modeling Alternatives +! Copyright (C) 2014-2020 NCAR/RAL; University of Saskatchewan; University of Washington +! +! This file is part of SUMMA +! +! For more information see: http://www.ral.ucar.edu/projects/summa +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see . + +module summaSolve4homegrown_module + +! data types +USE nrtype + +! access the global print flag +USE globalData,only:globalPrintFlag + +! access missing values +USE globalData,only:integerMissing ! missing integer +USE globalData,only:realMissing ! missing real number +USE globalData,only:quadMissing ! missing quadruple precision number + +! access named variables to describe the form and structure of the matrices used in the numerical solver +USE globalData,only: ixFullMatrix ! named variable for the full Jacobian matrix +USE globalData,only: ixBandMatrix ! named variable for the band diagonal matrix +USE globalData,only: ku ! number of super-diagonal bands +USE globalData,only: kl ! number of sub-diagonal bands +USE globalData,only: nBands ! length of the leading dimension of the band diagonal matrix +USE globalData,only: iJac1 ! first layer of the Jacobian to print +USE globalData,only: iJac2 ! last layer of the Jacobian to print + +! indices of elements of data structure +USE var_lookup,only:iLookFLUX ! named variables for structure elements +USE var_lookup,only:iLookPROG ! named variables for structure elements +USE var_lookup,only:iLookPARAM ! named variables for structure elements +USE var_lookup,only:iLookINDEX ! named variables for structure elements +USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure + +USE multiconst,only:& + iden_water ! intrinsic density of liquid water (kg m-3) + +! provide access to the derived types to define the data structures +USE data_types,only:& + var_i, & ! data vector (i4b) + var_d, & ! data vector (rkind) + var_ilength, & ! data vector with variable length dimension (i4b) + var_dlength, & ! data vector with variable length dimension (rkind) + zLookup, & ! lookup tables + model_options, & ! defines the model decisions + in_type_computJacob, & ! class for computJacob arguments + out_type_computJacob, & ! class for computJacob arguments + in_type_lineSearchRefinement, & ! class for lineSearchRefinement arguments + out_type_lineSearchRefinement,& ! class for lineSearchRefinement arguments + in_type_summaSolve4homegrown, & ! class for summaSolve4homegrown arguments + io_type_summaSolve4homegrown, & ! class for summaSolve4homegrown arguments + out_type_summaSolve4homegrown ! class for summaSolve4homegrown arguments + + +! look-up values for the choice of groundwater parameterization +USE mDecisions_module,only: & + qbaseTopmodel, & ! TOPMODEL-ish baseflow parameterization + bigBucket, & ! a big bucket (lumped aquifer model) + noExplicit ! no explicit groundwater parameterization + +! look-up values for method used to compute derivative +USE mDecisions_module,only: & + numerical, & ! numerical solution + analytical ! analytical solution + +implicit none +private +public :: summaSolve4homegrown +public :: refine_Newton_step +public :: checkConv +contains + + ! ************************************************************************************************************************** + ! public subroutine summaSolve4homegrown: calculate the iteration increment, evaluate the new state, and refine if necessary + ! ************************************************************************************************************************** + subroutine summaSolve4homegrown(& + ! input: model control + in_SS4HG, & ! intent(in): model control and previous function value + ! input: state vectors + stateVecTrial, & ! intent(in): trial state vector + fScale, & ! intent(in): characteristic scale of the function evaluations + xScale, & ! intent(in): characteristic scale of the state vector + rVec, & ! intent(in): residual vector + sMul, & ! intent(inout): state vector multiplier (used in the residual calculations) + dMat, & ! intent(inout): diagonal matrix (excludes flux derivatives) + ! input: data structures + model_decisions, & ! intent(in): model decisions + lookup_data, & ! intent(in): lookup tables + type_data, & ! intent(in): type of vegetation and soil + attr_data, & ! intent(in): spatial attributes + mpar_data, & ! intent(in): model parameters + forc_data, & ! intent(in): model forcing data + bvar_data, & ! intent(in): average model variables for the entire basin + prog_data, & ! intent(in): model prognostic variables for a local HRU + ! input-output: data structures + indx_data, & ! intent(inout): index data + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + flux_data, & ! intent(inout): model fluxes for a local HRU + deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables + ! input-output: baseflow + dBaseflow_dMatric, & ! intent(inout): derivative in baseflow w.r.t. matric head (s-1) + io_SS4HG, & ! intent(inout): first flux call flag, root brackets, index of lowest saturated layer + ! output + stateVecNew, & ! intent(out): new state vector + fluxVecNew, & ! intent(out): new flux vector + resSinkNew, & ! intent(out): additional (sink) terms on the RHS of the state equation + resVecNew, & ! intent(out): new residual vector + out_SS4HG) ! intent(out): new function evaluation, convergence flag, and error control + USE computJacob_module, only: computJacob + USE matrixOper_module, only: lapackSolv + USE matrixOper_module, only: scaleMatrices + implicit none + ! -------------------------------------------------------------------------------------------------------------------------------- + type(in_type_summaSolve4homegrown),intent(in) :: in_SS4HG ! model control variables and previous function evaluation + type(io_type_summaSolve4homegrown),intent(inout) :: io_SS4HG ! first flux call flag and baseflow variables + ! input: state vectors + real(rkind),intent(in) :: stateVecTrial(:) ! trial state vector + real(rkind),intent(in) :: fScale(:) ! characteristic scale of the function evaluations + real(rkind),intent(in) :: xScale(:) ! characteristic scale of the state vector + real(qp),intent(in) :: rVec(:) ! NOTE: qp ! residual vector + real(qp),intent(inout) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) + real(rkind),intent(inout) :: dMat(:) ! diagonal matrix (excludes flux derivatives) + ! input: data structures + type(model_options),intent(in) :: model_decisions(:) ! model decisions + type(zLookup), intent(in) :: lookup_data ! lookup tables + type(var_i), intent(in) :: type_data ! type of vegetation and soil + type(var_d), intent(in) :: attr_data ! spatial attributes + type(var_dlength), intent(in) :: mpar_data ! model parameters + type(var_d), intent(in) :: forc_data ! model forcing data + type(var_dlength), intent(in) :: bvar_data ! model variables for the local basin + type(var_dlength), intent(in) :: prog_data ! prognostic variables for a local HRU + ! output: data structures + type(var_ilength),intent(inout) :: indx_data ! indices defining model states and layers + type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + ! input-output: baseflow + real(rkind),intent(inout) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + ! output: flux and residual vectors + real(rkind),intent(out) :: stateVecNew(:) ! new state vector + real(rkind),intent(out) :: fluxVecNew(:) ! new flux vector + real(rkind),intent(out) :: resSinkNew(:) ! sink terms on the RHS of the flux equation + real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector + type(out_type_summaSolve4homegrown),intent(out) :: out_SS4HG ! new function evaluation, convergence flag, and error control + ! -------------------------------------------------------------------------------------------------------------------------------- + ! local variables + ! -------------------------------------------------------------------------------------------------------------------------------- + ! Jacobian matrix + real(rkind) :: nJac(in_SS4HG % nState,in_SS4HG % nState) ! numerical Jacobian matrix + real(rkind) :: aJac(in_SS4HG % nLeadDim,in_SS4HG % nState) ! Jacobian matrix + real(rkind) :: aJacScaled(in_SS4HG % nLeadDim,in_SS4HG % nState) ! Jacobian matrix (scaled) + real(rkind) :: aJacScaledTemp(in_SS4HG % nLeadDim,in_SS4HG % nState) ! Jacobian matrix (scaled) -- temporary copy since decomposed in lapack + ! solution/step vectors + real(rkind),dimension(in_SS4HG % nState) :: rVecScaled ! residual vector (scaled) + real(rkind),dimension(in_SS4HG % nState) :: newtStepScaled ! full newton step (scaled) + ! general + integer(i4b) :: mSoil ! number of soil layers in solution vector + integer(i4b) :: iLayer ! row index + integer(i4b) :: jLayer ! column index + logical(lgt) :: return_flag ! flag that controls execution of return statements + character(LEN=256) :: cmessage ! error message of downwind routine + ! class objects for subroutine arguments + type(in_type_computJacob) :: in_computJacob ! computJacob object + type(out_type_computJacob) :: out_computJacob ! computJacob object + ! -------------------------------------------------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------------------------------------------------- + + ! ***** Compute the Newton Step ***** + + ! initial setup including computing the Jacobian -- return if error + call initialize_summaSolve4homegrown; if (return_flag) return + ! compute the Newton step -- return if error + call update_summaSolve4homegrown; if (return_flag) return + ! final check for errors + call finalize_summaSolve4homegrown; if (return_flag) return + + contains + + subroutine initialize_summaSolve4homegrown + ! *** Initial steps for the summaSolve4homegrown algorithm (computing the Newton step) *** + + associate(& + err => out_SS4HG % err ,& + message => out_SS4HG % message & + &) + ! initialize error control + err=0; message='summaSolve4homegrown/' + return_flag=.false. ! initialize return flag + + ! choose Jacobian type + select case(model_decisions(iLookDECISIONS%fDerivMeth)%iDecision) + case(numerical) + err=20; message=trim(message)//'numerical derivatives are not implemented for BE homegrown solver'; + return_flag=.true.; return + case(analytical); ! this is fine + case default + err=20; message=trim(message)//'expect choice numericl or analytic to calculate derivatives for Jacobian'; + return_flag=.true.; return + end select + + end associate + + ! get the number of soil layers in the solution vector + mSoil = size(indx_data%var(iLookINDEX%ixMatOnly)%dat) + + ! compute the Jacobian + call update_Jacobian; if (return_flag) return ! compute Jacobian for Newton step -- return if error + end subroutine initialize_summaSolve4homegrown + + subroutine update_summaSolve4homegrown + ! *** Update steps for the summaSolve4homegrown algorithm (computing the Newton step) *** + call solve_linear_system; if (return_flag) return ! solve the linear system for the Newton step -- return if error + + ! refine Newton step if needed + call refine_Newton_step(in_SS4HG,mSoil,stateVecTrial,newtStepScaled,aJacScaled,rVecScaled,fScale,xScale,& ! input + &model_decisions,lookup_data,type_data,attr_data,mpar_data,forc_data,bvar_data,prog_data,& ! input + &sMul,io_SS4HG,indx_data,diag_data,flux_data,deriv_data,dBaseflow_dMatric,& ! input-output + &stateVecNew,fluxVecNew,resSinkNew,resVecNew,out_SS4HG,return_flag) ! output + if (return_flag) return ! return if error + end subroutine update_summaSolve4homegrown + + subroutine finalize_summaSolve4homegrown + ! *** Final steps for the summaSolve4homegrown algorithm (computing the Newton step) *** + associate(err => out_SS4HG % err,message => out_SS4HG % message) + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if ! check for errors + end associate + end subroutine finalize_summaSolve4homegrown + + subroutine update_Jacobian + ! *** Update Jacobian used for Newton step *** + + ! compute the analytical Jacobian matrix + ! NOTE: The derivatives were computed in the previous call to computFlux + ! This occurred either at the call to eval8summa at the start of systemSolv + ! or in the call to eval8summa in the previous iteration (within lineSearchRefinement or trustRegionRefinement) + associate(& + err => out_SS4HG % err ,& + message => out_SS4HG % message & + &) + call initialize_computJacob_summaSolve4homegrown + call computJacob(in_computJacob,indx_data,prog_data,diag_data,deriv_data,dBaseflow_dMatric,dMat,aJac,out_computJacob) + call finalize_computJacob_summaSolve4homegrown + if (err/=0) then; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if ! (check for errors) + + end associate + end subroutine update_Jacobian + + subroutine solve_linear_system + ! *** Solve the linear system for the Newton step using LAPACK routines *** + + associate(& + nState => in_SS4HG % nState ,& ! intent(in): total number of state variables + ixMatrix => in_SS4HG % ixMatrix ,& ! intent(in): type of matrix (full or band diagonal) + err => out_SS4HG % err ,& ! intent(out): error code + message => out_SS4HG % message & ! intent(out): error message + &) + + ! scale the residual vector + rVecScaled(1:nState) = fScale(:)*real(rVec(:), rkind) ! NOTE: residual vector is in quadruple precision + + ! scale matrices + call scaleMatrices(ixMatrix,nState,aJac,fScale,xScale,aJacScaled,err,cmessage) + if (err/=0) then; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if ! check for errors + + ! debug statement for scaled Jacobian + if (globalPrintFlag .and. ixMatrix==ixBandMatrix) then + print*, '** SCALED banded analytical Jacobian:' + write(*,'(a4,1x,100(i17,1x))') 'xCol', (iLayer, iLayer=iJac1,iJac2) + do iLayer=kl+1,nBands + write(*,'(i4,1x,100(e17.10,1x))') iLayer, (aJacScaled(iLayer,jLayer),jLayer=min(iJac1,nState),min(iJac2,nState)) + end do + end if + + ! copy the scaled matrix, since it is decomposed in lapackSolv + aJacScaledTemp = aJacScaled + + ! compute the newton step: use the lapack routines to solve the linear system A.X=B + call lapackSolv(ixMatrix,nState,aJacScaledTemp,-rVecScaled,newtStepScaled,err,cmessage) + if (err/=0) then; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if ! check for errors + + ! debug statement for Newton step + if (globalPrintFlag) write(*,'(a,1x,10(e17.10,1x))') 'newtStepScaled = ', newtStepScaled(min(iJac1,nState):min(iJac2,nState)) + + end associate + end subroutine solve_linear_system + + subroutine initialize_computJacob_summaSolve4homegrown + ! *** Transfer data to in_computJacob class object from local variables in summaSolve4homegrown *** + associate(& + ixGroundwater => model_decisions(iLookDECISIONS%groundwatr)%iDecision,& ! intent(in): [i4b] groundwater parameterization + dt_cur => in_SS4HG % dt_cur ,& ! intent(in): current stepsize + nSnow => in_SS4HG % nSnow ,& ! intent(in): number of snow layers + nSoil => in_SS4HG % nSoil ,& ! intent(in): number of soil layers + nLayers => in_SS4HG % nLayers ,& ! intent(in): total number of layers + ixMatrix => in_SS4HG % ixMatrix ,& ! intent(in): type of matrix (full or band diagonal) + computeVegFlux => in_SS4HG % computeVegFlux & ! intent(in): flag to indicate if computing fluxes over vegetation + &) + call in_computJacob % initialize(dt_cur,nSnow,nSoil,nLayers,computeVegFlux,(ixGroundwater==qbaseTopmodel),ixMatrix) + end associate + end subroutine initialize_computJacob_summaSolve4homegrown + + subroutine finalize_computJacob_summaSolve4homegrown + ! *** Transfer data from out_computJacob class object to local variables in summaSolve4homegrown *** + associate(err => out_SS4HG % err) + call out_computJacob % finalize(err,cmessage) + end associate + end subroutine finalize_computJacob_summaSolve4homegrown + + end subroutine summaSolve4homegrown + + ! ********************************************************************************************************* + ! * module subroutine refine_Newton_step: refine the Newton step if necessary + ! ********************************************************************************************************* + subroutine refine_Newton_step(in_SS4HG,mSoil,stateVecTrial,newtStepScaled,aJacScaled,rVecScaled,fScale,xScale,& ! input + &model_decisions,lookup_data,type_data,attr_data,mpar_data,forc_data,bvar_data,prog_data,& ! input + &sMul,io_SS4HG,indx_data,diag_data,flux_data,deriv_data,dBaseflow_dMatric,& ! input-output + &stateVecNew,fluxVecNew,resSinkNew,resVecNew,out_SS4HG,return_flag) ! output + ! provide access to the external procedures + USE matrixOper_module, only: computeGradient + USE eval8summa_module, only: imposeConstraints + implicit none + ! input + type(in_type_summaSolve4homegrown),intent(in) :: in_SS4HG ! model control variables and previous function evaluation + integer(i4b),intent(in) :: mSoil ! number of soil layers in solution vector + real(rkind),intent(in) :: stateVecTrial(:) ! trial state vector + real(rkind),intent(in) :: newtStepScaled(:) ! scaled newton step + real(rkind),intent(in) :: aJacScaled(:,:) ! scaled jacobian matrix + real(rkind),intent(in) :: rVecScaled(:) ! scaled residual vector + real(rkind),intent(in) :: fScale(:) ! characteristic scale of the function evaluations + real(rkind),intent(in) :: xScale(:) ! characteristic scale of the state vector + type(model_options),intent(in) :: model_decisions(:) ! model decisions + type(zLookup), intent(in) :: lookup_data ! lookup tables + type(var_i), intent(in) :: type_data ! type of vegetation and soil + type(var_d), intent(in) :: attr_data ! spatial attributes + type(var_dlength), intent(in) :: mpar_data ! model parameters + type(var_d), intent(in) :: forc_data ! model forcing data + type(var_dlength), intent(in) :: bvar_data ! model variables for the local basin + type(var_dlength), intent(in) :: prog_data ! prognostic variables for a local HRU + ! input-output + real(qp),intent(inout) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) + type(io_type_summaSolve4homegrown),intent(inout) :: io_SS4HG ! first flux call flag and baseflow variables + type(var_ilength),intent(inout) :: indx_data ! indices defining model states and layers + type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + real(rkind),intent(inout) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + ! output + real(rkind),intent(out) :: stateVecNew(:) ! new state vector + real(rkind),intent(out) :: fluxVecNew(:) ! new flux vector + real(rkind),intent(out) :: resSinkNew(:) ! sink terms on the RHS of the flux equation + real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector + type(out_type_summaSolve4homegrown),intent(out) :: out_SS4HG ! new function evaluation, convergence flag, and error control + logical(lgt),intent(out) :: return_flag ! flag that controls execution of return statements + ! local + logical(lgt) :: doRefine ! flag for step refinement + integer(i4b),parameter :: ixLineSearch=1001 ! step refinement = line search + integer(i4b),parameter :: ixTrustRegion=1002 ! step refinement = trust region + integer(i4b),parameter :: ixStepRefinement=ixLineSearch ! decision for the numerical solution + character(LEN=256) :: cmessage ! error message of downwind routine + type(in_type_lineSearchRefinement) :: in_LSR ! lineSearchRefinement + type(out_type_lineSearchRefinement) :: out_LSR ! lineSearchRefinement + type(in_type_lineSearchRefinement) :: in_TRR ! trustRegionRefinement + type(out_type_lineSearchRefinement) :: out_TRR ! trustRegionRefinement + type(out_type_lineSearchRefinement) :: out_SRF ! safeRootFinder + + ! initialize error control + associate(& + err => out_SS4HG % err ,& + message => out_SS4HG % message & + &) + err=0; message='refine_Newton_step/' + end associate + return_flag = .false. ! initialize return flag (used to indicate non-recoverable errors) + + ! initialize the flag for step refinement + doRefine=.true. + + ! * case 1: state vector + ! compute the flux vector and the residual, and (if necessary) refine the iteration increment + ! NOTE: in 99.9% of cases newtStep will be used (no refinement) + + associate(& + fOld => in_SS4HG % fOld ,& + fNew => out_SS4HG % fNew ,& + converged => out_SS4HG % converged,& + err => out_SS4HG % err ,& + message => out_SS4HG % message & + &) + if (size(stateVecTrial)>1) then + + ! try to backtrack + select case(ixStepRefinement) + case(ixLineSearch) + call in_LSR % initialize(doRefine,fOld) + call lineSearchRefinement(in_LSR,in_SS4HG,mSoil,stateVecTrial,newtStepScaled,aJacScaled,rVecScaled,fScale,xScale,& ! input + &model_decisions,lookup_data,type_data,attr_data,mpar_data,forc_data,bvar_data,prog_data,& ! input + &sMul,io_SS4HG,indx_data,diag_data,flux_data,deriv_data,dBaseflow_dMatric,& ! input-output + &stateVecNew,fluxVecNew,resSinkNew,resVecNew,out_SS4HG,out_LSR) ! output + call out_LSR % finalize(fNew,converged,err,cmessage) + case(ixTrustRegion) + call in_TRR % initialize(doRefine,fOld) + call trustRegionRefinement(in_TRR,in_SS4HG,stateVecTrial,newtStepScaled,aJacScaled,rVecScaled,stateVecNew,fluxVecNew,resVecNew,out_TRR) + call out_TRR % finalize(fNew,converged,err,cmessage) + case default; err=20; message=trim(message)//'unable to identify numerical solution'; return_flag=.true.; return + end select + + ! check warnings: negative error code = warning; in this case back-tracked to the original value + ! NOTE: Accept the full newton step if back-tracked to the original value + if (err<0) then + doRefine=.false.; + call in_LSR % initialize(doRefine,fOld) + call lineSearchRefinement(in_LSR,in_SS4HG,mSoil,stateVecTrial,newtStepScaled,aJacScaled,rVecScaled,fScale,xScale,& ! input + &model_decisions,lookup_data,type_data,attr_data,mpar_data,forc_data,bvar_data,prog_data,& ! input + &sMul,io_SS4HG,indx_data,diag_data,flux_data,deriv_data,dBaseflow_dMatric,& ! input-output + &stateVecNew,fluxVecNew,resSinkNew,resVecNew,out_SS4HG,out_LSR) ! output + call out_LSR % finalize(fNew,converged,err,cmessage) + end if + + ! * case 2: scalar + else + call safeRootfinder(mSoil,stateVecTrial,rVecScaled,newtStepScaled,fScale,xScale,& ! input + &in_SS4HG,model_decisions,lookup_data,type_data,attr_data,& ! input + &mpar_data,forc_data,bvar_data,prog_data,& ! input + &sMul,io_SS4HG,indx_data,diag_data,flux_data,deriv_data,dBaseflow_dMatric,& ! input-output + &out_SS4HG,stateVecNew,fluxVecNew,resSinkNew,resVecNew,out_SRF) ! output + call out_SRF % finalize(fNew,converged,err,cmessage) + end if + + ! final check for errors + if (err/=0) then; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if ! check for errors + + end associate + end subroutine refine_Newton_step + + ! ********************************************************************************************************* + ! * module subroutine lineSearchRefinement: refine the iteration increment using line searches + ! ********************************************************************************************************* + subroutine lineSearchRefinement(in_LSR,in_SS4HG,mSoil,stateVecTrial,newtStepScaled,aJacScaled,rVecScaled,fScale,xScale,& + &model_decisions,lookup_data,type_data,attr_data,mpar_data,forc_data,bvar_data,prog_data,& + &sMul,io_SS4HG,indx_data,diag_data,flux_data,deriv_data,dBaseflow_dMatric,& + &stateVecNew,fluxVecNew,resSinkNew,resVecNew,out_SS4HG,out_LSR) + ! provide access to the external procedures + USE matrixOper_module, only: computeGradient + USE eval8summa_module, only: imposeConstraints + implicit none + ! input + type(in_type_lineSearchRefinement),intent(in) :: in_LSR ! class object for intent(in) arguments + type(in_type_summaSolve4homegrown),intent(in) :: in_SS4HG ! model control variables and previous function evaluation + integer(i4b),intent(in) :: mSoil ! number of soil layers in solution vector + real(rkind),intent(in) :: stateVecTrial(:) ! trial state vector + real(rkind),intent(in) :: newtStepScaled(:) ! scaled newton step + real(rkind),intent(in) :: aJacScaled(:,:) ! scaled jacobian matrix + real(rkind),intent(in) :: rVecScaled(:) ! scaled residual vector + real(rkind),intent(in) :: fScale(:) ! characteristic scale of the function evaluations + real(rkind),intent(in) :: xScale(:) ! characteristic scale of the state vector + type(model_options),intent(in) :: model_decisions(:) ! model decisions + type(zLookup), intent(in) :: lookup_data ! lookup tables + type(var_i), intent(in) :: type_data ! type of vegetation and soil + type(var_d), intent(in) :: attr_data ! spatial attributes + type(var_dlength), intent(in) :: mpar_data ! model parameters + type(var_d), intent(in) :: forc_data ! model forcing data + type(var_dlength), intent(in) :: bvar_data ! model variables for the local basin + type(var_dlength), intent(in) :: prog_data ! prognostic variables for a local HRU + ! input-output + real(qp),intent(inout) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) + type(io_type_summaSolve4homegrown),intent(inout) :: io_SS4HG ! first flux call flag and baseflow variables + type(var_ilength),intent(inout) :: indx_data ! indices defining model states and layers + type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + real(rkind),intent(inout) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + ! output + real(rkind),intent(out) :: stateVecNew(:) ! new state vector + real(rkind),intent(out) :: fluxVecNew(:) ! new flux vector + real(rkind),intent(out) :: resSinkNew(:) ! sink terms on the RHS of the flux equation + real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector + type(out_type_summaSolve4homegrown),intent(out) :: out_SS4HG ! new function evaluation, convergence flag, and error control + type(out_type_lineSearchRefinement),intent(out) :: out_LSR ! class object for intent(out) arguments + ! -------------------------------------------------------------------------------------------------------- + ! local + character(len=256) :: cmessage ! error message of downwind routine + real(rkind) :: gradScaled(in_SS4HG % nState) ! scaled gradient + real(rkind) :: xInc(in_SS4HG % nState) ! iteration increment (re-scaled to original units of the state vector) + logical(lgt) :: feasible ! flag to denote the feasibility of the solution + integer(i4b) :: iLine ! line search index + integer(i4b),parameter :: maxLineSearch=5 ! maximum number of backtracks + real(rkind),parameter :: alpha=1.e-4_rkind ! check on gradient + real(rkind) :: xLambda ! backtrack magnitude + real(rkind) :: xLambdaTemp ! temporary backtrack magnitude + real(rkind) :: slopeInit ! initial slope + real(rkind) :: rhs1,rhs2 ! rhs used to compute the cubic + real(rkind) :: aCoef,bCoef ! coefficients in the cubic + real(rkind) :: disc ! temporary variable used in cubic + real(rkind) :: xLambdaPrev ! previous lambda value (used in the cubic) + real(rkind) :: fPrev ! previous function evaluation (used in the cubic) + ! -------------------------------------------------------------------------------------------------------- + associate(& + ! intent(in) variables + doLineSearch => in_LSR % doSearch ,& ! flag to do the line search + fOld => in_LSR % fOld ,& ! old function value + ! local variables + nSnow => in_SS4HG % nSnow ,& ! number of snow layers + nSoil => in_SS4HG % nSoil ,& ! number of soil layers + nState => in_SS4HG % nState ,& ! total number of state variables + ixMatrix => in_SS4HG % ixMatrix ,& ! type of matrix (full or band diagonal) + ! intent(out) variables + fNew => out_LSR % fNew ,& ! new function evaluation + converged => out_LSR % converged ,& ! convergence flag + err => out_LSR % err ,& ! error code + message => out_LSR % message & ! error message + &) + ! initialize error control + err=0; message='lineSearchRefinement/' + converged = .false. + + ! check the need to compute the line search + if (doLineSearch) then + + ! compute the gradient of the function vector + call computeGradient(ixMatrix,nState,aJacScaled,rVecScaled,gradScaled,err,cmessage) + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if ! check for errors + + ! compute the initial slope + slopeInit = dot_product(gradScaled,newtStepScaled) + + end if ! if computing the line search + + ! initialize lambda + xLambda=1._rkind + + ! ***** LINE SEARCH LOOP... + lineSearch: do iLine=1,maxLineSearch ! try to refine the function by shrinking the step size + + ! back-track along the search direction + ! NOTE: start with back-tracking the scaled step + xInc(:) = xLambda*newtStepScaled(:) + + ! re-scale the iteration increment + xInc(:) = xInc(:)*xScale(:) + + ! state vector with proposed iteration increment + stateVecNew = stateVecTrial + xInc + + ! impose solution constraints adjusting state vector and iteration increment + ! NOTE: We may not need to do this (or at least, do ALL of this), as we can probably rely on the line search here + call imposeConstraints(model_decisions,indx_data,prog_data,mpar_data,stateVecNew,stateVecTrial,nState,nSoil,nSnow,cmessage,err) + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if ! check for errors + xInc = stateVecNew - stateVecTrial + + ! compute the residual vector and function + ! NOTE: This calls eval8summa in a wrapper subroutine + call eval8summa_wrapper(stateVecNew,fScale,in_SS4HG,model_decisions,& + &lookup_data,type_data,attr_data,mpar_data,forc_data,bvar_data,prog_data,& + &sMul,io_SS4HG,indx_data,diag_data,flux_data,deriv_data,dBaseflow_dMatric,& + &fluxVecNew,resSinkNew,resVecNew,fNew,feasible,err,cmessage) + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if ! check for errors + + ! check line search + if (globalPrintFlag) then + write(*,'(a,1x,i4,1x,e17.10)' ) 'iLine, xLambda = ', iLine, xLambda + write(*,'(a,1x,10(e17.10,1x))') 'fOld,fNew = ', fOld,fNew + write(*,'(a,1x,10(e17.10,1x))') 'fOld + alpha*slopeInit*xLambda = ', fOld + alpha*slopeInit*xLambda + write(*,'(a,1x,10(e17.10,1x))') 'resVecNew = ', resVecNew(min(iJac1,nState):min(iJac2,nState)) + write(*,'(a,1x,10(e17.10,1x))') 'xInc = ', xInc(min(iJac1,nState):min(iJac2,nState)) + end if + + ! check feasibility + if (.not.feasible) cycle ! go back and impose constraints again + + ! check convergence + ! NOTE: some efficiency gains possible by scaling the full newton step outside the line search loop + converged = checkConv(mSoil,in_SS4HG,mpar_data,indx_data,prog_data,resVecNew,newtStepScaled*xScale,stateVecNew,out_SS4HG) + if (converged) return + + ! early return if not computing the line search + if (.not.doLineSearch) return + + ! check if the function is accepted + if (fNew < fOld + alpha*slopeInit*xLambda) return + + ! *** + ! *** IF GET TO HERE WE BACKTRACK + ! --> all remaining code simply computes the restricted step multiplier (xLambda) + + ! first backtrack: use quadratic + if (iLine==1) then + xLambdaTemp = -slopeInit / ( 2._rkind*(fNew - fOld - slopeInit) ) + if (xLambdaTemp > 0.5_rkind*xLambda) xLambdaTemp = 0.5_rkind*xLambda + + ! subsequent backtracks: use cubic + else + + ! check that we did not back-track all the way back to the original value + if (iLine == maxLineSearch) then + message=trim(message)//'backtracked all the way back to the original value' + err=-20; return + end if + + ! define rhs + rhs1 = fNew - fOld - xLambda*slopeInit + rhs2 = fPrev - fOld - xLambdaPrev*slopeInit + + ! define coefficients + aCoef = (rhs1/(xLambda*xLambda) - rhs2/(xLambdaPrev*xLambdaPrev))/(xLambda - xLambdaPrev) + bCoef = (-xLambdaPrev*rhs1/(xLambda*xLambda) + xLambda*rhs2/(xLambdaPrev*xLambdaPrev)) / (xLambda - xLambdaPrev) + + ! check if a quadratic + if (aCoef == 0._rkind) then + xLambdaTemp = -slopeInit/(2._rkind*bCoef) + + ! calculate cubic + else + disc = bCoef*bCoef - 3._rkind*aCoef*slopeInit + if (disc < 0._rkind) then + xLambdaTemp = 0.5_rkind*xLambda + else + xLambdaTemp = (-bCoef + sqrt(disc))/(3._rkind*aCoef) + end if + end if + + ! constrain to <= 0.5*xLambda + if (xLambdaTemp > 0.5_rkind*xLambda) xLambdaTemp=0.5_rkind*xLambda + + end if ! subsequent backtracks + + ! save results + xLambdaPrev = xLambda + fPrev = fNew + + ! constrain lambda + xLambda = max(xLambdaTemp, 0.1_rkind*xLambda) + + end do lineSearch + end associate + + end subroutine lineSearchRefinement + + ! ********************************************************************************************************* + ! * module subroutine trustRegionRefinement: refine the iteration increment using trust regions + ! ********************************************************************************************************* + subroutine trustRegionRefinement(in_TRR,in_SS4HG,stateVecTrial,newtStepScaled,aJacScaled,rVecScaled,stateVecNew,fluxVecNew,resVecNew,out_TRR) + ! provide access to the matrix routines + USE matrixOper_module, only: lapackSolv + USE matrixOper_module, only: computeGradient + implicit none + ! input + type(in_type_lineSearchRefinement),intent(in) :: in_TRR ! object for scalar intent(in) arguments -- reusing line search class + type(in_type_summaSolve4homegrown),intent(in) :: in_SS4HG ! model control variables and previous function evaluation + real(rkind),intent(in) :: stateVecTrial(:) ! trial state vector + real(rkind),intent(in) :: newtStepScaled(:) ! scaled newton step + real(rkind),intent(in) :: aJacScaled(:,:) ! scaled jacobian matrix + real(rkind),intent(in) :: rVecScaled(:) ! scaled residual vector + ! output + real(rkind),intent(out) :: stateVecNew(:) ! new state vector + real(rkind),intent(out) :: fluxVecNew(:) ! new flux vector + real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector + type(out_type_lineSearchRefinement),intent(out) :: out_TRR ! object for scalar intent(in) arguments -- reusing line search class + ! -------------------------------------------------------------------------------------------------------- + ! local variables + + ! .. needed .. + + ! -------------------------------------------------------------------------------------------------------- + associate(& + ! input + doTrustRefinement => in_TRR % doSearch ,& ! flag to refine using trust regions + fOld => in_TRR % fOld ,& ! old function value + nState => in_SS4HG % nState ,& ! total number of state variables + ! output + fNew => out_TRR % fNew ,& ! new function evaluation + converged => out_TRR % converged ,& ! convergence flag + err => out_TRR % err ,& ! error code + message => out_TRR % message & ! error message + &) + + err=0; message='trustRegionRefinement/' + converged =.false. + + ! check the need to refine the step + if (doTrustRefinement) then + + ! check vectors + if (size(stateVecTrial)/=nState .or. size(newtStepScaled)/=nState .or. size(rVecScaled)/=nState)then + message=trim(message)//'unexpected size of input vectors' + err=20; return + end if + + ! check matrix + if (size(aJacScaled,1)/=nState .or. size(aJacScaled,2)/=nState) then + message=trim(message)//'unexpected size of Jacobian matrix' + err=20; return + end if + + ! dummy check for the function + if (fOld==realMissing) print*, 'missing fOld in trustRegionRefinement' + + ! dummy + stateVecNew = realMissing + fluxVecNew = realMissing + resVecNew = quadMissing + fNew = realMissing + converged = .true. + + + end if ! if doing the trust region refinement + + message=trim(message)//'routine not implemented yet' + err=20; return + + end associate + + end subroutine trustRegionRefinement + + ! ********************************************************************************************************* + ! * module subroutine safeRootfinder: refine the 1-d iteration increment using brackets + ! ********************************************************************************************************* + subroutine safeRootfinder(mSoil,stateVecTrial,rVecscaled,newtStepScaled,fScale,xScale,& + &in_SS4HG,model_decisions,lookup_data,type_data,attr_data,& + &mpar_data,forc_data,bvar_data,prog_data,& + &sMul,io_SS4HG,indx_data,diag_data,flux_data,deriv_data,dBaseflow_dMatric,& + &out_SS4HG,stateVecNew,fluxVecNew,resSinkNew,resVecNew,out_SRF) + USE,intrinsic :: ieee_arithmetic,only:ieee_is_nan ! IEEE arithmetic (check NaN) + USE eval8summa_module,only: imposeConstraints ! imposeConstraints + USE globalData,only:dNaN ! double precision NaN + implicit none + ! input + integer(i4b),intent(in) :: mSoil ! number of soil layers in solution vector + real(rkind),intent(in) :: stateVecTrial(:) ! trial state vector + real(rkind),intent(in) :: rVecScaled(:) ! scaled residual vector + real(rkind),intent(in) :: newtStepScaled(:) ! scaled newton step + real(rkind),intent(in) :: fScale(:) ! characteristic scale of the function evaluations + real(rkind),intent(in) :: xScale(:) ! characteristic scale of the state vector + type(in_type_summaSolve4homegrown),intent(in) :: in_SS4HG ! model control variables and previous function evaluation + type(model_options),intent(in) :: model_decisions(:) ! model decisions + type(zLookup), intent(in) :: lookup_data ! lookup tables + type(var_i), intent(in) :: type_data ! type of vegetation and soil + type(var_d), intent(in) :: attr_data ! spatial attributes + type(var_dlength), intent(in) :: mpar_data ! model parameters + type(var_d), intent(in) :: forc_data ! model forcing data + type(var_dlength), intent(in) :: bvar_data ! model variables for the local basin + type(var_dlength), intent(in) :: prog_data ! prognostic variables for a local HRU + ! input-output + real(qp),intent(inout) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) + type(io_type_summaSolve4homegrown),intent(inout) :: io_SS4HG ! first flux call flag and baseflow variables + type(var_ilength),intent(inout) :: indx_data ! indices defining model states and layers + type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + real(rkind),intent(inout) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + ! output + type(out_type_summaSolve4homegrown),intent(out) :: out_SS4HG ! new function evaluation, convergence flag, and error control + real(rkind),intent(out) :: stateVecNew(:) ! new state vector + real(rkind),intent(out) :: fluxVecNew(:) ! new flux vector + real(rkind),intent(out) :: resSinkNew(:) ! sink terms on the RHS of the flux equation + real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector + type(out_type_lineSearchRefinement),intent(out) :: out_SRF ! object for scalar intent(out) arguments (reusing lineSearchRefinement class) + ! -------------------------------------------------------------------------------------------------------- + ! local variables + character(len=256) :: cmessage ! error message of downwind routine + real(rkind),parameter :: relTolerance=0.005_rkind ! force bi-section if trial is slightly larger than (smaller than) xmin (xmax) + real(rkind) :: xTolerance ! relTolerance*(xmax-xmin) + real(rkind) :: xInc(in_SS4HG % nState) ! iteration increment (re-scaled to original units of the state vector) + real(rkind) :: rVec(in_SS4HG % nState) ! residual vector (re-scaled to original units of the state equation) + logical(lgt) :: feasible ! feasibility of the solution + logical(lgt) :: doBisection ! flag to do the bi-section + logical(lgt) :: bracketsDefined ! flag to define if the brackets are defined + integer(i4b),parameter :: nCheck=100 ! number of times to check the model state variables + real(rkind),parameter :: delX=1._rkind ! trial increment + ! -------------------------------------------------------------------------------------------------------- + associate(& + iter => in_SS4HG % iter ,& ! intent(in): iteration index + nSnow => in_SS4HG % nSnow ,& ! intent(in): number of snow layers + nSoil => in_SS4HG % nSoil ,& ! intent(in): number of soil layers + nState => in_SS4HG % nState ,& ! intent(in): total number of state + xMin => io_SS4HG % xMin ,& ! intent(inout): bracket of the root + xMax => io_SS4HG % xMax ,& ! intent(inout): bracket of the root + fNew => out_SRF % fNew ,& ! intent(out): new function evaluation + converged => out_SRF % converged ,& ! intent(out): convergence flag + err => out_SRF % err ,& ! intent(out): error code + message => out_SRF % message & ! intent(out): error message + &) + + err=0; message='safeRootfinder/' + converged = .false. + + ! check scalar + if (size(stateVecTrial)/=1 .or. size(rVecScaled)/=1 .or. size(newtStepScaled)/=1) then + message=trim(message)//'unexpected size of input vectors' + err=20; return + end if + + ! initialize brackets to rkind precision NaN + if (iter==1) then + xMax = dNaN + xMin = dNaN + end if + + ! get the residual vector + rVec = real(rVecScaled, rkind)*real(fScale, rkind) + + ! update brackets + if (rVec(1)<0._rkind) then + xMin = stateVecTrial(1) + else + xMax = stateVecTrial(1) + end if + + ! get the iteration increment + xInc = newtStepScaled*xScale + + ! ***** + ! * case 1: the iteration increment is the same sign as the residual vector + if (xInc(1)*rVec(1) > 0._rkind) then + + ! get brackets if they do not exist + if ( ieee_is_nan(xMin) .or. ieee_is_nan(xMax) ) then + call getBrackets(stateVecTrial,rVec,fScale,in_SS4HG,model_decisions,lookup_data,type_data,attr_data,& + &mpar_data,forc_data,bvar_data,prog_data,& + &sMul,io_SS4HG,indx_data,diag_data,flux_data,deriv_data,dBaseflow_dMatric,& + &out_SS4HG,stateVecNew,fluxVecNew,resSinkNew,resVecNew,xMin,xMax,err,cmessage) + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if ! check for errors + end if + + ! use bi-section + stateVecNew(1) = 0.5_rkind*(xMin + xMax) + + ! ***** + ! * case 2: the iteration increment is the correct sign + else + + ! state vector with proposed iteration increment + stateVecNew = stateVecTrial + xInc + + ! impose solution constraints adjusting state vector and iteration increment + call imposeConstraints(model_decisions,indx_data,prog_data,mpar_data,stateVecNew,stateVecTrial,nState,nSoil,nSnow,cmessage,err) + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if ! check for errors + xInc = stateVecNew - stateVecTrial + + end if ! if the iteration increment is the same sign as the residual vector + + ! bi-section + bracketsDefined = ( .not.ieee_is_nan(xMin) .and. .not.ieee_is_nan(xMax) ) ! check that the brackets are defined + if (bracketsDefined) then + xTolerance = relTolerance*(xMax-xMin) + doBisection = (stateVecNew(1)xMax-xTolerance) + if (doBisection) stateVecNew(1) = 0.5_rkind*(xMin+xMax) + end if + + ! evaluate summa + call eval8summa_wrapper(stateVecNew,fScale,in_SS4HG,model_decisions,& + &lookup_data,type_data,attr_data,mpar_data,forc_data,bvar_data,prog_data,& + &sMul,io_SS4HG,indx_data,diag_data,flux_data,deriv_data,dBaseflow_dMatric,& + &fluxVecNew,resSinkNew,resVecNew,fNew,feasible,err,cmessage) + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if ! check for errors + + ! check feasibility (should be feasible because of the call to imposeConstraints, except if canopyTemp>canopyTempMax (500._rkind)) + if (.not.feasible) then; err=20; message=trim(message)//'state vector not feasible'; return; end if + + ! check convergence + converged = checkConv(mSoil,in_SS4HG,mpar_data,indx_data,prog_data,resVecNew,xInc,stateVecNew,out_SS4HG) + + end associate + + end subroutine safeRootfinder + + ! ********************************************************************************************************* + ! * module subroutine getBrackets: get the brackets for safeRootfinder + ! ********************************************************************************************************* + subroutine getBrackets(stateVecTrial,rVec,fScale,in_SS4HG,model_decisions,lookup_data,type_data,attr_data,& + &mpar_data,forc_data,bvar_data,prog_data,& + &sMul,io_SS4HG,indx_data,diag_data,flux_data,deriv_data,dBaseflow_dMatric,& + &out_SS4HG,stateVecNew,fluxVecNew,resSinkNew,resVecNew,xMin,xMax,err,message) + USE,intrinsic :: ieee_arithmetic,only:ieee_is_nan ! IEEE arithmetic (check NaN) + USE eval8summa_module,only: imposeConstraints ! imposeConstraints + implicit none + ! input + real(rkind),intent(in) :: stateVecTrial(:) ! trial state vector + real(qp),intent(in) :: rVec(:) ! NOTE: qp ! residual vector + real(rkind),intent(in) :: fScale(:) ! characteristic scale of the function evaluations + type(in_type_summaSolve4homegrown),intent(in) :: in_SS4HG ! model control variables and previous function evaluation + type(model_options),intent(in) :: model_decisions(:) ! model decisions + type(zLookup), intent(in) :: lookup_data ! lookup tables + type(var_i), intent(in) :: type_data ! type of vegetation and soil + type(var_d), intent(in) :: attr_data ! spatial attributes + type(var_dlength), intent(in) :: mpar_data ! model parameters + type(var_d), intent(in) :: forc_data ! model forcing data + type(var_dlength), intent(in) :: bvar_data ! model variables for the local basin + type(var_dlength), intent(in) :: prog_data ! prognostic variables for a local HRU + ! input-output + real(qp),intent(inout) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) + type(io_type_summaSolve4homegrown),intent(inout) :: io_SS4HG ! first flux call flag and baseflow variables + type(var_ilength),intent(inout) :: indx_data ! indices defining model states and layers + type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + real(rkind),intent(inout) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + integer(i4b),intent(inout) :: err ! error code + ! output + type(out_type_summaSolve4homegrown),intent(out) :: out_SS4HG ! new function evaluation, convergence flag, and error control + real(rkind),intent(out) :: stateVecNew(:) ! new state vector + real(rkind),intent(out) :: fluxVecNew(:) ! updated flux vector + real(rkind),intent(out) :: resSinkNew(:) ! sink terms on the RHS of the flux equation + real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! updated residual vector + real(rkind),intent(out) :: xMin,xMax ! constraints + character(*),intent(out) :: message ! error message + ! locals + real(rkind) :: stateVecPrev(in_SS4HG % nState) ! iteration state vector + integer(i4b) :: iCheck ! check the model state variables + integer(i4b),parameter :: nCheck=100 ! number of times to check the model state variables + logical(lgt) :: feasible ! feasibility of the solution + real(rkind),parameter :: delX=1._rkind ! trial increment + real(rkind) :: xIncrement(in_SS4HG % nState) ! trial increment + character(len=256) :: cmessage ! error message of downwind routine + ! initialize + err=0; message='getBrackets/' + + ! initialize state vector + stateVecNew = stateVecTrial + stateVecPrev = stateVecNew + + ! get xIncrement + xIncrement = -sign((/delX/),rVec) + + ! try the increment a few times + do iCheck=1,nCheck + + ! state vector with proposed iteration increment + stateVecNew = stateVecPrev + xIncrement + + ! impose solution constraints adjusting state vector and iteration increment + associate(& + nSnow => in_SS4HG % nSnow ,& ! intent(in): number of snow layers + nSoil => in_SS4HG % nSoil ,& ! intent(in): number of soil layers + nState => in_SS4HG % nState & ! intent(in): total number of state variables + &) + call imposeConstraints(model_decisions,indx_data,prog_data,mpar_data,stateVecNew,stateVecPrev,nState,nSoil,nSnow,cmessage,err) + end associate + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if ! check for errors + xIncrement = stateVecNew - stateVecPrev + + ! evaluate summa + associate(fNew => out_SS4HG % fNew) + call eval8summa_wrapper(stateVecNew,fScale,in_SS4HG,model_decisions,& + &lookup_data,type_data,attr_data,mpar_data,forc_data,bvar_data,prog_data,& + &sMul,io_SS4HG,indx_data,diag_data,flux_data,deriv_data,dBaseflow_dMatric,& + &fluxVecNew,resSinkNew,resVecNew,fNew,feasible,err,cmessage) + end associate + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if ! check for errors + + ! check feasibility (should be feasible because of the call to imposeConstraints, except if canopyTemp>canopyTempMax (500._rkind)) + if (.not.feasible) then; message=trim(message)//'state vector not feasible'; err=20; return; end if + + ! update brackets + if (real(resVecNew(1), rkind)<0._rkind) then + xMin = stateVecNew(1) + else + xMax = stateVecNew(1) + end if + + ! check that the brackets are defined + if ( .not.ieee_is_nan(xMin) .and. .not.ieee_is_nan(xMax) ) exit + + ! check that we found the brackets + if (iCheck==nCheck) then + message=trim(message)//'could not fix the problem where residual and iteration increment are of the same sign' + err=20; return + endif + + ! Save the state vector + stateVecPrev = stateVecNew + + end do ! multiple checks + + end subroutine getBrackets + + ! ********************************************************************************************************* + ! * module subroutine eval8summa_wrapper: compute the right-hand-side vector + ! ********************************************************************************************************* + ! NOTE: This is simply a wrapper routine for eval8summa, to reduce the number of calling arguments + subroutine eval8summa_wrapper(stateVecNew,fScale,in_SS4HG,model_decisions,& + &lookup_data,type_data,attr_data,mpar_data,forc_data,bvar_data,prog_data,& + &sMul,io_SS4HG,indx_data,diag_data,flux_data,deriv_data,dBaseflow_dMatric,& + &fluxVecNew,resSinkNew,resVecNew,fNew,feasible,err,message) + USE eval8summa_module,only:eval8summa ! simulation of fluxes and residuals given a trial state vector + implicit none + ! input + real(rkind),intent(in) :: stateVecNew(:) ! updated state vector + real(rkind),intent(in) :: fScale(:) ! characteristic scale of the function evaluations + type(in_type_summaSolve4homegrown),intent(in) :: in_SS4HG ! model control variables and previous function evaluation + type(model_options),intent(in) :: model_decisions(:) ! model decisions + type(zLookup), intent(in) :: lookup_data ! lookup tables + type(var_i), intent(in) :: type_data ! type of vegetation and soil + type(var_d), intent(in) :: attr_data ! spatial attributes + type(var_dlength), intent(in) :: mpar_data ! model parameters + type(var_d), intent(in) :: forc_data ! model forcing data + type(var_dlength), intent(in) :: bvar_data ! model variables for the local basin + type(var_dlength), intent(in) :: prog_data ! prognostic variables for a local HRU + ! input-output + real(qp),intent(inout) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) + type(io_type_summaSolve4homegrown),intent(inout) :: io_SS4HG ! first flux call flag and baseflow variables + type(var_ilength),intent(inout) :: indx_data ! indices defining model states and layers + type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + real(rkind),intent(inout) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + ! output + real(rkind),intent(out) :: fluxVecNew(:) ! updated flux vector + real(rkind),intent(out) :: resSinkNew(:) ! sink terms on the RHS of the flux equation + real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! updated residual vector + real(rkind),intent(out) :: fNew ! new function value + logical(lgt),intent(out) :: feasible ! flag to denote the feasibility of the solution + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! ---------------------------------------------------------------------------------------------------------- + ! local + !real(rkind),allocatable :: fRHS(:) ! RHS function for ARKODE + character(len=256) :: cmessage ! error message of downwind routine + ! ---------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message='eval8summa_wrapper/' + + associate(& + dt_cur => in_SS4HG % dt_cur ,& ! intent(in): current stepsize + dt => in_SS4HG % dt ,& ! intent(in): entire time step for drainage pond rate + nSnow => in_SS4HG % nSnow ,& ! intent(in): number of snow layers + nSoil => in_SS4HG % nSoil ,& ! intent(in): number of soil layers + nLayers => in_SS4HG % nLayers ,& ! intent(in): total number of layers + nState => in_SS4HG % nState ,& ! intent(in): total number of state variables + firstSubStep => in_SS4HG % firstSubStep ,& ! intent(in): flag to indicate if we are processing the first sub-step + computeVegFlux => in_SS4HG % computeVegFlux ,& ! intent(in): flag to indicate if computing fluxes over vegetation + scalarSolution => in_SS4HG % scalarSolution ,& ! intent(in): flag to denote if implementing the scalar solution + firstFluxCall => io_SS4HG % firstFluxCall ,& ! intent(inout): flag to indicate if we are processing the first flux call + ixSaturation => io_SS4HG % ixSaturation & ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) + &) + ! compute the flux and the residual vector for a given state vector + call eval8summa(& + ! input: model control + dt_cur, & ! intent(in): current stepsize + dt, & ! intent(in): length of the time step (seconds) + nSnow, & ! intent(in): number of snow layers + nSoil, & ! intent(in): number of soil layers + nLayers, & ! intent(in): total number of layers + nState, & ! intent(in): total number of state variables + .false., & ! intent(in): not inside Sundials solver + firstSubStep, & ! intent(in): flag to indicate if we are processing the first sub-step + firstFluxCall, & ! intent(inout): flag to indicate if we are processing the first flux call + .false., & ! intent(in): not processing the first iteration in a splitting operation + computeVegFlux, & ! intent(in): flag to indicate if we need to compute fluxes over vegetation + scalarSolution, & ! intent(in): flag to indicate the scalar solution + ! input: state vectors + stateVecNew, & ! intent(in): updated model state vector + fScale, & ! intent(in): characteristic scale of the function evaluations + sMul, & ! intent(inout): state vector multiplier (used in the residual calculations) + ! input: data structures + model_decisions, & ! intent(in): model decisions + lookup_data, & ! intent(in): lookup tables + type_data, & ! intent(in): type of vegetation and soil + attr_data, & ! intent(in): spatial attributes + mpar_data, & ! intent(in): model parameters + forc_data, & ! intent(in): model forcing data + bvar_data, & ! intent(in): average model variables for the entire basin + prog_data, & ! intent(in): model prognostic variables for a local HRU + ! input-output: data structures + indx_data, & ! intent(inout): index data + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + flux_data, & ! intent(inout): model fluxes for a local HRU + deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables + ! input-output: baseflow + ixSaturation, & ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) + dBaseflow_dMatric, & ! intent(out): derivative in baseflow w.r.t. matric head (s-1) + ! output + feasible, & ! intent(out): flag to denote the feasibility of the solution + fluxVecNew, & ! intent(out): new flux vector + !fRHS, & ! intent(out): RHS function for ARKODE + resSinkNew, & ! intent(out): additional (sink) terms on the RHS of the state equation + resVecNew, & ! intent(out): new residual vector + fNew, & ! intent(out): new function evaluation + err,cmessage) ! intent(out): error control + end associate + + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if ! check for errors + + end subroutine eval8summa_wrapper + + ! ********************************************************************************************************* + ! module function checkConv: check convergence based on the residual vector + ! ********************************************************************************************************* + function checkConv(mSoil,in_SS4HG,mpar_data,indx_data,prog_data,rVec,xInc,xVec,out_SS4HG) + implicit none + ! result + logical(lgt) :: checkConv ! flag to denote convergence + ! dummies + integer(i4b),intent(in) :: mSoil ! number of soil layers in solution vector + type(in_type_summaSolve4homegrown),intent(in) :: in_SS4HG ! model control variables and previous function evaluation + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers + type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU + real(rkind),intent(in) :: rVec(:) ! residual vector (mixed units) + real(rkind),intent(in) :: xInc(:) ! iteration increment (mixed units) + real(rkind),intent(in) :: xVec(:) ! state vector (mixed units) + type(out_type_summaSolve4homegrown),intent(in) :: out_SS4HG ! new function evaluation, convergence flag, and error control + ! locals + real(rkind),dimension(mSoil) :: psiScale ! scaling factor for matric head + real(rkind),parameter :: xSmall=1.e-0_rkind ! a small offset + real(rkind),parameter :: scalarTighten=0.1_rkind ! scaling factor for the scalar solution + real(rkind) :: soilWatbalErr ! error in the soil water balance + real(rkind) :: canopy_max ! absolute value of the residual in canopy water (kg m-2) + real(rkind),dimension(1) :: energy_max ! maximum absolute value of the energy residual (J m-3) + real(rkind),dimension(1) :: liquid_max ! maximum absolute value of the volumetric liquid water content residual (-) + real(rkind),dimension(1) :: matric_max ! maximum absolute value of the matric head iteration increment (m) + real(rkind) :: aquifer_max ! absolute value of the residual in aquifer water (m) + logical(lgt) :: canopyConv ! flag for canopy water balance convergence + logical(lgt) :: watbalConv ! flag for soil water balance convergence + logical(lgt) :: liquidConv ! flag for residual convergence + logical(lgt) :: matricConv ! flag for matric head convergence + logical(lgt) :: energyConv ! flag for energy convergence + logical(lgt) :: aquiferConv ! flag for aquifer water balance convergence + ! ------------------------------------------------------------------------------------------------------------------------------------------------- + ! association to variables in the data structures + associate(& + ! model control + iter => in_SS4HG % iter ,& ! intent(in): iteration index + nSnow => in_SS4HG % nSnow ,& ! intent(in): number of snow layers + scalarSolution => in_SS4HG % scalarSolution ,& ! intent(in): flag to denote if implementing the scalar solution + ! convergence parameters + absConvTol_liquid => mpar_data%var(iLookPARAM%absConvTol_liquid)%dat(1),& ! intent(in): [dp] absolute convergence tolerance for vol frac liq water (-) + absConvTol_matric => mpar_data%var(iLookPARAM%absConvTol_matric)%dat(1),& ! intent(in): [dp] absolute convergence tolerance for matric head (m) + absConvTol_energy => mpar_data%var(iLookPARAM%absConvTol_energy)%dat(1),& ! intent(in): [dp] absolute convergence tolerance for energy (J m-3) + ! layer depth + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat ,& ! intent(in): [dp(:)] depth of each layer in the snow-soil sub-domain (m) + ! model indices + ixAqWat => indx_data%var(iLookINDEX%ixAqWat)%dat(1) ,& ! intent(in): [i4b] index of aquifer storage state variable + ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy air space energy state variable + ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable + ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) + ixNrgOnly => indx_data%var(iLookINDEX%ixNrgOnly)%dat ,& ! intent(in): [i4b(:)] list of indices for all energy states + ixHydOnly => indx_data%var(iLookINDEX%ixHydOnly)%dat ,& ! intent(in): [i4b(:)] list of indices for all hydrology states + ixMatOnly => indx_data%var(iLookINDEX%ixMatOnly)%dat ,& ! intent(in): [i4b(:)] list of indices for matric head state variables in the state vector + ixMatricHead => indx_data%var(iLookINDEX%ixMatricHead)%dat & ! intent(in): [i4b(:)] list of indices for matric head in the soil vector + &) + + ! check convergence based on the canopy water balance + if (ixVegHyd/=integerMissing) then + canopy_max = real(abs(rVec(ixVegHyd)), rkind)*iden_water + canopyConv = (canopy_max < absConvTol_liquid) ! absolute error in canopy water balance (mm) + else + canopy_max = realMissing + canopyConv = .true. + end if + + ! check convergence based on the residuals for energy (J m-3) + if (size(ixNrgOnly)>0) then + energy_max = real(maxval(abs( rVec(ixNrgOnly) )), rkind) + energyConv = (energy_max(1) < absConvTol_energy) ! (based on the residual) + else + energy_max = realMissing + energyConv = .true. + end if + + ! check convergence based on the residuals for volumetric liquid water content (-) + if (size(ixHydOnly)>0) then + liquid_max = real(maxval(abs( rVec(ixHydOnly) ) ), rkind) + ! (tighter convergence for the scalar solution) + if (scalarSolution) then + liquidConv = (liquid_max(1) < absConvTol_liquid*scalarTighten) ! (based on the residual) + else + liquidConv = (liquid_max(1) < absConvTol_liquid) ! (based on the residual) + end if + else + liquid_max = realMissing + liquidConv = .true. + end if + + ! check convergence based on the iteration increment for matric head + ! NOTE: scale by matric head to avoid unnecessairly tight convergence when there is no water + if (size(ixMatOnly)>0) then + psiScale = abs( xVec(ixMatOnly) ) + xSmall ! avoid divide by zero + matric_max = maxval(abs( xInc(ixMatOnly)/psiScale ) ) + matricConv = (matric_max(1) < absConvTol_matric) ! NOTE: based on iteration increment + else + matric_max = realMissing + matricConv = .true. + end if + + ! check convergence based on the soil water balance error (m) + if (size(ixMatOnly)>0) then + soilWatBalErr = sum( real(rVec(ixMatOnly), rkind)*mLayerDepth(nSnow+ixMatricHead) ) + watbalConv = (abs(soilWatbalErr) < absConvTol_liquid) ! absolute error in total soil water balance (m) + else + soilWatbalErr = realMissing + watbalConv = .true. + end if + + ! check convergence based on the aquifer storage + if (ixAqWat/=integerMissing) then + aquifer_max = real(abs(rVec(ixAqWat)), rkind)*iden_water + aquiferConv = (aquifer_max < absConvTol_liquid) ! absolute error in aquifer water balance (mm) + else + aquifer_max = realMissing + aquiferConv = .true. + end if + + ! final convergence check + checkConv = (canopyConv .and. watbalConv .and. matricConv .and. liquidConv .and. energyConv .and. aquiferConv) + + ! print progress towards solution + if (globalPrintFlag) then + write(*,'(a,1x,i4,1x,6(e15.5,1x),7(L1,1x))') 'check convergence: ', iter, & + matric_max(1), liquid_max(1), energy_max(1), canopy_max, aquifer_max, soilWatBalErr, matricConv, liquidConv, energyConv, watbalConv, canopyConv, aquiferConv, watbalConv + end if + + end associate ! end associations with variables in the data structures + + end function checkConv + +end module summaSolve4homegrown_module diff --git a/build/source/engine/summaSolve4ida.f90 b/build/source/engine/summaSolve4ida.f90 new file mode 100644 index 000000000..a8beb510a --- /dev/null +++ b/build/source/engine/summaSolve4ida.f90 @@ -0,0 +1,1008 @@ +! SUMMA - Structure for Unifying Multiple Modeling Alternatives +! Copyright (C) 2014-2020 NCAR/RAL; University of Saskatchewan; University of Washington +! +! This file is part of SUMMA +! +! For more information see: http://www.ral.ucar.edu/projects/summa +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see . + +module summaSolve4ida_module + + +!======= Inclusions =========== +USE, intrinsic :: iso_c_binding +USE nrtype +USE type4ida + +! access missing values +USE globalData,only:integerMissing ! missing integer +USE globalData,only:realMissing ! missing real number +USE globalData,only:verySmaller ! a smaller number used as an additive constant to check if substantial difference among real numbers + +! access matrix information +USE globalData,only: ixFullMatrix ! named variable for the full Jacobian matrix +USE globalData,only: ixBandMatrix ! named variable for the band diagonal matrix +USE globalData,only: ku ! number of super-diagonal bands +USE globalData,only: kl ! number of sub-diagonal bands + +! global metadata +USE globalData,only:flux_meta ! metadata on the model fluxes + +! constants +USE multiconst,only: Tfreeze ! temperature at freezing (K) + +! provide access to indices that define elements of the data structures +USE var_lookup,only:iLookPROG ! named variables for structure elements +USE var_lookup,only:iLookDIAG ! named variables for structure elements +USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure +USE var_lookup,only:iLookDERIV ! named variables for structure elements +USE var_lookup,only:iLookFLUX ! named variables for structure elements +USE var_lookup,only:iLookPARAM ! named variables for structure elements +USE var_lookup,only:iLookINDEX ! named variables for structure elements + +! provide access to the derived types to define the data structures +USE data_types,only:& + var_i, & ! data vector (i4b) + var_d, & ! data vector (rkind) + var_ilength, & ! data vector with variable length dimension (i4b) + var_dlength, & ! data vector with variable length dimension (rkind) + model_options ! defines the model decisions + +! look-up values for the choice of groundwater parameterization +USE mDecisions_module,only: & + qbaseTopmodel, & ! TOPMODEL-ish baseflow parameterization + bigBucket, & ! a big bucket (lumped aquifer model) + noExplicit ! no explicit groundwater parameterization + +! look-up values for the choice of variable in energy equations (BE residual or IDA state variable) +USE mDecisions_module,only: & + closedForm, & ! use temperature with closed form heat capacity + enthalpyFormLU, & ! use enthalpy with soil temperature-enthalpy lookup tables + enthalpyForm ! use enthalpy with soil temperature-enthalpy analytical solution + +! look-up values for method used to compute derivative +USE mDecisions_module,only: & + numerical, & ! numerical solution + analytical ! analytical solution + +! privacy + implicit none + private::setInitialCondition + private::setSolverParams + private::find_rootdir + public::layerDisCont4ida + private::getErrMessage + public::summaSolve4ida + +contains + + +! ************************************************************************************ +! * public subroutine summaSolve4ida: solve F(y,y') = 0 by IDA (y is the state vector) +! ************************************************************************************ +subroutine summaSolve4ida(& + dt_cur, & ! intent(in): current stepsize + dt, & ! intent(in): data time step + atol, & ! intent(in): absolute tolerance + rtol, & ! intent(in): relative tolerance + nSnow, & ! intent(in): number of snow layers + nSoil, & ! intent(in): number of soil layers + nLayers, & ! intent(in): total number of layers + nStat, & ! intent(in): total number of state variables + ixMatrix, & ! intent(in): type of matrix (dense or banded) + firstSubStep, & ! intent(in): flag to indicate if we are processing the first sub-step + computeVegFlux, & ! intent(in): flag to indicate if we need to compute fluxes over vegetation + scalarSolution, & ! intent(in): flag to indicate the scalar solution + computMassBalance, & ! intent(in): flag to compute mass balance + computNrgBalance, & ! intent(in): flag to compute energy balance + ! input: state vectors + stateVecInit, & ! intent(in): initial state vector + sMul, & ! intent(inout): state vector multiplier (used in the residual calculations) + dMat, & ! intent(inout): diagonal of the Jacobian matrix (excludes fluxes) + ! input: data structures + model_decisions, & ! intent(in): model decisions + lookup_data, & ! intent(in): lookup data + type_data, & ! intent(in): type of vegetation and soil + attr_data, & ! intent(in): spatial attributes + mpar_data, & ! intent(in): model parameters + forc_data, & ! intent(in): model forcing data + bvar_data, & ! intent(in): average model variables for the entire basin + prog_data, & ! intent(in): model prognostic variables for a local HRU + ! input-output: data structures + indx_data, & ! intent(inout): index data + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + flux_data, & ! intent(inout): model fluxes for a local HRU + flux_sum, & ! intent(inout): sum of fluxes model fluxes for a local HRU over a dt_cur + deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables + mLayerCmpress_sum, & ! intent(inout): sum of compression of the soil matrix + ! output + ixSaturation, & ! intent(inout) index of the lowest saturated layer (NOTE: only computed on the first iteration) + idaSucceeds, & ! intent(out): flag to indicate if IDA successfully solved the problem in current data step + tooMuchMelt, & ! intent(inout): lag to denote that there was too much melt + nSteps, & ! intent(out): number of time steps taken in solver + stateVec, & ! intent(out): model state vector + stateVecPrime, & ! intent(out): derivative of model state vector + balance, & ! intent(inout): balance per state + err,message) ! intent(out): error control + + !======= Inclusions =========== + USE fida_mod ! Fortran interface to IDA + USE fsundials_core_mod ! Fortran interface to SUNContext + USE fnvector_serial_mod ! Fortran interface to serial N_Vector + USE fsunmatrix_dense_mod ! Fortran interface to dense SUNMatrix + USE fsunmatrix_band_mod ! Fortran interface to banded SUNMatrix + USE fsunlinsol_dense_mod ! Fortran interface to dense SUNLinearSolver + USE fsunlinsol_band_mod ! Fortran interface to banded SUNLinearSolver + USE fsunnonlinsol_newton_mod ! Fortran interface to Newton SUNNonlinearSolver + USE allocspace_module,only:allocLocal ! allocate local data structures + USE getVectorz_module, only:checkFeas ! check feasibility of state vector + USE eval8summaWithPrime_module,only:eval8summa4ida ! DAE/ODE functions + USE computJacobWithPrime_module,only:computJacob4ida ! system Jacobian + USE tol4ida_module,only:computWeight4ida ! weight required for tolerances + USE var_lookup,only:maxvarDecisions ! maximum number of decisions + !======= Declarations ========= + implicit none + + ! -------------------------------------------------------------------------------------------------------------------------------- + ! calling variables + ! -------------------------------------------------------------------------------------------------------------------------------- + ! input: model control + real(rkind),intent(in) :: dt_cur ! current stepsize + real(qp),intent(in) :: dt ! data time step + real(qp),intent(inout) :: atol(:) ! vector of absolute tolerances + real(qp),intent(inout) :: rtol(:) ! vector of relative tolerances + integer(i4b),intent(in) :: nSnow ! number of snow layers + integer(i4b),intent(in) :: nSoil ! number of soil layers + integer(i4b),intent(in) :: nLayers ! total number of layers + integer(i4b),intent(in) :: nStat ! total number of state variables + integer(i4b),intent(in) :: ixMatrix ! form of matrix (dense or banded) + logical(lgt),intent(in) :: firstSubStep ! flag to indicate if we are processing the first sub-step + logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation + logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution + logical(lgt),intent(in) :: computMassBalance ! flag to compute mass balance + logical(lgt),intent(in) :: computNrgBalance ! flag to compute energy balance + ! input: state vectors + real(rkind),intent(in) :: stateVecInit(:) ! model state vector + real(qp),intent(in) :: sMul(:) ! state vector multiplier (used in the residual calculations) + real(rkind), intent(inout) :: dMat(:) ! diagonal of the Jacobian matrix (excludes fluxes) + ! input: data structures + type(model_options),intent(in) :: model_decisions(:) ! model decisions + type(zLookup), intent(in) :: lookup_data ! lookup tables + type(var_i), intent(in) :: type_data ! type of vegetation and soil + type(var_d), intent(in) :: attr_data ! spatial attributes + type(var_dlength), intent(in) :: mpar_data ! model parameters + type(var_d), intent(in) :: forc_data ! model forcing data + type(var_dlength), intent(in) :: bvar_data ! model variables for the local basin + type(var_dlength), intent(in) :: prog_data ! prognostic variables for a local HRU + ! input-output: data structures + type(var_ilength),intent(inout) :: indx_data ! indices defining model states and layers + type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(inout) :: flux_sum ! sum of fluxes model fluxes for a local HRU over a dt_cur + type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + real(rkind),intent(inout) :: mLayerCmpress_sum(:) ! sum of soil compress + ! output: state vectors + integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer + integer(i4b),intent(out) :: nSteps ! number of time steps taken in solver + real(rkind),intent(inout) :: stateVec(:) ! model state vector (y) + real(rkind),intent(inout) :: stateVecPrime(:) ! model state vector (y') + logical(lgt),intent(out) :: idaSucceeds ! flag to indicate if IDA is successful + logical(lgt),intent(inout) :: tooMuchMelt ! flag to denote that there was too much melt + ! output: residual terms and balances + real(rkind),intent(inout) :: balance(:) ! balance per state + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + + ! -------------------------------------------------------------------------------------------------------------------------------- + ! local variables + ! -------------------------------------------------------------------------------------------------------------------------------- + type(N_Vector), pointer :: sunvec_y ! sundials solution vector + type(N_Vector), pointer :: sunvec_yp ! sundials derivative vector + type(SUNMatrix), pointer :: sunmat_A ! sundials matrix + type(SUNLinearSolver), pointer :: sunlinsol_LS ! sundials linear solver + type(c_ptr) :: ida_mem ! IDA memory + type(c_ptr) :: sunctx ! SUNDIALS simulation context + type(data4ida), target :: eqns_data ! IDA type + integer(i4b) :: retval, retvalr ! return value + logical(lgt) :: feasible ! feasibility flag + real(qp) :: t0 ! starting time + real(qp) :: dt_last(1) ! last time step + real(qp) :: dt_diff ! difference from previous timestep + integer(c_long) :: mu, lu ! in banded matrix mode in SUNDIALS type + integer(c_long) :: nState ! total number of state variables in SUNDIALS type + integer(i4b) :: iVar, i ! indices + integer(i4b) :: nRoot ! total number of roots (events) to find + real(qp) :: tret(1) ! time in data window + real(qp) :: tretPrev ! previous time in data window + integer(i4b),allocatable :: rootsfound(:) ! crossing direction of discontinuities + integer(i4b),allocatable :: rootdir(:) ! forced crossing direction of discontinuities + logical(lgt) :: tinystep ! if step goes below small size + type(var_dlength) :: flux_prev ! previous model fluxes for a local HRU + character(LEN=256) :: cmessage ! error message of downwind routine + real(rkind) :: dt_mult ! multiplier for time step average values + real(rkind),allocatable :: mLayerMatricHeadPrimePrev(:) ! previous derivative value for total water matric potential (m s-1) + real(rkind),allocatable :: resVecPrev(:) ! previous value for residuals + real(rkind),allocatable :: dCompress_dPsiPrev(:) ! previous derivative value soil compression + integer(c_long) :: nStepsSun(1) + integer(c_long) :: nREvals(1) + integer(c_long) :: nLinSetups(1) + integer(c_long) :: netFails(1) + integer(c_int) :: qLast(1) + integer(c_int) :: qCur(1) + real(c_double) :: hInitUsed(1) + real(c_double) :: hLast(1) + real(c_double) :: hCur(1) + real(c_double) :: tCur(1) + ! flags + logical(lgt) :: use_fdJac ! flag to use finite difference Jacobian, controlled by decision fDerivMeth + logical(lgt),parameter :: offErrWarnMessage = .true. ! flag to turn IDA warnings off, default true + logical(lgt) :: detect_events ! flag to do event detection and restarting, default true + ! ----------------------------------------------------------------------------------------------------- + ! link to the necessary variables + associate(& + ! number of state variables of a specific type + nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg )%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow+soil domain + nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the snow+soil domain + ! model indices + ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy air space energy state variable + ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable + ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) + ixAqWat => indx_data%var(iLookINDEX%ixAqWat)%dat(1) ,& ! intent(in): [i4b] index of water storage in the aquifer + ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in): [i4b(:)] indices for energy states in the snow+soil subdomain + ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in): [i4b(:)] indices for hydrology states in the snow+soil subdomain + ixSnowOnlyNrg => indx_data%var(iLookINDEX%ixSnowOnlyNrg)%dat ,& ! intent(in): [i4b(:)] indices for energy states in the snow subdomain + ixSoilOnlyNrg => indx_data%var(iLookINDEX%ixSoilOnlyNrg)%dat ,& ! intent(in): [i4b(:)] indices for energy states in the soil subdomain + ixSoilOnlyHyd => indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat ,& ! intent(in): [i4b(:)] indices for hydrology states in the soil subdomain + layerType => indx_data%var(iLookINDEX%layerType)%dat & ! intent(in): [i4b(:)] named variables defining the type of layer in snow+soil domain + ) ! association to necessary variables for the residual computations + + ! initialize error control + err=0; message="summaSolve4ida/" + + ! choose Jacobian type + select case(model_decisions(iLookDECISIONS%fDerivMeth)%iDecision) + case(numerical); use_fdJac =.true. + case(analytical); use_fdJac =.false. + case default; err=20; message=trim(message)//'expect choice numericl or analytic to calculate derivatives for Jacobian'; return + end select + + nState = nStat ! total number of state variables in SUNDIALS type + idaSucceeds = .true. + + ! fill eqns_data which will be required later to call eval8summa4ida + eqns_data%dt = dt + eqns_data%nSnow = nSnow + eqns_data%nSoil = nSoil + eqns_data%nLayers = nLayers + eqns_data%nState = int(nState,i4b) + eqns_data%ixMatrix = ixMatrix + eqns_data%firstSubStep = firstSubStep + eqns_data%computeVegFlux = computeVegFlux + eqns_data%scalarSolution = scalarSolution + eqns_data%deriv_data = deriv_data + eqns_data%lookup_data = lookup_data + eqns_data%type_data = type_data + eqns_data%attr_data = attr_data + eqns_data%mpar_data = mpar_data + eqns_data%forc_data = forc_data + eqns_data%bvar_data = bvar_data + eqns_data%prog_data = prog_data + eqns_data%indx_data = indx_data + eqns_data%diag_data = diag_data + eqns_data%flux_data = flux_data + eqns_data%ixSaturation = ixSaturation + + ! allocate space and fill + allocate( eqns_data%model_decisions(maxvarDecisions) ); eqns_data%model_decisions = model_decisions + allocate( eqns_data%atol(int(nState,i4b)) ); eqns_data%atol = atol + allocate( eqns_data%rtol(int(nState,i4b)) ); eqns_data%rtol = rtol + allocate( eqns_data%sMul(int(nState,i4b)) ); eqns_data%sMul = sMul + allocate( eqns_data%dMat(int(nState,i4b)) ); eqns_data%dMat = dMat + + ! allocate space for the to save previous fluxes + call allocLocal(flux_meta(:),flux_prev,nSnow,nSoil,err,cmessage) + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif + + ! allocate space for other variables + if(model_decisions(iLookDECISIONS%groundwatr)%iDecision==qbaseTopmodel)then + allocate(eqns_data%dBaseflow_dMatric(nSoil,nSoil),stat=err) + else + allocate(eqns_data%dBaseflow_dMatric(0,0),stat=err) + end if + allocate( eqns_data%mLayerTempPrev(nLayers) ) + allocate( eqns_data%mLayerMatricHeadPrev(nSoil) ) + allocate( eqns_data%mLayerTempTrial(nLayers) ) + allocate( eqns_data%mLayerMatricHeadTrial(nSoil) ) + allocate( eqns_data%mLayerTempPrime(nLayers) ) + allocate( eqns_data%mLayerMatricHeadPrime(nSoil) ) + allocate( eqns_data%mLayerVolFracWatPrime(nLayers) ) + allocate( mLayerMatricHeadPrimePrev(nSoil) ) + allocate( dCompress_dPsiPrev(nSoil) ) + allocate( eqns_data%fluxVec(int(nState,i4b)) ) + allocate( eqns_data%resVec(int(nState,i4b)) ) + allocate( eqns_data%resSink(int(nState,i4b)) ) + allocate( resVecPrev(int(nState,i4b)) ) + + ! need the following values for the first substep + do iVar=1,size(flux_meta) ! loop through fluxes + flux_prev%var(iVar)%dat(:) = 0._rkind + end do + eqns_data%scalarCanopyTempPrev = prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1) + eqns_data%mLayerTempPrev(:) = prog_data%var(iLookPROG%mLayerTemp)%dat(:) + eqns_data%scalarCanopyTempTrial = prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1) + eqns_data%mLayerTempTrial(:) = prog_data%var(iLookPROG%mLayerTemp)%dat(:) + eqns_data%mLayerMatricHeadPrev(:) = prog_data%var(iLookPROG%mLayerMatricHead)%dat(:) + mLayerMatricHeadPrimePrev = 0._rkind + dCompress_dPsiPrev(:) = 0._rkind + resVecPrev(:) = 0._rkind + balance(:) = 0._rkind + + retval = FSUNContext_Create(SUN_COMM_NULL, sunctx) + + ! create serial vectors + sunvec_y => FN_VMake_Serial(nState, stateVec, sunctx) + if (.not. associated(sunvec_y)) then; err=20; message=trim(message)//'sunvec = NULL'; return; endif + sunvec_yp => FN_VMake_Serial(nState, stateVecPrime, sunctx) + if (.not. associated(sunvec_yp)) then; err=20; message=trim(message)//'sunvec = NULL'; return; endif + + ! initialize solution vectors + call setInitialCondition(nState, stateVecInit, sunvec_y, sunvec_yp) + + ! create memory + ida_mem = FIDACreate(sunctx) + if (.not. c_associated(ida_mem)) then; err=20; message=trim(message)//'ida_mem = NULL'; return; endif + + ! Attach user data to memory + retval = FIDASetUserData(ida_mem, c_loc(eqns_data)) + if (retval /= 0) then; err=20; message=trim(message)//'error in FIDASetUserData'; return; endif + + ! Set the function IDA will use to advance the state + t0 = 0._rkind + retval = FIDAInit(ida_mem, c_funloc(eval8summa4ida), t0, sunvec_y, sunvec_yp) + if (retval /= 0) then; err=20; message=trim(message)//'error in FIDAInit'; return; endif + + ! set tolerances + retval = FIDAWFtolerances(ida_mem, c_funloc(computWeight4ida)) + if (retval /= 0) then; err=20; message=trim(message)//'error in FIDAWFtolerances'; return; endif + + ! set event detection flag + if (mpar_data%var(iLookPARAM%idaDetectEvents)%dat(1) == 0._rkind) then + detect_events = .false. + else + detect_events = .true. + end if + + ! initialize rootfinding problem and allocate space, counting roots + if(detect_events)then + nRoot = 0 + if(ixVegNrg/=integerMissing) nRoot = nRoot+1 + if(nSnow>0)then + do i = 1,nSnow + if(ixSnowOnlyNrg(i)/=integerMissing) nRoot = nRoot+1 + enddo + endif + if(nSoil>0)then + do i = 1,nSoil + if(ixSoilOnlyHyd(i)/=integerMissing) nRoot = nRoot+1 + if(ixSoilOnlyNrg(i)/=integerMissing) nRoot = nRoot+1 + enddo + endif + allocate( rootsfound(nRoot) ) + allocate( rootdir(nRoot) ) + rootdir = 0 + retval = FIDARootInit(ida_mem, nRoot, c_funloc(layerDisCont4ida)) + if (retval /= 0) then; err=20; message=trim(message)//'error in FIDARootInit'; return; endif + else ! will not use, allocate at something + nRoot = 1 + allocate( rootsfound(nRoot) ) + allocate( rootdir(nRoot) ) + endif + + ! define the form of the matrix + select case(ixMatrix) + case(ixBandMatrix) + mu = ku; lu = kl; + ! Create banded SUNMatrix for use in linear solves + sunmat_A => FSUNBandMatrix(nState, mu, lu, sunctx) + if (.not. associated(sunmat_A)) then; err=20; message=trim(message)//'sunmat = NULL'; return; endif + + ! Create banded SUNLinearSolver object + sunlinsol_LS => FSUNLinSol_Band(sunvec_y, sunmat_A, sunctx) + if (.not. associated(sunlinsol_LS)) then; err=20; message=trim(message)//'sunlinsol = NULL'; return; endif + + case(ixFullMatrix) + ! Create dense SUNMatrix for use in linear solves + sunmat_A => FSUNDenseMatrix(nState, nState, sunctx) + if (.not. associated(sunmat_A)) then; err=20; message=trim(message)//'sunmat = NULL'; return; endif + + ! Create dense SUNLinearSolver object + sunlinsol_LS => FSUNLinSol_Dense(sunvec_y, sunmat_A, sunctx) + if (.not. associated(sunlinsol_LS)) then; err=20; message=trim(message)//'sunlinsol = NULL'; return; endif + + ! check + case default; err=20; message=trim(message)//'error in type of matrix'; return + + end select ! form of matrix + + ! Attach the matrix and linear solver + ! For the nonlinear solver, IDA uses a Newton SUNNonlinearSolver-- it is not necessary to create and attach it + retval = FIDASetLinearSolver(ida_mem, sunlinsol_LS, sunmat_A); + if (retval /= 0) then; err=20; message=trim(message)//'error in FIDASetLinearSolver'; return; endif + + ! Set the user-supplied Jacobian routine + if(.not.use_fdJac)then + retval = FIDASetJacFn(ida_mem, c_funloc(computJacob4ida)) + if (retval /= 0) then; err=20; message=trim(message)//'error in FIDASetJacFn'; return; endif + endif + + ! Enforce the solver to stop at end of the time step + retval = FIDASetStopTime(ida_mem, dt_cur) + if (retval /= 0) then; err=20; message=trim(message)//'error in FIDASetStopTime'; return; endif + + ! Set solver parameters at end of setup + call setSolverParams(dt_cur, eqns_data%mpar_data, ida_mem, retval) + if (retval /= 0) then; err=20; message=trim(message)//'error in setSolverParams'; return; endif + + ! Disable error messages and warnings + if(offErrWarnMessage) then + retval = FSUNLogger_SetErrorFilename(ida_mem, c_null_char) + retval = FSUNLogger_SetWarningFilename(ida_mem, c_null_char) + retval = FIDASetNoInactiveRootWarn(ida_mem) + endif + + !*********************** Main Solver * loop on one_step mode ***************************** + tinystep = .false. + tret(1) = t0 ! initial time + tretPrev = tret(1) + nSteps = 0 ! initialize number of time steps taken in solver + + do while(tret(1) < dt_cur) + ! call this at beginning of step to reduce root bouncing (only looking in one direction) + if(detect_events .and. .not.tinystep)then + call find_rootdir(eqns_data, rootdir) + retval = FIDASetRootDirection(ida_mem, rootdir) + if (retval /= 0) then; err=20; message=trim(message)//'error in FIDASetRootDirection'; return; endif + endif + + eqns_data%firstFluxCall = .false. ! already called for initial data window + eqns_data%firstSplitOper = .false. ! already called for initial data window + + ! call IDASolve, advance solver just one internal step + retvalr = FIDASolve(ida_mem, dt_cur, tret, sunvec_y, sunvec_yp, IDA_ONE_STEP) + ! early return if IDASolve failed + if( retvalr < 0 )then + idaSucceeds = .false. + if (eqns_data%err/=0)then; message=trim(message)//trim(eqns_data%message); return; endif ! fail from summa problem + call getErrMessage(retvalr,cmessage) ! fail from solver problem + message=trim(message)//trim(cmessage) + !if(retvalr==-1) err = -20 ! max iterations failure, exit and reduce the data window time in varSubStep + exit + end if + + tooMuchMelt = .false. + ! loop through non-missing energy state variables in the snow domain to see if need to merge + do concurrent (i=1:nSnow,ixSnowOnlyNrg(i)/=integerMissing) + if(model_decisions(iLookDECISIONS%nrgConserv)%iDecision.ne.closedForm)then !using enthalpy as state variable + if (stateVec(ixSnowOnlyNrg(i)) > 0._rkind) tooMuchMelt = .true. !need to merge + else + if (stateVec(ixSnowOnlyNrg(i)) > Tfreeze) tooMuchMelt = .true. !need to merge + endif + enddo + if(tooMuchMelt)exit + + ! get the last stepsize and difference from previous end time, not necessarily the same + retval = FIDAGetLastStep(ida_mem, dt_last) + dt_diff = tret(1) - tretPrev + nSteps = nSteps + 1 ! number of time steps taken in solver + + ! possible that vegetation water may go a bit negative because of discontinous canopy wetting derivatives, so check and correct + if(ixVegHyd/=integerMissing)then + if(stateVec(ixVegHyd) < 0._rkind .and. stateVec(ixVegHyd)>= -verySmaller*1.e3_rkind) stateVec(ixVegHyd) = 0._rkind ! set to zero + endif + + ! check the feasibility of the solution + feasible=.true. + call checkFeas(& + ! input + stateVec, & ! intent(in): model state vector (mixed units) + eqns_data%mpar_data, & ! intent(in): model parameters + eqns_data%prog_data, & ! intent(in): model prognostic variables for a local HRU + eqns_data%indx_data, & ! intent(in): indices defining model states and layers + model_decisions(iLookDECISIONS%nrgConserv)%iDecision.ne.closedForm, & ! intent(in): flag to indicate if we are using enthalpy as state variable + ! output: feasibility + feasible, & ! intent(inout): flag to denote the feasibility of the solution + ! output: error control + err,cmessage) ! intent(out): error control + + ! early return for non-feasible solutions, right now will just fail if goes infeasible + if(.not.feasible)then + idaSucceeds = .false. + message=trim(message)//trim(cmessage)//'non-feasible' ! err=0 is already set, could make this a warning and reduce the data window time in varSubStep + exit + end if + + ! sum of fluxes smoothed over the time step, average from instantaneous values + if (nSteps>1) then + dt_mult = dt_diff/2._rkind + else ! first step no averaging + dt_mult = dt_diff + end if + + do iVar=1,size(flux_meta) + flux_sum%var(iVar)%dat(:) = flux_sum%var(iVar)%dat(:) + ( eqns_data%flux_data%var(iVar)%dat(:) & + + flux_prev%var(iVar)%dat(:) ) * dt_mult + end do + mLayerCmpress_sum(:) = mLayerCmpress_sum(:) + ( eqns_data%deriv_data%var(iLookDERIV%dCompress_dPsi)%dat(:) * eqns_data%mLayerMatricHeadPrime(:) & + + dCompress_dPsiPrev(:) * mLayerMatricHeadPrimePrev(:) ) * dt_mult + + ! ---- + ! * compute energy balance, from residuals + ! formulation with prime variables would cancel to closedForm version, so does not matter which formulation is used + !------------------------ + if(computNrgBalance)then + + ! compute energy balance mean, resVec is the instantaneous residual vector from the solver + ! note, if needCm and/or updateCp are false in eval8summaWithPrime, then the energy balance is not accurate + if(ixCasNrg/=integerMissing) balance(ixCasNrg) = balance(ixCasNrg) + ( eqns_data%resVec(ixCasNrg) + resVecPrev(ixCasNrg) )*dt_mult/dt + if(ixVegNrg/=integerMissing) balance(ixVegNrg) = balance(ixVegNrg) + ( eqns_data%resVec(ixVegNrg) + resVecPrev(ixVegNrg) )*dt_mult/dt + if(nSnowSoilNrg>0)then + do concurrent (i=1:nLayers,ixSnowSoilNrg(i)/=integerMissing) + balance(ixSnowSoilNrg(i)) = balance(ixSnowSoilNrg(i)) + ( eqns_data%resVec(ixSnowSoilNrg(i)) + resVecPrev(ixSnowSoilNrg(i)) )*dt_mult/dt + enddo + endif + endif + + ! ---- + ! * compute mass balance, from residuals + !------------------------ + if(computMassBalance)then + + ! compute mass balance mean, resVec is the instantaneous residual vector from the solver + if(ixVegHyd/=integerMissing) balance(ixVegHyd) = balance(ixVegHyd) + ( eqns_data%resVec(ixVegHyd) + resVecPrev(ixVegHyd) )*dt_mult/dt + if(nSnowSoilHyd>0)then + do concurrent (i=1:nLayers,ixSnowSoilHyd(i)/=integerMissing) + balance(ixSnowSoilHyd(i)) = balance(ixSnowSoilHyd(i)) + ( eqns_data%resVec(ixSnowSoilHyd(i)) + resVecPrev(ixSnowSoilHyd(i)) )*dt_mult/dt + enddo + endif + if(ixAqWat/=integerMissing) balance(ixAqWat) = balance(ixAqWat) + ( eqns_data%resVec(ixAqWat) + resVecPrev(ixAqWat) )*dt_mult/dt + endif + + ! save required quantities for next step + eqns_data%scalarCanopyTempPrev = eqns_data%scalarCanopyTempTrial + eqns_data%mLayerTempPrev(:) = eqns_data%mLayerTempTrial(:) + eqns_data%mLayerMatricHeadPrev(:) = eqns_data%mLayerMatricHeadTrial(:) + mLayerMatricHeadPrimePrev(:) = eqns_data%mLayerMatricHeadPrime(:) + dCompress_dPsiPrev(:) = eqns_data%deriv_data%var(iLookDERIV%dCompress_dPsi)%dat(:) + tretPrev = tret(1) + resVecPrev(:) = eqns_data%resVec(:) + flux_prev = eqns_data%flux_data + + ! Restart for where vegetation and layers cross freezing point + if(detect_events)then + if (retvalr .eq. IDA_ROOT_RETURN) then ! IDASolve succeeded and found one or more roots at tret(1) + ! Reininitialize solver for running after discontinuity and restart + retval = FIDAReInit(ida_mem, tret(1), sunvec_y, sunvec_yp) + if (retval /= 0) then; err=20; message=trim(message)//'error in FIDAReInit'; return; endif + ! don't keep calling if step is small, or took many steps already (prevents root bouncing) + if(dt_last(1) < 1.e-6_rkind .or. abs(dt_diff) < 1.e-6_rkind & + .or. (mpar_data%var(iLookPARAM%idaMaxDataWindowSteps)%dat(1)<1.e10_rkind & + .and. nSteps>=mpar_data%var(iLookPARAM%idaMaxDataWindowSteps)%dat(1)))then ! treat 1e10 as no limit on steps + retval = FIDARootInit(ida_mem, 0, c_funloc(layerDisCont4ida)) + tinystep = .true. + else + retval = FIDARootInit(ida_mem, nRoot, c_funloc(layerDisCont4ida)) + tinystep = .false. + endif + if (retval /= 0) then; err=20; message=trim(message)//'error in FIDARootInit'; return; endif + endif + endif + enddo ! while loop on one_step mode until time dt_cur + !****************************** End of Main Solver *************************************** + + if(idaSucceeds)then + ! copy to output data + diag_data = eqns_data%diag_data + flux_data = eqns_data%flux_data + deriv_data = eqns_data%deriv_data + ixSaturation = eqns_data%ixSaturation + indx_data%var(iLookINDEX%numberFluxCalc)%dat(1) = eqns_data%indx_data%var(iLookINDEX%numberFluxCalc)%dat(1) !only number of flux calculations changes in indx_data + err = eqns_data%err + message = eqns_data%message + endif + + ! free memory + deallocate( eqns_data%model_decisions) + deallocate( eqns_data%sMul ) + deallocate( eqns_data%dMat ) + deallocate( eqns_data%dBaseflow_dMatric ) + deallocate( eqns_data%mLayerTempPrev ) + deallocate( eqns_data%mLayerMatricHeadPrev ) + deallocate( eqns_data%mLayerTempTrial ) + deallocate( eqns_data%mLayerMatricHeadTrial ) + deallocate( eqns_data%mLayerTempPrime ) + deallocate( eqns_data%mLayerMatricHeadPrime ) + deallocate( eqns_data%mLayerVolFracWatPrime ) + deallocate( mLayerMatricHeadPrimePrev ) + deallocate( dCompress_dPsiPrev ) + deallocate( eqns_data%resVec ) + deallocate( eqns_data%resSink ) + deallocate( rootsfound ) + deallocate( rootdir ) + + ! Get Stats from IDA + retval = FIDAGetIntegratorStats(ida_mem, nStepsSun, nREvals, nLinSetups, & + netFails, qLast, qCur, hInitUsed, hLast, & + hCur, tCur) + + diag_data%var(iLookDIAG%numSteps)%dat(1) = nStepsSun(1) + diag_data%var(iLookDIAG%numResEvals)%dat(1) = nREvals(1) + diag_data%var(iLookDIAG%numLinSolvSetups)%dat(1) = nLinSetups(1) + diag_data%var(iLookDIAG%numErrTestFails)%dat(1) = netFails(1) + diag_data%var(iLookDIAG%kLast)%dat(1) = qLast(1) + diag_data%var(iLookDIAG%kCur)%dat(1) = qCur(1) + diag_data%var(iLookDIAG%hInitUsed)%dat(1) = hInitUsed(1) + diag_data%var(iLookDIAG%hLast)%dat(1) = hLast(1) + diag_data%var(iLookDIAG%hCur)%dat(1) = hCur(1) + diag_data%var(iLookDIAG%tCur)%dat(1) = tCur(1) + + call FIDAFree(ida_mem) + retval = FSUNLinSolFree(sunlinsol_LS) + if(retval /= 0)then; err=20; message=trim(message)//'unable to free the linear solver'; return; endif + call FSUNMatDestroy(sunmat_A) + call FN_VDestroy(sunvec_y) + call FN_VDestroy(sunvec_yp) + retval = FSUNContext_Free(sunctx) + if(retval /= 0)then; err=20; message=trim(message)//'unable to free the SUNDIALS context'; return; endif + + end associate + +end subroutine summaSolve4ida + +! ---------------------------------------------------------------- +! SetInitialCondition: routine to initialize u and up vectors. +! ---------------------------------------------------------------- +subroutine setInitialCondition(neq, y, sunvec_u, sunvec_up) + + !======= Inclusions =========== + USE, intrinsic :: iso_c_binding + USE fsundials_core_mod + USE fnvector_serial_mod + + !======= Declarations ========= + implicit none + + ! calling variables + type(N_Vector) :: sunvec_u ! solution N_Vector + type(N_Vector) :: sunvec_up ! derivative N_Vector + integer(c_long) :: neq + real(rkind) :: y(neq) + + ! pointers to data in SUNDIALS vectors + real(c_double), pointer :: uu(:) + real(c_double), pointer :: up(:) + + ! get data arrays from SUNDIALS vectors + uu(1:neq) => FN_VGetArrayPointer(sunvec_u) + up(1:neq) => FN_VGetArrayPointer(sunvec_up) + + uu = y + up = 0._rkind + +end subroutine setInitialCondition + +! ---------------------------------------------------------------- +! setSolverParams: private routine to set parameters in IDA solver +! ---------------------------------------------------------------- +subroutine setSolverParams(dt_cur,mpar_data,ida_mem,retval) + + !======= Inclusions =========== + USE, intrinsic :: iso_c_binding + USE fida_mod ! Fortran interface to IDA + USE data_types,only:var_dlength + !======= Declarations ========= + implicit none + + ! calling variables + real(rkind),intent(in) :: dt_cur ! current whole time step + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(c_ptr),intent(inout) :: ida_mem ! IDA memory + integer(i4b),intent(out) :: retval ! return value + + !======= Internals ============ + integer,parameter :: nonlin_iter = 4 ! maximum number of nonlinear iterations before reducing step size, default = 4 + real(qp),parameter :: coef_nonlin = 0.33 ! coefficient in the nonlinear convergence test, default = 0.33 + integer,parameter :: fail_iter = 50 ! maximum number of error test and convergence test failures, default 10 + + associate(& + max_order => mpar_data%var(iLookPARAM%idaMaxOrder)%dat(1), & ! maximum BDF order + max_err_test_fail => mpar_data%var(iLookPARAM%idaMaxErrTestFail)%dat(1), & ! maximum number of error test failures + max_steps => mpar_data%var(iLookPARAM%idaMaxInternalSteps)%dat(1), & ! maximum number of steps + h_init => mpar_data%var(iLookPARAM%idaInitStepSize)%dat(1), & ! initial stepsize + h_min => mpar_data%var(iLookPARAM%idaMinStepSize)%dat(1) & ! minimum stepsize + ) + + ! Set the maximum BDF order + retval = FIDASetMaxOrd(ida_mem, int(max_order)) + if (retval /= 0) return + + ! Set coefficient in the nonlinear convergence test + retval = FIDASetNonlinConvCoef(ida_mem, coef_nonlin) + if (retval /= 0) return + + ! Set maximun number of nonliear iterations, maybe should just make 4 (instead of SUMMA parameter) + retval = FIDASetMaxNonlinIters(ida_mem, nonlin_iter) + if (retval /= 0) return + + ! Set maximum number of convergence test failures + retval = FIDASetMaxConvFails(ida_mem, fail_iter) + if (retval /= 0) return + + ! Set maximum number of error test failures + retval = FIDASetMaxErrTestFails(ida_mem, int(max_err_test_fail)) + if (retval /= 0) return + + ! Set maximum number of steps + retval = FIDASetMaxNumSteps(ida_mem, int(max_steps, kind=8)) + if (retval /= 0) return + + ! Set maximum stepsize + retval = FIDASetMaxStep(ida_mem, dt_cur) + if (retval /= 0) return + + ! Set initial stepsize + retval = FIDASetInitStep(ida_mem, h_init) + if (retval /= 0) return + + ! Set minimum stepsize + retval = FIDASetMinStep(ida_mem, h_min) + if (retval /= 0) return + end associate ! end association to variables in the data structure + +end subroutine setSolverParams + +! ---------------------------------------------------------------------------------------- +! find_rootdir: private routine to determine which direction to look for the root, by +! determining if the variable is greater or less than the root. Need to do this to prevent +! bouncing around solution +! Note: do not need to change if using enthalpy as state variable or not +! ---------------------------------------------------------------------------------------- +subroutine find_rootdir(eqns_data,rootdir) + + !======= Inclusions =========== + use, intrinsic :: iso_c_binding + use fsundials_core_mod + use fnvector_serial_mod + use soil_utils_module,only:crit_soilT ! compute the critical temperature below which ice exists + use globalData,only:integerMissing ! missing integer + use var_lookup,only:iLookINDEX ! named variables for structure elements + use multiconst,only:Tfreeze ! freezing point of pure water (K) + + !======= Declarations ========= + implicit none + + ! calling variables + type(data4ida),intent(in) :: eqns_data ! equations data + integer(i4b),intent(inout) :: rootdir(:) ! root function directions to search + + ! local variables + integer(i4b) :: i,ind ! indices + integer(i4b) :: nState ! number of states + integer(i4b) :: nSnow ! number of snow layers + integer(i4b) :: nSoil ! number of soil layers + real(rkind) :: xPsi ! matric head at layer (m) + real(rkind) :: TcSoil ! critical point when soil begins to freeze (K) + + ! get equations data variables + nState = eqns_data%nState + nSnow = eqns_data%nSnow + nSoil = eqns_data%nSoil + + ! initialize + ind = 0 + + ! identify the critical point when vegetation begins to freeze + if(eqns_data%indx_data%var(iLookINDEX%ixVegNrg)%dat(1)/=integerMissing)then + ind = ind+1 + rootdir(ind) = 1 + if(eqns_data%scalarCanopyTempPrev > Tfreeze) rootdir(ind) = -1 + endif + + if(nSnow>0)then + do i = 1,nSnow + ! identify the critical point when the snow layer begins to freeze + if(eqns_data%indx_data%var(iLookINDEX%ixSnowOnlyNrg)%dat(i)/=integerMissing)then + ind = ind+1 + rootdir(ind) = 1 + if(eqns_data%mLayerTempPrev(i) > Tfreeze) rootdir(ind) = -1 + endif + end do + endif + + if(nSoil>0)then + do i = 1,nSoil + xPsi = eqns_data%mLayerMatricHeadPrev(i) + ! identify the critical point when soil matrix potential goes below 0 and Tfreeze depends only on temp + if (eqns_data%indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat(i)/=integerMissing)then + ind = ind+1 + rootdir(ind) = 1 + if(xPsi > 0._rkind ) rootdir(ind) = -1 + endif + ! identify the critical point when the soil layer begins to freeze + if(eqns_data%indx_data%var(iLookINDEX%ixSoilOnlyNrg)%dat(i)/=integerMissing)then + ind = ind+1 + TcSoil = crit_soilT(xPsi) + rootdir(ind) = 1 + if(eqns_data%mLayerTempPrev(i+nSnow) > TcSoil) rootdir(ind) = -1 + endif + end do + endif + +end subroutine find_rootdir + +! ---------------------------------------------------------------------------------------- +! layerDisCont4ida: The root function routine to find soil matrix potential = 0, +! soil temp = critical frozen point, and snow and veg temp = Tfreeze +! ---------------------------------------------------------------------------------------- +! Return values: +! 0 = success, +! 1 = recoverable error, +! -1 = non-recoverable error +! ---------------------------------------------------------------------------------------- +integer(c_int) function layerDisCont4ida(t, sunvec_u, sunvec_up, gout, user_data) & + result(ierr) bind(C,name='layerDisCont4ida') + + !======= Inclusions =========== + use, intrinsic :: iso_c_binding + use fsundials_core_mod + use fnvector_serial_mod + use soil_utils_module,only:crit_soilT ! compute the critical temperature below which ice exists + use globalData,only:integerMissing ! missing integer + use var_lookup,only:iLookINDEX ! named variables for structure elements + use multiconst,only:Tfreeze ! freezing point of pure water (K) + + !======= Declarations ========= + implicit none + + ! calling variables + real(c_double), value :: t ! current time + type(N_Vector) :: sunvec_u ! solution N_Vector + type(N_Vector) :: sunvec_up ! derivative N_Vector + real(c_double) :: gout(999) ! root function values, if (nVeg + nSnow + 2*nSoil)>999, problem + type(c_ptr), value :: user_data ! user-defined data + + ! local variables + integer(i4b) :: i,ind ! indices + integer(i4b) :: nState ! number of states + integer(i4b) :: nSnow ! number of snow layers + integer(i4b) :: nSoil ! number of soil layers + logical(lgt) :: enthalpyStateVec ! flag to indicate if we are using enthalpy as state variable + real(rkind) :: xPsi ! matric head at layer (m) + real(rkind) :: TcSoil ! critical point when soil begins to freeze (K) + + ! pointers to data in SUNDIALS vectors + real(c_double), pointer :: uu(:) + type(data4ida), pointer :: eqns_data ! equations data + + !======= Internals ============ + ! get equations data from user-defined data + call c_f_pointer(user_data, eqns_data) + nState = eqns_data%nState + nSnow = eqns_data%nSnow + nSoil = eqns_data%nSoil + enthalpyStateVec = eqns_data%model_decisions(iLookDECISIONS%nrgConserv)%iDecision.ne.closedForm + + + ! get data array from SUNDIALS vector + uu(1:nState) => FN_VGetArrayPointer(sunvec_u) + + ! initialize + ind = 0 + + ! identify the critical point when vegetation begins to freeze + if(eqns_data%indx_data%var(iLookINDEX%ixVegNrg)%dat(1)/=integerMissing)then + ind = ind+1 + if(enthalpyStateVec)then + gout(ind) = uu(eqns_data%indx_data%var(iLookINDEX%ixVegNrg)%dat(1)) + else + gout(ind) = uu(eqns_data%indx_data%var(iLookINDEX%ixVegNrg)%dat(1)) - Tfreeze + end if + endif + + if(nSnow>0)then + do i = 1,nSnow + ! identify the critical point when the snow layer begins to freeze + if(eqns_data%indx_data%var(iLookINDEX%ixSnowOnlyNrg)%dat(i)/=integerMissing)then + ind = ind+1 + if(enthalpyStateVec)then + gout(ind) = uu(eqns_data%indx_data%var(iLookINDEX%ixSnowOnlyNrg)%dat(i)) + else + gout(ind) = uu(eqns_data%indx_data%var(iLookINDEX%ixSnowOnlyNrg)%dat(i)) - Tfreeze + end if + endif + end do + endif + + if(nSoil>0)then + do i = 1,nSoil + ! identify the critical point when soil matrix potential goes below 0 and Tfreeze depends only on temp + if (eqns_data%indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat(i)/=integerMissing)then + ind = ind+1 + xPsi = uu(eqns_data%indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat(i)) + gout(ind) = uu(eqns_data%indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat(i)) + else + xPsi = eqns_data%prog_data%var(iLookPROG%mLayerMatricHead)%dat(i) + endif + ! identify the critical point when the soil layer begins to freeze + if(eqns_data%indx_data%var(iLookINDEX%ixSoilOnlyNrg)%dat(i)/=integerMissing)then + ind = ind+1 + if(enthalpyStateVec)then + gout(ind) = uu(eqns_data%indx_data%var(iLookINDEX%ixSoilOnlyNrg)%dat(i)) + else + TcSoil = crit_soilT(xPsi) + gout(ind) = uu(eqns_data%indx_data%var(iLookINDEX%ixSoilOnlyNrg)%dat(i)) - TcSoil + end if + endif + end do + endif + + ! return success + ierr = 0 + return + +end function layerDisCont4ida + +! ---------------------------------------------------------------- +! getErrMessage: private routine to get error message for IDA solver +! ---------------------------------------------------------------- +subroutine getErrMessage(retval,message) + + !======= Declarations ========= + implicit none + + ! calling variables + integer(i4b),intent(in) :: retval ! return value from IDA + character(*),intent(out) :: message ! error message + + ! get message + if( retval==-1 ) message = 'IDA_TOO_MUCH_WORK' ! The solver took mxstep internal steps but could not reach tout. + if( retval==-2 ) message = 'IDA_TOO_MUCH_ACC' ! The solver could not satisfy the accuracy demanded by the user for some internal step. + if( retval==-3 ) message = 'IDA_ERR_FAIL' ! Error test failures occurred too many times during one internal timestep or minimum step size was reached. + if( retval==-4 ) message = 'IDA_CONV_FAIL' ! Convergence test failures occurred too many times during one internal time step or minimum step size was reached. + if( retval==-5 ) message = 'IDA_LINIT_FAIL' ! The linear solver’s initialization function failed. + if( retval==-6 ) message = 'IDA_LSETUP_FAIL' ! The linear solver’s setup function failed in an unrecoverable manner. + if( retval==-7 ) message = 'IDA_LSOLVE_FAIL' ! The linear solver’s solve function failed in an unrecoverable manner. + if( retval==-8 ) message = 'IDA_RES_FAIL' ! The user-provided residual function failed in an unrecoverable manner. + if( retval==-9 ) message = 'IDA_REP_RES_FAIL' ! The user-provided residual function repeatedly returned a recoverable error flag, but the solver was unable to recover. + if( retval==-10) message = 'IDA_RTFUNC_FAIL' ! The rootfinding function failed in an unrecoverable manner. + if( retval==-11) message = 'IDA_CONSTR_FAIL' ! The inequality constraints were violated and the solver was unable to recover. + if( retval==-12) message = 'IDA_FIRST_RES_FAIL' ! The user-provided residual function failed recoverably on the first call. + if( retval==-13) message = 'IDA_LINESEARCH_FAIL' ! The line search failed. + if( retval==-14) message = 'IDA_NO_RECOVERY' ! The residual function, linear solver setup function, or linear solver solve function had a recoverable failure, but IDACalcIC could not recover. + if( retval==-15) message = 'IDA_NLS_INIT_FAIL' ! The nonlinear solver’s init routine failed. + if( retval==-16) message = 'IDA_NLS_SETUP_FAIL' ! The nonlinear solver’s setup routine failed. + if( retval==-20) message = 'IDA_MEM_NULL' ! The ida_mem argument was NULL. + if( retval==-21) message = 'IDA_MEM_FAIL' ! A memory allocation failed. + if( retval==-22) message = 'IDA_ILL_INPUT' ! One of the function inputs is illegal. + if( retval==-23) message = 'IDA_NO_MALLOC' ! The IDA memory was not allocated by a call to IDAInit. + if( retval==-24) message = 'IDA_BAD_EWT' ! Zero value of some error weight component. + if( retval==-25) message = 'IDA_BAD_K' ! The k-th derivative is not available. + if( retval==-26) message = 'IDA_BAD_T' ! The time t is outside the last step taken. + if( retval==-27) message = 'IDA_BAD_DKY' ! The vector argument where derivative should be stored is NULL. + +end subroutine getErrMessage + + +end module summaSolve4ida_module diff --git a/build/source/engine/summaSolve4kinsol.f90 b/build/source/engine/summaSolve4kinsol.f90 new file mode 100644 index 000000000..0e694876f --- /dev/null +++ b/build/source/engine/summaSolve4kinsol.f90 @@ -0,0 +1,533 @@ +! SUMMA - Structure for Unifying Multiple Modeling Alternatives +! Copyright (C) 2014-2020 NCAR/RAL; University of Saskatchewan; University of Washington +! +! This file is part of SUMMA +! +! For more information see: http://www.ral.ucar.edu/projects/summa +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see . + +module summaSolve4kinsol_module + + !======= Inclusions =========== +USE, intrinsic :: iso_c_binding +USE nrtype +USE type4kinsol + +! access missing values +USE globalData,only:integerMissing ! missing integer +USE globalData,only:realMissing ! missing real number + +! access matrix information +USE globalData,only: ixFullMatrix ! named variable for the full Jacobian matrix +USE globalData,only: ixBandMatrix ! named variable for the band diagonal matrix +USE globalData,only: ku ! number of super-diagonal bands +USE globalData,only: kl ! number of sub-diagonal bands + +! global metadata +USE globalData,only:flux_meta ! metadata on the model fluxes + +! constants +USE multiconst,only: Tfreeze ! temperature at freezing (K) + +! provide access to indices that define elements of the data structures +USE var_lookup,only:iLookPROG ! named variables for structure elements +USE var_lookup,only:iLookDIAG ! named variables for structure elements +USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure +USE var_lookup,only:iLookDERIV ! named variables for structure elements +USE var_lookup,only:iLookFLUX ! named variables for structure elements +USE var_lookup,only:iLookPARAM ! named variables for structure elements +USE var_lookup,only:iLookINDEX ! named variables for structure elements + +! provide access to the derived types to define the data structures +USE data_types,only:& + var_i, & ! data vector (i4b) + var_d, & ! data vector (rkind) + var_ilength, & ! data vector with variable length dimension (i4b) + var_dlength, & ! data vector with variable length dimension (rkind) + zLookup, & ! lookup tables + model_options ! defines the model decisions + +! look-up values for the choice of groundwater parameterization +USE mDecisions_module,only: & + qbaseTopmodel, & ! TOPMODEL-ish baseflow parameterization + bigBucket, & ! a big bucket (lumped aquifer model) + noExplicit ! no explicit groundwater parameterization + +! look-up values for method used to compute derivative +USE mDecisions_module,only: & + numerical, & ! numerical solution + analytical ! analytical solution + +! privacy + implicit none + private::setInitialCondition + private::setSolverParams + private::getErrMessage + public::summaSolve4kinsol + +contains + + +! *************************************************************************************** +! * public subroutine summaSolve4kinsol: solve F(y) = 0 by KINSOL (y is the state vector) +! *************************************************************************************** +subroutine summaSolve4kinsol(& + dt_cur, & ! intent(in): current stepsize + dt, & ! intent(in): data time step + fScale, & ! intent(in): characteristic scale of the function evaluations (mixed units) + xScale, & ! intent(in): characteristic scale of the state vector (mixed units) + nSnow, & ! intent(in): number of snow layers + nSoil, & ! intent(in): number of soil layers + nLayers, & ! intent(in): total number of layers + nStat, & ! intent(in): total number of state variables + ixMatrix, & ! intent(in): type of matrix (dense or banded) + firstSubStep, & ! intent(in): flag to indicate if we are processing the first sub-step + computeVegFlux, & ! intent(in): flag to indicate if we need to compute fluxes over vegetation + scalarSolution, & ! intent(in): flag to indicate the scalar solution + ! input: state vectors + stateVecInit, & ! intent(in): initial state vector + sMul, & ! intent(inout): state vector multiplier (used in the residual calculations) + dMat, & ! intent(inout): diagonal of the Jacobian matrix (excludes fluxes) + ! input: data structures + model_decisions, & ! intent(in): model decisions + lookup_data, & ! intent(in): lookup tables + type_data, & ! intent(in): type of vegetation and soil + attr_data, & ! intent(in): spatial attributes + mpar_data, & ! intent(in): model parameters + forc_data, & ! intent(in): model forcing data + bvar_data, & ! intent(in): average model variables for the entire basin + prog_data, & ! intent(in): model prognostic variables for a local HRU + ! input-output: data structures + indx_data, & ! intent(inout): index data + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + flux_data, & ! intent(inout): model fluxes for a local HRU + deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables + ! output + ixSaturation, & ! intent(inout) index of the lowest saturated layer (NOTE: only computed on the first iteration) + kinsolSucceeds, & ! intent(out): flag to indicate if KINSOL successfully solved the problem in current data step + stateVec, & ! intent(inout): model state vector + fluxVec, & ! intent(out): model flux vector + resSink, & ! intent(out): additional (sink) terms on the RHS of the state equation + resVec, & ! intent(out): residual vector + err,message) ! intent(out): error control + + !======= Inclusions =========== + + USE fkinsol_mod ! Fortran interface to KINSOL + USE fsundials_core_mod ! Fortran interface to SUNContext + USE fnvector_serial_mod ! Fortran interface to serial N_Vector + USE fsunmatrix_dense_mod ! Fortran interface to dense SUNMatrix + USE fsunmatrix_band_mod ! Fortran interface to banded SUNMatrix + USE fsunlinsol_dense_mod ! Fortran interface to dense SUNLinearSolver + USE fsunlinsol_band_mod ! Fortran interface to banded SUNLinearSolver + USE allocspace_module,only:allocLocal ! allocate local data structures + USE getVectorz_module,only:checkFeas ! check feasibility of state vector + USE eval8summa_module,only:eval8summa4kinsol ! DAE/ODE functions + USE eval8summa_module,only:eval8summa ! residual of DAE + USE computJacob_module,only:computJacob4kinsol ! system Jacobian + USE var_lookup,only:maxvarDecisions ! maximum number of decisions + + !======= Declarations ========= + implicit none + + ! -------------------------------------------------------------------------------------------------------------------------------- + ! calling variables + ! -------------------------------------------------------------------------------------------------------------------------------- + ! input: model control + real(rkind),intent(in) :: dt_cur ! current stepsize + real(rkind),intent(in) :: dt ! data time step + real(rkind),intent(inout) :: fScale(:) ! characteristic scale of the function evaluations (mixed units) + real(rkind),intent(inout) :: xScale(:) ! characteristic scale of the state vector (mixed units) + integer(i4b),intent(in) :: nSnow ! number of snow layers + integer(i4b),intent(in) :: nSoil ! number of soil layers + integer(i4b),intent(in) :: nLayers ! total number of layers + integer(i4b),intent(in) :: nStat ! total number of state variables + integer(i4b),intent(in) :: ixMatrix ! form of matrix (dense or banded) + logical(lgt),intent(in) :: firstSubStep ! flag to indicate if we are processing the first sub-step + logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation + logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution + ! input: state vectors + real(rkind),intent(in) :: stateVecInit(:) ! model state vector + real(qp),intent(in) :: sMul(:) ! state vector multiplier (used in the residual calculations) + real(rkind), intent(inout) :: dMat(:) ! diagonal of the Jacobian matrix (excludes fluxes) + ! input: data structures + type(model_options),intent(in) :: model_decisions(:) ! model decisions + type(zLookup), intent(in) :: lookup_data ! lookup tables + type(var_i), intent(in) :: type_data ! type of vegetation and soil + type(var_d), intent(in) :: attr_data ! spatial attributes + type(var_dlength), intent(in) :: mpar_data ! model parameters + type(var_d), intent(in) :: forc_data ! model forcing data + type(var_dlength), intent(in) :: bvar_data ! model variables for the local basin + type(var_dlength), intent(in) :: prog_data ! prognostic variables for a local HRU + ! input-output: data structures + type(var_ilength),intent(inout) :: indx_data ! indices defining model states and layers + type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + ! output: state vectors + integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer + real(rkind),intent(inout) :: stateVec(:) ! model state vector (y) + real(rkind),intent(out) :: fluxVec(:) ! model flux vector (f) + real(rkind),intent(out) :: resSink(:) ! sink terms on the RHS of the flux equation + real(qp),intent(out) :: resVec(:) ! residual vector + logical(lgt),intent(out) :: kinsolSucceeds ! flag to indicate if KINSOL is successful + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + + ! -------------------------------------------------------------------------------------------------------------------------------- + ! local variables + ! -------------------------------------------------------------------------------------------------------------------------------- + type(N_Vector), pointer :: sunvec_y ! sundials solution vector + type(SUNMatrix), pointer :: sunmat_A ! sundials matrix + type(N_Vector), pointer :: sunvec_fscale ! vector containing diagonal elements of function scaling matrix + type(N_Vector), pointer :: sunvec_xscale ! vector containing diagonal elements of state scaling matrix + type(SUNLinearSolver), pointer :: sunlinsol_LS ! sundials linear solver + type(c_ptr) :: kinsol_mem ! KINSOL memory + type(c_ptr) :: sunctx ! SUNDIALS simulation context + type(data4kinsol), target :: eqns_data ! KINSOL type + integer(i4b) :: retval, retvalr ! return value + logical(lgt) :: feasible ! feasibility flag + integer(c_long) :: mu, lu ! in banded matrix mode in SUNDIALS type + integer(c_long) :: nState ! total number of state variables in SUNDIALS type + character(LEN=256) :: cmessage ! error message of downwind routine + logical(lgt) :: use_fdJac ! flag to use finite difference Jacobian, controlled by decision fDerivMeth + logical(lgt),parameter :: offErrWarnMessage = .true. ! flag to turn IDA warnings off, default true + ! ----------------------------------------------------------------------------------------------------- + + ! initialize error control + err=0; message="summaSolve4kinsol/" + + ! choose Jacobian type + select case(model_decisions(iLookDECISIONS%fDerivMeth)%iDecision) + case(numerical); use_fdJac =.true. + case(analytical); use_fdJac =.false. + case default; err=20; message=trim(message)//'expect choice numericl or analytic to calculate derivatives for Jacobian'; return + end select + + nState = nStat ! total number of state variables in SUNDIALS type + kinsolSucceeds = .true. + + ! fill eqns_data which will be required later to call eval8summa + eqns_data%dt_cur = dt_cur + eqns_data%dt = dt + eqns_data%nSnow = nSnow + eqns_data%nSoil = nSoil + eqns_data%nLayers = nLayers + eqns_data%nState = int(nState,i4b) + eqns_data%ixMatrix = ixMatrix + eqns_data%firstFluxCall = .false. ! already called for initial + eqns_data%firstSplitOper = .false. ! already called for initial and false inside solver + eqns_data%firstSubStep = firstSubStep + eqns_data%computeVegFlux = computeVegFlux + eqns_data%scalarSolution = scalarSolution + eqns_data%deriv_data = deriv_data + eqns_data%lookup_data = lookup_data + eqns_data%type_data = type_data + eqns_data%attr_data = attr_data + eqns_data%mpar_data = mpar_data + eqns_data%forc_data = forc_data + eqns_data%bvar_data = bvar_data + eqns_data%prog_data = prog_data + eqns_data%indx_data = indx_data + eqns_data%diag_data = diag_data + eqns_data%flux_data = flux_data + eqns_data%ixSaturation = ixSaturation + eqns_data%firstStateIteration = .true. + + ! allocate space and fill + allocate( eqns_data%model_decisions(maxvarDecisions) ); eqns_data%model_decisions = model_decisions + allocate( eqns_data%fScale(int(nState,i4b)) ); eqns_data%fScale = fScale + allocate( eqns_data%xScale(int(nState,i4b)) ); eqns_data%xScale = xScale + allocate( eqns_data%sMul(int(nState,i4b)) ); eqns_data%sMul = sMul + allocate( eqns_data%dMat(int(nState,i4b)) ); eqns_data%dMat = dMat + allocate( eqns_data%stateVecPrev(int(nState,i4b)) ); eqns_data%stateVecPrev = stateVecInit + + ! allocate space for other variables + if(model_decisions(iLookDECISIONS%groundwatr)%iDecision==qbaseTopmodel)then + allocate(eqns_data%dBaseflow_dMatric(nSoil,nSoil),stat=err) + else + allocate(eqns_data%dBaseflow_dMatric(0,0),stat=err) + end if + allocate( eqns_data%fluxVec(int(nState,i4b)) ) + allocate( eqns_data%resVec(int(nState,i4b)) ) + allocate( eqns_data%resSink(int(nState,i4b)) ) + + retval = FSUNContext_Create(SUN_COMM_NULL, sunctx) + + ! create serial vectors + sunvec_y => FN_VMake_Serial(nState, stateVec, sunctx) + if (.not. associated(sunvec_y)) then; err=20; message=trim(message)//'sunvec = NULL'; return; endif + + ! create the scaling vectors + sunvec_fscale => FN_VMake_Serial(nState, fscale, sunctx) + if (.not. associated(sunvec_fscale)) then; err=20; message=trim(message)//'sunvec = NULL'; return; endif + sunvec_xscale => FN_VMake_Serial(nState, xscale, sunctx) + if (.not. associated(sunvec_xscale)) then; err=20; message=trim(message)//'sunvec = NULL'; return; endif + + ! initialize solution vectors + call setInitialCondition(nState, stateVecInit, sunvec_y) + + ! create memory + kinsol_mem = FKINCreate(sunctx) + if (.not. c_associated(kinsol_mem)) then; err=20; message=trim(message)//'kinsol_mem = NULL'; return; endif + + ! Attach user data to memory + retval = FKINSetUserData(kinsol_mem, c_loc(eqns_data)) + if (retval /= 0) then; err=20; message=trim(message)//'error in FKINSetUserData'; return; endif + + ! Set solver parameters before calling FKINInit + call setSolverParams(nint(mpar_data%var(iLookPARAM%maxiter)%dat(1)), kinsol_mem, retval) + if (retval /= 0) then; err=20; message=trim(message)//'error in setSolverParams'; return; endif + + ! Set the function Kinsol will use to advance the state + retval = FKINInit(kinsol_mem, c_funloc(eval8summa4kinsol), sunvec_y) + if (retval /= 0) then; err=20; message=trim(message)//'error in FKINInit'; return; endif + + ! define the form of the matrix + select case(ixMatrix) + case(ixBandMatrix) + mu = ku; lu = kl; + ! Create banded SUNMatrix for use in linear solves + sunmat_A => FSUNBandMatrix(nState, mu, lu, sunctx) + if (.not. associated(sunmat_A)) then; err=20; message=trim(message)//'sunmat = NULL'; return; endif + + ! Create banded SUNLinearSolver object + sunlinsol_LS => FSUNLinSol_Band(sunvec_y, sunmat_A, sunctx) + if (.not. associated(sunlinsol_LS)) then; err=20; message=trim(message)//'sunlinsol = NULL'; return; endif + + case(ixFullMatrix) + ! Create dense SUNMatrix for use in linear solves + sunmat_A => FSUNDenseMatrix(nState, nState, sunctx) + if (.not. associated(sunmat_A)) then; err=20; message=trim(message)//'sunmat = NULL'; return; endif + + ! Create dense SUNLinearSolver object + sunlinsol_LS => FSUNLinSol_Dense(sunvec_y, sunmat_A, sunctx) + if (.not. associated(sunlinsol_LS)) then; err=20; message=trim(message)//'sunlinsol = NULL'; return; endif + + ! check + case default; err=20; message=trim(message)//'error in type of matrix'; return + + end select ! form of matrix + + ! Attach the matrix and linear solver + retval = FKINSetLinearSolver(kinsol_mem, sunlinsol_LS, sunmat_A); + if (retval /= 0) then; err=20; message=trim(message)//'error in FKINSetLinearSolver'; return; endif + + ! Set the user-supplied Jacobian routine + if(.not.use_fdJac)then + retval = FKINSetJacFn(kinsol_mem, c_funloc(computJacob4kinsol)) + if (retval /= 0) then; err=20; message=trim(message)//'error in FKINSetJacFn'; return; endif + endif + + ! Disable error messages and warnings + if(offErrWarnMessage) then + retval = FSUNLogger_SetErrorFilename(kinsol_mem, c_null_char) + retval = FSUNLogger_SetWarningFilename(kinsol_mem, c_null_char) + endif + + !****************************** Main Solver ********************************************** + ! Call KINSol to solve problem with choice of solver, linesearch or Picard + !retvalr = FKINSol(kinsol_mem, sunvec_y, KIN_LINESEARCH, sunvec_xscale, sunvec_fscale) + retvalr = FKINSol(kinsol_mem, sunvec_y, KIN_PICARD, sunvec_xscale, sunvec_fscale) + + ! check if KINSol failed + if( retvalr < 0 )then + kinsolSucceeds = .false. + if (eqns_data%err/=0)then; message=trim(message)//trim(eqns_data%message); return; endif !fail from summa problem + call getErrMessage(retvalr,cmessage) ! fail from solver problem + message=trim(message)//trim(cmessage) + if(retvalr==-6) err = -20 ! max iterations failure, exit and reduce the data window time in varSubStep + else + ! check the feasibility of the solution, imposeConstraints should keep it from going infeasible + feasible=.true. + call checkFeas(& + ! input + stateVec, & ! intent(in): model state vector (mixed units) + eqns_data%mpar_data, & ! intent(in): model parameters + eqns_data%prog_data, & ! intent(in): model prognostic variables for a local HRU + eqns_data%indx_data, & ! intent(in): indices defining model states and layers + .false., & ! intent(in): currently never using enthalpy as state vector in BE + ! output: feasibility + feasible, & ! intent(inout): flag to denote the feasibility of the solution + ! output: error control + err,cmessage) ! intent(out): error control + + if(.not. feasible)then + kinsolSucceeds = .false. + message=trim(message)//trim(cmessage)//'non-feasible' ! err=0 is already set, could make this a warning and reduce the data window time in varSubStep + endif + endif + !****************************** End of Main Solver *************************************** + + if(kinsolSucceeds)then + ! copy to output data + diag_data = eqns_data%diag_data + flux_data = eqns_data%flux_data + fluxVec = eqns_data%fluxVec + resVec = eqns_data%resVec + resSink = eqns_data%resSink + deriv_data = eqns_data%deriv_data + ixSaturation = eqns_data%ixSaturation + indx_data%var(iLookINDEX%numberFluxCalc)%dat(1) = eqns_data%indx_data%var(iLookINDEX%numberFluxCalc)%dat(1) !only number of flux calculations changes in indx_data + err = eqns_data%err + message = eqns_data%message + else + eqns_data%fluxVec(:) = realMissing + endif + + ! free memory + deallocate( eqns_data%model_decisions) + deallocate( eqns_data%fScale ) + deallocate( eqns_data%xScale ) + deallocate( eqns_data%sMul ) + deallocate( eqns_data%dMat ) + deallocate( eqns_data%stateVecPrev ) + deallocate( eqns_data%dBaseflow_dMatric ) + deallocate( eqns_data%fluxVec ) + deallocate( eqns_data%resVec ) + deallocate( eqns_data%resSink ) + + call FKINFree(kinsol_mem) + retval = FSUNLinSolFree(sunlinsol_LS) + if(retval /= 0)then; err=20; message=trim(message)//'unable to free the linear solver'; return; endif + call FSUNMatDestroy(sunmat_A) + call FN_VDestroy(sunvec_y) + call FN_VDestroy(sunvec_xscale) + call FN_VDestroy(sunvec_fscale) + retval = FSUNContext_Free(sunctx) + if(retval /= 0)then; err=20; message=trim(message)//'unable to free the SUNDIALS context'; return; endif + +end subroutine summaSolve4kinsol + +! ---------------------------------------------------------------- +! SetInitialCondition: routine to initialize u vector. +! ---------------------------------------------------------------- +subroutine setInitialCondition(neq, y, sunvec_u) + + !======= Inclusions =========== + USE, intrinsic :: iso_c_binding + USE fsundials_core_mod + USE fnvector_serial_mod + + !======= Declarations ========= + implicit none + + ! calling variables + type(N_Vector) :: sunvec_u ! solution N_Vector + integer(c_long) :: neq + real(rkind) :: y(neq) + + ! pointers to data in SUNDIALS vectors + real(c_double), pointer :: uu(:) + + ! get data arrays from SUNDIALS vectors + uu(1:neq) => FN_VGetArrayPointer(sunvec_u) + + uu = y + +end subroutine setInitialCondition + +! ------------------------------------------------------------------- +! setSolverParams: private routine to set parameters in KINSOL solver +! ------------------------------------------------------------------- +subroutine setSolverParams(nonlin_iter,kinsol_mem,retval) + + !======= Inclusions =========== + USE, intrinsic :: iso_c_binding + USE fkinsol_mod ! Fortran interface to KINSOL + + !======= Declarations ========= + implicit none + + ! calling variables + integer,intent(in) :: nonlin_iter ! maximum number of nonlinear iterations, default = 200, set in parameters + type(c_ptr),intent(inout) :: kinsol_mem ! KINSOL memory + integer(i4b),intent(out) :: retval ! return value + + !======= Internals ============ + integer(c_long) :: nonlin_itr ! maximum number of nonlinear iterations in SUNDIALS type + integer(c_long),parameter :: mset = 1 ! maximum number of times the solver is called without Jacobian update, pass 0 to give default of 10 times + integer(c_long),parameter :: msubset = 1 ! maximum number of nonlinear iterations between checks by the residual monitoring algorithm, default=5 + integer(c_long),parameter :: maa = 0 ! maximum number of prior residuals to use acceleration, default = 0 + integer(c_long),parameter :: beta_fail = 10 ! maximum number of beta condition failures, default = 10 + real(qp),parameter :: fnormtol = 0.0 ! stopping tolerance on the scaled maximum norm of the system function, pass 0 to give default of unit_roundoff**(1/3) + real(qp),parameter :: scsteptol = 0.0 ! stopping tolerance on the minimum scaled step length, pass 0 to give default of unit_roundoff**(2/3) + + ! Set maximum number of times the linear solver is called without a Jacobian update + retval = FKINSetMaxSetupCalls(kinsol_mem, mset) + if (retval /= 0) return + + ! Every msubset iterations, test if a Jacobian evaluation is necessary + retval = FKINSetMaxSubSetupCalls(kinsol_mem, msubset) + if (retval /= 0) return + + ! Set maximum number of iterations + nonlin_itr = nonlin_iter ! maximum number of nonlinear iterations in SUNDIALS type, maybe should just make 200 (instead of SUMMA parameter) + retval = FKINSetNumMaxIters(kinsol_mem, nonlin_itr) + if (retval /= 0) return + + ! Set maximum number of prior residuals to use for Anderson acceleration + ! ONLY in conjunction with Picard or fixed-point iteration + retval = FKINSetMAA(kinsol_mem, maa); + if (retval /= 0) return + + ! Set maximum number of beta condition failures in the linesearch + retval = FKINSetMaxBetaFails(kinsol_mem, beta_fail) + if (retval /= 0) return + + ! Set tolerances for stopping criteria: scaled maximum norm of the system function + retval = FKINSetFuncNormTol(kinsol_mem, fnormtol) + if (retval /= 0) return + + ! Set stopping tolerance on the scaled maximum norm of the system function + retval = FKINSetScaledStepTol(kinsol_mem, scsteptol) + if (retval /= 0) return + +end subroutine setSolverParams + +! ---------------------------------------------------------------- +! getErrMessage: private routine to get error message for KINSOL solver +! ---------------------------------------------------------------- +subroutine getErrMessage(retval,message) + + !======= Declarations ========= + implicit none + + ! calling variables + integer(i4b),intent(in) :: retval ! return value from KINSOL + character(*),intent(out) :: message ! error message + + ! get message + if( retval==-1 ) message = 'KIN_MEM_NULL' ! The kin_mem argument was NULL. + if( retval==-2 ) message = 'KIN_ILL_INPUT' ! One of the function inputs is illegal. + if( retval==-3 ) message = 'KIN_NO_MALLOC' ! The KINSOL memory was not allocated by a call to KINMalloc. + if( retval==-4 ) message = 'KIN_MEM_FAIL' ! A memory allocation failed. + if( retval==-5 ) message = 'KIN_LINESEARCH_NONCONV ' ! The linesearch algorithm was unable to find an iterate sufficiently distinct from the current iterate. + if( retval==-6 ) message = 'KIN_MAXITER_REACHED' ! The maximum number of nonlinear iterations has been reached. + if( retval==-7 ) message = 'KIN_MXNEWT_5X_EXCEEDED' ! Five consecutive steps have been taken that satisfy a scaled step length test. + if( retval==-8 ) message = 'KIN_LINESEARCH_BCFAIL' ! The linesearch algorithm was unable to satisfy the 𝛽-condition for nbcfails iterations. + if( retval==-9 ) message = 'KIN_LINSOLV_NO_RECOVERY' ! The user-supplied routine preconditioner slve function failed recoverably, but the preconditioner is already current. + if( retval==-10) message = 'KIN_LINIT_FAIL' ! The linear solver’s initialization function failed. + if( retval==-11) message = 'KIN_LSETUP_FAIL' ! The linear solver’s setup function failed in an unrecoverable manner. + if( retval==-12) message = 'KIN_LSOLVE_FAIL' ! The linear solver’s solve function failed in an unrecoverable manner. + if( retval==-13) message = 'KIN_SYSFUNC_FAIL' ! The system function failed in an unrecoverable manner. + if( retval==-14) message = 'KIN_FIRST_SYSFUNC_ERR' ! The system function failed with a recoverable error at the first call. + if( retval==-15) message = 'KIN_REPTD_SYSFUNC_ERR' ! The system function had repeated recoverable errors. + +end subroutine getErrMessage + + +end module summaSolve4kinsol_module diff --git a/build/source/engine/sunGeomtry.f90 b/build/source/engine/sunGeomtry.f90 old mode 100755 new mode 100644 index 7f7750d64..e03eedf11 --- a/build/source/engine/sunGeomtry.f90 +++ b/build/source/engine/sunGeomtry.f90 @@ -115,7 +115,6 @@ SUBROUTINE CLRSKY_RAD(MONTH,DAY,HOUR,DT,SLOPE,AZI,LAT,HRI,COSZEN) ENDIF ! Calculate time adjustment for ground slope, aspect and latitude (DDT = 0 for level surface) DDT=ATAN(SIN(AZI1)*SIN(SLOPE1)/(COS(SLOPE1)*COS(LAT1)-COS(AZI1)*SIN(SLOPE1)*SIN(LAT1))) - ! print*, 'ddt = ', ddt ! Set beginning time of time step (set to sunrise if before sunrise) T1=MAX(T,-TP-DDT,-TD) ! Set end time of time step (adjust if after sunset) diff --git a/build/source/engine/systemSolv.f90 b/build/source/engine/systemSolv.f90 old mode 100755 new mode 100644 index 616b49a58..023875dcf --- a/build/source/engine/systemSolv.f90 +++ b/build/source/engine/systemSolv.f90 @@ -23,12 +23,9 @@ module systemSolv_module ! data types USE nrtype -! access the global print flag -USE globalData,only:globalPrintFlag - ! access missing values USE globalData,only:integerMissing ! missing integer -USE globalData,only:realMissing ! missing double precision number +USE globalData,only:realMissing ! missing real number USE globalData,only:quadMissing ! missing quadruple precision number ! access matrix information @@ -38,11 +35,6 @@ module systemSolv_module USE globalData,only: iJac1 ! first layer of the Jacobian to print USE globalData,only: iJac2 ! last layer of the Jacobian to print -! domain types -USE globalData,only:iname_veg ! named variables for vegetation -USE globalData,only:iname_snow ! named variables for snow -USE globalData,only:iname_soil ! named variables for soil - ! state variable type USE globalData,only:iname_nrgCanair ! named variable defining the energy of the canopy air space USE globalData,only:iname_nrgCanopy ! named variable defining the energy of the vegetation canopy @@ -55,12 +47,10 @@ module systemSolv_module USE globalData,only:iname_lmpLayer ! named variable defining the liquid matric potential state variable for soil layers ! global metadata -USE globalData,only:flux_meta ! metadata on the model fluxes +USE globalData,only:flux_meta ! metadata on the model fluxes ! constants USE multiconst,only:& - LH_fus, & ! latent heat of fusion (J K-1) - Tfreeze, & ! temperature at freezing (K) iden_ice, & ! intrinsic density of ice (kg m-3) iden_water ! intrinsic density of liquid water (kg m-3) @@ -72,489 +62,785 @@ module systemSolv_module USE var_lookup,only:iLookPARAM ! named variables for structure elements USE var_lookup,only:iLookINDEX ! named variables for structure elements USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure +USE var_lookup,only:iLookDERIV ! named variables for structure elements ! provide access to the derived types to define the data structures USE data_types,only:& - var_i, & ! data vector (i4b) - var_d, & ! data vector (dp) - var_ilength, & ! data vector with variable length dimension (i4b) - var_dlength, & ! data vector with variable length dimension (dp) - model_options ! defines the model decisions + var_i, & ! data vector (i4b) + var_d, & ! data vector (rkind) + var_ilength, & ! data vector with variable length dimension (i4b) + var_dlength, & ! data vector with variable length dimension (rkind) + zLookup, & ! lookup tables + model_options, & ! defines the model decisions + in_type_summaSolve4homegrown, & ! class for summaSolve4homegrown arguments + io_type_summaSolve4homegrown, & ! class for summaSolve4homegrown arguments + out_type_summaSolve4homegrown ! class for summaSolve4homegrown arguments ! look-up values for the choice of groundwater representation (local-column, or single-basin) -USE mDecisions_module,only: & - localColumn, & ! separate groundwater representation in each local soil column - singleBasin ! single groundwater store over the entire basin +USE mDecisions_module,only:& + localColumn, & ! separate groundwater representation in each local soil column + singleBasin ! single groundwater store over the entire basin ! look-up values for the choice of groundwater parameterization -USE mDecisions_module,only: & - qbaseTopmodel, & ! TOPMODEL-ish baseflow parameterization - bigBucket, & ! a big bucket (lumped aquifer model) - noExplicit ! no explicit groundwater parameterization +USE mDecisions_module,only: & + qbaseTopmodel,& ! TOPMODEL-ish baseflow parameterization + bigBucket, & ! a big bucket (lumped aquifer model) + noExplicit ! no explicit groundwater parameterization + + ! look-up values for the numerical method +USE mDecisions_module,only:& + homegrown ,& ! homegrown backward Euler solution based on concepts from numerical recipes + kinsol ,& ! SUNDIALS backward Euler solution using Kinsol + ida ! SUNDIALS solution using IDA ! safety: set private unless specified otherwise implicit none private public::systemSolv -! control parameters -real(rkind),parameter :: valueMissing=-9999._rkind ! missing value -real(rkind),parameter :: verySmall=1.e-12_rkind ! a very small number (used to check consistency) -real(rkind),parameter :: veryBig=1.e+20_rkind ! a very big number -real(rkind),parameter :: dx = 1.e-8_rkind ! finite difference increment - contains - ! ********************************************************************************************************** - ! public subroutine systemSolv: run the coupled energy-mass model for one timestep - ! ********************************************************************************************************** - subroutine systemSolv(& - ! input: model control - dt, & ! intent(in): time step (s) - nState, & ! intent(in): total number of state variables - firstSubStep, & ! intent(in): flag to denote first sub-step - firstFluxCall, & ! intent(inout): flag to indicate if we are processing the first flux call - firstSplitOper, & ! intent(in): flag to indicate if we are processing the first flux call in a splitting operation - computeVegFlux, & ! intent(in): flag to denote if computing energy flux over vegetation - scalarSolution, & ! intent(in): flag to denote if implementing the scalar solution - ! input/output: data structures - type_data, & ! intent(in): type of vegetation and soil - attr_data, & ! intent(in): spatial attributes - forc_data, & ! intent(in): model forcing data - mpar_data, & ! intent(in): model parameters - indx_data, & ! intent(inout): index data - prog_data, & ! intent(inout): model prognostic variables for a local HRU - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - flux_temp, & ! intent(inout): model fluxes for a local HRU - bvar_data, & ! intent(in): model variables for the local basin - model_decisions, & ! intent(in): model decisions - stateVecInit, & ! intent(in): initial state vector - ! output - deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables - ixSaturation, & ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) - untappedMelt, & ! intent(out): un-tapped melt energy (J m-3 s-1) - stateVecTrial, & ! intent(out): updated state vector - reduceCoupledStep, & ! intent(out): flag to reduce the length of the coupled step - tooMuchMelt, & ! intent(out): flag to denote that there was too much melt - niter, & ! intent(out): number of iterations taken - err,message) ! intent(out): error code and error message - ! --------------------------------------------------------------------------------------- - ! structure allocations - USE allocspace_module,only:allocLocal ! allocate local data structures - ! simulation of fluxes and residuals given a trial state vector - USE eval8summa_module,only:eval8summa ! simulation of fluxes and residuals given a trial state vector - USE summaSolve_module,only:summaSolve ! calculate the iteration increment, evaluate the new state, and refine if necessary - USE getVectorz_module,only:getScaling ! get the scaling vectors - USE convE2Temp_module,only:temp2ethpy ! convert temperature to enthalpy - implicit none - ! --------------------------------------------------------------------------------------- - ! * dummy variables - ! --------------------------------------------------------------------------------------- - ! input: model control - real(rkind),intent(in) :: dt ! time step (seconds) - integer(i4b),intent(in) :: nState ! total number of state variables - logical(lgt),intent(in) :: firstSubStep ! flag to indicate if we are processing the first sub-step - logical(lgt),intent(inout) :: firstFluxCall ! flag to define the first flux call - logical(lgt),intent(in) :: firstSplitOper ! flag to indicate if we are processing the first flux call in a splitting operation - logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) - logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution - ! input/output: data structures - type(var_i),intent(in) :: type_data ! type of vegetation and soil - type(var_d),intent(in) :: attr_data ! spatial attributes - type(var_d),intent(in) :: forc_data ! model forcing data - type(var_dlength),intent(in) :: mpar_data ! model parameters - type(var_ilength),intent(inout) :: indx_data ! indices for a local HRU - type(var_dlength),intent(inout) :: prog_data ! prognostic variables for a local HRU - type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU - type(var_dlength),intent(inout) :: flux_temp ! model fluxes for a local HRU - type(var_dlength),intent(in) :: bvar_data ! model variables for the local basin - type(model_options),intent(in) :: model_decisions(:) ! model decisions - real(rkind),intent(in) :: stateVecInit(:) ! initial state vector (mixed units) - ! output: model control - type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables - integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) - real(rkind),intent(out) :: untappedMelt(:) ! un-tapped melt energy (J m-3 s-1) - real(rkind),intent(out) :: stateVecTrial(:) ! trial state vector (mixed units) - logical(lgt),intent(out) :: reduceCoupledStep ! flag to reduce the length of the coupled step - logical(lgt),intent(out) :: tooMuchMelt ! flag to denote that there was too much melt - integer(i4b),intent(out) :: niter ! number of iterations taken - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! ********************************************************************************************************************************************************* - ! ********************************************************************************************************************************************************* - ! --------------------------------------------------------------------------------------- - ! * general local variables - ! --------------------------------------------------------------------------------------- - character(LEN=256) :: cmessage ! error message of downwind routine - integer(i4b) :: iter ! iteration index - integer(i4b) :: iVar ! index of variable - integer(i4b) :: iLayer ! index of layer in the snow+soil domain - integer(i4b) :: iState ! index of model state - integer(i4b) :: nLeadDim ! length of the leading dimension of the Jacobian matrix (nBands or nState) - integer(i4b) :: local_ixGroundwater ! local index for groundwater representation - real(rkind) :: bulkDensity ! bulk density of a given layer (kg m-3) - real(rkind) :: volEnthalpy ! volumetric enthalpy of a given layer (J m-3) - real(rkind),parameter :: tempAccelerate=0.00_rkind ! factor to force initial canopy temperatures to be close to air temperature - real(rkind),parameter :: xMinCanopyWater=0.0001_rkind ! minimum value to initialize canopy water (kg m-2) - real(rkind),parameter :: tinyStep=0.000001_rkind ! stupidly small time step (s) - ! ------------------------------------------------------------------------------------------------------ - ! * model solver - ! ------------------------------------------------------------------------------------------------------ - logical(lgt),parameter :: forceFullMatrix=.false. ! flag to force the use of the full Jacobian matrix - integer(i4b) :: maxiter ! maximum number of iterations - integer(i4b) :: ixMatrix ! form of matrix (band diagonal or full matrix) - integer(i4b) :: localMaxIter ! maximum number of iterations (depends on solution type) - integer(i4b), parameter :: scalarMaxIter=100 ! maximum number of iterations for the scalar solution - type(var_dlength) :: flux_init ! model fluxes at the start of the time step - real(rkind),allocatable :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! NOTE: allocatable, since not always needed - real(rkind) :: stateVecNew(nState) ! new state vector (mixed units) - real(rkind) :: fluxVec0(nState) ! flux vector (mixed units) - real(rkind) :: fScale(nState) ! characteristic scale of the function evaluations (mixed units) - real(rkind) :: xScale(nState) ! characteristic scale of the state vector (mixed units) - real(rkind) :: dMat(nState) ! diagonal matrix (excludes flux derivatives) - real(rkind) :: sMul(nState) ! NOTE: qp ! multiplier for state vector for the residual calculations - real(rkind) :: rVec(nState) ! NOTE: qp ! residual vector - real(rkind) :: rAdd(nState) ! additional terms in the residual vector - real(rkind) :: fOld,fNew ! function values (-); NOTE: dimensionless because scaled - real(rkind) :: xMin,xMax ! state minimum and maximum (mixed units) - logical(lgt) :: converged ! convergence flag - logical(lgt) :: feasible ! feasibility flag - real(rkind) :: resSinkNew(nState) ! additional terms in the residual vector - real(rkind) :: fluxVecNew(nState) ! new flux vector - real(rkind) :: resVecNew(nState) ! NOTE: qp ! new residual vector - ! --------------------------------------------------------------------------------------- - ! point to variables in the data structures - ! --------------------------------------------------------------------------------------- - globalVars: associate(& - ! model decisions - ixGroundwater => model_decisions(iLookDECISIONS%groundwatr)%iDecision ,& ! intent(in): [i4b] groundwater parameterization - ixSpatialGroundwater => model_decisions(iLookDECISIONS%spatial_gw)%iDecision ,& ! intent(in): [i4b] spatial representation of groundwater (local-column or single-basin) - ! check the need to merge snow layers - mLayerTemp => prog_data%var(iLookPROG%mLayerTemp)%dat ,& ! intent(in): [dp(:)] temperature of each snow/soil layer (K) - mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat ,& ! intent(in): [dp(:)] volumetric fraction of liquid water (-) - mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat ,& ! intent(in): [dp(:)] volumetric fraction of ice (-) - mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat ,& ! intent(in): [dp(:)] depth of each layer in the snow-soil sub-domain (m) - snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1) ,& ! intent(in): [dp] scaling parameter for the snow freezing curve (K-1) - ! accelerate solution for temperature - airtemp => forc_data%var(iLookFORCE%airtemp) ,& ! intent(in): [dp] temperature of the upper boundary of the snow and soil domains (K) - ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy air space energy state variable - ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable - ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) - ! vector of energy and hydrology indices for the snow and soil domains - ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the snow+soil domain - ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the snow+soil domain - ixSoilOnlyHyd => indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the soil domain - nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg )%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow+soil domain - nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology state variables in the snow+soil domain - nSoilOnlyHyd => indx_data%var(iLookINDEX%nSoilOnlyHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology state variables in the soil domain - ! mapping from full domain to the sub-domain - ixMapFull2Subset => indx_data%var(iLookINDEX%ixMapFull2Subset)%dat ,& ! intent(in): [i4b] mapping of full state vector to the state subset - ixControlVolume => indx_data%var(iLookINDEX%ixControlVolume)%dat ,& ! intent(in): [i4b] index of control volume for different domains (veg, snow, soil) - ! type of state and domain for a given variable - ixStateType_subset => indx_data%var(iLookINDEX%ixStateType_subset)%dat ,& ! intent(in): [i4b(:)] [state subset] type of desired model state variables - ixDomainType_subset => indx_data%var(iLookINDEX%ixDomainType_subset)%dat ,& ! intent(in): [i4b(:)] [state subset] domain for desired model state variables - ! layer geometry - nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in): [i4b] number of snow layers - nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1) ,& ! intent(in): [i4b] number of soil layers - nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1) & ! intent(in): [i4b] total number of layers - ) - ! --------------------------------------------------------------------------------------- - ! initialize error control - err=0; message="systemSolv/" - - ! ***** - ! (0) PRELIMINARIES... - ! ******************** - - ! ----- - ! * initialize... - ! --------------- - - ! check - if(dt < tinyStep)then - message=trim(message)//'dt is tiny' - err=20; return - endif - - ! initialize the flags - tooMuchMelt = .false. ! too much melt - reduceCoupledStep = .false. ! need to reduce the length of the coupled step - - ! define maximum number of iterations - maxiter = nint(mpar_data%var(iLookPARAM%maxiter)%dat(1)) - - ! modify the groundwater representation for this single-column implementation - select case(ixSpatialGroundwater) - case(singleBasin); local_ixGroundwater = noExplicit ! force no explicit representation of groundwater at the local scale - case(localColumn); local_ixGroundwater = ixGroundwater ! go with the specified decision - case default; err=20; message=trim(message)//'unable to identify spatial representation of groundwater'; return - end select ! (modify the groundwater representation for this single-column implementation) - - ! allocate space for the model fluxes at the start of the time step - call allocLocal(flux_meta(:),flux_init,nSnow,nSoil,err,cmessage) - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif - - ! allocate space for the baseflow derivatives - ! NOTE: needs allocation because only used when baseflow sinks are active - if(ixGroundwater==qbaseTopmodel)then - allocate(dBaseflow_dMatric(nSoil,nSoil),stat=err) ! baseflow depends on total storage in the soil column, hence on matric head in every soil layer - else - allocate(dBaseflow_dMatric(0,0),stat=err) ! allocate zero-length dimnensions to avoid passing around an unallocated matrix - end if - if(err/=0)then; err=20; message=trim(message)//'unable to allocate space for the baseflow derivatives'; return; end if - - ! identify the matrix solution method - ! (the type of matrix used to solve the linear system A.X=B) - if(local_ixGroundwater==qbaseTopmodel .or. scalarSolution .or. forceFullMatrix)then - nLeadDim=nState ! length of the leading dimension - ixMatrix=ixFullMatrix ! named variable to denote the full Jacobian matrix - else - nLeadDim=nBands ! length of the leading dimension - ixMatrix=ixBandMatrix ! named variable to denote the band-diagonal matrix - endif - - ! initialize the model fluxes (some model fluxes are not computed in the iterations) - do iVar=1,size(flux_temp%var) - flux_init%var(iVar)%dat(:) = flux_temp%var(iVar)%dat(:) - end do - - ! ************************************************************************************************************************** - ! ************************************************************************************************************************** - ! ************************************************************************************************************************** - ! *** NUMERICAL SOLUTION FOR A GIVEN SUBSTEP AND SPLIT ********************************************************************* - ! ************************************************************************************************************************** - ! ************************************************************************************************************************** - ! ************************************************************************************************************************** - - ! ----- - ! * get scaling vectors... - ! ------------------------ - - ! initialize state vectors - call getScaling(& - ! input - diag_data, & ! intent(in): model diagnostic variables for a local HRU - indx_data, & ! intent(in): indices defining model states and layers - ! output - fScale, & ! intent(out): function scaling vector (mixed units) - xScale, & ! intent(out): variable scaling vector (mixed units) - sMul, & ! intent(out): multiplier for state vector (used in the residual calculations) - dMat, & ! intent(out): diagonal of the Jacobian matrix (excludes fluxes) - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (check for errors) - - ! ----- - ! * compute the initial function evaluation... - ! -------------------------------------------- - - ! initialize the trial state vectors - stateVecTrial = stateVecInit - - ! need to intialize canopy water at a positive value - if(ixVegHyd/=integerMissing)then - if(stateVecTrial(ixVegHyd) < xMinCanopyWater) stateVecTrial(ixVegHyd) = stateVecTrial(ixVegHyd) + xMinCanopyWater - endif - - ! try to accelerate solution for energy - if(ixCasNrg/=integerMissing) stateVecTrial(ixCasNrg) = stateVecInit(ixCasNrg) + (airtemp - stateVecInit(ixCasNrg))*tempAccelerate - if(ixVegNrg/=integerMissing) stateVecTrial(ixVegNrg) = stateVecInit(ixVegNrg) + (airtemp - stateVecInit(ixVegNrg))*tempAccelerate - - ! compute the flux and the residual vector for a given state vector - ! NOTE 1: The derivatives computed in eval8summa are used to calculate the Jacobian matrix for the first iteration - ! NOTE 2: The Jacobian matrix together with the residual vector is used to calculate the first iteration increment - call eval8summa(& - ! input: model control - dt, & ! intent(in): length of the time step (seconds) - nSnow, & ! intent(in): number of snow layers - nSoil, & ! intent(in): number of soil layers - nLayers, & ! intent(in): number of layers - nState, & ! intent(in): number of state variables in the current subset - firstSubStep, & ! intent(in): flag to indicate if we are processing the first sub-step - firstFluxCall, & ! intent(inout): flag to indicate if we are processing the first flux call - firstSplitOper, & ! intent(in): flag to indicate if we are processing the first flux call in a splitting operation - computeVegFlux, & ! intent(in): flag to indicate if we need to compute fluxes over vegetation - scalarSolution, & ! intent(in): flag to indicate the scalar solution - ! input: state vectors - stateVecTrial, & ! intent(in): model state vector - fScale, & ! intent(in): function scaling vector - sMul, & ! intent(in): state vector multiplier (used in the residual calculations) - ! input: data structures - model_decisions, & ! intent(in): model decisions - type_data, & ! intent(in): type of vegetation and soil - attr_data, & ! intent(in): spatial attributes - mpar_data, & ! intent(in): model parameters - forc_data, & ! intent(in): model forcing data - bvar_data, & ! intent(in): average model variables for the entire basin - prog_data, & ! intent(in): model prognostic variables for a local HRU - indx_data, & ! intent(in): index data - ! input-output: data structures - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - flux_init, & ! intent(inout): model fluxes for a local HRU (initial flux structure) - deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables - ! input-output: baseflow - ixSaturation, & ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) - dBaseflow_dMatric, & ! intent(out): derivative in baseflow w.r.t. matric head (s-1) - ! output - feasible, & ! intent(out): flag to denote the feasibility of the solution - fluxVec0, & ! intent(out): flux vector - rAdd, & ! intent(out): additional (sink) terms on the RHS of the state equation - rVec, & ! intent(out): residual vector - fOld, & ! intent(out): function evaluation - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (check for errors) - if(.not.feasible)then; message=trim(message)//'state vector not feasible'; err=20; return; endif - - ! copy over the initial flux structure since some model fluxes are not computed in the iterations - do concurrent ( iVar=1:size(flux_meta) ) - flux_temp%var(iVar)%dat(:) = flux_init%var(iVar)%dat(:) - end do - - ! check the need to merge snow layers - if(nSnow>0)then - ! compute the energy required to melt the top snow layer (J m-2) - bulkDensity = mLayerVolFracIce(1)*iden_ice + mLayerVolFracLiq(1)*iden_water - volEnthalpy = temp2ethpy(mLayerTemp(1),bulkDensity,snowfrz_scale) - ! set flag and error codes for too much melt - if(-volEnthalpy < flux_init%var(iLookFLUX%mLayerNrgFlux)%dat(1)*dt)then - tooMuchMelt=.true. - message=trim(message)//'net flux in the top snow layer can melt all the snow in the top layer' - err=-20; return ! negative error code to denote a warning - endif - endif - - ! ========================================================================================================================================== - ! ========================================================================================================================================== - ! ========================================================================================================================================== - ! ========================================================================================================================================== - - ! ************************** - ! *** MAIN ITERATION LOOP... - ! ************************** - - ! correct the number of iterations - localMaxIter = merge(scalarMaxIter, maxIter, scalarSolution) - - ! iterate - do iter=1,localMaxIter - - ! print iteration count - !print*, '*** iter, maxiter, dt = ', iter, localMaxiter, dt - !print*, trim(message)//'before summaSolve' - - ! keep track of the number of iterations - niter = iter+1 ! +1 because xFluxResid was moved outside the iteration loop (for backwards compatibility) - - ! compute the next trial state vector - ! 1) Computes the Jacobian matrix based on derivatives from the last flux evaluation - ! 2) Computes the iteration increment based on Jacobian and residuals from the last flux evaluation - ! 3) Computes new fluxes and derivatives, new residuals, and (if necessary) refines the state vector - call summaSolve(& - ! input: model control - dt, & ! intent(in): length of the time step (seconds) - iter, & ! intent(in): iteration index - nSnow, & ! intent(in): number of snow layers - nSoil, & ! intent(in): number of soil layers - nLayers, & ! intent(in): total number of layers - nLeadDim, & ! intent(in): length of the leading dimension of the Jacobian matrix (either nBands or nState) - nState, & ! intent(in): total number of state variables - ixMatrix, & ! intent(in): type of matrix (full or band diagonal) - firstSubStep, & ! intent(in): flag to indicate if we are processing the first sub-step - firstFluxCall, & ! intent(inout): flag to indicate if we are processing the first flux call - computeVegFlux, & ! intent(in): flag to indicate if we need to compute fluxes over vegetation - scalarSolution, & ! intent(in): flag to indicate the scalar solution - ! input: state vectors - stateVecTrial, & ! intent(in): trial state vector - xMin,xMax, & ! intent(inout): state maximum and minimum - fScale, & ! intent(in): function scaling vector - xScale, & ! intent(in): "variable" scaling vector, i.e., for state variables - rVec, & ! intent(in): residual vector - sMul, & ! intent(in): state vector multiplier (used in the residual calculations) - dMat, & ! intent(inout): diagonal matrix (excludes flux derivatives) - fOld, & ! intent(in): old function evaluation - ! input: data structures - model_decisions, & ! intent(in): model decisions - type_data, & ! intent(in): type of vegetation and soil - attr_data, & ! intent(in): spatial attributes - mpar_data, & ! intent(in): model parameters - forc_data, & ! intent(in): model forcing data - bvar_data, & ! intent(in): average model variables for the entire basin - prog_data, & ! intent(in): model prognostic variables for a local HRU - indx_data, & ! intent(in): index data - ! input-output: data structures - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - flux_temp, & ! intent(inout): model fluxes for a local HRU (temporary structure) - deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables - ! input-output: baseflow - ixSaturation, & ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) - dBaseflow_dMatric, & ! intent(inout): derivative in baseflow w.r.t. matric head (s-1) - ! output - stateVecNew, & ! intent(out): new state vector - fluxVecNew, & ! intent(out): new flux vector - resSinkNew, & ! intent(out): additional (sink) terms on the RHS of the state equa - resVecNew, & ! intent(out): new residual vector - fNew, & ! intent(out): new function evaluation - converged, & ! intent(out): convergence flag - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (check for errors) - - !print*, err,trim(cmessage) - - ! update function evaluation, residual vector, and states - ! NOTE 1: The derivatives computed in summaSolve are used to calculate the Jacobian matrix at the next iteration - ! NOTE 2: The Jacobian matrix together with the residual vector is used to calculate the new iteration increment - - ! save functions and residuals +! ********************************************************************************************************** +! public subroutine systemSolv: run the coupled energy-mass model for one timestep +! ********************************************************************************************************** +subroutine systemSolv(& + ! input: model control + dt_cur, & ! intent(in): current stepsize + dt, & ! intent(in): entire time step (s) + nState, & ! intent(in): total number of state variables + nLayers, & ! intent(in): total number of layers + firstSubStep, & ! intent(in): flag to denote first sub-step + firstFluxCall, & ! intent(inout): flag to indicate if we are processing the first flux call + firstSplitOper, & ! intent(in): flag to indicate if we are processing the first flux call in a splitting operation + computeVegFlux, & ! intent(in): flag to denote if computing energy flux over vegetation + scalarSolution, & ! intent(in): flag to denote if implementing the scalar solution + computMassBalance, & ! intent(in): flag to compute mass balance + computNrgBalance, & ! intent(in): flag to compute energy balance + ! input/output: data structures + lookup_data, & ! intent(in): lookup tables + type_data, & ! intent(in): type of vegetation and soil + attr_data, & ! intent(in): spatial attributes + forc_data, & ! intent(in): model forcing data + mpar_data, & ! intent(in): model parameters + indx_data, & ! intent(inout): index data + prog_data, & ! intent(inout): model prognostic variables for a local HRU + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + flux_temp, & ! intent(inout): model fluxes for a local HRU + bvar_data, & ! intent(in): model variables for the local basin + model_decisions, & ! intent(in): model decisions + stateVecInit, & ! intent(in): initial state vector + ! output + deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables + ixSaturation, & ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) + stateVecTrial, & ! intent(out): updated state vector + stateVecPrime, & ! intent(out): updated state vector if need the prime space (ida) + fluxVec, & ! intent(out): new flux vector + resSink, & ! intent(out): additional (sink) terms on the RHS of the state equa + resVec, & ! intent(out): new residual vector + untappedMelt, & ! intent(out): un-tapped melt energy (J m-3 s-1) + ! output: balances (only computed at this level for ida) + balance, & ! intent(out): balance of energy per state + ! output: model control + niter, & ! intent(out): number of iterations taken (homegrown) + nSteps, & ! intent(out): number of time steps taken in solver + reduceCoupledStep, & ! intent(out): flag to reduce the length of the coupled step + tooMuchMelt, & ! intent(out): flag to denote that there was too much melt + err,message) ! intent(out): error code and error message + ! --------------------------------------------------------------------------------------- + ! structure allocations + USE allocspace_module,only:allocLocal ! allocate local data structures + ! state vector and solver + USE getVectorz_module,only:getScaling ! get the scaling vectors + USE enthalpyTemp_module,only:T2enthalpy_snwWat ! convert temperature to liq+ice enthalpy for a snow layer +#ifdef SUNDIALS_ACTIVE + USE tol4ida_module,only:popTol4ida ! populate tolerances + USE eval8summaWithPrime_module,only:eval8summaWithPrime ! get the fluxes and residuals + USE summaSolve4ida_module,only:summaSolve4ida ! solve DAE by IDA + USE summaSolve4kinsol_module,only:summaSolve4kinsol ! solve DAE by KINSOL +#endif + USE eval8summa_module,only:eval8summa ! get the fluxes and residuals + USE summaSolve4homegrown_module,only:summaSolve4homegrown ! solve DAE using homegrown solver + + implicit none + ! --------------------------------------------------------------------------------------- + ! * dummy variables + ! --------------------------------------------------------------------------------------- + ! input: model control + real(rkind),intent(in) :: dt_cur ! current stepsize + real(rkind),intent(in) :: dt ! entire time step for drainage pond rate + integer(i4b),intent(in) :: nState ! total number of state variables + integer(i4b),intent(in) :: nLayers ! total number of layers + logical(lgt),intent(in) :: firstSubStep ! flag to indicate if we are processing the first sub-step + logical(lgt),intent(inout) :: firstFluxCall ! flag to define the first flux call + logical(lgt),intent(in) :: firstSplitOper ! flag to indicate if we are processing the first flux call in a splitting operation + logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) + logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution + logical(lgt),intent(in) :: computMassBalance ! flag to compute mass balance + logical(lgt),intent(in) :: computNrgBalance ! flag to compute energy balance + ! input/output: data structures + type(zLookup),intent(in) :: lookup_data ! lookup tables + type(var_i),intent(in) :: type_data ! type of vegetation and soil + type(var_d),intent(in) :: attr_data ! spatial attributes + type(var_d),intent(in) :: forc_data ! model forcing data + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_ilength),intent(inout) :: indx_data ! indices for a local HRU + type(var_dlength),intent(inout) :: prog_data ! prognostic variables for a local HRU + type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(inout) :: flux_temp ! model fluxes for a local HRU + type(var_dlength),intent(in) :: bvar_data ! model variables for the local basin + type(model_options),intent(in) :: model_decisions(:) ! model decisions + real(rkind),intent(in) :: stateVecInit(:) ! initial state vector (mixed units) + ! output + type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) + real(rkind),intent(out) :: stateVecTrial(:) ! trial state vector (mixed units) + real(rkind),intent(out) :: stateVecPrime(:) ! trial state vector (mixed units) + real(rkind),intent(out) :: fluxVec(nState) ! flux vector (mixed units) + real(rkind),intent(out) :: resSink(nState) ! additional terms in the residual vector homegrown solver + real(qp),intent(out) :: resVec(nState) ! NOTE: qp ! residual vector + real(rkind),intent(out) :: untappedMelt(:) ! un-tapped melt energy (J m-3 s-1) + ! output: balances (only computed at this level for ida) + real(rkind),intent(out) :: balance(nState) ! balance per state + ! output: model control + integer(i4b),intent(out) :: niter ! number of iterations taken + integer(i4b),intent(out) :: nSteps ! number of time steps taken in solver + logical(lgt),intent(out) :: reduceCoupledStep ! flag to reduce the length of the coupled step + logical(lgt),intent(out) :: tooMuchMelt ! flag to denote that there was too much melt + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! --------------------------------------------------------------------------------------- + ! * general local variables + ! --------------------------------------------------------------------------------------- + character(LEN=256) :: cmessage ! error message of downwind routine + integer(i4b) :: iter ! iteration index + integer(i4b) :: iVar ! index of variable + integer(i4b) :: iLayer ! index of layer in the snow+soil domain + integer(i4b) :: iState ! index of model state + integer(i4b) :: nLeadDim ! length of the leading dimension of the Jacobian matrix (nBands or nState) + integer(i4b) :: local_ixGroundwater ! local index for groundwater representation + real(rkind) :: bulkDensity ! bulk density of a given layer (kg m-3) + real(rkind) :: volEnthalpy ! volumetric enthalpy of a given layer (J m-3) + real(rkind),parameter :: tinyStep=0.000001_rkind ! stupidly small time step (s) + ! ------------------------------------------------------------------------------------------------------ + ! * model solver + ! ------------------------------------------------------------------------------------------------------ + logical(lgt),parameter :: forceFullMatrix=.false. ! flag to force the use of the full Jacobian matrix + integer(i4b) :: ixMatrix ! form of matrix (band diagonal or full matrix) + type(var_dlength) :: flux_init ! model fluxes at the start of the time step + real(rkind),allocatable :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! NOTE: allocatable, since not always needed + real(rkind) :: stateVecNew(nState) ! new state vector (mixed units) + real(rkind) :: fluxVec0(nState) ! flux vector (mixed units) + real(rkind) :: dMat(nState) ! diagonal matrix (excludes flux derivatives) + real(qp) :: sMul(nState) ! NOTE: qp ! multiplier for state vector for the residual calculations + real(rkind) :: rAdd(nState) ! additional terms in the residual vector + logical(lgt) :: feasible ! feasibility flag + logical(lgt) :: sunSucceeds ! flag to indicate if SUNDIALS successfully solved the problem in current data step + ! ida variables + real(rkind) :: atol(nState) ! absolute tolerance ida + real(rkind) :: rtol(nState) ! relative tolerance ida + type(var_dlength) :: flux_sum ! sum of fluxes model fluxes for a local HRU over a dt_cur + real(rkind), allocatable :: mLayerCmpress_sum(:) ! sum of compression of the soil matrix + ! ida solver variables outputted if use eval8summaWithPrime (not used here, just inside ida solver) + logical(lgt) :: firstSplitOper0 ! flag to indicate if we are processing the first flux call in a splitting operation, changed inside eval8summaWithPrime + real(rkind) :: scalarCanopyTempPrime ! prime value for temperature of the vegetation canopy (K s-1) + real(rkind) :: scalarCanopyWatPrime ! prime value for total water content of the vegetation canopy (kg m-2 s-1) + real(rkind) :: mLayerTempPrime(nLayers) ! prime vector of temperature of each snow and soil layer (K s-1) + real(rkind), allocatable :: mLayerMatricHeadPrime(:) ! prime vector of matric head of each snow and soil layer (m s-1) + real(rkind) :: mLayerVolFracWatPrime(nLayers)! prime vector of volumetric total water content of each snow and soil layer (s-1) + ! kinsol and homegrown solver variables + real(rkind) :: fScale(nState) ! characteristic scale of the function evaluations (mixed units) + real(rkind) :: xScale(nState) ! characteristic scale of the state vector (mixed units) + real(qp) :: resVecNew(nState) ! NOTE: qp ! new residual vector homegrown solver + ! homegrown solver variables + real(rkind) :: fOld,fNew ! function values (-); NOTE: dimensionless because scaled homegrown solver + real(rkind) :: xMin,xMax ! state minimum and maximum (mixed units) homegrown solver + integer(i4b) :: maxiter ! maximum number of iterations homegrown solver + integer(i4b) :: localMaxIter ! maximum number of iterations (depends on solution type) homegrown solver + integer(i4b), parameter :: scalarMaxIter=100 ! maximum number of iterations for the scalar solution homegrown solver + logical(lgt) :: converged ! convergence flag homegrown solver + logical(lgt), parameter :: post_massCons=.false. ! “perfectly” conserve mass by pushing the errors into the states, turn off for now to agree with SUNDIALS + ! class objects for call to summaSolve4homegrown + type(in_type_summaSolve4homegrown) :: in_SS4HG ! object for intent(in) summaSolve4homegrown arguments + type(io_type_summaSolve4homegrown) :: io_SS4HG ! object for intent(io) summaSolve4homegrown arguments + type(out_type_summaSolve4homegrown) :: out_SS4HG ! object for intent(out) summaSolve4homegrown arguments + ! flags + logical(lgt) :: return_flag ! flag for handling systemSolv returns trigerred from internal subroutines + logical(lgt) :: exit_flag ! flag for handling loop exit statements trigerred from internal subroutines + ! ----------------------------------------------------------------------------------------------------------- + + call initialize_systemSolv; if (return_flag) return ! initialize variables and allocate arrays -- return if error + + call initial_function_evaluations; if (return_flag) return ! initial function evaluations -- return if error + + ! ************************** + ! * Solving the System + ! ************************** + associate(ixNumericalMethod => model_decisions(iLookDECISIONS%num_method)%iDecision) ! intent(in): [i4b] choice of numerical solver + select case(ixNumericalMethod) + case(ida) ! solve for general time step using IDA + call solve_with_IDA; if (return_flag) return ! solve using IDA -- return if error + case(kinsol) ! solve for BE time step using KINSOL + call solve_with_KINSOL; if (return_flag) return ! solve using KINSOL -- return if error + case(homegrown) ! solve for BE time step using Newton iterations + call Newton_iterations_homegrown; if (return_flag) return ! Newton iterations using homegrown solver -- return if error + end select + end associate + + call finalize_systemSolv ! set untapped melt to zero and deallocate arrays + +contains + + subroutine initialize_systemSolv + ! *** Initial setup operations for the systemSolv subroutine *** + + ! initialize error control + err=0; message="systemSolv/" + return_flag=.false. ! initialize return flag + nSteps = 0 ! initialize number of time steps taken in solver + + ! check time step size + if (dt_cur < tinyStep) then + message=trim(message)//'dt is tiny' + err=20; return_flag=.true.; return + end if + + ! initialize the flags + tooMuchMelt = .false. ! too much melt + reduceCoupledStep = .false. ! need to reduce the length of the coupled step + ! initialize balances + balance(:) = realMissing + + associate(& + ixSpatialGroundwater => model_decisions(iLookDECISIONS%spatial_gw)%iDecision,& ! intent(in): [i4b] spatial representation of groundwater (local-column or single-basin) + ixGroundwater => model_decisions(iLookDECISIONS%groundwatr)%iDecision & ! intent(in): [i4b] groundwater parameterization + &) + + ! modify the groundwater representation for this single-column implementation + select case(ixSpatialGroundwater) + case(singleBasin); local_ixGroundwater = noExplicit ! force no explicit representation of groundwater at the local scale + case(localColumn); local_ixGroundwater = ixGroundwater ! go with the specified decision + case default; err=20; message=trim(message)//'unable to identify spatial representation of groundwater'; + return_flag=.true.; return + end select + + call allocate_memory; if (return_flag) return + + ! identify the matrix solution method, using the full matrix can be slow in many-layered systems + ! (the type of matrix used to solve the linear system A.X=B) + if (local_ixGroundwater==qbaseTopmodel .or. scalarSolution .or. forceFullMatrix .or. computeVegFlux) then + nLeadDim=nState ! length of the leading dimension + ixMatrix=ixFullMatrix ! named variable to denote the full Jacobian matrix + else + nLeadDim=nBands ! length of the leading dimension + ixMatrix=ixBandMatrix ! named variable to denote the band-diagonal matrix + end if + end associate + + ! initialize the model fluxes (some model fluxes are not computed in the iterations) + do iVar=1,size(flux_temp%var) + flux_init%var(iVar)%dat(:) = flux_temp%var(iVar)%dat(:) + end do + + ! initialize state vectors -- get scaling vectors + call getScaling(diag_data,indx_data,fScale,xScale,sMul,dMat,err,cmessage) + if (err/=0) then; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if ! check for errors + end subroutine initialize_systemSolv + + subroutine allocate_memory + ! ** Allocate arrays used in systemSolv subroutine ** + associate(& + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in): [i4b] number of snow layers + nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1) ,& ! intent(in): [i4b] number of soil layers + ixNumericalMethod => model_decisions(iLookDECISIONS%num_method)%iDecision,& ! intent(in): [i4b] choice of numerical solver + ixGroundwater => model_decisions(iLookDECISIONS%groundwatr)%iDecision & ! intent(in): [i4b] groundwater parameterization + &) + ! allocate space for the model fluxes at the start of the time step + call allocLocal(flux_meta(:),flux_init,nSnow,nSoil,err,cmessage) + if (err/=0) then; err=20; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if + + ! allocate space for mLayerCmpress_sum at the start of the time step + if (ixNumericalMethod==ida) then + allocate( mLayerCmpress_sum(nSoil) ) + allocate( mLayerMatricHeadPrime(nSoil) ) + else + allocate( mLayerCmpress_sum(0) ) ! allocate zero-length dimensions to avoid passing around an unallocated matrix + allocate( mLayerMatricHeadPrime(0) ) ! allocate zero-length dimensions to avoid passing around an unallocated matrix + end if + + ! allocate space for the baseflow derivatives + ! NOTE: needs allocation because only used when baseflow sinks are active + if (ixGroundwater==qbaseTopmodel) then + allocate(dBaseflow_dMatric(nSoil,nSoil),stat=err) ! baseflow depends on total storage in the soil column, hence on matric head in every soil layer + else + allocate(dBaseflow_dMatric(0,0),stat=err) ! allocate zero-length dimensions to avoid passing around an unallocated matrix + end if + if (err/=0) then; err=20; message=trim(message)//'unable to allocate space for the baseflow derivatives'; return_flag=.true.; return; end if + end associate + + end subroutine allocate_memory + + subroutine initial_function_evaluations + ! ** Compute initial function evaluations ** + + ! initialize the trial state vectors + stateVecTrial = stateVecInit + + ! compute the initial flux and the residual vector, also gets values needed for the Jacobian matrix + associate(ixNumericalMethod => model_decisions(iLookDECISIONS%num_method)%iDecision) ! intent(in): [i4b] choice of numerical solver + if (ixNumericalMethod==ida) then + call initial_flux_and_residual_vectors_prime; if (return_flag) return + else + call initial_flux_and_residual_vectors; if (return_flag) return + end if + end associate + + if (.not.feasible) then; message=trim(message)//'state vector not feasible'; err=20; return_flag=.true.; return; end if + + ! copy over the initial flux structure since some model fluxes are not computed in the iterations + do concurrent ( iVar=1:size(flux_meta) ) + flux_temp%var(iVar)%dat(:) = flux_init%var(iVar)%dat(:) + end do + + ! check the need to merge snow layers + associate(& + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in): [i4b] number of snow layers + mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat ,& ! intent(in): [dp(:)] volumetric fraction of ice (-) + mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat ,& ! intent(in): [dp(:)] volumetric fraction of liquid water (-) + mLayerTemp => prog_data%var(iLookPROG%mLayerTemp)%dat ,& ! intent(in): [dp(:)] temperature of each snow/soil layer (K) + snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1) & ! intent(in): [dp] scaling parameter for the snow freezing curve (K-1) + &) + ! check the need to merge snow layers + if (nSnow>0) then + ! compute the energy required to melt the top snow layer (J m-2) + bulkDensity = mLayerVolFracIce(1)*iden_ice + mLayerVolFracLiq(1)*iden_water + volEnthalpy = T2enthalpy_snwWat(mLayerTemp(1),bulkDensity,snowfrz_scale) + ! set flag and error codes for too much melt + if (-volEnthalpy < flux_init%var(iLookFLUX%mLayerNrgFlux)%dat(1)*dt_cur) then + tooMuchMelt = .true. + !message=trim(message)//'net flux in the top snow layer can melt all the snow in the top layer' + err=-20; return ! negative error code to denote a warning + end if + end if + end associate + end subroutine initial_function_evaluations + + subroutine initial_flux_and_residual_vectors + ! ** Compute initial flux and residual vectors ** + ! Note: prime initial values are 0 so it's fine to run the regular eval8summa with every solver choice + associate(& + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1),& ! intent(in): [i4b] number of snow layers + nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1) & ! intent(in): [i4b] number of soil layers + &) + call eval8summa(& + ! input: model control + dt_cur, & ! intent(in): current stepsize + dt, & ! intent(in): length of the entire time step (seconds) for drainage pond rate + nSnow, & ! intent(in): number of snow layers + nSoil, & ! intent(in): number of soil layers + nLayers, & ! intent(in): number of layers + nState, & ! intent(in): number of state variables in the current subset + .false., & ! intent(in): not inside Sundials solver + firstSubStep, & ! intent(in): flag to indicate if we are processing the first sub-step + firstFluxCall, & ! intent(inout): flag to indicate if we are processing the first flux call + firstSplitOper, & ! intent(in): flag to indicate if we are processing the first flux call in a splitting operation + computeVegFlux, & ! intent(in): flag to indicate if we need to compute fluxes over vegetation + scalarSolution, & ! intent(in): flag to indicate the scalar solution + ! input: state vectors + stateVecTrial, & ! intent(in): model state vector + fScale, & ! intent(in): characteristic scale of the function evaluations + sMul, & ! intent(inout): state vector multiplier (used in the residual calculations) + ! input: data structures + model_decisions, & ! intent(in): model decisions + lookup_data, & ! intent(in): lookup tables + type_data, & ! intent(in): type of vegetation and soil + attr_data, & ! intent(in): spatial attributes + mpar_data, & ! intent(in): model parameters + forc_data, & ! intent(in): model forcing data + bvar_data, & ! intent(in): average model variables for the entire basin + prog_data, & ! intent(in): model prognostic variables for a local HRU + ! input-output: data structures + indx_data, & ! intent(inout): index data + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + flux_init, & ! intent(inout): model fluxes for a local HRU (initial flux structure) + deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables + ! input-output: baseflow + ixSaturation, & ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) + dBaseflow_dMatric, & ! intent(out): derivative in baseflow w.r.t. matric head (s-1) + ! output + feasible, & ! intent(out): flag to denote the feasibility of the solution + fluxVec0, & ! intent(out): flux vector + rAdd, & ! intent(out): additional (sink) terms on the RHS of the state equation + resVec, & ! intent(out): residual vector + fOld, & ! intent(out): function evaluation + err,cmessage) ! intent(out): error control + end associate + if (err/=0) then; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if ! check for errors + end subroutine initial_flux_and_residual_vectors + + subroutine initial_flux_and_residual_vectors_prime +#ifdef SUNDIALS_ACTIVE + ! ** Compute initial flux and residual vectors ** + ! Note: Need this extra subroutine to handle the case of enthalpy as a state variable, currently only implemented in the prime version + ! If we implement it in the regular version, we can remove this subroutine + associate(& + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) , & ! intent(in): [i4b] number of snow layers + nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1) , & ! intent(in): [i4b] number of soil layers + scalarCanopyEnthalpy => prog_data%var(iLookPROG%scalarCanopyEnthalpy)%dat(1), & ! intent(inout): [dp] enthalpy of the vegetation canopy (J m-2) + scalarCanopyTemp => prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1) , & ! intent(inout): [dp] temperature of the vegetation canopy (K) + scalarCanopyWat => prog_data%var(iLookPROG%scalarCanopyWat)%dat(1) , & ! intent(inout): [dp] total water content of the vegetation canopy (kg m-2) + mLayerTemp => prog_data%var(iLookPROG%mLayerTemp)%dat , & ! intent(inout): [dp(:)] temperature of each snow/soil layer (K) + mLayerMatricHead => prog_data%var(iLookPROG%mLayerMatricHead)%dat & ! intent(out): [dp(:)] matric head (m) + &) + stateVecPrime(:) = 0._rkind ! prime initial values are 0 + firstSplitOper0 = firstSplitOper ! set the flag for the first split operation, do not want to reset it here + call eval8summaWithPrime(& + ! input: model control + dt, & ! intent(in): length of the entire time step (seconds) for drainage pond rate + nSnow, & ! intent(in): number of snow layers + nSoil, & ! intent(in): number of soil layers + nLayers, & ! intent(in): total number of layers + .false., & ! intent(in): not inside Sundials solver + firstSubStep, & ! intent(in): flag to indicate if we are processing the first sub-step + firstFluxCall, & ! intent(inout): flag to indicate if we are processing the first flux call + firstSplitOper0, & ! intent(inout): flag to indicate if we are processing the first flux call in a splitting operation + computeVegFlux, & ! intent(in): flag to indicate if we need to compute fluxes over vegetation + scalarSolution, & ! intent(in): flag to indicate the scalar solution + ! input: state vectors + stateVecTrial, & ! intent(in): model state vector + stateVecPrime, & ! intent(in): derivative of model state vector + sMul, & ! intent(inout): state vector multiplier (used in the residual calculations) + ! input: data structures + model_decisions, & ! intent(in): model decisions + lookup_data, & ! intent(in): lookup table data structure + type_data, & ! intent(in): type of vegetation and soil + attr_data, & ! intent(in): spatial attributes + mpar_data, & ! intent(in): model parameters + forc_data, & ! intent(in): model forcing data + bvar_data, & ! intent(in): average model variables for the entire basin + prog_data, & ! intent(in): model prognostic variables for a local HRU + ! input-output: data stuctures + indx_data, & ! intent(inout): index data + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + flux_init, & ! intent(inout): model fluxes for a local HRU + deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables + ! input-output: values needed in case canopy gets buried + scalarCanopyEnthalpy, & ! intent(inout): value for enthalpy of the vegetation canopy (J m-3) + scalarCanopyTemp, & ! intent(inout): value for temperature of the vegetation canopy (K), also used to start enthalpy calculations + scalarCanopyWat, & ! intent(inout): value for total water content of the vegetation canopy (kg m-2) + ! output: new values of variables needed in data window outside of internal IDA for rootfinding and to start enthalpy calculations + mLayerTemp, & ! intent(inout): vector of layer temperature (K) + mLayerMatricHead, & ! intent(out): value for total water matric potential (m) + ! output: new prime values of variables needed in data window outside of internal IDA for Jacobian + scalarCanopyTempPrime, & ! intent(out): prime value for temperature of the vegetation canopy (K s-1) + scalarCanopyWatPrime, & ! intent(out): prime value for total water content of the vegetation canopy (kg m-2 s-1) + mLayerTempPrime, & ! intent(out): prime vector of temperature of each snow and soil layer (K s-1) + mLayerMatricHeadPrime, & ! intent(out): prime vector of matric head of each snow and soil layer (m s-1) + mLayerVolFracWatPrime, & ! intent(out): prime vector of volumetric total water content of each snow and soil layer (s-1) + ! input-output: baseflow + ixSaturation, & ! intent(inout): index of the lowest saturated layer + dBaseflow_dMatric, & ! intent(out): derivative in baseflow w.r.t. matric head (s-1) + ! output: flux and residual vectors + feasible, & ! intent(out): flag to denote the feasibility of the solution + fluxVec0, & ! intent(out): flux vector + rAdd, & ! intent(out): sink terms on the RHS of the flux equation + resVec, & ! intent(out): residual vector + err,cmessage) ! intent(out): error control + end associate + if (err/=0) then; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if ! check for errors +#endif + end subroutine initial_flux_and_residual_vectors_prime + + subroutine Newton_step + ! ** Compute the Newton step using concepts from numerical recipes ** + associate(& + ! layer geometry + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1),& ! intent(in): [i4b] number of snow layers + nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1) & ! intent(in): [i4b] number of soil layers + ) + call in_SS4HG % initialize(dt_cur,dt,iter,nSnow,nSoil,nLayers,nLeadDim,nState,ixMatrix,firstSubStep,computeVegFlux,scalarSolution,fOld) + call io_SS4HG % initialize(firstFluxCall,xMin,xMax,ixSaturation) + call summaSolve4homegrown(in_SS4HG,& ! input: model control + &stateVecTrial,fScale,xScale,resVec,sMul,dMat,& ! input: state vectors + &model_decisions,lookup_data,type_data,attr_data,mpar_data,forc_data,bvar_data,prog_data,& ! input: data structures + &indx_data,diag_data,flux_temp,deriv_data,& ! input-output: data structures + &dBaseflow_dMatric,io_SS4HG,& ! input-output: baseflow + &stateVecNew,fluxVec,resSink,resVecNew,out_SS4HG) ! output + call io_SS4HG % finalize(firstFluxCall,xMin,xMax,ixSaturation) + call out_SS4HG % finalize(fNew,converged,err,cmessage) + end associate + if (err/=0) then; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if ! check for errors + + ! save the computed functions, residuals, and solution fOld = fNew - rVec = resVecNew + resVec = resVecNew stateVecTrial = stateVecNew + stateVecPrime = stateVecTrial !prime values not used here, dummy + nSteps = 1 ! number of time steps taken in solver + end subroutine Newton_step - ! print progress - !write(*,'(a,10(f16.14,1x))') 'rVec = ', rVec ( min(nState,iJac1) : min(nState,iJac2) ) - !write(*,'(a,10(f16.10,1x))') 'fluxVecNew = ', fluxVecNew ( min(nState,iJac1) : min(nState,iJac2) )*dt - !write(*,'(a,10(f16.10,1x))') 'stateVecTrial = ', stateVecTrial ( min(nState,iJac1) : min(nState,iJac2) ) - !print*, 'PAUSE: check states and fluxes'; read(*,*) + subroutine check_Newton_convergence + ! ** Check for convergence of current Newton step ** ! exit iteration loop if converged - if(converged) exit - + if (converged) then; exit_flag=.true.; return; end if + ! check convergence - if(iter==localMaxiter)then - message=trim(message)//'failed to converge' - err=-20; return - endif - !print*, 'PAUSE: iterating'; read(*,*) - - end do ! iterating - !print*, 'PAUSE: after iterations'; read(*,*) - - ! ----- - ! * update states... - ! ------------------ - - ! set untapped melt energy to zero - untappedMelt(:) = 0._rkind - - ! update temperatures (ensure new temperature is consistent with the fluxes) - if(nSnowSoilNrg>0)then - do concurrent (iLayer=1:nLayers,ixSnowSoilNrg(iLayer)/=integerMissing) ! (loop through non-missing energy state variables in the snow+soil domain) - iState = ixSnowSoilNrg(iLayer) - stateVecTrial(iState) = stateVecInit(iState) + (fluxVecNew(iState)*dt + resSinkNew(iState))/real(sMul(iState), rkind) - end do ! looping through non-missing energy state variables in the snow+soil domain - endif - - ! update volumetric water content in the snow (ensure change in state is consistent with the fluxes) - ! NOTE: for soil water balance is constrained within the iteration loop - if(nSnowSoilHyd>0)then - do concurrent (iLayer=1:nSnow,ixSnowSoilHyd(iLayer)/=integerMissing) ! (loop through non-missing water state variables in the snow domain) - iState = ixSnowSoilHyd(iLayer) - stateVecTrial(iState) = stateVecInit(iState) + (fluxVecNew(iState)*dt + resSinkNew(iState)) - end do ! looping through non-missing water state variables in the soil domain - endif - - ! end associate statements - end associate globalVars - - end subroutine systemSolv + if (iter==localMaxiter) then + message=trim(message)//'failed to converge' + err=-20; return_flag=.true.; return + end if + end subroutine check_Newton_convergence + + subroutine enforce_mass_conservation + ! Post processing step to “perfectly” conserve mass by pushing the errors into the state variables + ! NOTE: if the residual is large this will cause the state variables to be pushed outside of their bounds + layerVars: associate(& + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in): [i4b] number of snow layers + ! vector of energy and hydrology indices for the snow and soil domains + ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the snow+soil domain + ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the snow+soil domain + nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg )%dat(1),& ! intent(in): [i4b] number of energy state variables in the snow+soil domain + nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd )%dat(1) & ! intent(in): [i4b] number of hydrology state variables in the snow+soil domain + ) + + ! update temperatures (ensure new temperature is consistent with the fluxes) + if (nSnowSoilNrg>0) then + do concurrent (iLayer=1:nLayers,ixSnowSoilNrg(iLayer)/=integerMissing) ! loop through non-missing energy state variables in the snow+soil domain + iState = ixSnowSoilNrg(iLayer) + stateVecTrial(iState) = stateVecInit(iState) + (fluxVec(iState)*dt_cur + resSink(iState))/real(sMul(iState), rkind) + resVec(iState) = 0._qp + end do ! looping through non-missing energy state variables in the snow+soil domain + end if + + ! update volumetric water content in the snow (ensure change in state is consistent with the fluxes) + ! NOTE: for soil water balance is constrained within the iteration loop + if (nSnowSoilHyd>0) then + do concurrent (iLayer=1:nSnow,ixSnowSoilHyd(iLayer)/=integerMissing) ! (loop through non-missing water state variables in the snow domain) + iState = ixSnowSoilHyd(iLayer) + stateVecTrial(iState) = stateVecInit(iState) + (fluxVec(iState)*dt_cur + resSink(iState)) + resVec(iState) = 0._qp + end do ! looping through non-missing water state variables in the soil domain + end if + end associate layerVars + end subroutine enforce_mass_conservation + + subroutine solve_with_IDA +#ifdef SUNDIALS_ACTIVE + ! get tolerance vectors + call popTol4ida(& + ! input + nState, & ! intent(in): number of desired state variables + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(in): model diagnostic variables for a local HRU + indx_data, & ! intent(in): indices defining model states and layers + mpar_data, & ! intent(in): model parameters + ! output + atol, & ! intent(out): absolute tolerances vector (mixed units) + rtol, & ! intent(out): relative tolerances vector (mixed units) + err,cmessage) ! intent(out): error control + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if ! check for errors + + layerGeometry: associate(& + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1),& ! intent(in): [i4b] number of snow layers + nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1) & ! intent(in): [i4b] number of soil layers + ) + + ! allocate space for the temporary flux_sum structure + call allocLocal(flux_meta(:),flux_sum,nSnow,nSoil,err,cmessage) + if (err/=0) then; err=20; message=trim(message)//trim(cmessage); return; end if + + ! initialize flux_sum + do concurrent ( iVar=1:size(flux_meta) ) + flux_sum%var(iVar)%dat(:) = 0._rkind + end do + ! initialize sum of compression of the soil matrix + mLayerCmpress_sum(:) = 0._rkind + stateVecNew(:) = 0._rkind + stateVecPrime(:) = 0._rkind + + !--------------------------- + ! * solving F(y,y') = 0 by IDA, y is the state vector and y' is the time derivative vector dy/dt + !--------------------------- + ! iterations and updates to trial state vector, fluxes, and derivatives are done inside IDA solver + call summaSolve4ida(& + dt_cur, & ! intent(in): current stepsize + dt, & ! intent(in): entire time step for drainage pond rate + atol, & ! intent(in): absolute tolerance + rtol, & ! intent(in): relative tolerance + nSnow, & ! intent(in): number of snow layers + nSoil, & ! intent(in): number of soil layers + nLayers, & ! intent(in): number of snow+soil layers + nState, & ! intent(in): number of state variables in the current subset + ixMatrix, & ! intent(in): type of matrix (dense or banded) + firstSubStep, & ! intent(in): flag to indicate if we are processing the first sub-step + computeVegFlux, & ! intent(in): flag to indicate if we need to compute fluxes over vegetation + scalarSolution, & ! intent(in): flag to indicate the scalar solution + computMassBalance, & ! intent(in): flag to compute mass balance + computNrgBalance, & ! intent(in): flag to compute energy balance + ! input: state vector + stateVecTrial, & ! intent(in): model state vector at the beginning of the data time step + sMul, & ! intent(inout): state vector multiplier (used in the residual calculations) + dMat, & ! intent(inout): diagonal of the Jacobian matrix (excludes fluxes) + ! input: data structures + model_decisions, & ! intent(in): model decisions + lookup_data, & ! intent(in): lookup data + type_data, & ! intent(in): type of vegetation and soil + attr_data, & ! intent(in): spatial attributes + mpar_data, & ! intent(in): model parameters + forc_data, & ! intent(in): model forcing data + bvar_data, & ! intent(in): average model variables for the entire basin + prog_data, & ! intent(in): model prognostic variables for a local HRU + ! input-output: data structures + indx_data, & ! intent(inout): index data + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + flux_temp, & ! intent(inout): model fluxes for a local HRU + flux_sum, & ! intent(inout): sum of fluxes model fluxes for a local HRU over a data step + deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables + mLayerCmpress_sum, & ! intent(inout): sum of compression of the soil matrix + ! output + ixSaturation, & ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) + sunSucceeds, & ! intent(out): flag to indicate if ida successfully solved the problem in current data step + tooMuchMelt, & ! intent(inout): flag to denote that there was too much melt + nSteps, & ! intent(out): number of time steps taken in solver + stateVecNew, & ! intent(inout): model state vector (y) at the end of the data time step + stateVecPrime, & ! intent(inout): derivative of model state vector (y') at the end of the data time step + balance, & ! intent(inout): balance per state + err,cmessage) ! intent(out): error control + ! check if IDA is successful, only fail outright in the case of a non-recoverable error + if ( .not.sunSucceeds ) then + message=trim(message)//trim(cmessage) + if (err.ne.-20) err = 20 ! -20 is a recoverable error + return + else + if (tooMuchMelt) return !exit to start same step over after merge + end if + niter = 0 ! iterations are counted inside IDA solver + + ! save the computed solution + stateVecTrial = stateVecNew + + ! compute average flux + do iVar=1,size(flux_meta) + flux_temp%var(iVar)%dat(:) = ( flux_sum%var(iVar)%dat(:) ) / dt_cur + end do + + ! compute the total change in storage associated with compression of the soil matrix (kg m-2) + soilVars: associate(& + ! layer geometry + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat ,& ! depth of each layer in the snow-soil sub-domain (m) + mLayerCompress => diag_data%var(iLookDIAG%mLayerCompress)%dat ,& ! change in storage associated with compression of the soil matrix (-) + scalarSoilCompress => diag_data%var(iLookDIAG%scalarSoilCompress)%dat(1) & ! total change in storage associated with compression of the soil matrix (kg m-2 s-1) + ) + mLayerCompress = mLayerCmpress_sum / dt_cur + scalarSoilCompress = sum(mLayerCompress(1:nSoil)*mLayerDepth(nSnow+1:nLayers))*iden_water + end associate soilVars + end associate layerGeometry +#endif + end subroutine solve_with_IDA + + subroutine solve_with_KINSOL +#ifdef SUNDIALS_ACTIVE + associate(& + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1),& ! intent(in): [i4b] number of snow layers + nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1) & ! intent(in): [i4b] number of soil layers + ) + !--------------------------- + ! * solving F(y) = 0 from Backward Euler with KINSOL, y is the state vector + !--------------------------- + stateVecNew(:) = 0._rkind + ! iterations and updates to trial state vector, fluxes, and derivatives are done inside IDA solver + call summaSolve4kinsol(& + dt_cur, & ! intent(in): data time step + dt, & ! intent(in): length of the entire time step (seconds) for drainage pond rate + fScale, & ! intent(in): characteristic scale of the function evaluations + xScale, & ! intent(in): characteristic scale of the state vector + nSnow, & ! intent(in): number of snow layers + nSoil, & ! intent(in): number of soil layers + nLayers, & ! intent(in): number of snow+soil layers + nState, & ! intent(in): number of state variables in the current subset + ixMatrix, & ! intent(in): type of matrix (dense or banded) + firstSubStep, & ! intent(in): flag to indicate if we are processing the first sub-step + computeVegFlux, & ! intent(in): flag to indicate if we need to compute fluxes over vegetation + scalarSolution, & ! intent(in): flag to indicate the scalar solution + ! input: state vector + stateVecTrial, & ! intent(in): model state vector at the beginning of the data time step + sMul, & ! intent(inout): state vector multiplier (used in the residual calculations) + dMat, & ! intent(inout) diagonal of the Jacobian matrix (excludes fluxes) + ! input: data structures + model_decisions, & ! intent(in): model decisions + lookup_data, & ! intent(in): lookup tables + type_data, & ! intent(in): type of vegetation and soil + attr_data, & ! intent(in): spatial attributes + mpar_data, & ! intent(in): model parameters + forc_data, & ! intent(in): model forcing data + bvar_data, & ! intent(in): average model variables for the entire basin + prog_data, & ! intent(in): model prognostic variables for a local HRU + ! input-output: data structures + indx_data, & ! intent(inout): index data + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + flux_temp, & ! intent(inout): model fluxes for a local HRU + deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables + ! output + ixSaturation, & ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) + sunSucceeds, & ! intent(out): flag to indicate if ida successfully solved the problem in current data step + stateVecNew, & ! intent(inout): model state vector (y) at the end of the data time step + fluxVec, & ! intent(out): new flux vector + resSink, & ! intent(out): additional (sink) terms on the RHS of the state equation + resVec, & ! intent(out): new residual vector + err,cmessage) ! intent(out): error control + end associate + + ! check if KINSOL is successful, only fail outright in the case of a non-recoverable error + if ( .not.sunSucceeds ) then + message=trim(message)//trim(cmessage) + if (err.ne.-20) err = 20 ! -20 if hit maximum iterations + return + end if + niter = 0 ! iterations are counted inside KINSOL solver + nSteps = 1 ! number of time steps taken in solver + + ! save the computed solution + stateVecTrial = stateVecNew + stateVecPrime = stateVecTrial ! prime values not used here, dummy +#endif + end subroutine solve_with_KINSOL + + subroutine Newton_iterations_homegrown + ! ** Compute the backward Euler solution using Newton iterations from homegrown solver ** + + ! define maximum number of iterations + maxiter = nint(mpar_data%var(iLookPARAM%maxiter)%dat(1)) + + ! correct the number of iterations + localMaxIter = merge(scalarMaxIter, maxIter, scalarSolution) + + !--------------------------- + ! * solving F(y) = 0 from Backward Euler using concepts from numerical recipes, y is the state vector + !--------------------------- + ! iterate and update trial state vector, fluxes, and derivatives + exit_flag=.false. ! initialize exit flag + do iter=1,localMaxIter ! begin Newton iterations + niter = iter+1 ! # of iterations -- +1 because xFluxResid was moved outside the iteration loop (for backwards compatibility) + call Newton_step; if (return_flag) return ! compute Newton step -- return if error + call check_Newton_convergence ! check current Newton step for convergence + if (exit_flag) exit ! exit loop if convereged + if (return_flag) return ! return if error + end do + + if (post_massCons) call enforce_mass_conservation ! enforce mass conservation if desired + end subroutine Newton_iterations_homegrown + + subroutine finalize_systemSolv + ! set untapped melt energy to zero + untappedMelt(:) = 0._rkind + + ! free memory + deallocate(mLayerCmpress_sum) + deallocate(mLayerMatricHeadPrime) + deallocate(dBaseflow_dMatric) + end subroutine finalize_systemSolv + +end subroutine systemSolv end module systemSolv_module diff --git a/build/source/engine/tempAdjust.f90 b/build/source/engine/tempAdjust.f90 old mode 100755 new mode 100644 index cbc69963e..9fe8acd3c --- a/build/source/engine/tempAdjust.f90 +++ b/build/source/engine/tempAdjust.f90 @@ -25,8 +25,8 @@ module tempAdjust_module ! derived types to define the data structures USE data_types,only:& - var_d, & ! data vector (dp) - var_dlength ! data vector with variable length dimension (dp) + var_d, & ! data vector (rkind) + var_dlength ! data vector with variable length dimension (rkind) ! named variables defining elements in the data structures USE var_lookup,only:iLookPARAM,iLookPROG,iLookDIAG ! named variables for structure elements @@ -51,11 +51,11 @@ module tempAdjust_module ! ************************************************************************************************ subroutine tempAdjust(& ! input: derived parameters - canopyDepth, & ! intent(in): canopy depth (m) + canopyDepth, & ! intent(in): canopy depth (m) ! input/output: data structures mpar_data, & ! intent(in): model parameters prog_data, & ! intent(inout): model prognostic variables for a local HRU - diag_data, & ! intent(out): model diagnostic variables for a local HRU + diag_data, & ! intent(inout): model diagnostic variables for a local HRU ! output: error control err,message) ! intent(out): error control ! ------------------------------------------------------------------------------------------------ @@ -65,56 +65,50 @@ subroutine tempAdjust(& implicit none ! ------------------------------------------------------------------------------------------------ ! input: derived parameters - real(rkind),intent(in) :: canopyDepth ! depth of the vegetation canopy (m) - ! input/output: data structures - type(var_dlength),intent(in) :: mpar_data ! model parameters - type(var_dlength),intent(inout) :: prog_data ! model prognostic variables for a local HRU - type(var_dlength),intent(inout) :: diag_data ! model diagnostic variables for a local HRU - ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + real(rkind),intent(in) :: canopyDepth ! depth of the vegetation canopy (m) + ! input/output: data structures + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_dlength),intent(inout) :: prog_data ! model prognostic variables for a local HRU + type(var_dlength),intent(inout) :: diag_data ! model diagnostic variables for a local HRU + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message ! ------------------------------------------------------------------------------------------------ ! local variables for canopy thermodynamics - integer(i4b) :: iTry ! trial index - integer(i4b) :: iter ! iteration index - integer(i4b),parameter :: maxiter=100 ! maximum number of iterations - real(rkind) :: fLiq ! fraction of liquid water (-) - real(rkind) :: tempMin,tempMax ! solution constraints for temperature (K) - real(rkind) :: nrgMeltFreeze ! energy required to melt-freeze the water to the current canopy temperature (J m-3) - real(rkind) :: scalarCanopyWat ! total canopy water (kg m-2) - real(rkind) :: scalarCanopyIceOld ! canopy ice content after melt-freeze to the initial temperature (kg m-2) - real(rkind),parameter :: resNrgToler=0.1_rkind ! tolerance for the energy residual (J m-3) - real(rkind) :: f1,f2,x1,x2,fTry,xTry,fDer,xInc ! iteration variables - logical(lgt) :: fBis ! .true. if bisection + integer(i4b) :: iTry ! trial index + integer(i4b) :: iter ! iteration index + integer(i4b),parameter :: maxiter=100 ! maximum number of iterations + real(rkind) :: fLiq ! fraction of liquid water (-) + real(rkind) :: tempMin,tempMax ! solution constraints for temperature (K) + real(rkind) :: nrgMeltFreeze ! energy required to melt-freeze the water to the current canopy temperature (J m-3) + real(rkind) :: scalarCanopyWat ! total canopy water (kg m-2) + real(rkind) :: scalarCanopyIceOld ! canopy ice content after melt-freeze to the initial temperature (kg m-2) + real(rkind),parameter :: resNrgToler=0.1_rkind ! tolerance for the energy residual (J m-3) + real(rkind) :: f1,f2,x1,x2,fTry,xTry,fDer,xInc ! iteration variables + logical(lgt) :: fBis ! .true. if bisection ! ------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='tempAdjust/' ! ------------------------------------------------------------------------------------------------ ! associate variables in the data structure associate(& - ! model parameters for canopy thermodynamics (input) - snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1), & ! intent(in): [dp] scaling factor for snow freezing curve (K) - specificHeatVeg => mpar_data%var(iLookPARAM%specificHeatVeg)%dat(1), & ! intent(in): [dp] specific heat of vegetation mass (J kg-1 K-1) - maxMassVegetation => mpar_data%var(iLookPARAM%maxMassVegetation)%dat(1), & ! intent(in): [dp] maximum mass of vegetation (full foliage) (kg m-2) - + snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1), & ! intent(in): [dp] scaling factor for snow freezing curve (K) + specificHeatVeg => mpar_data%var(iLookPARAM%specificHeatVeg)%dat(1), & ! intent(in): [dp] specific heat of vegetation mass (J kg-1 K-1) + maxMassVegetation => mpar_data%var(iLookPARAM%maxMassVegetation)%dat(1), & ! intent(in): [dp] maximum mass of vegetation (full foliage) (kg m-2) ! state variables (input/output) scalarCanopyLiq => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1), & ! intent(inout): [dp] mass of liquid water on the vegetation canopy (kg m-2) scalarCanopyIce => prog_data%var(iLookPROG%scalarCanopyIce)%dat(1), & ! intent(inout): [dp] mass of ice on the vegetation canopy (kg m-2) scalarCanopyTemp => prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1), & ! intent(inout): [dp] temperature of the vegetation canopy (K) - ! diagnostic variables (output) - scalarBulkVolHeatCapVeg => diag_data%var(iLookDIAG%scalarBulkVolHeatCapVeg)%dat(1) & ! intent(out): [dp] volumetric heat capacity of the vegetation (J m-3 K-1) - + scalarBulkVolHeatCapVeg => diag_data%var(iLookDIAG%scalarBulkVolHeatCapVeg)%dat(1) & ! intent(out): [dp] volumetric heat capacity of the vegetation (J m-3 K-1) ) ! associate variables in the data structures ! ----------------------------------------------------------------------------------------------------------------------------------------------------- - ! ** preliminaries ! compute the total canopy water (state variable: will not change) scalarCanopyWat = scalarCanopyLiq + scalarCanopyIce - !write(*,'(a,1x,3(f20.10,1x))') 'scalarCanopyWat, scalarCanopyLiq, scalarCanopyIce = ', scalarCanopyWat, scalarCanopyLiq, scalarCanopyIce - + ! compute the fraction of liquid water associated with the canopy temperature fLiq = fracliquid(scalarCanopyTemp,snowfrz_scale) @@ -134,7 +128,7 @@ subroutine tempAdjust(& ! ** get ready for iterating - ! compute initial function and derivative + ! compute initial function x1 = scalarCanopyTemp f1 = nrgMeltFreeze fDer = resNrgDer(x1,scalarBulkVolHeatCapVeg,snowfrz_scale) @@ -142,109 +136,85 @@ subroutine tempAdjust(& ! compute new function based on newton step from the first function x2 = x1 + f1 / fDer f2 = resNrgFunc(x2,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) - !print*, 'x1, x2 = ', x1, x2 - !print*, 'f1, f2 = ', f1, f2 - - ! ensure that we bracket the root + + ! ensure that we bracket the root and recompute x2 if not if(f1*f2 > 0._rkind)then - xInc = f1 / fDer - x2 = 1._rkind - do iter=1,maxiter - ! successively expand limit in order to bracket the root - x2 = x1 + sign(x2,xInc)*2._rkind - f2 = resNrgFunc(x2,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) - if(f1*f2 < 0._rkind)exit - ! check that we bracketed the root - ! (should get here in just a couple of expansions) - if(iter==maxiter)then - message=trim(message)//'unable to bracket the root' - err=20; return - end if - end do ! trying to bracket the root + xInc = f1 / fDer + x2 = 1._rkind + do iter=1,maxiter + ! successively expand limit in order to bracket the root + x2 = x1 + sign(x2,xInc)*2._rkind + f2 = resNrgFunc(x2,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) + if(f1*f2 < 0._rkind)exit + ! check that we bracketed the root (should get here in just a couple of expansions) + if(iter==maxiter)then + message=trim(message)//'unable to bracket the root' + err=20; return + end if + end do ! trying to bracket the root end if ! first check that we bracketed the root - !print*, 'x1, x2 = ', x1, x2 - !print*, 'f1, f2 = ', f1, f2 ! define initial constraints if(x1 < x2)then - tempMin = x1 - tempMax = x2 + tempMin = x1 + tempMax = x2 else - tempMin = x2 - tempMax = x1 + tempMin = x2 + tempMax = x1 end if - !print*, 'tempMin, tempMax = ', tempMin, tempMax ! get starting trial xInc = huge(1._rkind) xTry = 0.5_rkind*(x1 + x2) fTry = resNrgFunc(xTry,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) fDer = resNrgDer(xTry,scalarBulkVolHeatCapVeg,snowfrz_scale) - !print*, 'xTry = ', xTry - !print*, 'fTry = ', fTry - - ! check the functions at the limits (should be of opposing sign) - !f1 = resNrgFunc(tempMax,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) - !f2 = resNrgFunc(tempMin,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) - !print*, 'f1, f2 = ', f1, f2 ! ----------------------------------------------------------------------------------------------------------------------------------------------------- ! iterate do iter=1,maxiter + if(xTry <= tempMin .or. xTry >= tempMax)then ! bisect if out of range + xTry = 0.5_rkind*(tempMin + tempMax) ! new value + fBis = .true. + else ! value in range; use the newton step + xInc = fTry/fDer + xTry = xTry + xInc + fBis = .false. + end if ! (switch between bi-section and newton) + + ! compute new function + fTry = resNrgFunc(xTry,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) + fDer = resNrgDer(xTry,scalarBulkVolHeatCapVeg,snowfrz_scale) + + ! update limits + if(fTry < 0._rkind)then + tempMax = min(xTry,tempMax) + else + tempMin = max(tempMin,xTry) + end if + + ! check the functions at the limits (should be of opposing sign) + !f1 = resNrgFunc(tempMax,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) + !f2 = resNrgFunc(tempMin,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) - ! bisect if out of range - if(xTry <= tempMin .or. xTry >= tempMax)then - xTry = 0.5_rkind*(tempMin + tempMax) ! new value - fBis = .true. - - ! value in range; use the newton step - else - xInc = fTry/fDer - xTry = xTry + xInc - fBis = .false. - - end if ! (switch between bi-section and newton) - - ! compute new function and derivative - fTry = resNrgFunc(xTry,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) - fDer = resNrgDer(xTry,scalarBulkVolHeatCapVeg,snowfrz_scale) - !print*, 'tempMin, tempMax = ', tempMin, tempMax - - ! update limits - if(fTry < 0._rkind)then - tempMax = min(xTry,tempMax) - else - tempMin = max(tempMin,xTry) - end if - - ! check the functions at the limits (should be of opposing sign) - !f1 = resNrgFunc(tempMax,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) - !f2 = resNrgFunc(tempMin,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) - !print*, 'f1, f2 = ', f1, f2 - - ! print progress - !write(*,'(a,1x,i4,1x,l1,1x,e20.10,1x,4(f20.10,1x))') 'iter, fBis, fTry, xTry, xInc, tempMin, tempMax = ', iter, fBis, fTry, xTry, xInc, tempMin, tempMax - - ! check convergence - if(abs(fTry) < resNrgToler) exit - - ! check non-convergence - if(iter==maxiter)then - ! (print out a 1-d x-section) - do iTry=1,maxiter - xTry = 1.0_rkind*real(iTry,kind(1._rkind))/real(maxiter,kind(1._rkind)) + 272.5_rkind - fTry = resNrgFunc(xTry,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) - write(*,'(a,1x,i4,1x,e20.10,1x,4(f20.10,1x))') 'iTry, fTry, xTry = ', iTry, fTry, xTry - end do - ! (return with error) - message=trim(message)//'unable to converge' - err=20; return - end if + ! check convergence + if(abs(fTry) < resNrgToler) exit + ! check non-convergence + if(iter==maxiter)then + ! (print out a 1-d x-section) + do iTry=1,maxiter + xTry = 1.0_rkind*real(iTry,kind(1._rkind))/real(maxiter,kind(1._rkind)) + 272.5_rkind + fTry = resNrgFunc(xTry,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) + write(*,'(a,1x,i4,1x,e20.10,1x,4(f20.10,1x))') 'iTry, fTry, xTry = ', iTry, fTry, xTry + end do + ! (return with error) + message=trim(message)//'unable to converge' + err=20; return + end if end do ! iterating ! ----------------------------------------------------------------------------------------------------------------------------------------------------- - ! update state variables + ! update state variables, but not heat capacity since used heat capacity to get these values scalarCanopyTemp = xTry scalarCanopyIce = (1._rkind - fracliquid(xTry,snowfrz_scale))*scalarCanopyWat scalarCanopyLiq = scalarCanopyWat - scalarCanopyIce @@ -258,36 +228,36 @@ subroutine tempAdjust(& ! ************************************************************************************************ ! internal function resNrgFunc: calculate the residual in energy (J m-3) ! ************************************************************************************************ - function resNrgFunc(xTemp,xTemp0,bulkVolHeatCapVeg,snowfrz_scale) + function resNrgFunc(xTemp,xTemp0,scalarBulkVolHeatCapVeg,snowfrz_scale) ! implicit none real(rkind),intent(in) :: xTemp ! temperature (K) real(rkind),intent(in) :: xTemp0 ! initial temperature (K) - real(rkind),intent(in) :: bulkVolHeatCapVeg ! volumetric heat capacity of veg (J m-3 K-1) + real(rkind),intent(in) :: scalarBulkVolHeatCapVeg ! volumetric heat capacity of veg (J m-3 K-1) real(rkind),intent(in) :: snowfrz_scale ! scaling factor in freezing curve (K-1) real(rkind) :: xIce ! canopy ice content (kg m-2) real(rkind) :: resNrgFunc ! residual in energy (J m-3) xIce = (1._rkind - fracliquid(xTemp,snowfrz_scale))*scalarCanopyWat - resNrgFunc = -bulkVolHeatCapVeg*(xTemp - xTemp0) + LH_fus*(xIce - scalarCanopyIceOld)/canopyDepth + nrgMeltFreeze + resNrgFunc = -scalarBulkVolHeatCapVeg*(xTemp - xTemp0) + LH_fus*(xIce - scalarCanopyIceOld)/canopyDepth + nrgMeltFreeze return end function resNrgFunc - ! ************************************************************************************************ ! internal function resNrgDer: calculate the derivative (J m-3 K-1) ! ************************************************************************************************ - function resNrgDer(xTemp,bulkVolHeatCapVeg,snowfrz_scale) + function resNrgDer(xTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) implicit none real(rkind),intent(in) :: xTemp ! temperature (K) - real(rkind),intent(in) :: bulkVolHeatCapVeg ! volumetric heat capacity of veg (J m-3 K-1) + real(rkind),intent(in) :: scalarBulkVolHeatCapVeg ! volumetric heat capacity of veg (J m-3 K-1) real(rkind),intent(in) :: snowfrz_scale ! scaling factor in freezing curve (K-1) real(rkind) :: dW_dT ! derivative in canopy ice content w.r.t. temperature (kg m-2 K-1) real(rkind) :: resNrgDer ! derivative (J m-3 K-1) dW_dT = -scalarCanopyWat*dFracLiq_dTk(xTemp,snowfrz_scale) - resNrgDer = bulkVolHeatCapVeg - dW_dT*LH_fus/canopyDepth + resNrgDer = scalarBulkVolHeatCapVeg - dW_dT*LH_fus/canopyDepth return end function resNrgDer + end subroutine tempAdjust diff --git a/build/source/engine/time_utils.f90 b/build/source/engine/time_utils.f90 old mode 100755 new mode 100644 index 451dc037f..2d56110cf --- a/build/source/engine/time_utils.f90 +++ b/build/source/engine/time_utils.f90 @@ -328,7 +328,7 @@ subroutine compcalday(julday, & !input integer(i4b), intent(out) :: id ! day integer(i4b), intent(out) :: ih ! hour integer(i4b), intent(out) :: imin ! minute - real(rkind), intent(out) :: dsec ! seconds + real(rkind), intent(out) :: dsec ! seconds integer(i4b), intent(out) :: err ! error code character(*), intent(out) :: message ! error message diff --git a/build/source/engine/tol4ida.f90 b/build/source/engine/tol4ida.f90 new file mode 100644 index 000000000..4d890894e --- /dev/null +++ b/build/source/engine/tol4ida.f90 @@ -0,0 +1,279 @@ +module tol4ida_module + +!======= Inclusions =========== +use, intrinsic :: iso_c_binding +use nrtype +use type4ida + +! missing values +USE globalData,only:integerMissing ! missing integer +USE globalData,only:realMissing ! missing real number + +! named variables to describe the state variable type +USE globalData,only:iname_nrgCanair ! named variable defining the energy of the canopy air space +USE globalData,only:iname_nrgCanopy ! named variable defining the energy of the vegetation canopy +USE globalData,only:iname_watCanopy ! named variable defining the mass of total water on the vegetation canopy +USE globalData,only:iname_liqCanopy ! named variable defining the mass of liquid water on the vegetation canopy +USE globalData,only:iname_nrgLayer ! named variable defining the energy state variable for snow+soil layers +USE globalData,only:iname_watLayer ! named variable defining the total water state variable for snow+soil layers +USE globalData,only:iname_liqLayer ! named variable defining the liquid water state variable for snow+soil layers +USE globalData,only:iname_matLayer ! named variable defining the matric head state variable for soil layers +USE globalData,only:iname_lmpLayer ! named variable defining the liquid matric potential state variable for soil layers +USE globalData,only:iname_watAquifer ! named variable defining the water storage in the aquifer + +! metadata for information in the data structures +USE globalData,only:indx_meta ! metadata for the variables in the index structure + +! provide access to the derived types to define the data structures +USE data_types,only:& + var_i, & ! data vector (i4b) + var_d, & ! data vector (rkind) + var_ilength, & ! data vector with variable length dimension (i4b) + var_dlength ! data vector with variable length dimension (rkind) + +! provide access to indices that define elements of the data structures +USE var_lookup,only:iLookDIAG ! named variables for structure elements +USE var_lookup,only:iLookPROG ! named variables for structure elements +USE var_lookup,only:iLookDERIV ! named variables for structure elements +USE var_lookup,only:iLookPARAM ! named variables for structure elements +USE var_lookup,only:iLookINDEX ! named variables for structure elements + + +! privacy +implicit none +private +public::computWeight4ida +public::popTol4ida + + +contains + +! ********************************************************************************************************** +! public function computWeight4ida: compute w_i = 1 / ( rtol_i * y_i + atol_i ) +! ********************************************************************************************************** +! Return values: +! 0 = success, +! -1 = non-recoverable error, NaN or negative values +! ---------------------------------------------------------------- +integer(c_int) function computWeight4ida(sunvec_y, sunvec_ewt, user_data) & + result(ierr) bind(C,name='computWeight4ida') + + !======= Inclusions =========== + use, intrinsic :: iso_c_binding + use fsundials_core_mod + use fnvector_serial_mod + use nrtype + use type4ida + + !======= Declarations ========= + implicit none + + ! calling variables + type(N_Vector) :: sunvec_y ! solution N_Vector y + type(N_Vector) :: sunvec_ewt ! derivative N_Vector W + type(c_ptr), value :: user_data ! user-defined data + + ! pointers to data in SUNDIALS vectors + type(data4ida), pointer :: tol_data ! equations data + real(rkind), pointer :: stateVec(:) + real(rkind), pointer :: weightVec(:) + integer(c_int) :: iState + + !======= Internals ============ + + ! get equations data from user-defined data + call c_f_pointer(user_data, tol_data) + + ! get data arrays from SUNDIALS vectors + stateVec(1:tol_data%nState) => FN_VGetArrayPointer(sunvec_y) + weightVec(1:tol_data%nState) => FN_VGetArrayPointer(sunvec_ewt) + + do iState = 1,tol_data%nState + weightVec(iState) = tol_data%rtol(iState) * abs( stateVec(iState) ) + tol_data%atol(iState) + weightVec(iState) = 1._rkind / weightVec(iState) + end do + + ierr = 0 + return + +end function computWeight4ida + + +! ********************************************************************************************************** +! public subroutine popTol4ida: populate tolerances for state vectors +! ********************************************************************************************************** +subroutine popTol4ida(& + ! input: data structures + nState, & ! intent(in): number of desired state variables + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(in): model diagnostic variables for a local HRU + indx_data, & ! intent(in): indices defining model states and layers + mpar_data, & ! intent(in) + ! output + absTol, & ! intent(out): model state vector + relTol, & + err,message) ! intent(out): error control + ! -------------------------------------------------------------------------------------------------------------------------------- + ! input: data structures + integer(i4b),intent(in) :: nState ! number of desired state variables + type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU + type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU + type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers + type(var_dlength),intent(in) :: mpar_data ! model parameters + ! output + real(rkind),intent(out) :: absTol(:) ! model state vector (mixed units) + real(rkind),intent(out) :: relTol(:) ! model state vector (mixed units) + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! -------------------------------------------------------------------------------------------------------------------------------- + ! local variables + ! -------------------------------------------------------------------------------------------------------------------------------- + ! state subsets + integer(i4b) :: iState ! index of state within the snow+soil domain + integer(i4b) :: iLayer ! index of layer within the snow+soil domain + integer(i4b) :: ixStateSubset ! index within the state subset + logical(lgt),dimension(nState) :: tolFlag ! flag to denote that the state is populated + real(rkind) :: absTolTempCas + real(rkind) :: relTolTempCas + real(rkind) :: absTolTempVeg + real(rkind) :: relTolTempVeg + real(rkind) :: absTolWatVeg + real(rkind) :: relTolWatVeg + real(rkind) :: absTolTempSoilSnow + real(rkind) :: relTolTempSoilSnow + real(rkind) :: absTolWatSnow + real(rkind) :: relTolWatSnow + real(rkind) :: absTolMatric + real(rkind) :: relTolMatric + real(rkind) :: absTolAquifr + real(rkind) :: relTolAquifr + + ! -------------------------------------------------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------------------------------------------------- + ! make association with variables in the data structures + fixedLength: associate(& + scalarCanairTemp => prog_data%var(iLookPROG%scalarCanairTemp)%dat(1) ,& ! intent(in) : [dp] temperature of the canopy air space (K) + scalarCanopyTemp => prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1) ,& ! intent(in) : [dp] temperature of the vegetation canopy (K) + scalarCanopyWat => prog_data%var(iLookPROG%scalarCanopyWat)%dat(1) ,& ! intent(in) : [dp] mass of total water on the vegetation canopy (kg m-2) + scalarCanopyLiq => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1) ,& ! intent(in) : [dp] mass of liquid water on the vegetation canopy (kg m-2) + ! model state variable vectors for the snow-soil layers + mLayerTemp => prog_data%var(iLookPROG%mLayerTemp)%dat ,& ! intent(in) : [dp(:)] temperature of each snow/soil layer (K) + mLayerVolFracWat => prog_data%var(iLookPROG%mLayerVolFracWat)%dat ,& ! intent(in) : [dp(:)] volumetric fraction of total water (-) + mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat ,& ! intent(in) : [dp(:)] volumetric fraction of liquid water (-) + mLayerMatricHead => prog_data%var(iLookPROG%mLayerMatricHead)%dat ,& ! intent(in) : [dp(:)] matric head (m) + mLayerMatricHeadLiq => diag_data%var(iLookDIAG%mLayerMatricHeadLiq)%dat ,& ! intent(in) : [dp(:)] matric potential of liquid water (m) + ! model state variables for the aquifer + scalarAquiferStorage=> prog_data%var(iLookPROG%scalarAquiferStorage)%dat(1) ,& ! intent(in) : [dp] storage of water in the aquifer (m) + ! indices defining specific model states + ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat ,& ! intent(in) : [i4b(:)] [length=1] index of canopy air space energy state variable + ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat ,& ! intent(in) : [i4b(:)] [length=1] index of canopy energy state variable + ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat ,& ! intent(in) : [i4b(:)] [length=1] index of canopy hydrology state variable (mass) + ixAqWat => indx_data%var(iLookINDEX%ixAqWat)%dat ,& ! intent(in) : [i4b(:)] [length=1] index of aquifer storage state variable + ! vector of energy and hydrology indices for the snow and soil domains + ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in) : [i4b(:)] index in the state subset for energy state variables in the snow+soil domain + ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in) : [i4b(:)] index in the state subset for hydrology state variables in the snow+soil domain + nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg )%dat(1) ,& ! intent(in) : [i4b] number of energy state variables in the snow+soil domain + nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd )%dat(1) ,& ! intent(in) : [i4b] number of hydrology state variables in the snow+soil domain + ! type of model state variabless + ixStateType_subset => indx_data%var(iLookINDEX%ixStateType_subset)%dat ,& ! intent(in) : [i4b(:)] [state subset] type of desired model state variables + ixHydType => indx_data%var(iLookINDEX%ixHydType)%dat ,& ! intent(in) : [i4b(:)] index of the type of hydrology states in snow+soil domain + ! number of layers + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in) : [i4b] number of snow layers + nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1) ,& ! intent(in) : [i4b] number of soil layers + nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1) & ! intent(in) : [i4b] total number of layers + ) ! end association with variables in the data structures + ! -------------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message='popTol4ida/' + + absTolTempCas = mpar_data%var(iLookPARAM%absTolTempCas)%dat(1) + relTolTempCas = mpar_data%var(iLookPARAM%relTolTempCas)%dat(1) + absTolTempVeg = mpar_data%var(iLookPARAM%absTolTempVeg)%dat(1) + relTolTempVeg = mpar_data%var(iLookPARAM%relTolTempVeg)%dat(1) + absTolWatVeg = mpar_data%var(iLookPARAM%absTolWatVeg)%dat(1) + relTolWatVeg = mpar_data%var(iLookPARAM%relTolWatVeg)%dat(1) + absTolTempSoilSnow = mpar_data%var(iLookPARAM%absTolTempSoilSnow)%dat(1) + relTolTempSoilSnow = mpar_data%var(iLookPARAM%relTolTempSoilSnow)%dat(1) + absTolWatSnow = mpar_data%var(iLookPARAM%absTolWatSnow)%dat(1) + relTolWatSnow = mpar_data%var(iLookPARAM%relTolWatSnow)%dat(1) + absTolMatric = mpar_data%var(iLookPARAM%absTolMatric)%dat(1) + relTolMatric = mpar_data%var(iLookPARAM%relTolMatric)%dat(1) + absTolAquifr = mpar_data%var(iLookPARAM%absTolAquifr)%dat(1) + relTolAquifr = mpar_data%var(iLookPARAM%relTolAquifr)%dat(1) + + ! ----- + ! * initialize state vectors... + ! ----------------------------- + + ! initialize flags + tolFlag(:) = .false. + + ! NOTE: currently vector length=1, and use "do concurrent" to generalize to a multi-layer canopy + do concurrent (iState=1:size(ixCasNrg),ixCasNrg(iState)/=integerMissing) + absTol( ixCasNrg(iState) ) = absTolTempCas ! transfer canopy air temperature to the state vector + relTol( ixCasNrg(iState) ) = relTolTempCas + tolFlag( ixCasNrg(iState) ) = .true. ! flag to denote that tolerances are populated + end do + + ! NOTE: currently vector length=1, and use "do concurrent" to generalize to a multi-layer canopy + do concurrent (iState=1:size(ixVegNrg),ixVegNrg(iState)/=integerMissing) + absTol( ixVegNrg(iState) ) = absTolTempVeg ! transfer vegetation temperature to the state vector + relTol( ixVegNrg(iState) ) = relTolTempVeg ! transfer vegetation temperature to the state vector + tolFlag( ixVegNrg(iState) ) = .true. ! flag to denote that tolerances are populated + end do + + ! NOTE: currently vector length=1, and use "do concurrent" to generalize to a multi-layer canopy + do concurrent (iState=1:size(ixVegHyd),ixVegHyd(iState)/=integerMissing) + tolFlag( ixVegHyd(iState) ) = .true. ! flag to denote that tolerances are populated + select case(ixStateType_subset( ixVegHyd(iState) )) + case(iname_watCanopy); absTol( ixVegHyd(iState) ) = absTolWatVeg ; relTol( ixVegHyd(iState) ) = relTolWatVeg + case(iname_liqCanopy); absTol( ixVegHyd(iState) ) = absTolWatVeg ; relTol( ixVegHyd(iState) ) = relTolWatVeg ! transfer liquid canopy water to the state vector + case default; tolFlag( ixVegHyd(iState) ) = .false. ! flag to denote that tolerances are populated + end select + end do + + ! tolerance for tempreture of the snow and soil domain + if(nSnowSoilNrg>0)then + do concurrent (iLayer=1:nLayers,ixSnowSoilNrg(iLayer)/=integerMissing) ! (loop through non-missing energy state variables in the snow+soil domain) + ixStateSubset = ixSnowSoilNrg(iLayer) ! index within the state vector + absTol(ixStateSubset) = absTolTempSoilSnow ! transfer temperature from a layer to the state vector + relTol(ixStateSubset) = relTolTempSoilSnow + tolFlag(ixStateSubset) = .true. ! flag to denote that tolerances are populated + end do ! looping through non-missing energy state variables in the snow+soil domain + endif + + ! NOTE: ixVolFracWat and ixVolFracLiq can also include states in the soil domain, hence enable primary variable switching + if(nSnowSoilHyd>0)then + do concurrent (iLayer=1:nLayers,ixSnowSoilHyd(iLayer)/=integerMissing) ! (loop through non-missing hydrology state variables in the snow+soil domain) + ixStateSubset = ixSnowSoilHyd(iLayer) ! index within the state vector + tolFlag(ixStateSubset) = .true. ! flag to denote that tolerances are populated + select case( ixHydType(iLayer) ) + case(iname_watLayer); absTol(ixStateSubset) = absTolWatSnow ; relTol(ixStateSubset) = relTolWatSnow + case(iname_liqLayer); absTol(ixStateSubset) = absTolWatSnow ; relTol(ixStateSubset) = relTolWatSnow + case(iname_matLayer); absTol(ixStateSubset) = absTolMatric ; relTol(ixStateSubset) = relTolMatric + case(iname_lmpLayer); absTol(ixStateSubset) = absTolMatric ; relTol(ixStateSubset) = relTolMatric + case default; tolFlag(ixStateSubset) = .false. ! flag to denote that tolerances are populated + end select + end do ! looping through non-missing energy state variables in the snow+soil domain + endif + + ! build the state vector for the aquifer storage + ! NOTE: currently vector length=1, and use "do concurrent" to generalize to a multi-layer aquifer + do concurrent (iState=1:size(ixAqWat),ixAqWat(iState)/=integerMissing) + absTol( ixAqWat(iState) ) = absTolAquifr ! transfer aquifer storage to the state vector + relTol( ixAqWat(iState) ) = relTolAquifr + tolFlag( ixAqWat(iState) ) = .true. ! flag to denote that tolerances are populated + end do + + ! check that we specified tolerances for all state variables + if(count(tolFlag)/=nState)then + print*, 'tolFlag = ', tolFlag + message=trim(message)//'tolerances not specified for some state variables' + err=20; return + endif + + end associate fixedLength ! end association to variables in the data structure where vector length does not change +end subroutine popTol4ida + + +end module tol4ida_module diff --git a/build/source/engine/updatState.f90 b/build/source/engine/updatState.f90 old mode 100755 new mode 100644 index 88bd826df..31b1bfb58 --- a/build/source/engine/updatState.f90 +++ b/build/source/engine/updatState.f90 @@ -23,10 +23,9 @@ module updatState_module ! physical constants USE multiconst,only:& Tfreeze, & ! freezing point of pure water (K) - iden_air, & ! intrinsic density of air (kg m-3) iden_ice, & ! intrinsic density of ice (kg m-3) iden_water, & ! intrinsic density of water (kg m-3) - gravity, & ! gravitational acceleteration (m s-2) + gravity, & ! gravitational acceleration (m s-2) LH_fus ! latent heat of fusion (J kg-1) implicit none private @@ -35,134 +34,109 @@ module updatState_module contains - ! ************************************************************************************************************* - ! public subroutine updateSnow: compute phase change impacts on volumetric liquid water and ice - ! ************************************************************************************************************* - subroutine updateSnow(& - ! input - mLayerTemp ,& ! intent(in): temperature (K) - mLayerTheta ,& ! intent(in): volume fraction of total water (-) - snowfrz_scale ,& ! intent(in): scaling parameter for the snow freezing curve (K-1) - ! output - mLayerVolFracLiq ,& ! intent(out): volumetric fraction of liquid water (-) - mLayerVolFracIce ,& ! intent(out): volumetric fraction of ice (-) - fLiq ,& ! intent(out): fraction of liquid water (-) - err,message) ! intent(out): error control - ! utility routines - USE snow_utils_module,only:fracliquid ! compute volumetric fraction of liquid water - implicit none - ! input variables - real(rkind),intent(in) :: mLayerTemp ! temperature (K) - real(rkind),intent(in) :: mLayerTheta ! volume fraction of total water (-) - real(rkind),intent(in) :: snowfrz_scale ! scaling parameter for the snow freezing curve (K-1) - ! output variables - real(rkind),intent(out) :: mLayerVolFracLiq ! volumetric fraction of liquid water (-) - real(rkind),intent(out) :: mLayerVolFracIce ! volumetric fraction of ice (-) - real(rkind),intent(out) :: fLiq ! fraction of liquid water (-) - ! error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - - ! initialize error control - err=0; message="updateSnow/" - - ! compute the volumetric fraction of liquid water and ice (-) - fLiq = fracliquid(mLayerTemp,snowfrz_scale) - mLayerVolFracLiq = fLiq*mLayerTheta - mLayerVolFracIce = (1._rkind - fLiq)*mLayerTheta*(iden_water/iden_ice) - !print*, 'mLayerTheta - (mLayerVolFracIce*(iden_ice/iden_water) + mLayerVolFracLiq) = ', mLayerTheta - (mLayerVolFracIce*(iden_ice/iden_water) + mLayerVolFracLiq) - !write(*,'(a,1x,4(f20.10,1x))') 'in updateSnow: fLiq, mLayerTheta, mLayerVolFracIce = ', & - ! fLiq, mLayerTheta, mLayerVolFracIce - !pause - - end subroutine updateSnow - - ! ************************************************************************************************************* - ! public subroutine updateSoil: compute phase change impacts on matric head and volumetric liquid water and ice - ! ************************************************************************************************************* - subroutine updateSoil(& - ! input - mLayerTemp ,& ! intent(in): temperature vector (K) - mLayerMatricHead ,& ! intent(in): matric head (m) - vGn_alpha ,& ! intent(in): van Genutchen "alpha" parameter - vGn_n ,& ! intent(in): van Genutchen "n" parameter - theta_sat ,& ! intent(in): soil porosity (-) - theta_res ,& ! intent(in): soil residual volumetric water content (-) - vGn_m ,& ! intent(in): van Genutchen "m" parameter (-) - ! output - mLayerVolFracWat ,& ! intent(out): volumetric fraction of total water (-) - mLayerVolFracLiq ,& ! intent(out): volumetric fraction of liquid water (-) - mLayerVolFracIce ,& ! intent(out): volumetric fraction of ice (-) - err,message) ! intent(out): error control - ! utility routines - USE soil_utils_module,only:volFracLiq ! compute volumetric fraction of liquid water based on matric head - USE soil_utils_module,only:matricHead ! compute the matric head based on volumetric liquid water content - implicit none - ! input variables - real(rkind),intent(in) :: mLayerTemp ! estimate of temperature (K) - real(rkind),intent(in) :: mLayerMatricHead ! matric head (m) - real(rkind),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter - real(rkind),intent(in) :: vGn_n ! van Genutchen "n" parameter - real(rkind),intent(in) :: theta_sat ! soil porosity (-) - real(rkind),intent(in) :: theta_res ! soil residual volumetric water content (-) - real(rkind),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) - ! output variables - real(rkind),intent(out) :: mLayerVolFracWat ! fractional volume of total water (-) - real(rkind),intent(out) :: mLayerVolFracLiq ! volumetric fraction of liquid water (-) - real(rkind),intent(out) :: mLayerVolFracIce ! volumetric fraction of ice (-) - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! define local variables - real(rkind) :: TcSoil ! critical soil temperature when all water is unfrozen (K) - real(rkind) :: xConst ! constant in the freezing curve function (m K-1) - real(rkind) :: mLayerPsiLiq ! liquid water matric potential (m) - real(rkind),parameter :: tinyVal=epsilon(1._rkind) ! used in balance check - ! initialize error control - err=0; message="updateSoil/" - - ! compute fractional **volume** of total water (liquid plus ice) - mLayerVolFracWat = volFracLiq(mLayerMatricHead,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) - if(mLayerVolFracWat > (theta_sat + tinyVal)) then - err=20 - message=trim(message)//'volume of liquid and ice (mLayerVolFracWat) exceeds porosity' - print*, 'mLayerVolFracWat = ', mLayerVolFracWat - print*, 'theta_sat (porosity) = ', theta_sat - print*, 'mLayerMatricHead = ', mLayerMatricHead - print*, 'theta_res = ', theta_res - print*, 'vGn_alpha = ', vGn_alpha - print*, 'vGn_n = ', vGn_n - print*, 'vGn_m = ', vGn_m - return - end if - - ! compute the critical soil temperature where all water is unfrozen (K) - ! (eq 17 in Dall'Amico 2011) - TcSoil = Tfreeze + min(mLayerMatricHead,0._rkind)*gravity*Tfreeze/LH_fus ! (NOTE: J = kg m2 s-2, so LH_fus is in units of m2 s-2) - - ! *** compute volumetric fraction of liquid water and ice for partially frozen soil - if(mLayerTemp < TcSoil)then ! (check if soil temperature is less than the critical temperature) - - ! - volumetric liquid water content (-) - ! NOTE: mLayerPsiLiq is the liquid water matric potential from the Clapeyron equation, used to separate the total water into liquid water and ice - ! mLayerPsiLiq is DIFFERENT from the liquid water matric potential used in the flux calculations - xConst = LH_fus/(gravity*Tfreeze) ! m K-1 (NOTE: J = kg m2 s-2) - mLayerPsiLiq = xConst*(mLayerTemp - Tfreeze) ! liquid water matric potential from the Clapeyron eqution - mLayerVolFracLiq = volFracLiq(mLayerPsiLiq,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) - +! ************************************************************************************************************* +! public subroutine updateSnow: compute phase change impacts on volumetric liquid water and ice (veg or soil) +! ************************************************************************************************************* +subroutine updateSnow(& + ! input + mLayerTemp ,& ! intent(in): temperature (K) + mLayerTheta ,& ! intent(in): volume fraction of total water (-) + snowfrz_scale ,& ! intent(in): scaling parameter for the snow freezing curve (K-1) + ! output + mLayerVolFracLiq ,& ! intent(out): volumetric fraction of liquid water (-) + mLayerVolFracIce ,& ! intent(out): volumetric fraction of ice (-) + fLiq ,& ! intent(out): fraction of liquid water (-) + err,message) ! intent(out): error control + ! utility routines + USE snow_utils_module,only:fracliquid ! compute volumetric fraction of liquid water + implicit none + ! input variables + real(rkind),intent(in) :: mLayerTemp ! temperature (K) + real(rkind),intent(in) :: mLayerTheta ! volume fraction of total water (-) + real(rkind),intent(in) :: snowfrz_scale ! scaling parameter for the snow freezing curve (K-1) + ! output variables + real(rkind),intent(out) :: mLayerVolFracLiq ! volumetric fraction of liquid water (-) + real(rkind),intent(out) :: mLayerVolFracIce ! volumetric fraction of ice (-) + real(rkind),intent(out) :: fLiq ! fraction of liquid water (-) + ! error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! initialize error control + err=0; message="updateSnow/" + + ! compute the volumetric fraction of liquid water and ice (-) + fLiq = fracliquid(mLayerTemp,snowfrz_scale) + mLayerVolFracLiq = fLiq*mLayerTheta + mLayerVolFracIce = (1._rkind - fLiq)*mLayerTheta*(iden_water/iden_ice) +end subroutine updateSnow + +! ************************************************************************************************************* +! public subroutine updateSoil: compute phase change impacts on matric head and volumetric liquid water and ice +! ************************************************************************************************************* +subroutine updateSoil(& + ! input + mLayerTemp ,& ! intent(in): temperature vector (K) + mLayerMatricHead ,& ! intent(in): matric head (m) + vGn_alpha ,& ! intent(in): van Genutchen "alpha" parameter + vGn_n ,& ! intent(in): van Genutchen "n" parameter + theta_sat ,& ! intent(in): soil porosity (-) + theta_res ,& ! intent(in): soil residual volumetric water content (-) + vGn_m ,& ! intent(in): van Genutchen "m" parameter (-) + ! output + mLayerVolFracWat ,& ! intent(out): volumetric fraction of total water (-) + mLayerVolFracLiq ,& ! intent(out): volumetric fraction of liquid water (-) + mLayerVolFracIce ,& ! intent(out): volumetric fraction of ice (-) + err,message) ! intent(out): error control + ! utility routines + USE soil_utils_module,only:volFracLiq ! compute volumetric fraction of liquid water based on matric head + USE soil_utils_module,only:matricHead ! compute the matric head based on volumetric liquid water content + implicit none + ! input variables + real(rkind),intent(in) :: mLayerTemp ! estimate of temperature (K) + real(rkind),intent(in) :: mLayerMatricHead ! matric head (m) + real(rkind),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter + real(rkind),intent(in) :: vGn_n ! van Genutchen "n" parameter + real(rkind),intent(in) :: theta_sat ! soil porosity (-) + real(rkind),intent(in) :: theta_res ! soil residual volumetric water content (-) + real(rkind),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) + ! output variables + real(rkind),intent(out) :: mLayerVolFracWat ! fractional volume of total water (-) + real(rkind),intent(out) :: mLayerVolFracLiq ! volumetric fraction of liquid water (-) + real(rkind),intent(out) :: mLayerVolFracIce ! volumetric fraction of ice (-) + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! define local variables + real(rkind) :: TcSoil ! critical soil temperature when all water is unfrozen (K) + real(rkind) :: xConst ! constant in the freezing curve function (m K-1) + real(rkind) :: mLayerPsiLiq ! liquid water matric potential (m) + ! initialize error control + err=0; message="updateSoil/" + + ! compute fractional **volume** of total water (liquid plus ice) + mLayerVolFracWat = volFracLiq(mLayerMatricHead,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) + if(mLayerVolFracWat > (theta_sat + epsilon(1._rkind)))then; err=20; message=trim(message)//'volume of liquid and ice exceeds porosity'; return; end if + + ! compute the critical soil temperature where all water is unfrozen (K) + ! (eq 17 in Dall'Amico 2011) + TcSoil = Tfreeze + min(mLayerMatricHead,0._rkind)*gravity*Tfreeze/LH_fus ! (NOTE: J = kg m2 s-2, so LH_fus is in units of m2 s-2) + + ! *** compute volumetric fraction of liquid water and ice for partially frozen soil + if(mLayerTemp < TcSoil)then ! (check if soil temperature is less than the critical temperature) + ! - volumetric liquid water content (-) + ! NOTE: mLayerPsiLiq is the liquid water matric potential from the Clapeyron equation, used to separate the total water into liquid water and ice + ! mLayerPsiLiq is DIFFERENT from the liquid water matric potential used in the flux calculations + xConst = LH_fus/(gravity*Tfreeze) ! m K-1 (NOTE: J = kg m2 s-2) + mLayerPsiLiq = xConst*(mLayerTemp - Tfreeze) ! liquid water matric potential from the Clapeyron eqution + mLayerVolFracLiq = volFracLiq(mLayerPsiLiq,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) + + ! *** compute volumetric fraction of liquid water and ice for unfrozen soil + else !( mLayerTemp >= TcSoil, all water is unfrozen, mLayerPsiLiq = mLayerMatricHead ) + mLayerVolFracLiq = mLayerVolFracWat + + end if ! (check if soil is partially frozen) ! - volumetric ice content (-) mLayerVolFracIce = mLayerVolFracWat - mLayerVolFracLiq - ! *** compute volumetric fraction of liquid water and ice for unfrozen soil - else - - ! all water is unfrozen - mLayerPsiLiq = mLayerMatricHead - mLayerVolFracLiq = mLayerVolFracWat - mLayerVolFracIce = 0._rkind - - end if ! (check if soil is partially frozen) - - end subroutine updateSoil - +end subroutine updateSoil -end module updatState_module +end module updatState_module \ No newline at end of file diff --git a/build/source/engine/updatStateWithPrime.f90 b/build/source/engine/updatStateWithPrime.f90 new file mode 100644 index 000000000..68091c4c3 --- /dev/null +++ b/build/source/engine/updatStateWithPrime.f90 @@ -0,0 +1,166 @@ +module updatStateWithPrime_module +USE nrtype +! physical constants +USE multiconst,only:& + Tfreeze, & ! freezing point of pure water (K) + iden_ice, & ! intrinsic density of ice (kg m-3) + iden_water, & ! intrinsic density of water (kg m-3) + gravity, & ! gravitational acceleration (m s-2) + LH_fus ! latent heat of fusion (J kg-1) + +! missing values +USE globalData,only:realMissing ! missing real number + +implicit none +private +public::updateSnowPrime +public::updateSoilPrime +contains + + +! ************************************************************************************************************* +! public subroutine updateSnowPrime: compute phase change impacts on volumetric liquid water and ice +! ************************************************************************************************************* +subroutine updateSnowPrime(& + ! input + mLayerTemp ,& ! intent(in): temperature (K) + mLayerTheta ,& ! intent(in): volume fraction of total water (-) + snowfrz_scale ,& ! intent(in): scaling parameter for the snow freezing curve (K-1) + mLayerTempPrime ,& ! intent(in): temperature (K) + mLayerThetaPrime ,& ! intent(in): volume fraction of total water (-) + ! output + mLayerVolFracLiq ,& ! intent(out): volumetric fraction of liquid water (-) + mLayerVolFracIce ,& ! intent(out): volumetric fraction of ice (-) + mLayerVolFracLiqPrime ,& ! intent(out): volumetric fraction of liquid water (-) + mLayerVolFracIcePrime ,& ! intent(out): volumetric fraction of ice (-) + fLiq ,& ! intent(out): fraction of liquid water (-) + err,message) ! intent(out): error control + ! utility routines + USE snow_utils_module,only:fracliquid ! compute volumetric fraction of liquid water + USE snow_utils_module,only:dFracLiq_dTk ! differentiate the freezing curve w.r.t. temperature (snow) + implicit none + ! input variables + real(rkind),intent(in) :: mLayerTemp ! temperature (K) + real(rkind),intent(in) :: mLayerTheta ! volume fraction of total water (-) + real(rkind),intent(in) :: snowfrz_scale ! scaling parameter for the snow freezing curve (K-1) + real(rkind),intent(in) :: mLayerTempPrime ! temperature (K) + real(rkind),intent(in) :: mLayerThetaPrime ! volume fraction of total water (-) + ! output variables + real(rkind),intent(out) :: mLayerVolFracLiq ! volumetric fraction of liquid water (-) + real(rkind),intent(out) :: mLayerVolFracIce ! volumetric fraction of ice (-) + real(rkind),intent(out) :: mLayerVolFracLiqPrime ! volumetric fraction of liquid water (-) + real(rkind),intent(out) :: mLayerVolFracIcePrime ! volumetric fraction of ice (-) + real(rkind),intent(out) :: fLiq ! fraction of liquid water (-) + ! error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! initialize error control + err=0; message="updateSnowPrime/" + + ! compute the volumetric fraction of liquid water and ice (-) + fLiq = fracliquid(mLayerTemp,snowfrz_scale) + mLayerVolFracLiq = fLiq*mLayerTheta + mLayerVolFracIce = (1._rkind - fLiq)*mLayerTheta*(iden_water/iden_ice) + mLayerVolFracLiqPrime = fLiq * mLayerThetaPrime + dFracLiq_dTk(mLayerTemp,snowfrz_scale) * mLayerTheta * mLayerTempPrime + mLayerVolFracIcePrime = ( mLayerThetaPrime - mLayerVolFracLiqPrime ) * (iden_water/iden_ice) + + ! set primes to missing if the temperature prime is missing (enthalpy is state variable) + if(mLayerTempPrime==realMissing)then + mLayerVolFracLiqPrime=realMissing + mLayerVolFracIcePrime=realMissing + end if + +end subroutine updateSnowPrime + +! *********************************************************************************************************************************** +! public subroutine updateSoilPrime: compute phase change impacts on matric head and volumetric liquid water and ice (veg or soil) +! *********************************************************************************************************************************** +subroutine updateSoilPrime(& + ! input + mLayerTemp ,& ! intent(in): temperature (K) + mLayerMatricHead ,& ! intent(in): total water matric potential (m) + mLayerTempPrime ,& ! intent(in): temperature time derivative (K/s) + mLayerMatricHeadPrime ,& ! intent(in): total water matric potential time derivative (m/s) + vGn_alpha ,& ! intent(in): van Genutchen "alpha" parameter + vGn_n ,& ! intent(in): van Genutchen "n" parameter + theta_sat ,& ! intent(in): soil porosity (-) + theta_res ,& ! intent(in): soil residual volumetric water content (-) + vGn_m ,& ! intent(in): van Genutchen "m" parameter (-) + ! output + mLayerVolFracWat ,& ! intent(out): volumetric fraction of total water (-) + mLayerVolFracLiq ,& ! intent(out): volumetric fraction of liquid water (-) + mLayerVolFracIce ,& ! intent(out): volumetric fraction of ice (-) + mLayerVolFracWatPrime ,& ! intent(out): volumetric fraction of total water time derivative (-) + mLayerVolFracLiqPrime ,& ! intent(out): volumetric fraction of liquid water time derivative (-) + mLayerVolFracIcePrime ,& ! intent(out): volumetric fraction of ice time derivative (-) + err,message) ! intent(out): error control + ! utility routines + USE soil_utils_module,only:volFracLiq ! compute volumetric fraction of liquid water based on matric head + USE soil_utils_module,only:matricHead ! compute the matric head based on volumetric liquid water content + USE soil_utils_module,only:dTheta_dPsi + implicit none + ! input variables + real(rkind),intent(in) :: mLayerTemp ! estimate of temperature (K) + real(rkind),intent(in) :: mLayerMatricHead ! matric head (m) + real(rkind),intent(in) :: mLayerTempPrime ! temperature time derivative (K/s) + real(rkind),intent(in) :: mLayerMatricHeadPrime ! matric head time derivative (m/s) + real(rkind),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter + real(rkind),intent(in) :: vGn_n ! van Genutchen "n" parameter + real(rkind),intent(in) :: theta_sat ! soil porosity (-) + real(rkind),intent(in) :: theta_res ! soil residual volumetric water content (-) + real(rkind),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) + ! output variables + real(rkind),intent(out) :: mLayerVolFracWat ! fractional volume of total water (-) + real(rkind),intent(out) :: mLayerVolFracLiq ! volumetric fraction of liquid water (-) + real(rkind),intent(out) :: mLayerVolFracIce ! volumetric fraction of ice (-) + real(rkind),intent(out) :: mLayerVolFracWatPrime ! fractional volume of total water (-) + real(rkind),intent(out) :: mLayerVolFracLiqPrime ! volumetric fraction of liquid water (-) + real(rkind),intent(out) :: mLayerVolFracIcePrime ! volumetric fraction of ice (-) + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! define local variables + real(rkind) :: TcSoil ! critical soil temperature when all water is unfrozen (K) + real(rkind) :: xConst ! constant in the freezing curve function (m K-1) + real(rkind) :: mLayerPsiLiq ! liquid water matric potential (m) + ! initialize error control + err=0; message="updateSoilPrime/" + + ! compute fractional **volume** of total water (liquid plus ice) + mLayerVolFracWat = volFracLiq(mLayerMatricHead,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) + mLayerVolFracWatPrime = dTheta_dPsi(mLayerMatricHead,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) * mLayerMatricHeadPrime + + if(mLayerVolFracWat > (theta_sat + epsilon(1._rkind)))then; err=20; message=trim(message)//'volume of liquid and ice exceeds porosity'; return; end if + + ! compute the critical soil temperature where all water is unfrozen (K) + ! (eq 17 in Dall'Amico 2011) + TcSoil = Tfreeze + min(mLayerMatricHead,0._rkind)*gravity*Tfreeze/LH_fus ! (NOTE: J = kg m2 s-2, so LH_fus is in units of m2 s-2) + + ! *** compute volumetric fraction of liquid water for partially frozen soil + if(mLayerTemp < TcSoil)then ! (check if soil temperature is less than the critical temperature) + ! NOTE: mLayerPsiLiq is the liquid water matric potential from the Clapeyron equation, used to separate the total water into liquid water and ice + ! mLayerPsiLiq is DIFFERENT from the liquid water matric potential used in the flux calculations + xConst = LH_fus/(gravity*Tfreeze) ! m K-1 (NOTE: J = kg m2 s-2) + mLayerPsiLiq = xConst*(mLayerTemp - Tfreeze) ! liquid water matric potential from the Clapeyron eqution + mLayerVolFracLiq = volFracLiq(mLayerPsiLiq,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) + mLayerVolFracLiqPrime = dTheta_dPsi(mLayerPsiLiq,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) * xConst * mLayerTempPrime + + ! *** compute volumetric fraction of liquid water for unfrozen soil + else !( mLayerTemp >= TcSoil, all water is unfrozen, mLayerPsiLiq = mLayerMatricHead ) + mLayerVolFracLiq = mLayerVolFracWat + mLayerVolFracLiqPrime = mLayerVolFracWatPrime + + end if ! (check if soil is partially frozen) + + ! - volumetric ice content (-) + mLayerVolFracIce = mLayerVolFracWat - mLayerVolFracLiq + mLayerVolFracIcePrime = mLayerVolFracWatPrime - mLayerVolFracLiqPrime + + ! set primes to missing if the temperature prime is missing (enthalpy is state variable) + if(mLayerTempPrime==realMissing)then + mLayerVolFracLiqPrime=realMissing + mLayerVolFracIcePrime=realMissing + end if + +end subroutine updateSoilPrime + +end module updatStateWithPrime_module diff --git a/build/source/engine/updateVars.f90 b/build/source/engine/updateVars.f90 old mode 100755 new mode 100644 index 63f20627f..4204d9a86 --- a/build/source/engine/updateVars.f90 +++ b/build/source/engine/updateVars.f90 @@ -53,20 +53,18 @@ module updateVars_module ! constants USE multiconst,only:& - gravity, & ! acceleration of gravity (m s-2) Tfreeze, & ! temperature at freezing (K) - Cp_air, & ! specific heat of air (J kg-1 K-1) LH_fus, & ! latent heat of fusion (J kg-1) - iden_air, & ! intrinsic density of air (kg m-3) iden_ice, & ! intrinsic density of ice (kg m-3) iden_water ! intrinsic density of liquid water (kg m-3) ! provide access to the derived types to define the data structures USE data_types,only:& var_i, & ! data vector (i4b) - var_d, & ! data vector (dp) + var_d, & ! data vector (rkind) var_ilength, & ! data vector with variable length dimension (i4b) - var_dlength ! data vector with variable length dimension (dp) + zLookup, & ! data vector with variable length dimension (rkind) + var_dlength ! data vector with variable length dimension (rkind) ! provide access to indices that define elements of the data structures USE var_lookup,only:iLookDIAG ! named variables for structure elements @@ -80,18 +78,21 @@ module updateVars_module USE updatState_module,only:updateSoil ! update soil states ! provide access to functions for the constitutive functions and derivatives -USE snow_utils_module,only:fracliquid ! compute the fraction of liquid water (snow) -USE snow_utils_module,only:dFracLiq_dTk ! differentiate the freezing curve w.r.t. temperature (snow) -USE soil_utils_module,only:dTheta_dTk ! differentiate the freezing curve w.r.t. temperature (soil) -USE soil_utils_module,only:dTheta_dPsi ! derivative in the soil water characteristic (soil) -USE soil_utils_module,only:dPsi_dTheta ! derivative in the soil water characteristic (soil) -USE soil_utils_module,only:matricHead ! compute the matric head based on volumetric water content -USE soil_utils_module,only:volFracLiq ! compute volumetric fraction of liquid water -USE soil_utils_module,only:crit_soilT ! compute critical temperature below which ice exists -USE soil_utils_module,only:liquidHead ! compute the liquid water matric potential +USE snow_utils_module,only:fracliquid ! compute the fraction of liquid water (snow) +USE snow_utils_module,only:dFracLiq_dTk ! differentiate the freezing curve w.r.t. temperature (snow) +USE soil_utils_module,only:dTheta_dTk ! differentiate the freezing curve w.r.t. temperature (soil) +USE soil_utils_module,only:dTheta_dPsi ! derivative in the soil water characteristic (soil) +USE soil_utils_module,only:matricHead ! compute the matric head based on volumetric water content +USE soil_utils_module,only:volFracLiq ! compute volumetric fraction of liquid water +USE soil_utils_module,only:crit_soilT ! compute critical temperature below which ice exists +USE soil_utils_module,only:liquidHead ! compute the liquid water matric potential +USE enthalpyTemp_module,only:T2enthTemp_cas ! convert temperature to enthalpy for canopy air space +USE enthalpyTemp_module,only:T2enthTemp_veg ! convert temperature to enthalpy for vegetation +USE enthalpyTemp_module,only:T2enthTemp_snow ! convert temperature to enthalpy for snow +USE enthalpyTemp_module,only:T2enthTemp_soil ! convert temperature to enthalpy for soil ! IEEE check -USE, intrinsic :: ieee_arithmetic ! check values (NaN, etc.) +USE, intrinsic :: ieee_arithmetic ! check values (NaN, etc.) implicit none private @@ -99,636 +100,709 @@ module updateVars_module contains - ! ********************************************************************************************************** - ! public subroutine updateVars: compute diagnostic variables - ! ********************************************************************************************************** - subroutine updateVars(& - ! input - do_adjustTemp, & ! intent(in): logical flag to adjust temperature to account for the energy used in melt+freeze - mpar_data, & ! intent(in): model parameters for a local HRU - indx_data, & ! intent(in): indices defining model states and layers - prog_data, & ! intent(in): model prognostic variables for a local HRU - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables - ! output: variables for the vegetation canopy - scalarCanopyTempTrial, & ! intent(inout): trial value of canopy temperature (K) - scalarCanopyWatTrial, & ! intent(inout): trial value of canopy total water (kg m-2) - scalarCanopyLiqTrial, & ! intent(inout): trial value of canopy liquid water (kg m-2) - scalarCanopyIceTrial, & ! intent(inout): trial value of canopy ice content (kg m-2) - ! output: variables for the snow-soil domain - mLayerTempTrial, & ! intent(inout): trial vector of layer temperature (K) - mLayerVolFracWatTrial, & ! intent(inout): trial vector of volumetric total water content (-) - mLayerVolFracLiqTrial, & ! intent(inout): trial vector of volumetric liquid water content (-) - mLayerVolFracIceTrial, & ! intent(inout): trial vector of volumetric ice water content (-) - mLayerMatricHeadTrial, & ! intent(inout): trial vector of total water matric potential (m) - mLayerMatricHeadLiqTrial, & ! intent(inout): trial vector of liquid water matric potential (m) - ! output: error control - err,message) ! intent(out): error control - ! -------------------------------------------------------------------------------------------------------------------------------- - ! -------------------------------------------------------------------------------------------------------------------------------- - implicit none - ! input - logical(lgt) ,intent(in) :: do_adjustTemp ! flag to adjust temperature to account for the energy used in melt+freeze - type(var_dlength),intent(in) :: mpar_data ! model parameters for a local HRU - type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers - type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU - type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU - type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables - ! output: variables for the vegetation canopy - real(rkind),intent(inout) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) - real(rkind),intent(inout) :: scalarCanopyWatTrial ! trial value of canopy total water (kg m-2) - real(rkind),intent(inout) :: scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) - real(rkind),intent(inout) :: scalarCanopyIceTrial ! trial value of canopy ice content (kg m-2) - ! output: variables for the snow-soil domain - real(rkind),intent(inout) :: mLayerTempTrial(:) ! trial vector of layer temperature (K) - real(rkind),intent(inout) :: mLayerVolFracWatTrial(:) ! trial vector of volumetric total water content (-) - real(rkind),intent(inout) :: mLayerVolFracLiqTrial(:) ! trial vector of volumetric liquid water content (-) - real(rkind),intent(inout) :: mLayerVolFracIceTrial(:) ! trial vector of volumetric ice water content (-) - real(rkind),intent(inout) :: mLayerMatricHeadTrial(:) ! trial vector of total water matric potential (m) - real(rkind),intent(inout) :: mLayerMatricHeadLiqTrial(:) ! trial vector of liquid water matric potential (m) - ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! -------------------------------------------------------------------------------------------------------------------------------- - ! general local variables - integer(i4b) :: iState ! index of model state variable - integer(i4b) :: iLayer ! index of layer within the snow+soil domain - integer(i4b) :: ixFullVector ! index within full state vector - integer(i4b) :: ixDomainType ! name of a given model domain - integer(i4b) :: ixControlIndex ! index within a given model domain - integer(i4b) :: ixOther,ixOtherLocal ! index of the coupled state variable within the (full, local) vector - logical(lgt) :: isCoupled ! .true. if a given variable shared another state variable in the same control volume - logical(lgt) :: isNrgState ! .true. if a given variable is an energy state - logical(lgt),allocatable :: computedCoupling(:) ! .true. if computed the coupling for a given state variable - real(rkind) :: scalarVolFracLiq ! volumetric fraction of liquid water (-) - real(rkind) :: scalarVolFracIce ! volumetric fraction of ice (-) - real(rkind) :: Tcrit ! critical soil temperature below which ice exists (K) - real(rkind) :: xTemp ! temporary temperature (K) - real(rkind) :: effSat ! effective saturation (-) - real(rkind) :: avPore ! available pore space (-) - character(len=256) :: cMessage ! error message of downwind routine - logical(lgt),parameter :: printFlag=.false. ! flag to turn on printing - ! iterative solution for temperature - real(rkind) :: meltNrg ! energy for melt+freeze (J m-3) - real(rkind) :: residual ! residual in the energy equation (J m-3) - real(rkind) :: derivative ! derivative in the energy equation (J m-3 K-1) - real(rkind) :: tempInc ! iteration increment (K) - integer(i4b) :: iter ! iteration index - integer(i4b) :: niter ! number of iterations - integer(i4b),parameter :: maxiter=100 ! maximum number of iterations - real(rkind),parameter :: nrgConvTol=1.e-4_rkind ! convergence tolerance for energy (J m-3) - real(rkind),parameter :: tempConvTol=1.e-6_rkind ! convergence tolerance for temperature (K) - real(rkind) :: critDiff ! temperature difference from critical (K) - real(rkind) :: tempMin ! minimum bracket for temperature (K) - real(rkind) :: tempMax ! maximum bracket for temperature (K) - logical(lgt) :: bFlag ! flag to denote that iteration increment was constrained using bi-section - real(rkind),parameter :: epsT=1.e-7_rkind ! small interval above/below critical temperature (K) - ! -------------------------------------------------------------------------------------------------------------------------------- - ! make association with variables in the data structures - associate(& - ! number of model layers, and layer type - nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in): [i4b] total number of snow layers - nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1) ,& ! intent(in): [i4b] total number of soil layers - nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1) ,& ! intent(in): [i4b] total number of snow and soil layers - mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat ,& ! intent(in): [dp(:)] depth of each layer in the snow-soil sub-domain (m) - ! indices defining model states and layers - ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable - ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) - ! indices in the full vector for specific domains - ixNrgCanair => indx_data%var(iLookINDEX%ixNrgCanair)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for energy states in canopy air space domain - ixNrgCanopy => indx_data%var(iLookINDEX%ixNrgCanopy)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for energy states in the canopy domain - ixHydCanopy => indx_data%var(iLookINDEX%ixHydCanopy)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for hydrology states in the canopy domain - ixNrgLayer => indx_data%var(iLookINDEX%ixNrgLayer)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for energy states in the snow+soil domain - ixHydLayer => indx_data%var(iLookINDEX%ixHydLayer)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for hydrology states in the snow+soil domain - ! mapping between the full state vector and the state subset - ixMapFull2Subset => indx_data%var(iLookINDEX%ixMapFull2Subset)%dat ,& ! intent(in): [i4b(:)] list of indices in the state subset for each state in the full state vector - ixMapSubset2Full => indx_data%var(iLookINDEX%ixMapSubset2Full)%dat ,& ! intent(in): [i4b(:)] [state subset] list of indices of the full state vector in the state subset - ! type of domain, type of state variable, and index of control volume within domain - ixDomainType_subset => indx_data%var(iLookINDEX%ixDomainType_subset)%dat ,& ! intent(in): [i4b(:)] [state subset] id of domain for desired model state variables - ixControlVolume => indx_data%var(iLookINDEX%ixControlVolume)%dat ,& ! intent(in): [i4b(:)] index of the control volume for different domains (veg, snow, soil) - ixStateType => indx_data%var(iLookINDEX%ixStateType)%dat ,& ! intent(in): [i4b(:)] indices defining the type of the state (iname_nrgLayer...) - ! snow parameters - snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1) ,& ! intent(in): [dp] scaling parameter for the snow freezing curve (K-1) - ! depth-varying model parameters - vGn_m => diag_data%var(iLookDIAG%scalarVGn_m)%dat ,& ! intent(in): [dp(:)] van Genutchen "m" parameter (-) - vGn_n => mpar_data%var(iLookPARAM%vGn_n)%dat ,& ! intent(in): [dp(:)] van Genutchen "n" parameter (-) - vGn_alpha => mpar_data%var(iLookPARAM%vGn_alpha)%dat ,& ! intent(in): [dp(:)] van Genutchen "alpha" parameter (m-1) - theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat ,& ! intent(in): [dp(:)] soil porosity (-) - theta_res => mpar_data%var(iLookPARAM%theta_res)%dat ,& ! intent(in): [dp(:)] soil residual volumetric water content (-) - ! model diagnostic variables (heat capacity) - canopyDepth => diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1) ,& ! intent(in): [dp ] canopy depth (m) - scalarBulkVolHeatCapVeg => diag_data%var(iLookDIAG%scalarBulkVolHeatCapVeg)%dat(1),& ! intent(in): [dp ] volumetric heat capacity of the vegetation (J m-3 K-1) - mLayerVolHtCapBulk => diag_data%var(iLookDIAG%mLayerVolHtCapBulk)%dat ,& ! intent(in): [dp(:)] volumetric heat capacity in each layer (J m-3 K-1) - ! model diagnostic variables (fraction of liquid water) - scalarFracLiqVeg => diag_data%var(iLookDIAG%scalarFracLiqVeg)%dat(1) ,& ! intent(out): [dp] fraction of liquid water on vegetation (-) - mLayerFracLiqSnow => diag_data%var(iLookDIAG%mLayerFracLiqSnow)%dat ,& ! intent(out): [dp(:)] fraction of liquid water in each snow layer (-) - ! model states for the vegetation canopy - scalarCanairTemp => prog_data%var(iLookPROG%scalarCanairTemp)%dat(1) ,& ! intent(in): [dp] temperature of the canopy air space (K) - scalarCanopyTemp => prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1) ,& ! intent(in): [dp] temperature of the vegetation canopy (K) - scalarCanopyWat => prog_data%var(iLookPROG%scalarCanopyWat)%dat(1) ,& ! intent(in): [dp] mass of total water on the vegetation canopy (kg m-2) - ! model state variable vectors for the snow-soil layers - mLayerTemp => prog_data%var(iLookPROG%mLayerTemp)%dat ,& ! intent(in): [dp(:)] temperature of each snow/soil layer (K) - mLayerVolFracWat => prog_data%var(iLookPROG%mLayerVolFracWat)%dat ,& ! intent(in): [dp(:)] volumetric fraction of total water (-) - mLayerMatricHead => prog_data%var(iLookPROG%mLayerMatricHead)%dat ,& ! intent(in): [dp(:)] total water matric potential (m) - mLayerMatricHeadLiq => diag_data%var(iLookDIAG%mLayerMatricHeadLiq)%dat ,& ! intent(in): [dp(:)] liquid water matric potential (m) - ! model diagnostic variables from a previous solution - scalarCanopyLiq => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1) ,& ! intent(in): [dp(:)] mass of liquid water on the vegetation canopy (kg m-2) - scalarCanopyIce => prog_data%var(iLookPROG%scalarCanopyIce)%dat(1) ,& ! intent(in): [dp(:)] mass of ice on the vegetation canopy (kg m-2) - mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat ,& ! intent(in): [dp(:)] volumetric fraction of liquid water (-) - mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat ,& ! intent(in): [dp(:)] volumetric fraction of ice (-) - ! derivatives - dVolTot_dPsi0 => deriv_data%var(iLookDERIV%dVolTot_dPsi0 )%dat ,& ! intent(out): [dp(:)] derivative in total water content w.r.t. total water matric potential - dPsiLiq_dPsi0 => deriv_data%var(iLookDERIV%dPsiLiq_dPsi0 )%dat ,& ! intent(out): [dp(:)] derivative in liquid water matric pot w.r.t. the total water matric pot (-) - dPsiLiq_dTemp => deriv_data%var(iLookDERIV%dPsiLiq_dTemp )%dat ,& ! intent(out): [dp(:)] derivative in the liquid water matric potential w.r.t. temperature - mLayerdTheta_dTk => deriv_data%var(iLookDERIV%mLayerdTheta_dTk)%dat ,& ! intent(out): [dp(:)] derivative of volumetric liquid water content w.r.t. temperature - dTheta_dTkCanopy => deriv_data%var(iLookDERIV%dTheta_dTkCanopy)%dat(1) & ! intent(out): [dp] derivative of volumetric liquid water content w.r.t. temperature - ) ! association with variables in the data structures - - ! -------------------------------------------------------------------------------------------------------------------------------- - ! -------------------------------------------------------------------------------------------------------------------------------- - - ! initialize error control - err=0; message='updateVars/' - - ! allocate space and assign values to the flag vector - allocate(computedCoupling(size(ixMapSubset2Full)),stat=err) ! .true. if computed the coupling for a given state variable - if(err/=0)then; message=trim(message)//'problem allocating computedCoupling'; return; endif - computedCoupling(:)=.false. - - ! loop through model state variables - do iState=1,size(ixMapSubset2Full) - - ! check the need for the computations - if(computedCoupling(iState)) cycle - - ! ----- - ! - compute indices... - ! -------------------- - - ! get domain type, and index of the control volume within the domain - ixFullVector = ixMapSubset2Full(iState) ! index within full state vector - ixDomainType = ixDomainType_subset(iState) ! named variables defining the domain (iname_cas, iname_veg, etc.) - ixControlIndex = ixControlVolume(ixFullVector) ! index within a given domain - - ! get the layer index - select case(ixDomainType) - case(iname_cas); cycle ! canopy air space: do nothing - case(iname_veg); iLayer = 0 - case(iname_snow); iLayer = ixControlIndex - case(iname_soil); iLayer = ixControlIndex + nSnow - case(iname_aquifer); cycle ! aquifer: do nothing - case default; err=20; message=trim(message)//'expect case to be iname_cas, iname_veg, iname_snow, iname_soil, iname_aquifer'; return - end select - - ! get the index of the other (energy or mass) state variable within the full state vector - select case(ixDomainType) - case(iname_veg) ; ixOther = merge(ixHydCanopy(1), ixNrgCanopy(1), ixStateType(ixFullVector)==iname_nrgCanopy) - case(iname_snow, iname_soil); ixOther = merge(ixHydLayer(iLayer),ixNrgLayer(iLayer),ixStateType(ixFullVector)==iname_nrgLayer) - case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return - end select - - ! get the index in the local state vector - ixOtherLocal = ixMapFull2Subset(ixOther) ! ixOtherLocal could equal integerMissing - if(ixOtherLocal/=integerMissing) computedCoupling(ixOtherLocal)=.true. - - ! check if we have a coupled solution - isCoupled = (ixOtherLocal/=integerMissing) - - ! check if we are an energy state - isNrgState = (ixStateType(ixFullVector)==iname_nrgCanopy .or. ixStateType(ixFullVector)==iname_nrgLayer) - - if(printFlag)then - print*, 'iState = ', iState, size(ixMapSubset2Full) - print*, 'ixFullVector = ', ixFullVector - print*, 'ixDomainType = ', ixDomainType - print*, 'ixControlIndex = ', ixControlIndex - print*, 'ixOther = ', ixOther - print*, 'ixOtherLocal = ', ixOtherLocal - print*, 'do_adjustTemp = ', do_adjustTemp - print*, 'isCoupled = ', isCoupled - print*, 'isNrgState = ', isNrgState - endif - - ! ======================================================================================================================================= - ! ======================================================================================================================================= - ! ======================================================================================================================================= - ! ======================================================================================================================================= - ! ======================================================================================================================================= - ! ======================================================================================================================================= - - ! update hydrology state variables for the uncoupled solution - if(.not.isNrgState .and. .not.isCoupled)then - - ! update the total water from volumetric liquid water - if(ixStateType(ixFullVector)==iname_liqCanopy .or. ixStateType(ixFullVector)==iname_liqLayer)then - select case(ixDomainType) - case(iname_veg); scalarCanopyWatTrial = scalarCanopyLiqTrial + scalarCanopyIceTrial - case(iname_snow); mLayerVolFracWatTrial(iLayer) = mLayerVolFracLiqTrial(iLayer) + mLayerVolFracIceTrial(iLayer)*iden_ice/iden_water - case(iname_soil); mLayerVolFracWatTrial(iLayer) = mLayerVolFracLiqTrial(iLayer) + mLayerVolFracIceTrial(iLayer) ! no volume expansion - case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, or iname_soil'; return - end select - endif - - ! update the total water and the total water matric potential - if(ixDomainType==iname_soil)then - select case( ixStateType(ixFullVector) ) - ! --> update the total water from the liquid water matric potential - case(iname_lmpLayer) - effSat = volFracLiq(mLayerMatricHeadLiqTrial(ixControlIndex),vGn_alpha(ixControlIndex),0._rkind,1._rkind,vGn_n(ixControlIndex),vGn_m(ixControlIndex)) ! effective saturation - avPore = theta_sat(ixControlIndex) - mLayerVolFracIceTrial(iLayer) - theta_res(ixControlIndex) ! available pore space - mLayerVolFracLiqTrial(iLayer) = effSat*avPore + theta_res(ixControlIndex) - mLayerVolFracWatTrial(iLayer) = mLayerVolFracLiqTrial(iLayer) + mLayerVolFracIceTrial(iLayer) ! no volume expansion - mLayerMatricHeadTrial(ixControlIndex) = matricHead(mLayerVolFracWatTrial(iLayer),vGn_alpha(ixControlIndex),theta_res(ixControlIndex),theta_sat(ixControlIndex),vGn_n(ixControlIndex),vGn_m(ixControlIndex)) - !write(*,'(a,1x,i4,1x,3(f20.10,1x))') 'mLayerVolFracLiqTrial(iLayer) 1 = ', iLayer, mLayerVolFracLiqTrial(iLayer), mLayerVolFracIceTrial(iLayer), mLayerVolFracWatTrial(iLayer) - ! --> update the total water from the total water matric potential - case(iname_matLayer) - mLayerVolFracWatTrial(iLayer) = volFracLiq(mLayerMatricHeadTrial(ixControlIndex),vGn_alpha(ixControlIndex),theta_res(ixControlIndex),theta_sat(ixControlIndex),vGn_n(ixControlIndex),vGn_m(ixControlIndex)) - ! --> update the total water matric potential (assume already have mLayerVolFracWatTrial given block above) - case(iname_liqLayer, iname_watLayer) - mLayerMatricHeadTrial(ixControlIndex) = matricHead(mLayerVolFracWatTrial(iLayer),vGn_alpha(ixControlIndex),theta_res(ixControlIndex),theta_sat(ixControlIndex),vGn_n(ixControlIndex),vGn_m(ixControlIndex)) - case default; err=20; message=trim(message)//'expect iname_lmpLayer, iname_matLayer, iname_liqLayer, or iname_watLayer'; return - end select - endif ! if in the soil domain - - endif ! if hydrology state variable or uncoupled solution - - ! compute the critical soil temperature below which ice exists - select case(ixDomainType) - case(iname_veg, iname_snow); Tcrit = Tfreeze - case(iname_soil); Tcrit = crit_soilT( mLayerMatricHeadTrial(ixControlIndex) ) - case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return - end select - - ! initialize temperature - select case(ixDomainType) - case(iname_veg); xTemp = scalarCanopyTempTrial - case(iname_snow, iname_soil); xTemp = mLayerTempTrial(iLayer) - case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return - end select - - ! define brackets for the root - ! NOTE: start with an enormous range; updated quickly in the iterations - tempMin = xTemp - 10._rkind - tempMax = xTemp + 10._rkind - - ! get iterations (set to maximum iterations if adjusting the temperature) - niter = merge(maxiter, 1, do_adjustTemp) - - ! iterate - iterations: do iter=1,niter - - ! restrict temperature - if(xTemp <= tempMin .or. xTemp >= tempMax)then - xTemp = 0.5_rkind*(tempMin + tempMax) ! new value - bFlag = .true. - else - bFlag = .false. - endif - - ! ----- - ! - compute derivatives... - ! ------------------------ - - ! compute the derivative in total water content w.r.t. total water matric potential (m-1) - ! NOTE 1: valid for frozen and unfrozen conditions - ! NOTE 2: for case "iname_lmpLayer", dVolTot_dPsi0 = dVolLiq_dPsi - if(ixDomainType==iname_soil)then - select case( ixStateType(ixFullVector) ) - case(iname_lmpLayer); dVolTot_dPsi0(ixControlIndex) = dTheta_dPsi(mLayerMatricHeadLiqTrial(ixControlIndex),vGn_alpha(ixControlIndex),0._rkind,1._rkind,vGn_n(ixControlIndex),vGn_m(ixControlIndex))*avPore - case default; dVolTot_dPsi0(ixControlIndex) = dTheta_dPsi(mLayerMatricHeadTrial(ixControlIndex),vGn_alpha(ixControlIndex),theta_res(ixControlIndex),theta_sat(ixControlIndex),vGn_n(ixControlIndex),vGn_m(ixControlIndex)) - end select - endif - - ! compute the derivative in liquid water content w.r.t. temperature - ! --> partially frozen: dependence of liquid water on temperature - if(xTemp unfrozen: no dependence of liquid water on temperature - else - select case(ixDomainType) - case(iname_veg); dTheta_dTkCanopy = 0._rkind - case(iname_snow, iname_soil); mLayerdTheta_dTk(iLayer) = 0._rkind - case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return - end select ! domain type - endif - - ! ----- - ! - update volumetric fraction of liquid water and ice... - ! => case of hydrology state uncoupled with energy (and when not adjusting the temperature)... - ! ----------------------------------------------------------------------------------------------- - - ! case of hydrology state uncoupled with energy (and when not adjusting the temperature) - if(.not.do_adjustTemp .and. .not.isNrgState .and. .not.isCoupled)then - - ! compute the fraction of snow - select case(ixDomainType) - case(iname_veg); scalarFracLiqVeg = fracliquid(xTemp,snowfrz_scale) - case(iname_snow); mLayerFracLiqSnow(iLayer) = fracliquid(xTemp,snowfrz_scale) - case(iname_soil) ! do nothing - case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return - end select ! domain type - - ! ----- - ! - update volumetric fraction of liquid water and ice... - ! => case of energy state or coupled solution (or adjusting the temperature)... - ! -------------------------------------------------------------------------------- - - ! case of energy state OR coupled solution (or adjusting the temperature) - elseif(do_adjustTemp .or. ( (isNrgState .or. isCoupled) ) )then - - ! identify domain type - select case(ixDomainType) - - ! *** vegetation canopy - case(iname_veg) - - ! compute volumetric fraction of liquid water and ice - call updateSnow(xTemp, & ! intent(in) : temperature (K) - scalarCanopyWatTrial/(iden_water*canopyDepth),& ! intent(in) : volumetric fraction of total water (-) - snowfrz_scale, & ! intent(in) : scaling parameter for the snow freezing curve (K-1) - scalarVolFracLiq, & ! intent(out) : trial volumetric fraction of liquid water (-) - scalarVolFracIce, & ! intent(out) : trial volumetric fraction if ice (-) - scalarFracLiqVeg, & ! intent(out) : fraction of liquid water (-) - err,cmessage) ! intent(out) : error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - - ! compute mass of water on the canopy - ! NOTE: possibilities for speed-up here - scalarCanopyLiqTrial = scalarFracLiqVeg *scalarCanopyWatTrial - scalarCanopyIceTrial = (1._rkind - scalarFracLiqVeg)*scalarCanopyWatTrial - - ! *** snow layers - case(iname_snow) - - ! compute volumetric fraction of liquid water and ice - call updateSnow(xTemp, & ! intent(in) : temperature (K) - mLayerVolFracWatTrial(iLayer), & ! intent(in) : mass state variable = trial volumetric fraction of water (-) - snowfrz_scale, & ! intent(in) : scaling parameter for the snow freezing curve (K-1) - mLayerVolFracLiqTrial(iLayer), & ! intent(out) : trial volumetric fraction of liquid water (-) - mLayerVolFracIceTrial(iLayer), & ! intent(out) : trial volumetric fraction if ice (-) - mLayerFracLiqSnow(iLayer), & ! intent(out) : fraction of liquid water (-) - err,cmessage) ! intent(out) : error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - - ! *** soil layers - case(iname_soil) - - ! compute volumetric fraction of liquid water and ice - call updateSoil(xTemp, & ! intent(in) : temperature (K) - mLayerMatricHeadTrial(ixControlIndex), & ! intent(in) : total water matric potential (m) - vGn_alpha(ixControlIndex),vGn_n(ixControlIndex),theta_sat(ixControlIndex),theta_res(ixControlIndex),vGn_m(ixControlIndex), & ! intent(in) : soil parameters - mLayerVolFracWatTrial(iLayer), & ! intent(in) : mass state variable = trial volumetric fraction of water (-) - mLayerVolFracLiqTrial(iLayer), & ! intent(out) : trial volumetric fraction of liquid water (-) - mLayerVolFracIceTrial(iLayer), & ! intent(out) : trial volumetric fraction if ice (-) - err,cmessage) ! intent(out) : error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - - ! check - case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return - - end select ! domain type - - ! final check - else - - ! do nothing (input = output) -- and check that we got here correctly - if( (isNrgState .or. isCoupled) )then - scalarVolFracLiq = realMissing - scalarVolFracIce = realMissing - else - message=trim(message)//'unexpected else branch' - err=20; return - endif - - endif ! if energy state or solution is coupled - - ! ----- - ! - update temperatures... - ! ------------------------ - - ! check the need to adjust temperature - if(do_adjustTemp)then - - ! get the melt energy - meltNrg = merge(LH_fus*iden_ice, LH_fus*iden_water, ixDomainType==iname_snow) - - ! compute the residual and the derivative - select case(ixDomainType) - - ! * vegetation - case(iname_veg) - call xTempSolve(& - ! constant over iterations - meltNrg = meltNrg ,& ! intent(in) : energy for melt+freeze (J m-3) - heatCap = scalarBulkVolHeatCapVeg ,& ! intent(in) : volumetric heat capacity (J m-3 K-1) - tempInit = scalarCanopyTemp ,& ! intent(in) : initial temperature (K) - volFracIceInit = scalarCanopyIce/(iden_water*canopyDepth),& ! intent(in) : initial volumetric fraction of ice (-) - ! trial values - xTemp = xTemp ,& ! intent(inout) : trial value of temperature - dLiq_dT = dTheta_dTkCanopy ,& ! intent(in) : derivative in liquid water content w.r.t. temperature (K-1) - volFracIceTrial = scalarVolFracIce ,& ! intent(in) : trial value for volumetric fraction of ice - ! residual and derivative - residual = residual ,& ! intent(out) : residual (J m-3) - derivative = derivative ) ! intent(out) : derivative (J m-3 K-1) - - ! * snow and soil - case(iname_snow, iname_soil) - call xTempSolve(& - ! constant over iterations - meltNrg = meltNrg ,& ! intent(in) : energy for melt+freeze (J m-3) - heatCap = mLayerVolHtCapBulk(iLayer) ,& ! intent(in) : volumetric heat capacity (J m-3 K-1) - tempInit = mLayerTemp(iLayer) ,& ! intent(in) : initial temperature (K) - volFracIceInit = mLayerVolFracIce(iLayer) ,& ! intent(in) : initial volumetric fraction of ice (-) - ! trial values - xTemp = xTemp ,& ! intent(inout) : trial value of temperature - dLiq_dT = mLayerdTheta_dTk(iLayer) ,& ! intent(in) : derivative in liquid water content w.r.t. temperature (K-1) - volFracIceTrial = mLayerVolFracIceTrial(iLayer) ,& ! intent(in) : trial value for volumetric fraction of ice - ! residual and derivative - residual = residual ,& ! intent(out) : residual (J m-3) - derivative = derivative ) ! intent(out) : derivative (J m-3 K-1) - - ! * check - case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return - - end select ! domain type - - ! check validity of residual - if( ieee_is_nan(residual) )then - message=trim(message)//'residual is not valid' - err=20; return - endif - - ! update bracket - if(residual < 0._rkind)then - tempMax = min(xTemp,tempMax) - else - tempMin = max(tempMin,xTemp) - end if - - ! compute iteration increment - tempInc = residual/derivative ! K - - ! check - if(globalPrintFlag)& - write(*,'(i4,1x,e20.10,1x,5(f20.10,1x),L1)') iter, residual, xTemp-Tcrit, tempInc, Tcrit, tempMin, tempMax, bFlag - - ! check convergence - if(abs(residual) < nrgConvTol .or. abs(tempInc) < tempConvTol) exit iterations - - ! add constraints for snow temperature - if(ixDomainType==iname_veg .or. ixDomainType==iname_snow)then - if(tempInc > Tcrit - xTemp) tempInc=(Tcrit - xTemp)*0.5_rkind ! simple bi-section method - endif ! if the domain is vegetation or snow - - ! deal with the discontinuity between partially frozen and unfrozen soil - if(ixDomainType==iname_soil)then - ! difference from the temperature below which ice exists - critDiff = Tcrit - xTemp - ! --> initially frozen (T < Tcrit) - if(critDiff > 0._rkind)then - if(tempInc > critDiff) tempInc = critDiff + epsT ! set iteration increment to slightly above critical temperature - ! --> initially unfrozen (T > Tcrit) - else - if(tempInc < critDiff) tempInc = critDiff - epsT ! set iteration increment to slightly below critical temperature - endif - endif ! if the domain is soil - - ! update the temperature trial - xTemp = xTemp + tempInc - - ! check failed convergence - if(iter==maxiter)then - message=trim(message)//'failed to converge' - err=-20; return ! negative error code = try to recover - endif - - endif ! if adjusting the temperature - - end do iterations ! iterating - - ! save temperature - select case(ixDomainType) - case(iname_veg); scalarCanopyTempTrial = xTemp - case(iname_snow, iname_soil); mLayerTempTrial(iLayer) = xTemp - end select - - ! ======================================================================================================================================= - ! ======================================================================================================================================= - - ! ----- - ! - compute the liquid water matric potential (and necessay derivatives)... - ! ------------------------------------------------------------------------- - - ! only for soil - if(ixDomainType==iname_soil)then - - ! check liquid water (include tolerance) - if(mLayerVolFracLiqTrial(iLayer) > theta_sat(ixControlIndex)+epsT )then - message=trim(message)//'liquid water greater than porosity' - print*,'---------------' - print*,'porosity(theta_sat)=', theta_sat(ixControlIndex) - print*,'liq water =',mLayerVolFracLiqTrial(iLayer) - print*,'layer =',iLayer - print*,'---------------' - err=20; return - endif - - ! case of hydrology state uncoupled with energy - if(.not.isNrgState .and. .not.isCoupled)then - - ! derivatives relating liquid water matric potential to total water matric potential and temperature - dPsiLiq_dPsi0(ixControlIndex) = 1._rkind ! exact correspondence (psiLiq=psi0) - dPsiLiq_dTemp(ixControlIndex) = 0._rkind ! no relationship between liquid water matric potential and temperature - - ! case of energy state or coupled solution - else - - ! compute the liquid matric potential (and the derivatives w.r.t. total matric potential and temperature) - call liquidHead(& - ! input - mLayerMatricHeadTrial(ixControlIndex) ,& ! intent(in) : total water matric potential (m) - mLayerVolFracLiqTrial(iLayer) ,& ! intent(in) : volumetric fraction of liquid water (-) - mLayerVolFracIceTrial(iLayer) ,& ! intent(in) : volumetric fraction of ice (-) - vGn_alpha(ixControlIndex),vGn_n(ixControlIndex),theta_sat(ixControlIndex),theta_res(ixControlIndex),vGn_m(ixControlIndex), & ! intent(in) : soil parameters - dVolTot_dPsi0(ixControlIndex) ,& ! intent(in) : derivative in the soil water characteristic (m-1) - mLayerdTheta_dTk(iLayer) ,& ! intent(in) : derivative in volumetric total water w.r.t. temperature (K-1) - ! output - mLayerMatricHeadLiqTrial(ixControlIndex) ,& ! intent(out): liquid water matric potential (m) - dPsiLiq_dPsi0(ixControlIndex) ,& ! intent(out): derivative in the liquid water matric potential w.r.t. the total water matric potential (-) - dPsiLiq_dTemp(ixControlIndex) ,& ! intent(out): derivative in the liquid water matric potential w.r.t. temperature (m K-1) - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - - endif ! switch between hydrology and energy state - - endif ! if domain is soil - - end do ! looping through state variables - - ! deallocate space - deallocate(computedCoupling,stat=err) ! .true. if computed the coupling for a given state variable - if(err/=0)then; message=trim(message)//'problem deallocating computedCoupling'; return; endif - - ! end association to the variables in the data structures - end associate +! ********************************************************************************************************** +! public subroutine updateVars: compute diagnostic variables and derivatives +! ********************************************************************************************************** +subroutine updateVars(& + ! input + computeEnthTemp, & ! intent(in): flag if computing temperature compoment of enthalpy + use_lookup, & ! intent(in): flag to use the lookup table for soil enthalpy + do_adjustTemp, & ! intent(in): logical flag to adjust temperature to account for the energy used in melt+freeze + mpar_data, & ! intent(in): model parameters for a local HRU + indx_data, & ! intent(in): indices defining model states and layers + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables + lookup_data, & ! intent(in): lookup table data structure + scalarCanairTempTrial, & ! intent(in): trial value of canopy air space temperature (K) + ! output: variables for the vegetation canopy + scalarCanopyTempTrial, & ! intent(inout): trial value of canopy temperature (K) + scalarCanopyWatTrial, & ! intent(inout): trial value of canopy total water (kg m-2) + scalarCanopyLiqTrial, & ! intent(inout): trial value of canopy liquid water (kg m-2) + scalarCanopyIceTrial, & ! intent(inout): trial value of canopy ice content (kg m-2) + ! output: variables for the snow-soil domain + mLayerTempTrial, & ! intent(inout): trial vector of layer temperature (K) + mLayerVolFracWatTrial, & ! intent(inout): trial vector of volumetric total water content (-) + mLayerVolFracLiqTrial, & ! intent(inout): trial vector of volumetric liquid water content (-) + mLayerVolFracIceTrial, & ! intent(inout): trial vector of volumetric ice water content (-) + mLayerMatricHeadTrial, & ! intent(inout): trial vector of total water matric potential (m) + mLayerMatricHeadLiqTrial, & ! intent(inout): trial vector of liquid water matric potential (m) + ! output: enthalpy variables + scalarCanairEnthalpyTrial, & ! intent(inout): trial value for enthalpy of the canopy air space (J m-3) + scalarCanopyEnthTempTrial, & ! intent(inout): trial value for temperature component of enthalpy of the vegetation canopy (J m-3) + mLayerEnthTempTrial, & ! intent(inout): trial vector of temperature component of enthalpy of each snow+soil layer (J m-3) + ! output: error control + err,message) ! intent(out): error control + ! -------------------------------------------------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------------------------------------------------- + implicit none + ! input + logical(lgt) ,intent(in) :: computeEnthTemp ! flag if computing temperature compoment of enthalpy + logical(lgt) ,intent(in) :: use_lookup ! flag to use the lookup table for soil enthalpy + logical(lgt) ,intent(in) :: do_adjustTemp ! flag to adjust temperature to account for the energy used in melt+freeze + type(var_dlength),intent(in) :: mpar_data ! model parameters for a local HRU + type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers + type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU + type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + type(zLookup) ,intent(in) :: lookup_data ! lookup tables + real(rkind),intent(in) :: scalarCanairTempTrial ! trial value of canopy air space temperature (K) + ! output: variables for the vegetation canopy + real(rkind),intent(inout) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) + real(rkind),intent(inout) :: scalarCanopyWatTrial ! trial value of canopy total water (kg m-2) + real(rkind),intent(inout) :: scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) + real(rkind),intent(inout) :: scalarCanopyIceTrial ! trial value of canopy ice content (kg m-2) + ! output: variables for the snow-soil domain + real(rkind),intent(inout) :: mLayerTempTrial(:) ! trial vector of layer temperature (K) + real(rkind),intent(inout) :: mLayerVolFracWatTrial(:) ! trial vector of volumetric total water content (-) + real(rkind),intent(inout) :: mLayerVolFracLiqTrial(:) ! trial vector of volumetric liquid water content (-) + real(rkind),intent(inout) :: mLayerVolFracIceTrial(:) ! trial vector of volumetric ice water content (-) + real(rkind),intent(inout) :: mLayerMatricHeadTrial(:) ! trial vector of total water matric potential (m) + real(rkind),intent(inout) :: mLayerMatricHeadLiqTrial(:) ! trial vector of liquid water matric potential (m) + ! output: enthalpy variables + real(rkind),intent(inout) :: scalarCanairEnthalpyTrial ! trial value for enthalpy of the canopy air space (J m-3) + real(rkind),intent(inout) :: scalarCanopyEnthTempTrial ! trial value for temperature component of enthalpy of the vegetation canopy (J m-3) + real(rkind),intent(inout) :: mLayerEnthTempTrial(:) ! trial vector of temperature component of enthalpy of each snow+soil layer (J m-3) + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! -------------------------------------------------------------------------------------------------------------------------------- + ! general local variables + integer(i4b) :: iState ! index of model state variable + integer(i4b) :: iLayer ! index of layer within the snow+soil domain + integer(i4b) :: ixFullVector ! index within full state vector + integer(i4b) :: ixDomainType ! name of a given model domain + integer(i4b) :: ixControlIndex ! index within a given model domain + integer(i4b) :: ixOther,ixOtherLocal ! index of the coupled state variable within the (full, local) vector + logical(lgt) :: isCoupled ! .true. if a given variable shared another state variable in the same control volume + logical(lgt) :: isNrgState ! .true. if a given variable is an energy state + logical(lgt),allocatable :: computedCoupling(:) ! .true. if computed the coupling for a given state variable + real(rkind) :: scalarVolFracLiq ! volumetric fraction of liquid water (-) + real(rkind) :: scalarVolFracIce ! volumetric fraction of ice (-) + real(rkind) :: Tcrit ! critical soil temperature below which ice exists (K) + real(rkind) :: xTemp ! temporary temperature (K) + real(rkind) :: effSat ! effective saturation (-) + real(rkind) :: avPore ! available pore space (-) + character(len=256) :: cMessage ! error message of downwind routine + logical(lgt),parameter :: printFlag=.false. ! flag to turn on printing + ! iterative solution for temperature + real(rkind) :: meltNrg ! energy for melt+freeze (J m-3) + real(rkind) :: residual ! residual in the energy equation (J m-3) + real(rkind) :: derivative ! derivative in the energy equation (J m-3 K-1) + real(rkind) :: tempInc ! iteration increment (K) + integer(i4b) :: iter ! iteration index + integer(i4b) :: niter ! number of iterations + integer(i4b),parameter :: maxiter=100 ! maximum number of iterations + real(rkind),parameter :: nrgConvTol=1.e-4_rkind ! convergence tolerance for energy (J m-3) + real(rkind),parameter :: tempConvTol=1.e-6_rkind ! convergence tolerance for temperature (K) + real(rkind) :: critDiff ! temperature difference from critical (K) + real(rkind) :: tempMin ! minimum bracket for temperature (K) + real(rkind) :: tempMax ! maximum bracket for temperature (K) + logical(lgt) :: bFlag ! flag to denote that iteration increment was constrained using bi-section + real(rkind),parameter :: epsT=1.e-7_rkind ! small interval above/below critical temperature (K) + ! -------------------------------------------------------------------------------------------------------------------------------- + ! make association with variables in the data structures + associate(& + ! number of model layers, and layer type + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in): [i4b] total number of snow layers + nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1) ,& ! intent(in): [i4b] total number of soil layers + nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1) ,& ! intent(in): [i4b] total number of snow and soil layers + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat ,& ! intent(in): [dp(:)] depth of each layer in the snow-soil sub-domain (m) + ! indices defining model states and layers + ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable + ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) + ! indices in the full vector for specific domains + ixNrgCanair => indx_data%var(iLookINDEX%ixNrgCanair)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for energy states in canopy air space domain + ixNrgCanopy => indx_data%var(iLookINDEX%ixNrgCanopy)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for energy states in the canopy domain + ixHydCanopy => indx_data%var(iLookINDEX%ixHydCanopy)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for hydrology states in the canopy domain + ixNrgLayer => indx_data%var(iLookINDEX%ixNrgLayer)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for energy states in the snow+soil domain + ixHydLayer => indx_data%var(iLookINDEX%ixHydLayer)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for hydrology states in the snow+soil domain + ! mapping between the full state vector and the state subset + ixMapFull2Subset => indx_data%var(iLookINDEX%ixMapFull2Subset)%dat ,& ! intent(in): [i4b(:)] list of indices in the state subset for each state in the full state vector + ixMapSubset2Full => indx_data%var(iLookINDEX%ixMapSubset2Full)%dat ,& ! intent(in): [i4b(:)] [state subset] list of indices of the full state vector in the state subset + ! type of domain, type of state variable, and index of control volume within domain + ixDomainType_subset => indx_data%var(iLookINDEX%ixDomainType_subset)%dat ,& ! intent(in): [i4b(:)] [state subset] id of domain for desired model state variables + ixControlVolume => indx_data%var(iLookINDEX%ixControlVolume)%dat ,& ! intent(in): [i4b(:)] index of the control volume for different domains (veg, snow, soil) + ixStateType => indx_data%var(iLookINDEX%ixStateType)%dat ,& ! intent(in): [i4b(:)] indices defining the type of the state (iname_nrgLayer...) + ! snow parameters + snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1) ,& ! intent(in): [dp] scaling parameter for the snow freezing curve (K-1) + ! depth-varying model parameters (heat capacity, enthalpy) + specificHeatVeg => mpar_data%var(iLookPARAM%specificHeatVeg)%dat(1) ,& ! intent(in): [dp ] specific heat of vegetation (J kg-1 K-1) + maxMassVegetation => mpar_data%var(iLookPARAM%maxMassVegetation)%dat(1) ,& ! intent(in): [dp ] maximum mass of vegetation (kg m-2) + soil_dens_intr => mpar_data%var(iLookPARAM%soil_dens_intr)%dat ,& ! intent(in): [dp(:)] intrinsic soil density (kg m-3) + vGn_m => diag_data%var(iLookDIAG%scalarVGn_m)%dat ,& ! intent(in): [dp(:)] van Genutchen "m" parameter (-) + vGn_n => mpar_data%var(iLookPARAM%vGn_n)%dat ,& ! intent(in): [dp(:)] van Genutchen "n" parameter (-) + vGn_alpha => mpar_data%var(iLookPARAM%vGn_alpha)%dat ,& ! intent(in): [dp(:)] van Genutchen "alpha" parameter (m-1) + theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat ,& ! intent(in): [dp(:)] soil porosity (-) + theta_res => mpar_data%var(iLookPARAM%theta_res)%dat ,& ! intent(in): [dp(:)] soil residual volumetric water content (-) + ! model diagnostic variables (heat capacity) + canopyDepth => diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1) ,& ! intent(in): [dp ] canopy depth (m) + scalarBulkVolHeatCapVeg => diag_data%var(iLookDIAG%scalarBulkVolHeatCapVeg)%dat(1),& ! intent(in): [dp ] volumetric heat capacity of the vegetation (J m-3 K-1) + mLayerVolHtCapBulk => diag_data%var(iLookDIAG%mLayerVolHtCapBulk)%dat ,& ! intent(in): [dp(:)] volumetric heat capacity in each layer (J m-3 K-1) + ! model diagnostic variables (fraction of liquid water) + scalarFracLiqVeg => diag_data%var(iLookDIAG%scalarFracLiqVeg)%dat(1) ,& ! intent(out): [dp] fraction of liquid water on vegetation (-) + mLayerFracLiqSnow => diag_data%var(iLookDIAG%mLayerFracLiqSnow)%dat ,& ! intent(out): [dp(:)] fraction of liquid water in each snow layer (-) + ! model states from a previous solution + scalarCanopyTemp => prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1) ,& ! intent(in): [dp] temperature of the vegetation canopy (K) + mLayerTemp => prog_data%var(iLookPROG%mLayerTemp)%dat ,& ! intent(in): [dp(:)] temperature of each snow/soil layer (K) + scalarCanopyWat => prog_data%var(iLookPROG%scalarCanopyWat)%dat(1) ,& ! intent(in): [dp] mass of total water on the vegetation canopy (kg m-2) + mLayerVolFracWat => prog_data%var(iLookPROG%mLayerVolFracWat)%dat ,& ! intent(in): [dp(:)] volumetric fraction of total water (-) + ! model diagnostic variables from a previous solution + scalarCanopyIce => prog_data%var(iLookPROG%scalarCanopyIce)%dat(1) ,& ! intent(in): [dp(:)] mass of ice on the vegetation canopy (kg m-2) + mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat ,& ! intent(in): [dp(:)] volumetric fraction of ice (-) + ! derivatives + dVolTot_dPsi0 => deriv_data%var(iLookDERIV%dVolTot_dPsi0 )%dat ,& ! intent(out): [dp(:)] derivative in total water content w.r.t. total water matric potential + dPsiLiq_dPsi0 => deriv_data%var(iLookDERIV%dPsiLiq_dPsi0 )%dat ,& ! intent(out): [dp(:)] derivative in liquid water matric pot w.r.t. the total water matric pot (-) + dPsiLiq_dTemp => deriv_data%var(iLookDERIV%dPsiLiq_dTemp )%dat ,& ! intent(out): [dp(:)] derivative in the liquid water matric potential w.r.t. temperature + mLayerdTheta_dTk => deriv_data%var(iLookDERIV%mLayerdTheta_dTk)%dat ,& ! intent(out): [dp(:)] derivative of volumetric liquid water content w.r.t. temperature + dTheta_dTkCanopy => deriv_data%var(iLookDERIV%dTheta_dTkCanopy)%dat(1) ,& ! intent(out): [dp] derivative of volumetric liquid water content w.r.t. temperature + dFracLiqWat_dTk => deriv_data%var(iLookDERIV%dFracLiqWat_dTk)%dat ,& ! intent(out): [dp(:)] derivative in fraction of liquid water w.r.t. temperature + dFracLiqVeg_dTkCanopy => deriv_data%var(iLookDERIV%dFracLiqVeg_dTkCanopy)%dat(1),& ! intent(out): [dp ] derivative in fraction of (throughfall + drainage) w.r.t. temperature + ! derivatives inside solver for Jacobian only + mLayerdTemp_dt => deriv_data%var(iLookDERIV%mLayerdTemp_dt )%dat ,& ! intent(out): [dp(:)] timestep change in layer temperature + scalarCanopydTemp_dt => deriv_data%var(iLookDERIV%scalarCanopydTemp_dt)%dat(1) ,& ! intent(out): [dp ] timestep change in canopy temperature + mLayerdWat_dt => deriv_data%var(iLookDERIV%mLayerdWat_dt)%dat ,& ! intent(out): [dp(:)] timestep change in layer volumetric fraction of total water + scalarCanopydWat_dt => deriv_data%var(iLookDERIV%scalarCanopydWat_dt)%dat(1) & ! intent(out): [dp ] timestep change in canopy total water + ) ! association with variables in the data structures + + ! -------------------------------------------------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------------------------------------------------- + + ! initialize error control + err=0; message='updateVars/' + + ! allocate space and assign values to the flag vector + allocate(computedCoupling(size(ixMapSubset2Full)),stat=err) ! .true. if computed the coupling for a given state variable + if(err/=0)then; message=trim(message)//'problem allocating computedCoupling'; return; endif + computedCoupling(:)=.false. + + ! loop through model state variables + do iState=1,size(ixMapSubset2Full) + + ! check the need for the computations + if(computedCoupling(iState)) cycle + + ! ----- + ! - compute indices... + ! -------------------- + + ! get domain type, and index of the control volume within the domain + ixFullVector = ixMapSubset2Full(iState) ! index within full state vector + ixDomainType = ixDomainType_subset(iState) ! named variables defining the domain (iname_cas, iname_veg, etc.) + ixControlIndex = ixControlVolume(ixFullVector) ! index within a given domain + + ! get the layer index + select case(ixDomainType) + case(iname_cas); iLayer = 0 + case(iname_veg); iLayer = 0 + case(iname_snow); iLayer = ixControlIndex + case(iname_soil); iLayer = ixControlIndex + nSnow + case(iname_aquifer); cycle ! aquifer: do nothing + case default; err=20; message=trim(message)//'expect case to be iname_cas, iname_veg, iname_snow, iname_soil, iname_aquifer'; return + end select + + ! get the index of the other (energy or mass) state variable within the full state vector + select case(ixDomainType) + case(iname_cas) ; ixOther = integerMissing + case(iname_veg) ; ixOther = merge(ixHydCanopy(1), ixNrgCanopy(1), ixStateType(ixFullVector)==iname_nrgCanopy) + case(iname_snow, iname_soil); ixOther = merge(ixHydLayer(iLayer),ixNrgLayer(iLayer),ixStateType(ixFullVector)==iname_nrgLayer) + case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return + end select + + ! get the index in the local state vector + if(ixDomainType==iname_cas)then + ixOtherLocal = integerMissing + else + ixOtherLocal = ixMapFull2Subset(ixOther) ! ixOtherLocal could equal integerMissing + endif + if(ixOtherLocal/=integerMissing) computedCoupling(ixOtherLocal)=.true. + + ! check if we have a coupled solution + isCoupled = (ixOtherLocal/=integerMissing) + + ! check if we are an energy state + isNrgState = (ixStateType(ixFullVector)==iname_nrgCanopy .or. ixStateType(ixFullVector)==iname_nrgLayer) + + if(printFlag)then + print*, 'iState = ', iState, size(ixMapSubset2Full) + print*, 'ixFullVector = ', ixFullVector + print*, 'ixDomainType = ', ixDomainType + print*, 'ixControlIndex = ', ixControlIndex + print*, 'ixOther = ', ixOther + print*, 'ixOtherLocal = ', ixOtherLocal + print*, 'do_adjustTemp = ', do_adjustTemp + print*, 'isCoupled = ', isCoupled + print*, 'isNrgState = ', isNrgState + endif + + ! calculate temperature component of enthalpy for canopy air space + if(ixDomainType==iname_cas)then + if(computeEnthTemp)then + call T2enthTemp_cas(& + scalarCanairTempTrial, & ! intent(in): canopy air temperature (K) + scalarCanairEnthalpyTrial) ! intent(out): enthalpy of the canopy air space (J m-3) + else + scalarCanairEnthalpyTrial = realMissing + endif + cycle ! no more to do on canopy air space + endif + + ! update hydrology state variables for the uncoupled solution + if(.not.isNrgState .and. .not.isCoupled)then + + ! update the total water from volumetric liquid water + if(ixStateType(ixFullVector)==iname_liqCanopy .or. ixStateType(ixFullVector)==iname_liqLayer)then + select case(ixDomainType) + case(iname_veg); scalarCanopyWatTrial = scalarCanopyLiqTrial + scalarCanopyIceTrial + case(iname_snow); mLayerVolFracWatTrial(iLayer) = mLayerVolFracLiqTrial(iLayer) + mLayerVolFracIceTrial(iLayer)*iden_ice/iden_water + case(iname_soil); mLayerVolFracWatTrial(iLayer) = mLayerVolFracLiqTrial(iLayer) + mLayerVolFracIceTrial(iLayer) ! no volume expansion + case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, or iname_soil'; return + end select + endif + + ! update the total water and the total water matric potential + if(ixDomainType==iname_soil)then + select case( ixStateType(ixFullVector) ) + ! --> update the total water from the liquid water matric potential + case(iname_lmpLayer) + effSat = volFracLiq(mLayerMatricHeadLiqTrial(ixControlIndex),vGn_alpha(ixControlIndex),0._rkind,1._rkind,vGn_n(ixControlIndex),vGn_m(ixControlIndex)) ! effective saturation + avPore = theta_sat(ixControlIndex) - mLayerVolFracIceTrial(iLayer) - theta_res(ixControlIndex) ! available pore space + mLayerVolFracLiqTrial(iLayer) = effSat*avPore + theta_res(ixControlIndex) + mLayerVolFracWatTrial(iLayer) = mLayerVolFracLiqTrial(iLayer) + mLayerVolFracIceTrial(iLayer) ! no volume expansion + mLayerMatricHeadTrial(ixControlIndex) = matricHead(mLayerVolFracWatTrial(iLayer),vGn_alpha(ixControlIndex),theta_res(ixControlIndex),theta_sat(ixControlIndex),vGn_n(ixControlIndex),vGn_m(ixControlIndex)) + ! --> update the total water from the total water matric potential + case(iname_matLayer) + mLayerVolFracWatTrial(iLayer) = volFracLiq(mLayerMatricHeadTrial(ixControlIndex),vGn_alpha(ixControlIndex),theta_res(ixControlIndex),theta_sat(ixControlIndex),vGn_n(ixControlIndex),vGn_m(ixControlIndex)) + ! --> update the total water matric potential (assume already have mLayerVolFracWatTrial given block above) + case(iname_liqLayer, iname_watLayer) + mLayerMatricHeadTrial(ixControlIndex) = matricHead(mLayerVolFracWatTrial(iLayer),vGn_alpha(ixControlIndex),theta_res(ixControlIndex),theta_sat(ixControlIndex),vGn_n(ixControlIndex),vGn_m(ixControlIndex)) + case default; err=20; message=trim(message)//'expect iname_lmpLayer, iname_matLayer, iname_liqLayer, or iname_watLayer'; return + end select + endif ! if in the soil domain + + endif ! if hydrology state variable or uncoupled solution + + ! compute the critical soil temperature below which ice exists + select case(ixDomainType) + case(iname_veg, iname_snow); Tcrit = Tfreeze + case(iname_soil); Tcrit = crit_soilT( mLayerMatricHeadTrial(ixControlIndex) ) + case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return + end select + + ! initialize temperature + select case(ixDomainType) + case(iname_veg); xTemp = scalarCanopyTempTrial + case(iname_snow, iname_soil); xTemp = mLayerTempTrial(iLayer) + case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return + end select + + ! define brackets for the root + ! NOTE: start with an enormous range; updated quickly in the iterations + tempMin = xTemp - 10._rkind + tempMax = xTemp + 10._rkind + + ! get iterations (set to maximum iterations if adjusting the temperature) + niter = merge(maxiter, 1, do_adjustTemp) + + ! iterate + iterations: do iter=1,niter + + ! restrict temperature + if(xTemp <= tempMin .or. xTemp >= tempMax)then + xTemp = 0.5_rkind*(tempMin + tempMax) ! new value + bFlag = .true. + else + bFlag = .false. + endif + + ! ----- + ! - compute derivatives... + ! ------------------------ + + ! compute temperature time derivatives + select case(ixDomainType) + case(iname_veg); scalarCanopydTemp_dt = xTemp - scalarCanopyTemp + case(iname_snow, iname_soil); mLayerdTemp_dt(iLayer) = xTemp - mLayerTemp(iLayer) + end select + + ! compute the derivative in total water content w.r.t. total water matric potential (m-1) + ! NOTE 1: valid for frozen and unfrozen conditions + ! NOTE 2: for case "iname_lmpLayer", dVolTot_dPsi0 = dVolLiq_dPsi + if(ixDomainType==iname_soil)then + select case( ixStateType(ixFullVector) ) + case(iname_lmpLayer); dVolTot_dPsi0(ixControlIndex) = dTheta_dPsi(mLayerMatricHeadLiqTrial(ixControlIndex),vGn_alpha(ixControlIndex),0._rkind,1._rkind,vGn_n(ixControlIndex),vGn_m(ixControlIndex))*avPore + case default; dVolTot_dPsi0(ixControlIndex) = dTheta_dPsi(mLayerMatricHeadTrial(ixControlIndex),vGn_alpha(ixControlIndex),theta_res(ixControlIndex),theta_sat(ixControlIndex),vGn_n(ixControlIndex),vGn_m(ixControlIndex)) + end select + endif + + ! compute the derivative in liquid water content w.r.t. temperature + ! --> partially frozen: dependence of liquid water on temperature + if(xTemp unfrozen: no dependence of liquid water on temperature + else + select case(ixDomainType) + case(iname_veg); dTheta_dTkCanopy = 0._rkind; dFracLiqVeg_dTkCanopy = 0._rkind + case(iname_snow, iname_soil); mLayerdTheta_dTk(iLayer) = 0._rkind; dFracLiqWat_dTk(iLayer) = 0._rkind + case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return + end select ! domain type + endif + + + ! ----- + ! - update volumetric fraction of liquid water and ice... + ! => case of hydrology state uncoupled with energy (and when not adjusting the temperature)... + ! ----------------------------------------------------------------------------------------------- + + ! case of hydrology state uncoupled with energy (and when not adjusting the temperature) + if(.not.do_adjustTemp .and. .not.isNrgState .and. .not.isCoupled)then + + ! compute the fraction of snow + select case(ixDomainType) + case(iname_veg); scalarFracLiqVeg = fracliquid(xTemp,snowfrz_scale) + case(iname_snow); mLayerFracLiqSnow(iLayer) = fracliquid(xTemp,snowfrz_scale) + case(iname_soil) ! do nothing + case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return + end select ! domain type + + ! ----- + ! - update volumetric fraction of liquid water and ice... + ! => case of energy state or coupled solution (or adjusting the temperature)... + ! -------------------------------------------------------------------------------- + + ! case of energy state OR coupled solution (or adjusting the temperature) + elseif(do_adjustTemp .or. ( (isNrgState .or. isCoupled) ) )then + + ! identify domain type + select case(ixDomainType) + + ! *** vegetation canopy + case(iname_veg) + + ! compute volumetric fraction of liquid water and ice + call updateSnow(xTemp, & ! intent(in): temperature (K) + scalarCanopyWatTrial/(iden_water*canopyDepth),& ! intent(in): volumetric fraction of total water (-) + snowfrz_scale, & ! intent(in): scaling parameter for the snow freezing curve (K-1) + scalarVolFracLiq, & ! intent(out): trial volumetric fraction of liquid water (-) + scalarVolFracIce, & ! intent(out): trial volumetric fraction if ice (-) + scalarFracLiqVeg, & ! intent(out): fraction of liquid water (-) + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! compute mass of water on the canopy + ! NOTE: possibilities for speed-up here + scalarCanopyLiqTrial = scalarFracLiqVeg *scalarCanopyWatTrial !(kg m-2), scalarVolFracLiq*iden_water*canopyDepth + scalarCanopyIceTrial = (1._rkind - scalarFracLiqVeg)*scalarCanopyWatTrial !(kg m-2), scalarVolFracIce* iden_ice *canopyDepth + + ! *** snow layers + case(iname_snow) + + ! compute volumetric fraction of liquid water and ice + call updateSnow(xTemp, & ! intent(in): temperature (K) + mLayerVolFracWatTrial(iLayer), & ! intent(in): mass state variable = trial volumetric fraction of water (-) + snowfrz_scale, & ! intent(in): scaling parameter for the snow freezing curve (K-1) + mLayerVolFracLiqTrial(iLayer), & ! intent(out): trial volumetric fraction of liquid water (-) + mLayerVolFracIceTrial(iLayer), & ! intent(out): trial volumetric fraction if ice (-) + mLayerFracLiqSnow(iLayer), & ! intent(out): fraction of liquid water (-) + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! *** soil layers + case(iname_soil) + + ! compute volumetric fraction of liquid water and ice + call updateSoil(xTemp, & ! intent(in): temperature (K) + mLayerMatricHeadTrial(ixControlIndex), & ! intent(in): total water matric potential (m) + vGn_alpha(ixControlIndex),vGn_n(ixControlIndex),theta_sat(ixControlIndex),theta_res(ixControlIndex),vGn_m(ixControlIndex), & ! intent(in): soil parameters + mLayerVolFracWatTrial(iLayer), & ! intent(in): mass state variable = trial volumetric fraction of water (-) + mLayerVolFracLiqTrial(iLayer), & ! intent(out): trial volumetric fraction of liquid water (-) + mLayerVolFracIceTrial(iLayer), & ! intent(out): trial volumetric fraction if ice (-) + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! check + case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return + + end select ! domain type + + ! final check + else + + ! do nothing (input = output) -- and check that we got here correctly + if( (isNrgState .or. isCoupled) )then + scalarVolFracLiq = realMissing + scalarVolFracIce = realMissing + else + message=trim(message)//'unexpected else branch' + err=20; return + endif + + endif ! if energy state or solution is coupled + + ! compute water time derivatives + select case(ixDomainType) + case(iname_veg); scalarCanopydWat_dt = scalarCanopyWatTrial - scalarCanopyWat + case(iname_snow, iname_soil); mLayerdWat_dt(iLayer) = mLayerVolFracWatTrial(iLayer) - mLayerVolFracWat(iLayer) + end select + + ! ----- + ! - update temperatures... + ! ------------------------ + + ! check the need to adjust temperature + if(do_adjustTemp)then + + ! get the melt energy + meltNrg = merge(LH_fus*iden_ice, LH_fus*iden_water, ixDomainType==iname_snow) + + ! compute the residual and the derivative + select case(ixDomainType) + + ! * vegetation + case(iname_veg) + call xTempSolve(& + ! constant over iterations + meltNrg = meltNrg ,& ! intent(in): energy for melt+freeze (J m-3) + heatCap = scalarBulkVolHeatCapVeg ,& ! intent(in): volumetric heat capacity (J m-3 K-1) + tempInit = scalarCanopyTemp ,& ! intent(in): initial temperature (K) + volFracIceInit = scalarCanopyIce/(iden_water*canopyDepth),& ! intent(in): initial volumetric fraction of ice (-) + ! trial values + xTemp = xTemp ,& ! intent(inout): trial value of temperature + dLiq_dT = dTheta_dTkCanopy ,& ! intent(in): derivative in liquid water content w.r.t. temperature (K-1) + volFracIceTrial = scalarVolFracIce ,& ! intent(in): trial value for volumetric fraction of ice + ! residual and derivative + residual = residual ,& ! intent(out): residual (J m-3) + derivative = derivative ) ! intent(out): derivative (J m-3 K-1) + + ! * snow and soil + case(iname_snow, iname_soil) + call xTempSolve(& + ! constant over iterations + meltNrg = meltNrg ,& ! intent(in): energy for melt+freeze (J m-3) + heatCap = mLayerVolHtCapBulk(iLayer) ,& ! intent(in): volumetric heat capacity (J m-3 K-1) + tempInit = mLayerTemp(iLayer) ,& ! intent(in): initial temperature (K) + volFracIceInit = mLayerVolFracIce(iLayer) ,& ! intent(in): initial volumetric fraction of ice (-) + ! trial values + xTemp = xTemp ,& ! intent(inout): trial value of temperature + dLiq_dT = mLayerdTheta_dTk(iLayer) ,& ! intent(in): derivative in liquid water content w.r.t. temperature (K-1) + volFracIceTrial = mLayerVolFracIceTrial(iLayer) ,& ! intent(in): trial value for volumetric fraction of ice + ! residual and derivative + residual = residual ,& ! intent(out): residual (J m-3) + derivative = derivative ) ! intent(out): derivative (J m-3 K-1) + + ! * check + case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return + + end select ! domain type + + ! check validity of residual + if( ieee_is_nan(residual) )then + message=trim(message)//'residual is not valid' + err=20; return + endif + + ! update bracket + if(residual < 0._rkind)then + tempMax = min(xTemp,tempMax) + else + tempMin = max(tempMin,xTemp) + end if + + ! compute iteration increment + tempInc = residual/derivative ! K + + ! check + if(globalPrintFlag)& + write(*,'(i4,1x,e20.10,1x,5(f20.10,1x),L1)') iter, residual, xTemp-Tcrit, tempInc, Tcrit, tempMin, tempMax, bFlag + + ! check convergence + if(abs(residual) < nrgConvTol .or. abs(tempInc) < tempConvTol) exit iterations + + ! add constraints for snow temperature + if(ixDomainType==iname_veg .or. ixDomainType==iname_snow)then + if(tempInc > Tcrit - xTemp) tempInc=(Tcrit - xTemp)*0.5_rkind ! simple bi-section method + endif ! if the domain is vegetation or snow + + ! deal with the discontinuity between partially frozen and unfrozen soil + if(ixDomainType==iname_soil)then + ! difference from the temperature below which ice exists + critDiff = Tcrit - xTemp + ! --> initially frozen (T < Tcrit) + if(critDiff > 0._rkind)then + if(tempInc > critDiff) tempInc = critDiff + epsT ! set iteration increment to slightly above critical temperature + ! --> initially unfrozen (T > Tcrit) + else + if(tempInc < critDiff) tempInc = critDiff - epsT ! set iteration increment to slightly below critical temperature + endif + endif ! if the domain is soil + + ! update the temperature trial + xTemp = xTemp + tempInc + + ! check failed convergence + if(iter==maxiter)then + message=trim(message)//'failed to converge' + err=-20; return ! negative error code = try to recover + endif + + endif ! if adjusting the temperature + + end do iterations ! iterating + + ! save temperature + select case(ixDomainType) + case(iname_veg); scalarCanopyTempTrial = xTemp + case(iname_snow, iname_soil); mLayerTempTrial(iLayer) = xTemp + end select + + ! calculate temperature component of enthalpy for remaining domains + if(ixDomainType==iname_veg)then + if(computeEnthTemp)then + call T2enthTemp_veg(& + canopyDepth, & ! intent(in): canopy depth (m) + specificHeatVeg, & ! intent(in): specific heat of vegetation (J kg-1 K-1) + maxMassVegetation, & ! intent(in): maximum mass of vegetation (kg m-2) + snowfrz_scale, & ! intent(in): scaling parameter for the snow freezing curve (K-1) + scalarCanopyTempTrial, & ! intent(in): canopy temperature (K) + scalarCanopyWatTrial, & ! intent(in): canopy water content (kg m-2) + scalarCanopyEnthTempTrial) ! intent(out): temperature component of enthalpy of the vegetation canopy (J m-3) + else + scalarCanopyEnthTempTrial = realMissing + endif + elseif(ixDomainType==iname_snow)then + if(computeEnthTemp)then + call T2enthTemp_snow(& + snowfrz_scale, & ! intent(in): scaling parameter for the snow freezing curve (K-1) + mLayerTempTrial(iLayer), & ! intent(in): layer temperature (K) + mLayerVolFracWatTrial(iLayer), & ! intent(in): volumetric total water content (-) + mLayerEnthTempTrial(iLayer)) ! intent(out): temperature component of enthalpy of each snow layer (J m-3) + else + mLayerEnthTempTrial(iLayer) = realMissing + endif + elseif(ixDomainType==iname_soil)then + if(computeEnthTemp)then + call T2enthTemp_soil(& + use_lookup, & ! intent(in): flag to use the lookup table for soil enthalpy + soil_dens_intr(ixControlIndex), & ! intent(in): intrinsic soil density (kg m-3) + vGn_alpha(ixControlIndex),vGn_n(ixControlIndex),theta_sat(ixControlIndex),theta_res(ixControlIndex),vGn_m(ixControlIndex), & ! intent(in): soil parameters + ixControlIndex, & ! intent(in): index of the control volume within the domain + lookup_data, & ! intent(in): lookup table data structure + realMissing, & ! intent(in): lower value of integral (not computed) + mLayerTempTrial(iLayer), & ! intent(in): layer temperature (K) + mLayerMatricHeadTrial(ixControlIndex), & ! intent(in): matric head (m) + mLayerEnthTempTrial(iLayer), & ! intent(out): temperature component of enthalpy soil layer (J m-3) + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + else + mLayerEnthTempTrial(iLayer) = realMissing + endif + endif + + ! ======================================================================================================================================= + ! ======================================================================================================================================= + + ! ----- + ! - compute the liquid water matric potential (and necessary derivatives)... + ! ------------------------------------------------------------------------- + + ! only for soil + if(ixDomainType==iname_soil)then + + ! check liquid water (include tolerance) + if(mLayerVolFracLiqTrial(iLayer) > theta_sat(ixControlIndex)+epsT )then + message=trim(message)//'liquid water greater than porosity' + print*,'---------------' + print*,'porosity(theta_sat)=', theta_sat(ixControlIndex) + print*,'liq water =',mLayerVolFracLiqTrial(iLayer) + print*,'layer =',iLayer + print*,'---------------' + err=20; return + endif + + ! case of hydrology state uncoupled with energy + if(.not.isNrgState .and. .not.isCoupled)then + + ! derivatives relating liquid water matric potential to total water matric potential and temperature + dPsiLiq_dPsi0(ixControlIndex) = 1._rkind ! exact correspondence (psiLiq=psi0) + dPsiLiq_dTemp(ixControlIndex) = 0._rkind ! no relationship between liquid water matric potential and temperature + + ! case of energy state or coupled solution + else + + ! compute the liquid matric potential (and the derivatives w.r.t. total matric potential and temperature) + call liquidHead(& + ! input + mLayerMatricHeadTrial(ixControlIndex) ,& ! intent(in): total water matric potential (m) + mLayerVolFracLiqTrial(iLayer) ,& ! intent(in): volumetric fraction of liquid water (-) + mLayerVolFracIceTrial(iLayer) ,& ! intent(in): volumetric fraction of ice (-) + vGn_alpha(ixControlIndex),vGn_n(ixControlIndex),theta_sat(ixControlIndex),theta_res(ixControlIndex),vGn_m(ixControlIndex), & ! intent(in): soil parameters + dVolTot_dPsi0(ixControlIndex) ,& ! intent(in): derivative in the soil water characteristic (m-1) + mLayerdTheta_dTk(iLayer) ,& ! intent(in): derivative in volumetric total water w.r.t. temperature (K-1) + ! output + mLayerMatricHeadLiqTrial(ixControlIndex) ,& ! intent(out): liquid water matric potential (m) + dPsiLiq_dPsi0(ixControlIndex) ,& ! intent(out): derivative in the liquid water matric potential w.r.t. the total water matric potential (-) + dPsiLiq_dTemp(ixControlIndex) ,& ! intent(out): derivative in the liquid water matric potential w.r.t. temperature (m K-1) + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + + endif ! switch between hydrology and energy state + + endif ! if domain is soil + + end do ! looping through state variables + + deallocate(computedCoupling,stat=err) ! .true. if computed the coupling for a given state variable + if(err/=0)then; message=trim(message)//'problem deallocating computedCoupling'; return; endif + + end associate end subroutine updateVars - ! ********************************************************************************************************** - ! private subroutine xTempSolve: compute residual and derivative for temperature - ! ********************************************************************************************************** - subroutine xTempSolve(& - ! input: constant over iterations - meltNrg ,& ! intent(in) : energy for melt+freeze (J m-3) - heatCap ,& ! intent(in) : volumetric heat capacity (J m-3 K-1) - tempInit ,& ! intent(in) : initial temperature (K) - volFracIceInit ,& ! intent(in) : initial volumetric fraction of ice (-) - ! input-output: trial values - xTemp ,& ! intent(inout) : trial value of temperature - dLiq_dT ,& ! intent(in) : derivative in liquid water content w.r.t. temperature (K-1) - volFracIceTrial ,& ! intent(in) : trial value for volumetric fraction of ice - ! output: residual and derivative - residual ,& ! intent(out) : residual (J m-3) - derivative ) ! intent(out) : derivative (J m-3 K-1) - implicit none - ! input: constant over iterations - real(rkind),intent(in) :: meltNrg ! energy for melt+freeze (J m-3) - real(rkind),intent(in) :: heatCap ! volumetric heat capacity (J m-3 K-1) - real(rkind),intent(in) :: tempInit ! initial temperature (K) - real(rkind),intent(in) :: volFracIceInit ! initial volumetric fraction of ice (-) - ! input-output: trial values - real(rkind),intent(inout) :: xTemp ! trial value for temperature - real(rkind),intent(in) :: dLiq_dT ! derivative in liquid water content w.r.t. temperature (K-1) - real(rkind),intent(in) :: volFracIceTrial ! trial value for the volumetric fraction of ice (-) - ! output: residual and derivative - real(rkind),intent(out) :: residual ! residual (J m-3) - real(rkind),intent(out) :: derivative ! derivative (J m-3 K-1) - ! subroutine starts here - residual = -heatCap*(xTemp - tempInit) + meltNrg*(volFracIceTrial - volFracIceInit) ! J m-3 - derivative = heatCap + LH_fus*iden_water*dLiq_dT ! J m-3 K-1 - - ! check validity of residual ... - ! informational only: if nan, the sim will start to error out from calling routine - if( ieee_is_nan(residual) )then - print*, '--------' - print*, 'ERROR: residual is not valid in xTempSolve' - print*, 'heatCap', heatCap - print*, 'xTemp', xTemp - print*, 'tempInit', tempInit - print*, 'meltNrg', meltNrg - print*, 'volFracIceTrial', volFracIceTrial - print*, 'volFracIceInit', volFracIceInit - print*, 'dLiq_dT', dLiq_dT - print*, '--------' - endif - - end subroutine xTempSolve +! ********************************************************************************************************** +! private subroutine xTempSolve: compute residual and derivative for temperature +! ********************************************************************************************************** +subroutine xTempSolve(& + ! input: constant over iterations + meltNrg ,& ! intent(in): energy for melt+freeze (J m-3) + heatCap ,& ! intent(in): volumetric heat capacity (J m-3 K-1) + tempInit ,& ! intent(in): initial temperature (K) + volFracIceInit ,& ! intent(in): initial volumetric fraction of ice (-) + ! input-output: trial values + xTemp ,& ! intent(inout): trial value of temperature + dLiq_dT ,& ! intent(in): derivative in liquid water content w.r.t. temperature (K-1) + volFracIceTrial ,& ! intent(in): trial value for volumetric fraction of ice + ! output: residual and derivative + residual ,& ! intent(out): residual (J m-3) + derivative ) ! intent(out): derivative (J m-3 K-1) + implicit none + ! input: constant over iterations + real(rkind),intent(in) :: meltNrg ! energy for melt+freeze (J m-3) + real(rkind),intent(in) :: heatCap ! volumetric heat capacity (J m-3 K-1) + real(rkind),intent(in) :: tempInit ! initial temperature (K) + real(rkind),intent(in) :: volFracIceInit ! initial volumetric fraction of ice (-) + ! input-output: trial values + real(rkind),intent(inout) :: xTemp ! trial value for temperature + real(rkind),intent(in) :: dLiq_dT ! derivative in liquid water content w.r.t. temperature (K-1) + real(rkind),intent(in) :: volFracIceTrial ! trial value for the volumetric fraction of ice (-) + ! output: residual and derivative + real(rkind),intent(out) :: residual ! residual (J m-3) + real(rkind),intent(out) :: derivative ! derivative (J m-3 K-1) + ! subroutine starts here + residual = -heatCap*(xTemp - tempInit) + meltNrg*(volFracIceTrial - volFracIceInit) ! J m-3 + derivative = heatCap + LH_fus*iden_water*dLiq_dT ! J m-3 K-1 +end subroutine xTempSolve end module updateVars_module diff --git a/build/source/engine/updateVarsWithPrime.f90 b/build/source/engine/updateVarsWithPrime.f90 new file mode 100644 index 000000000..ae5be7ab0 --- /dev/null +++ b/build/source/engine/updateVarsWithPrime.f90 @@ -0,0 +1,900 @@ +! SUMMA - Structure for Unifying Multiple Modeling Alternatives +! Copyright (C) 2014-2015 NCAR/RAL +! +! This file is part of SUMMA +! +! For more information see: http://www.ral.ucar.edu/projects/summa +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see . + +module updateVarsWithPrime_module + +! data types +USE nrtype + +! missing values +USE globalData,only:integerMissing ! missing integer +USE globalData,only:realMissing ! missing real number + +! access the global print flag +USE globalData,only:globalPrintFlag + +! domain types +USE globalData,only:iname_cas ! named variables for canopy air space +USE globalData,only:iname_veg ! named variables for vegetation canopy +USE globalData,only:iname_snow ! named variables for snow +USE globalData,only:iname_soil ! named variables for soil +USE globalData,only:iname_aquifer ! named variables for the aquifer + +! named variables to describe the state variable type +USE globalData,only:iname_nrgCanair ! named variable defining the energy of the canopy air space +USE globalData,only:iname_nrgCanopy ! named variable defining the energy of the vegetation canopy +USE globalData,only:iname_watCanopy ! named variable defining the mass of total water on the vegetation canopy +USE globalData,only:iname_liqCanopy ! named variable defining the mass of liquid water on the vegetation canopy +USE globalData,only:iname_nrgLayer ! named variable defining the energy state variable for snow+soil layers +USE globalData,only:iname_watLayer ! named variable defining the total water state variable for snow+soil layers +USE globalData,only:iname_liqLayer ! named variable defining the liquid water state variable for snow+soil layers +USE globalData,only:iname_matLayer ! named variable defining the matric head state variable for soil layers +USE globalData,only:iname_lmpLayer ! named variable defining the liquid matric potential state variable for soil layers + +! metadata for information in the data structures +USE globalData,only:indx_meta ! metadata for the variables in the index structure + +! constants +USE multiconst,only:& + Tfreeze, & ! temperature at freezing (K) + LH_fus, & ! latent heat of fusion (J kg-1) + iden_ice, & ! intrinsic density of ice (kg m-3) + iden_water ! intrinsic density of liquid water (kg m-3) + +! provide access to the derived types to define the data structures +USE data_types,only:& + var_i, & ! data vector (i4b) + var_d, & ! data vector (rkind) + var_ilength, & ! data vector with variable length dimension (i4b) + zLookup, & ! data vector with variable length dimension (rkind) + var_dlength ! data vector with variable length dimension (rkind) + +! provide access to indices that define elements of the data structures +USE var_lookup,only:iLookDIAG ! named variables for structure elements +USE var_lookup,only:iLookPROG ! named variables for structure elements +USE var_lookup,only:iLookDERIV ! named variables for structure elements +USE var_lookup,only:iLookPARAM ! named variables for structure elements +USE var_lookup,only:iLookINDEX ! named variables for structure elements + +! provide access to routines to update states +USE updatStateWithPrime_module,only:updateSnowPrime ! update snow states +USE updatStateWithPrime_module,only:updateSoilPrime ! update soil states + +! provide access to functions for the constitutive functions and derivatives +USE snow_utils_module,only:fracliquid ! compute the fraction of liquid water (snow) +USE snow_utils_module,only:dFracLiq_dTk ! differentiate the freezing curve w.r.t. temperature (snow) +USE soil_utils_module,only:dTheta_dTk ! differentiate the freezing curve w.r.t. temperature (soil) +USE soil_utils_module,only:dTheta_dPsi ! derivative in the soil water characteristic (soil) +USE soil_utils_module,only:dPsi_dTheta ! derivative in the soil water characteristic (soil) +USE soil_utils_module,only:matricHead ! compute the matric head based on volumetric water content +USE soil_utils_module,only:volFracLiq ! compute volumetric fraction of liquid water +USE soil_utils_module,only:crit_soilT ! compute critical temperature below which ice exists +USE soil_utilsAddPrime_module,only:liquidHeadPrime ! compute the liquid water matric potential +USE soil_utilsAddPrime_module,only:d2Theta_dPsi2 ! second derivative in the soil water characteristic (soil) +USE soil_utilsAddPrime_module,only:d2Theta_dTk2 ! second derivative in the freezing curve w.r.t. temperature (soil) +USE enthalpyTemp_module,only:enthalpy2T_cas ! compute canopy air space temperature from enthalpy +USE enthalpyTemp_module,only:enthalpy2T_veg ! compute canopy temperature from enthalpy and water content +USE enthalpyTemp_module,only:enthalpy2T_snow ! compute snow layer temperature from enthalpy and water content +USE enthalpyTemp_module,only:enthalpy2T_soil ! compute soil layer temperature from enthalpy and matric potential + +! IEEE checks +USE, intrinsic :: ieee_arithmetic ! check values (NaN, etc.) + +implicit none +private +public::updateVarsWithPrime + +contains + +! ********************************************************************************************************** +! public subroutine updateVarsWithPrime: compute diagnostic variables and derivatives for Prime Jacobian +! ********************************************************************************************************** +subroutine updateVarsWithPrime(& + ! input + enthalpyStateVec, & ! intent(in): flag if enthalpy is the state variable + use_lookup, & ! intent(in): flag to use the lookup table for soil enthalpy + computJac, & ! intent(in): flag if computing for Jacobian update + do_adjustTemp, & ! intent(in): flag to adjust temperature to account for the energy used in melt+freeze + mpar_data, & ! intent(in): model parameters for a local HRU + indx_data, & ! intent(in): indices defining model states and layers + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables + lookup_data, & ! intent(in): lookup table data structure + ! input: enthalpy state variables + scalarCanairEnthalpyTrial, & ! intent(in): trial value for enthalpy of the canopy air space (J m-3) + scalarCanopyEnthalpyTrial, & ! intent(in): trial value for enthalpy of the vegetation canopy (J m-3) + mLayerEnthalpyTrial, & ! intent(in): trial vector of enthalpy of each snow+soil layer (J m-3) + ! output: variables for the vegetation canopy + scalarCanairTempTrial, & ! intent(inout): trial value of canopy air space temperature (K) + scalarCanopyTempTrial, & ! intent(inout): trial value of canopy temperature (K) + scalarCanopyWatTrial, & ! intent(inout): trial value of canopy total water (kg m-2) + scalarCanopyLiqTrial, & ! intent(inout): trial value of canopy liquid water (kg m-2) + scalarCanopyIceTrial, & ! intent(inout): trial value of canopy ice content (kg m-2) + scalarCanopyTempPrime, & ! intent(inout): trial value of time derivative canopy temperature (K) + scalarCanopyWatPrime, & ! intent(inout): trial value of time derivative canopy total water (kg m-2) + scalarCanopyLiqPrime, & ! intent(inout): trial value of time derivative canopy liquid water (kg m-2) + scalarCanopyIcePrime, & ! intent(inout): trial value of time derivative canopy ice content (kg m-2) + ! output: variables for the snow-soil domain + mLayerTempTrial, & ! intent(inout): trial vector of layer temperature (K) + mLayerVolFracWatTrial, & ! intent(inout): trial vector of volumetric total water content (-) + mLayerVolFracLiqTrial, & ! intent(inout): trial vector of volumetric liquid water content (-) + mLayerVolFracIceTrial, & ! intent(inout): trial vector of volumetric ice water content (-) + mLayerMatricHeadTrial, & ! intent(inout): trial vector of total water matric potential (m) + mLayerMatricHeadLiqTrial, & ! intent(inout): trial vector of liquid water matric potential (m) + mLayerTempPrime, & ! intent(inout): trial value of time derivative layer temperature (K) + mLayerVolFracWatPrime, & ! intent(inout): trial value of time derivative volumetric total water content (-) + mLayerVolFracLiqPrime, & ! intent(inout): trial value of time derivative volumetric liquid water content (-) + mLayerVolFracIcePrime, & ! intent(inout): trial value of time derivative volumetric ice water content (-) + mLayerMatricHeadPrime, & ! intent(inout): trial value of time derivative total water matric potential (m) + mLayerMatricHeadLiqPrime, & ! intent(inout): trial value of time derivative liquid water matric potential (m) + ! output: error control + err,message) ! intent(out): error control + ! -------------------------------------------------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------------------------------------------------- + implicit none + ! input + logical(lgt) ,intent(in) :: enthalpyStateVec ! flag if enthalpy is the state variable + logical(lgt) ,intent(in) :: use_lookup ! flag to use the lookup table for soil enthalpy, otherwise use hypergeometric function + logical(lgt) ,intent(in) :: computJac ! flag if computing for Jacobian update + logical(lgt) ,intent(in) :: do_adjustTemp ! flag to adjust temperature to account for the energy used in melt+freeze + type(var_dlength),intent(in) :: mpar_data ! model parameters for a local HRU + type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers + type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU + type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + type(zLookup) ,intent(in) :: lookup_data ! lookup tables + ! input: enthalpy state variables + real(rkind),intent(in) :: scalarCanairEnthalpyTrial ! trial value for enthalpy of the canopy air space (J m-3) + real(rkind),intent(in) :: scalarCanopyEnthalpyTrial ! trial value for enthalpy of the vegetation canopy (J m-3) + real(rkind),intent(in) :: mLayerEnthalpyTrial(:) ! trial vector of enthalpy of each snow+soil layer (J m-3) + ! output: variables for the vegetation canopy + real(rkind),intent(inout) :: scalarCanairTempTrial ! trial value of canopy air space temperature (K) + real(rkind),intent(inout) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) + real(rkind),intent(inout) :: scalarCanopyWatTrial ! trial value of canopy total water (kg m-2) + real(rkind),intent(inout) :: scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) + real(rkind),intent(inout) :: scalarCanopyIceTrial ! trial value of canopy ice content (kg m-2) + real(rkind),intent(inout) :: scalarCanopyTempPrime ! trial value of time derivative canopy temperature (K) + real(rkind),intent(inout) :: scalarCanopyWatPrime ! trial value of time derivative canopy total water (kg m-2) + real(rkind),intent(inout) :: scalarCanopyLiqPrime ! trial value of time derivative canopy liquid water (kg m-2) + real(rkind),intent(inout) :: scalarCanopyIcePrime ! trial value of time derivative canopy ice content (kg m-2) + ! output: variables for the snow-soil domain + real(rkind),intent(inout) :: mLayerTempTrial(:) ! trial vector of layer temperature (K) + real(rkind),intent(inout) :: mLayerVolFracWatTrial(:) ! trial vector of volumetric total water content (-) + real(rkind),intent(inout) :: mLayerVolFracLiqTrial(:) ! trial vector of volumetric liquid water content (-) + real(rkind),intent(inout) :: mLayerVolFracIceTrial(:) ! trial vector of volumetric ice water content (-) + real(rkind),intent(inout) :: mLayerMatricHeadTrial(:) ! trial vector of total water matric potential (m) + real(rkind),intent(inout) :: mLayerMatricHeadLiqTrial(:) ! trial vector of liquid water matric potential (m) + real(rkind),intent(inout) :: mLayerTempPrime(:) ! trial value of time derivative layer temperature (K) + real(rkind),intent(inout) :: mLayerVolFracWatPrime(:) ! trial value of time derivative volumetric total water content (-) + real(rkind),intent(inout) :: mLayerVolFracLiqPrime(:) ! trial value of time derivative volumetric liquid water content (-) + real(rkind),intent(inout) :: mLayerVolFracIcePrime(:) ! trial value of time derivative volumetric ice water content (-) + real(rkind),intent(inout) :: mLayerMatricHeadPrime(:) ! trial value of time derivative total water matric potential (m) + real(rkind),intent(inout) :: mLayerMatricHeadLiqPrime(:) ! trial value of time derivative liquid water matric potential (m) + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! -------------------------------------------------------------------------------------------------------------------------------- + ! general local variables + integer(i4b) :: iState ! index of model state variable + integer(i4b) :: iLayer ! index of layer within the snow+soil domain + integer(i4b) :: ixFullVector ! index within full state vector + integer(i4b) :: ixDomainType ! name of a given model domain + integer(i4b) :: ixControlIndex ! index within a given model domain + integer(i4b) :: ixOther,ixOtherLocal ! index of the coupled state variable within the (full, local) vector + logical(lgt) :: isCoupled ! .true. if a given variable shared another state variable in the same control volume + logical(lgt) :: isNrgState ! .true. if a given variable is an energy state + logical(lgt),allocatable :: computedCoupling(:) ! .true. if computed the coupling for a given state variable + real(rkind) :: scalarVolFracLiq ! volumetric fraction of liquid water (-) + real(rkind) :: scalarVolFracIce ! volumetric fraction of ice (-) + real(rkind) :: scalarVolFracLiqPrime ! time derivative volumetric fraction of liquid water (-) + real(rkind) :: scalarVolFracIcePrime ! time derivative volumetric fraction of ice (-) + real(rkind) :: Tcrit ! critical soil temperature below which ice exists (K) + real(rkind) :: xTemp ! temporary temperature (K) + real(rkind) :: fLiq ! fraction of liquid water (-) + real(rkind) :: effSat ! effective saturation (-) + real(rkind) :: avPore ! available pore space (-) + character(len=256) :: cMessage ! error message of downwind routine + logical(lgt),parameter :: printFlag=.false. ! flag to turn on printing + ! iterative solution for temperature + real(rkind) :: meltNrg ! energy for melt+freeze (J m-3) + real(rkind) :: residual ! residual in the energy equation (J m-3) + real(rkind) :: derivative ! derivative in the energy equation (J m-3 K-1) + real(rkind) :: tempInc ! iteration increment (K) + integer(i4b) :: iter ! iteration index + integer(i4b) :: niter ! number of iterations + integer(i4b),parameter :: maxiter=100 ! maximum number of iterations + real(rkind),parameter :: nrgConvTol=1.e-4_rkind ! convergence tolerance for energy (J m-3) + real(rkind),parameter :: tempConvTol=1.e-6_rkind ! convergence tolerance for temperature (K) + real(rkind) :: critDiff ! temperature difference from critical (K) + real(rkind) :: tempMin ! minimum bracket for temperature (K) + real(rkind) :: tempMax ! maximum bracket for temperature (K) + logical(lgt) :: bFlag ! flag to denote that iteration increment was constrained using bi-section + real(rkind),parameter :: epsT=1.e-7_rkind ! small interval above/below critical temperature (K) + ! -------------------------------------------------------------------------------------------------------------------------------- + ! make association with variables in the data structures + associate(& + ! number of model layers, and layer type + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in): [i4b] total number of snow layers + nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1) ,& ! intent(in): [i4b] total number of soil layers + nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1) ,& ! intent(in): [i4b] total number of snow and soil layers + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat ,& ! intent(in): [dp(:)] depth of each layer in the snow-soil sub-domain (m) + ! indices defining model states and layers + ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable + ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) + ! indices in the full vector for specific domains + ixNrgCanair => indx_data%var(iLookINDEX%ixNrgCanair)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for energy states in canopy air space domain + ixNrgCanopy => indx_data%var(iLookINDEX%ixNrgCanopy)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for energy states in the canopy domain + ixHydCanopy => indx_data%var(iLookINDEX%ixHydCanopy)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for hydrology states in the canopy domain + ixNrgLayer => indx_data%var(iLookINDEX%ixNrgLayer)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for energy states in the snow+soil domain + ixHydLayer => indx_data%var(iLookINDEX%ixHydLayer)%dat ,& ! intent(in): [i4b(:)] indices IN THE FULL VECTOR for hydrology states in the snow+soil domain + ! mapping between the full state vector and the state subset + ixMapFull2Subset => indx_data%var(iLookINDEX%ixMapFull2Subset)%dat ,& ! intent(in): [i4b(:)] list of indices in the state subset for each state in the full state vector + ixMapSubset2Full => indx_data%var(iLookINDEX%ixMapSubset2Full)%dat ,& ! intent(in): [i4b(:)] [state subset] list of indices of the full state vector in the state subset + ! type of domain, type of state variable, and index of control volume within domain + ixDomainType_subset => indx_data%var(iLookINDEX%ixDomainType_subset)%dat ,& ! intent(in): [i4b(:)] [state subset] id of domain for desired model state variables + ixControlVolume => indx_data%var(iLookINDEX%ixControlVolume)%dat ,& ! intent(in): [i4b(:)] index of the control volume for different domains (veg, snow, soil) + ixStateType => indx_data%var(iLookINDEX%ixStateType)%dat ,& ! intent(in): [i4b(:)] indices defining the type of the state (iname_nrgLayer...) + ! snow parameters + snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1) ,& ! intent(in): [dp ] scaling parameter for the snow freezing curve (K-1) + ! depth-varying model parameters + soil_dens_intr => mpar_data%var(iLookPARAM%soil_dens_intr)%dat ,& ! intent(in): [dp(:)] intrinsic soil density (kg m-3) + vGn_m => diag_data%var(iLookDIAG%scalarVGn_m)%dat ,& ! intent(in): [dp(:)] van Genutchen "m" parameter (-) + vGn_n => mpar_data%var(iLookPARAM%vGn_n)%dat ,& ! intent(in): [dp(:)] van Genutchen "n" parameter (-) + vGn_alpha => mpar_data%var(iLookPARAM%vGn_alpha)%dat ,& ! intent(in): [dp(:)] van Genutchen "alpha" parameter (m-1) + theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat ,& ! intent(in): [dp(:)] soil porosity (-) + theta_res => mpar_data%var(iLookPARAM%theta_res)%dat ,& ! intent(in): [dp(:)] soil residual volumetric water content (-) + ! model diagnostic variables (heat capacity, enthalpy) + specificHeatVeg => mpar_data%var(iLookPARAM%specificHeatVeg)%dat(1) ,& ! intent(in): [dp ] specific heat of vegetation (J kg-1 K-1) + maxMassVegetation => mpar_data%var(iLookPARAM%maxMassVegetation)%dat(1) ,& ! intent(in): [dp ] maximum mass of vegetation (kg m-2) + canopyDepth => diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1) ,& ! intent(in): [dp ] canopy depth (m) + scalarBulkVolHeatCapVeg => diag_data%var(iLookDIAG%scalarBulkVolHeatCapVeg)%dat(1) ,& ! intent(in): [dp ] volumetric heat capacity of the vegetation (J m-3 K-1) + mLayerVolHtCapBulk => diag_data%var(iLookDIAG%mLayerVolHtCapBulk)%dat ,& ! intent(in): [dp(:)] volumetric heat capacity in each layer (J m-3 K-1) + ! model diagnostic variables (fraction of liquid water) + scalarFracLiqVeg => diag_data%var(iLookDIAG%scalarFracLiqVeg)%dat(1) ,& ! intent(out): [dp] fraction of liquid water on vegetation (-) + mLayerFracLiqSnow => diag_data%var(iLookDIAG%mLayerFracLiqSnow)%dat ,& ! intent(out): [dp(:)] fraction of liquid water in each snow layer (-) + ! model states from a previous solution + scalarCanopyTemp => prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1) ,& ! intent(in): [dp] temperature of the vegetation canopy (K) + mLayerTemp => prog_data%var(iLookPROG%mLayerTemp)%dat ,& ! intent(in): [dp(:)] temperature of each snow/soil layer (K) + ! model diagnostic variables from a previous solution + scalarCanopyIce => prog_data%var(iLookPROG%scalarCanopyIce)%dat(1) ,& ! intent(in): [dp(:)] mass of ice on the vegetation canopy (kg m-2) + mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat ,& ! intent(in): [dp(:)] volumetric fraction of ice (-) + ! derivatives + dVolTot_dPsi0 => deriv_data%var(iLookDERIV%dVolTot_dPsi0)%dat ,& ! intent(out): [dp(:)] derivative in total water content w.r.t. total water matric potential + dPsiLiq_dPsi0 => deriv_data%var(iLookDERIV%dPsiLiq_dPsi0)%dat ,& ! intent(out): [dp(:)] derivative in liquid water matric pot w.r.t. the total water matric pot (-) + dPsiLiq_dTemp => deriv_data%var(iLookDERIV%dPsiLiq_dTemp)%dat ,& ! intent(out): [dp(:)] derivative in the liquid water matric potential w.r.t. temperature + mLayerdTheta_dTk => deriv_data%var(iLookDERIV%mLayerdTheta_dTk)%dat ,& ! intent(out): [dp(:)] derivative of volumetric liquid water content w.r.t. temperature + dTheta_dTkCanopy => deriv_data%var(iLookDERIV%dTheta_dTkCanopy)%dat(1) ,& ! intent(out): [dp] derivative of volumetric liquid water content w.r.t. temperature + dFracLiqWat_dTk => deriv_data%var(iLookDERIV%dFracLiqWat_dTk)%dat ,& ! intent(out): [dp(:)] derivative in fraction of liquid water w.r.t. temperature + dFracLiqVeg_dTkCanopy => deriv_data%var(iLookDERIV%dFracLiqVeg_dTkCanopy)%dat(1) ,& ! intent(out): [dp ] derivative in fraction of (throughfall + drainage) w.r.t. temperature + ! derivatives inside solver for Jacobian only + d2VolTot_dPsi02 => deriv_data%var(iLookDERIV%d2VolTot_dPsi02)%dat ,& ! intent(out): [dp(:)] second derivative in total water content w.r.t. total water matric potential + mLayerd2Theta_dTk2 => deriv_data%var(iLookDERIV%mLayerd2Theta_dTk2)%dat ,& ! intent(out): [dp(:)] second derivative of volumetric liquid water content w.r.t. temperature + d2Theta_dTkCanopy2 => deriv_data%var(iLookDERIV%d2Theta_dTkCanopy2)%dat(1) ,& ! intent(out): [dp ] second derivative of volumetric liquid water content w.r.t. temperature + ! derivatives of temperature if enthalpy is the state variable + dCanairTemp_dEnthalpy => deriv_data%var(iLookDERIV%dCanairTemp_dEnthalpy)%dat(1) ,& ! intent(out): [dp] derivative of canopy air temperature w.r.t. enthalpy + dCanopyTemp_dEnthalpy => deriv_data%var(iLookDERIV%dCanopyTemp_dEnthalpy)%dat(1) ,& ! intent(out): [dp] derivative of canopy temperature w.r.t. enthalpy + dTemp_dEnthalpy => deriv_data%var(iLookDERIV%dTemp_dEnthalpy)%dat ,& ! intent(out): [dp(:)] derivative of temperature w.r.t. enthalpy + dCanopyTemp_dCanWat => deriv_data%var(iLookDERIV%dCanopyTemp_dCanWat)%dat(1) ,& ! intent(out): [dp] derivative of canopy temperature w.r.t. volumetric water content + dTemp_dTheta => deriv_data%var(iLookDERIV%dTemp_dTheta)%dat ,& ! intent(out): [dp(:)] derivative of temperature w.r.t. volumetric water content + dTemp_dPsi0 => deriv_data%var(iLookDERIV%dTemp_dPsi0)%dat & ! intent(out): [dp(:)] derivative of temperature w.r.t. total water matric potential + ) ! association with variables in the data structures + + ! -------------------------------------------------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------------------------------------------------- + + ! initialize error control + err=0; message='updateVarsWithPrime/' + + ! allocate space and assign values to the flag vector + allocate(computedCoupling(size(ixMapSubset2Full)),stat=err) ! .true. if computed the coupling for a given state variable + if(err/=0)then; message=trim(message)//'problem allocating computedCoupling'; return; endif + computedCoupling(:)=.false. + + ! loop through model state variables + do iState=1,size(ixMapSubset2Full) + + ! check the need for the computations + if(computedCoupling(iState)) cycle + + ! ----- + ! - compute indices... + ! -------------------- + + ! get domain type, and index of the control volume within the domain + ixFullVector = ixMapSubset2Full(iState) ! index within full state vector + ixDomainType = ixDomainType_subset(iState) ! named variables defining the domain (iname_cas, iname_veg, etc.) + ixControlIndex = ixControlVolume(ixFullVector) ! index within a given domain + + ! get the layer index + select case(ixDomainType) + case(iname_cas); iLayer = 0 + case(iname_veg); iLayer = 0 + case(iname_snow); iLayer = ixControlIndex + case(iname_soil); iLayer = ixControlIndex + nSnow + case(iname_aquifer); cycle ! aquifer: do nothing + case default; err=20; message=trim(message)//'expect case to be iname_cas, iname_veg, iname_snow, iname_soil, iname_aquifer'; return + end select + + ! get the index of the other (energy or mass) state variable within the full state vector + select case(ixDomainType) + case(iname_cas) ; ixOther = integerMissing + case(iname_veg) ; ixOther = merge(ixHydCanopy(1), ixNrgCanopy(1), ixStateType(ixFullVector)==iname_nrgCanopy) + case(iname_snow, iname_soil); ixOther = merge(ixHydLayer(iLayer),ixNrgLayer(iLayer),ixStateType(ixFullVector)==iname_nrgLayer) + case default; err=20; message=trim(message)//'expect case to be iname_cas, iname_veg, iname_snow, iname_soil'; return + end select + + ! get the index in the local state vector + if(ixDomainType==iname_cas)then + ixOtherLocal = integerMissing + else + ixOtherLocal = ixMapFull2Subset(ixOther) ! ixOtherLocal could equal integerMissing + endif + if(ixOtherLocal/=integerMissing) computedCoupling(ixOtherLocal)=.true. + + ! check if we have a coupled solution + isCoupled = (ixOtherLocal/=integerMissing) + + ! check if we are an energy state + isNrgState = (ixStateType(ixFullVector)==iname_nrgCanair .or. ixStateType(ixFullVector)==iname_nrgCanopy .or. ixStateType(ixFullVector)==iname_nrgLayer) + + if(printFlag)then + print*, 'iState = ', iState, size(ixMapSubset2Full) + print*, 'ixFullVector = ', ixFullVector + print*, 'ixDomainType = ', ixDomainType + print*, 'ixControlIndex = ', ixControlIndex + print*, 'ixOther = ', ixOther + print*, 'ixOtherLocal = ', ixOtherLocal + print*, 'do_adjustTemp = ', do_adjustTemp + print*, 'isCoupled = ', isCoupled + print*, 'isNrgState = ', isNrgState + endif + + ! compute temperature from enthalpy for canopy air space + if(ixDomainType==iname_cas)then + if(enthalpyStateVec)then + call enthalpy2T_cas(& + computJac, & ! intent(in): flag if computing for Jacobian update + scalarCanairEnthalpyTrial, & ! intent(in): trial value for enthalpy of the canopy air space (J m-3) + scalarCanairTempTrial, & ! intent(out): trial value for canopy air temperature (K) + dCanairTemp_dEnthalpy, & ! intent(out): derivative of canopy air temperature with enthalpy + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + else + dCanairTemp_dEnthalpy = 0._rkind + endif + cycle ! no more to do on canopy air space + end if + + ! update hydrology state variables for the uncoupled solution + if(.not.isNrgState .and. .not.isCoupled)then + + ! update the total water from volumetric liquid water + if(ixStateType(ixFullVector)==iname_liqCanopy .or. ixStateType(ixFullVector)==iname_liqLayer)then + select case(ixDomainType) + case(iname_veg) + scalarCanopyWatTrial = scalarCanopyLiqTrial + scalarCanopyIceTrial + scalarCanopyWatPrime = scalarCanopyLiqPrime + scalarCanopyIcePrime + case(iname_snow) + mLayerVolFracWatTrial(iLayer) = mLayerVolFracLiqTrial(iLayer) + mLayerVolFracIceTrial(iLayer)*iden_ice/iden_water + mLayerVolFracWatPrime(iLayer) = mLayerVolFracLiqPrime(iLayer) + mLayerVolFracIcePrime(iLayer)*iden_ice/iden_water + case(iname_soil) + mLayerVolFracWatTrial(iLayer) = mLayerVolFracLiqTrial(iLayer) + mLayerVolFracIceTrial(iLayer) ! no volume expansion + mLayerVolFracWatPrime(iLayer) = mLayerVolFracLiqPrime(iLayer) + mLayerVolFracIcePrime(iLayer) + case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, or iname_soil'; return + end select + endif + + ! update the total water and the total water matric potential + if(ixDomainType==iname_soil)then + select case( ixStateType(ixFullVector) ) + ! --> update the total water from the liquid water matric potential + case(iname_lmpLayer) + effSat = volFracLiq(mLayerMatricHeadLiqTrial(ixControlIndex),vGn_alpha(ixControlIndex),0._rkind,1._rkind,vGn_n(ixControlIndex),vGn_m(ixControlIndex)) ! effective saturation + avPore = theta_sat(ixControlIndex) - mLayerVolFracIceTrial(iLayer) - theta_res(ixControlIndex) ! available pore space + mLayerVolFracLiqTrial(iLayer) = effSat*avPore + theta_res(ixControlIndex) + mLayerVolFracWatTrial(iLayer) = mLayerVolFracLiqTrial(iLayer) + mLayerVolFracIceTrial(iLayer) ! no volume expansion + mLayerVolFracWatPrime(iLayer) = mLayerVolFracLiqPrime(iLayer) + mLayerVolFracIcePrime(iLayer) + mLayerMatricHeadTrial(ixControlIndex) = matricHead(mLayerVolFracWatTrial(iLayer),vGn_alpha(ixControlIndex),theta_res(ixControlIndex),theta_sat(ixControlIndex),vGn_n(ixControlIndex),vGn_m(ixControlIndex)) + mLayerMatricHeadPrime(ixControlIndex) = dPsi_dTheta(mLayerVolFracWatTrial(iLayer),vGn_alpha(ixControlIndex),theta_res(ixControlIndex),theta_sat(ixControlIndex),vGn_n(ixControlIndex),vGn_m(ixControlIndex)) * mLayerVolFracWatPrime(iLayer) + ! --> update the total water from the total water matric potential + case(iname_matLayer) + mLayerVolFracWatTrial(iLayer) = volFracLiq(mLayerMatricHeadTrial(ixControlIndex),vGn_alpha(ixControlIndex),theta_res(ixControlIndex),theta_sat(ixControlIndex),vGn_n(ixControlIndex),vGn_m(ixControlIndex)) + mLayerVolFracWatPrime(iLayer) = dTheta_dPsi(mLayerMatricHeadTrial(ixControlIndex),vGn_alpha(ixControlIndex),theta_res(ixControlIndex),theta_sat(ixControlIndex),vGn_n(ixControlIndex),vGn_m(ixControlIndex)) *mLayerMatricHeadPrime(ixControlIndex) + ! --> update the total water matric potential (assume already have mLayerVolFracWatTrial given block above) + case(iname_liqLayer, iname_watLayer) + mLayerMatricHeadTrial(ixControlIndex) = matricHead(mLayerVolFracWatTrial(iLayer),vGn_alpha(ixControlIndex),theta_res(ixControlIndex),theta_sat(ixControlIndex),vGn_n(ixControlIndex),vGn_m(ixControlIndex)) + mLayerMatricHeadPrime(ixControlIndex) = dPsi_dTheta(mLayerVolFracWatTrial(iLayer),vGn_alpha(ixControlIndex),theta_res(ixControlIndex),theta_sat(ixControlIndex),vGn_n(ixControlIndex),vGn_m(ixControlIndex)) * mLayerVolFracWatPrime(iLayer) + case default; err=20; message=trim(message)//'expect iname_lmpLayer, iname_matLayer, iname_liqLayer, or iname_watLayer'; return + end select + endif ! if in the soil domain + + endif ! if hydrology state variable or uncoupled solution + + ! compute temperature from enthalpy and water content for remaining domains + if(ixDomainType==iname_veg)then + if(enthalpyStateVec)then + scalarCanopyTempTrial = scalarCanopyTemp ! start at previous value + call enthalpy2T_veg(& + computJac, & ! intent(in): flag if computing for Jacobian update + canopyDepth, & ! intent(in): canopy depth (m) + specificHeatVeg, & ! intent(in): specific heat of vegetation (J kg-1 K-1) + maxMassVegetation, & ! intent(in): maximum mass of vegetation (kg m-2) + snowfrz_scale, & ! intent(in): scaling parameter for the snow freezing curve (K-1) + scalarCanopyEnthalpyTrial, & ! intent(in): trial value for enthalpy of the vegetation canopy (J m-3) + scalarCanopyWatTrial, & ! intent(in): trial value for canopy total water (kg m-2) + scalarCanopyTempTrial, & ! intent(inout): trial value for canopy temperature (K) + dCanopyTemp_dEnthalpy, & ! intent(inout): derivative of canopy temperature with enthalpy + dCanopyTemp_dCanWat, & ! intent(inout): derivative of canopy temperature with canopy water + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + else + dCanopyTemp_dEnthalpy = 0._rkind + dCanopyTemp_dCanWat = 0._rkind + endif + elseif(ixDomainType==iname_snow)then + if(enthalpyStateVec)then + mLayerTempTrial(iLayer) = mLayerTemp(iLayer) ! start at previous value + call enthalpy2T_snow(& + computJac, & ! intent(in): flag if computing for Jacobian update + snowfrz_scale, & ! intent(in): scaling parameter for the snow freezing curve (K-1) + mLayerEnthalpyTrial(iLayer), & ! intent(in): enthalpy of snow+soil layer (J m-3) + mLayerVolFracWatTrial(iLayer), & ! intent(in): volumetric total water content (-) + mLayerTempTrial(iLayer), & ! intent(inout): layer temperature (K) + dTemp_dEnthalpy(iLayer), & ! intent(inout): derivative of layer temperature with enthalpy + dTemp_dTheta(iLayer), & ! intent(inout): derivative of layer temperature with volumetric total water content + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + else + dTemp_dEnthalpy(iLayer) = 0._rkind + dTemp_dTheta(iLayer) = 0._rkind + endif + elseif(ixDomainType==iname_soil)then + if(enthalpyStateVec)then + mLayerTempTrial(iLayer) = mLayerTemp(iLayer) ! start at previous value + call enthalpy2T_soil(& + computJac, & ! intent(in): flag if computing for Jacobian update + use_lookup, & ! intent(in): flag to use the lookup table for soil enthalpy + soil_dens_intr(ixControlIndex), & ! intent(in): intrinsic soil density (kg m-3) + vGn_alpha(ixControlIndex), & ! intent(in): van Genutchen "alpha" parameter + vGn_n(ixControlIndex), & ! intent(in): van Genutchen "n" parameter + theta_sat(ixControlIndex), & ! intent(in): soil porosity (-) + theta_res(ixControlIndex), & ! intent(in): soil residual volumetric water content (-) + vGn_m(ixControlIndex), & ! intent(in): van Genutchen "m" parameter (-) + ixControlIndex, & ! intent(in): index of the control volume within the domain + lookup_data, & ! intent(in): lookup table data structure + mLayerEnthalpyTrial(iLayer), & ! intent(in): trial vector of enthalpy of each snow+soil layer (J m-3) + mLayerMatricHeadTrial(ixControlIndex), & ! intent(in): trial vector of total water matric potential (m) + mLayerTempTrial(iLayer), & ! intent(inout): trial vector of layer temperature (K) + dTemp_dEnthalpy(iLayer), & ! intent(inout): derivative of layer temperature with enthalpy + dTemp_dTheta(iLayer), & ! intent(inout): derivative of layer temperature with volumetric total water content + dTemp_dPsi0(ixControlIndex), & ! intent(inout): derivative of layer temperature with total water matric potential + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + else + dTemp_dEnthalpy(iLayer) = 0._rkind + dTemp_dTheta(iLayer) = 0._rkind + dTemp_dPsi0(ixControlIndex) = 0._rkind + endif + endif + + ! compute the critical soil temperature below which ice exists + select case(ixDomainType) + case(iname_veg, iname_snow); Tcrit = Tfreeze + case(iname_soil); Tcrit = crit_soilT( mLayerMatricHeadTrial(ixControlIndex) ) + case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return + end select + + ! initialize temperature + select case(ixDomainType) + case(iname_veg); xTemp = scalarCanopyTempTrial + case(iname_snow, iname_soil); xTemp = mLayerTempTrial(iLayer) + case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return + end select + + ! define brackets for the root + ! NOTE: start with an enormous range; updated quickly in the iterations + tempMin = xTemp - 10._rkind + tempMax = xTemp + 10._rkind + + ! get iterations (set to maximum iterations if adjusting the temperature) + niter = merge(maxiter, 1, do_adjustTemp) + + ! iterate + iterations: do iter=1,niter + + ! restrict temperature + if(xTemp <= tempMin .or. xTemp >= tempMax)then + xTemp = 0.5_rkind*(tempMin + tempMax) ! new value + bFlag = .true. + else + bFlag = .false. + endif + + ! ----- + ! - compute derivatives... + ! ------------------------ + + ! compute the derivative in total water content w.r.t. total water matric potential (m-1) + ! NOTE 1: valid for frozen and unfrozen conditions + ! NOTE 2: for case "iname_lmpLayer", dVolTot_dPsi0 = dVolLiq_dPsi + if(ixDomainType==iname_soil)then + select case( ixStateType(ixFullVector) ) + case(iname_lmpLayer) + dVolTot_dPsi0(ixControlIndex) = dTheta_dPsi(mLayerMatricHeadLiqTrial(ixControlIndex),vGn_alpha(ixControlIndex),0._rkind,1._rkind,vGn_n(ixControlIndex),vGn_m(ixControlIndex))*avPore + if(computJac) d2VolTot_dPsi02(ixControlIndex) = d2Theta_dPsi2(mLayerMatricHeadLiqTrial(ixControlIndex),vGn_alpha(ixControlIndex),0._rkind,1._rkind,vGn_n(ixControlIndex),vGn_m(ixControlIndex))*avPore + case default + dVolTot_dPsi0(ixControlIndex) = dTheta_dPsi(mLayerMatricHeadTrial(ixControlIndex),vGn_alpha(ixControlIndex),theta_res(ixControlIndex),theta_sat(ixControlIndex),vGn_n(ixControlIndex),vGn_m(ixControlIndex)) + if(computJac) d2VolTot_dPsi02(ixControlIndex) = d2Theta_dPsi2(mLayerMatricHeadTrial(ixControlIndex),vGn_alpha(ixControlIndex),theta_res(ixControlIndex),theta_sat(ixControlIndex),& + vGn_n(ixControlIndex),vGn_m(ixControlIndex)) + end select + endif + + ! compute the derivative in liquid water content w.r.t. temperature + ! --> partially frozen: dependence of liquid water on temperature + if(xTemp unfrozen: no dependence of liquid water on temperature + else + select case(ixDomainType) + case(iname_veg); dTheta_dTkCanopy = 0._rkind; d2Theta_dTkCanopy2 = 0._rkind; dFracLiqVeg_dTkCanopy = 0._rkind + case(iname_snow, iname_soil); mLayerdTheta_dTk(iLayer) = 0._rkind; mLayerd2Theta_dTk2(iLayer) = 0._rkind; dFracLiqWat_dTk(iLayer) = 0._rkind + case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return + end select ! domain type + endif + + ! ----- + ! - update volumetric fraction of liquid water and ice... + ! => case of hydrology state uncoupled with energy (and when not adjusting the temperature)... + ! ----------------------------------------------------------------------------------------------- + + ! case of hydrology state uncoupled with energy (and when not adjusting the temperature) + if(.not.do_adjustTemp .and. .not.isNrgState .and. .not.isCoupled)then + + ! compute the fraction of snow + select case(ixDomainType) + case(iname_veg); scalarFracLiqVeg = fracliquid(xTemp,snowfrz_scale) + case(iname_snow); mLayerFracLiqSnow(iLayer) = fracliquid(xTemp,snowfrz_scale) + case(iname_soil) ! do nothing + case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return + end select ! domain type + + ! ----- + ! - update volumetric fraction of liquid water and ice... + ! => case of energy state or coupled solution (or adjusting the temperature)... + ! -------------------------------------------------------------------------------- + + ! case of energy state OR coupled solution (or adjusting the temperature) + elseif(do_adjustTemp .or. ( (isNrgState .or. isCoupled) ) )then + + ! identify domain type + select case(ixDomainType) + + ! *** vegetation canopy + case(iname_veg) + + ! compute volumetric fraction of liquid water and ice + call updateSnowPrime(& + xTemp, & ! intent(in): temperature (K) + scalarCanopyWatTrial/(iden_water*canopyDepth),& ! intent(in): volumetric fraction of total water (-) + snowfrz_scale, & ! intent(in): scaling parameter for the snow freezing curve (K-1) + scalarCanopyTempPrime, & ! intent(in): canopy temperature time derivative (K/s) + scalarCanopyWatPrime/(iden_water*canopyDepth),& ! intent(in): volumetric fraction of total water time derivative (-) + scalarVolFracLiq, & ! intent(out): trial canopy liquid water (-) + scalarVolFracIce, & ! intent(out): trial volumetric canopy ice (-) + scalarVolFracLiqPrime, & ! intent(out): trial volumetric canopy liquid water (-) + scalarVolFracIcePrime, & ! intent(out): trial volumetric canopy ice (-) + scalarFracLiqVeg, & ! intent(out): fraction of liquid water (-) + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! compute mass of water on the canopy + ! NOTE: possibilities for speed-up here + scalarCanopyLiqTrial = scalarFracLiqVeg *scalarCanopyWatTrial !(kg m-2), scalarVolFracLiq*iden_water*canopyDepth + scalarCanopyLiqPrime = scalarVolFracLiqPrime*iden_water*canopyDepth + scalarCanopyIceTrial = (1._rkind - scalarFracLiqVeg)*scalarCanopyWatTrial !(kg m-2), scalarVolFracIce* iden_ice *canopyDepth + scalarCanopyIcePrime = scalarVolFracIcePrime* iden_ice *canopyDepth + + ! *** snow layers + case(iname_snow) + + ! compute volumetric fraction of liquid water and ice + call updateSnowPrime(& + xTemp, & ! intent(in): temperature (K) + mLayerVolFracWatTrial(iLayer), & ! intent(in): mass state variable = trial volumetric fraction of water (-) + snowfrz_scale, & ! intent(in): scaling parameter for the snow freezing curve (K-1) + mLayerTempPrime(iLayer), & ! intent(in): temperature time derivative (K/s) + mLayerVolFracWatPrime(iLayer), & ! intent(in): volumetric fraction of total water time derivative (-) + mLayerVolFracLiqTrial(iLayer), & ! intent(out): trial volumetric fraction of liquid water (-) + mLayerVolFracIceTrial(iLayer), & ! intent(out): trial volumetric fraction if ice (-) + mLayerVolFracLiqPrime(iLayer), & ! intent(out): volumetric fraction of liquid water time derivative (-) + mLayerVolFracIcePrime(iLayer), & ! intent(out): volumetric fraction of ice time derivative (-) + mLayerFracLiqSnow(iLayer), & ! intent(out): fraction of liquid water (-) + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! *** soil layers + case(iname_soil) + + ! compute volumetric fraction of liquid water and ice + call updateSoilPrime(& + xTemp, & ! intent(in): temperature (K) + mLayerMatricHeadTrial(ixControlIndex), & ! intent(in): total water matric potential (m) + mLayerTempPrime(iLayer), & ! intent(in): temperature time derivative (K/s) + mLayerMatricHeadPrime(ixControlIndex), & ! intent(in): total water matric potential time derivative (m/s) + vGn_alpha(ixControlIndex),vGn_n(ixControlIndex),theta_sat(ixControlIndex),theta_res(ixControlIndex),vGn_m(ixControlIndex), & ! intent(in): soil parameters + mLayerVolFracWatTrial(iLayer), & ! intent(in): mass state variable = trial volumetric fraction of water (-) + mLayerVolFracLiqTrial(iLayer), & ! intent(out): trial volumetric fraction of liquid water (-) + mLayerVolFracIceTrial(iLayer), & ! intent(out): trial volumetric fraction if ice (-) + mLayerVolFracWatPrime(iLayer), & ! intent(out): volumetric fraction of total water time derivative (-) + mLayerVolFracLiqPrime(iLayer), & ! intent(out): volumetric fraction of liquid water time derivative (-) + mLayerVolFracIcePrime(iLayer), & ! intent(out): volumetric fraction of ice time derivative (-) + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! check + case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return + + end select ! domain type + + ! final check + else + + ! do nothing (input = output) -- and check that we got here correctly + if( (isNrgState .or. isCoupled) )then + scalarVolFracLiq = realMissing + scalarVolFracIce = realMissing + else + message=trim(message)//'unexpected else branch' + err=20; return + endif + + endif ! if energy state or solution is coupled + + ! ----- + ! ------------------------ + + ! check the need to adjust temperature (will always be false if inside solver) + ! can be true if inside varSubstep, outside solver, if in a splitting case + ! NOTE: should be adjusting enthalpy if that is the state variabls + if(do_adjustTemp)then + + ! get the melt energy + meltNrg = merge(LH_fus*iden_ice, LH_fus*iden_water, ixDomainType==iname_snow) + + ! compute the residual and the derivative + select case(ixDomainType) + + ! * vegetation + case(iname_veg) + call xTempSolve(& + ! constant over iterations + meltNrg = meltNrg ,& ! intent(in): energy for melt+freeze (J m-3) + heatCap = scalarBulkVolHeatCapVeg ,& ! intent(in): volumetric heat capacity (J m-3 K-1) + tempInit = scalarCanopyTemp ,& ! intent(in): initial temperature (K) + volFracIceInit = scalarCanopyIce/(iden_water*canopyDepth),& ! intent(in): initial volumetric fraction of ice (-) + ! trial values + xTemp = xTemp ,& ! intent(inout): trial value of temperature + dLiq_dT = dTheta_dTkCanopy ,& ! intent(in): derivative in liquid water content w.r.t. temperature (K-1) + volFracIceTrial = scalarVolFracIce ,& ! intent(in): trial value for volumetric fraction of ice + ! residual and derivative + residual = residual ,& ! intent(out): residual (J m-3) + derivative = derivative ) ! intent(out): derivative (J m-3 K-1) + + ! * snow and soil + case(iname_snow, iname_soil) + call xTempSolve(& + ! constant over iterations + meltNrg = meltNrg ,& ! intent(in): energy for melt+freeze (J m-3) + heatCap = mLayerVolHtCapBulk(iLayer) ,& ! intent(in): volumetric heat capacity (J m-3 K-1) + tempInit = mLayerTemp(iLayer) ,& ! intent(in): initial temperature (K) + volFracIceInit = mLayerVolFracIce(iLayer) ,& ! intent(in): initial volumetric fraction of ice (-) + ! trial values + xTemp = xTemp ,& ! intent(inout): trial value of temperature + dLiq_dT = mLayerdTheta_dTk(iLayer) ,& ! intent(in): derivative in liquid water content w.r.t. temperature (K-1) + volFracIceTrial = mLayerVolFracIceTrial(iLayer) ,& ! intent(in): trial value for volumetric fraction of ice + ! residual and derivative + residual = residual ,& ! intent(out): residual (J m-3) + derivative = derivative ) ! intent(out): derivative (J m-3 K-1) + + ! * check + case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return + + end select ! domain type + + ! check validity of residual + if( ieee_is_nan(residual) )then + message=trim(message)//'residual is not valid' + err=20; return + endif + + ! update bracket + if(residual < 0._rkind)then + tempMax = min(xTemp,tempMax) + else + tempMin = max(tempMin,xTemp) + end if + + ! compute iteration increment + tempInc = residual/derivative ! K + + ! check + if(globalPrintFlag)& + write(*,'(i4,1x,e20.10,1x,5(f20.10,1x),L1)') iter, residual, xTemp-Tcrit, tempInc, Tcrit, tempMin, tempMax, bFlag + + ! check convergence + if(abs(residual) < nrgConvTol .or. abs(tempInc) < tempConvTol) exit iterations + + ! add constraints for snow temperature + if(ixDomainType==iname_veg .or. ixDomainType==iname_snow)then + if(tempInc > Tcrit - xTemp) tempInc=(Tcrit - xTemp)*0.5_rkind ! simple bi-section method + endif ! if the domain is vegetation or snow + + ! deal with the discontinuity between partially frozen and unfrozen soil + if(ixDomainType==iname_soil)then + ! difference from the temperature below which ice exists + critDiff = Tcrit - xTemp + ! --> initially frozen (T < Tcrit) + if(critDiff > 0._rkind)then + if(tempInc > critDiff) tempInc = critDiff + epsT ! set iteration increment to slightly above critical temperature + ! --> initially unfrozen (T > Tcrit) + else + if(tempInc < critDiff) tempInc = critDiff - epsT ! set iteration increment to slightly below critical temperature + endif + endif ! if the domain is soil + + ! update the temperature trial + xTemp = xTemp + tempInc + + ! check failed convergence + if(iter==maxiter)then + message=trim(message)//'failed to converge' + err=-20; return ! negative error code = try to recover + endif + + endif ! if adjusting the temperature + + end do iterations ! iterating + + ! save temperature + select case(ixDomainType) + case(iname_veg); scalarCanopyTempTrial = xTemp + case(iname_snow, iname_soil); mLayerTempTrial(iLayer) = xTemp + end select + + ! ======================================================================================================================================= + ! ======================================================================================================================================= + + ! ----- + ! - compute the liquid water matric potential (and necessary derivatives)... + ! ------------------------------------------------------------------------- + + ! only for soil + if(ixDomainType==iname_soil)then + + ! check liquid water + if(mLayerVolFracLiqTrial(iLayer) > theta_sat(ixControlIndex) )then + message=trim(message)//'liquid water greater than porosity' + err=20; return + endif + + ! case of hydrology state uncoupled with energy + if(.not.isNrgState .and. .not.isCoupled)then + + ! derivatives relating liquid water matric potential to total water matric potential and temperature + dPsiLiq_dPsi0(ixControlIndex) = 1._rkind ! exact correspondence (psiLiq=psi0) + dPsiLiq_dTemp(ixControlIndex) = 0._rkind ! no relationship between liquid water matric potential and temperature + + ! case of energy state or coupled solution + else + ! compute the liquid matric potential (and the derivatives w.r.t. total matric potential and temperature) + call liquidHeadPrime(& + ! input + mLayerMatricHeadTrial(ixControlIndex) ,& ! intent(in): total water matric potential (m) + mLayerMatricHeadPrime(ixControlIndex) ,& ! intent(in): total water matric potential time derivative (m s-1) + mLayerVolFracLiqTrial(iLayer) ,& ! intent(in): volumetric fraction of liquid water (-) + mLayerVolFracIceTrial(iLayer) ,& ! intent(in): volumetric fraction of ice (-) + vGn_alpha(ixControlIndex),vGn_n(ixControlIndex),theta_sat(ixControlIndex),theta_res(ixControlIndex),vGn_m(ixControlIndex) ,& ! intent(in): soil parameters + dVolTot_dPsi0(ixControlIndex) ,& ! intent(in): derivative in the soil water characteristic (m-1) + mLayerdTheta_dTk(iLayer) ,& ! intent(in): derivative in volumetric total water w.r.t. temperature (K-1) + mLayerVolFracLiqPrime(iLayer) ,& ! intent(in): volumetric fraction of liquid water time derivative (-) + mLayerVolFracIcePrime(iLayer) ,& ! intent(in): volumetric fraction of ice time derivative (-) + ! output + mLayerMatricHeadLiqTrial(ixControlIndex) ,& ! intent(out): liquid water matric potential (m) + mLayerMatricHeadLiqPrime(ixControlIndex) ,& ! intent(out): liquid water matric potential time derivative (m s-1) + dPsiLiq_dPsi0(ixControlIndex) ,& ! intent(out): derivative in the liquid water matric potential w.r.t. the total water matric potential (-) + dPsiLiq_dTemp(ixControlIndex) ,& ! intent(out): derivative in the liquid water matric potential w.r.t. temperature (m K-1) + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + + endif ! switch between hydrology and energy state + + endif ! if domain is soil + + end do ! looping through state variables + + ! deallocate space + deallocate(computedCoupling,stat=err) ! .true. if computed the coupling for a given state variable + if(err/=0)then; message=trim(message)//'problem deallocating computedCoupling'; return; endif + + ! end association to the variables in the data structures +end associate + +end subroutine updateVarsWithPrime + + +! ********************************************************************************************************** +! private subroutine xTempSolve: compute residual and derivative for temperature +! ********************************************************************************************************** +subroutine xTempSolve(& + ! input: constant over iterations + meltNrg ,& ! intent(in): energy for melt+freeze (J m-3) + heatCap ,& ! intent(in): volumetric heat capacity (J m-3 K-1) + tempInit ,& ! intent(in): initial temperature (K) + volFracIceInit ,& ! intent(in): initial volumetric fraction of ice (-) + ! input-output: trial values + xTemp ,& ! intent(inout): trial value of temperature + dLiq_dT ,& ! intent(in): derivative in liquid water content w.r.t. temperature (K-1) + volFracIceTrial ,& ! intent(in): trial value for volumetric fraction of ice + ! output: residual and derivative + residual ,& ! intent(out): residual (J m-3) + derivative ) ! intent(out): derivative (J m-3 K-1) + implicit none + ! input: constant over iterations + real(rkind),intent(in) :: meltNrg ! energy for melt+freeze (J m-3) + real(rkind),intent(in) :: heatCap ! volumetric heat capacity (J m-3 K-1) + real(rkind),intent(in) :: tempInit ! initial temperature (K) + real(rkind),intent(in) :: volFracIceInit ! initial volumetric fraction of ice (-) + ! input-output: trial values + real(rkind),intent(inout) :: xTemp ! trial value for temperature + real(rkind),intent(in) :: dLiq_dT ! derivative in liquid water content w.r.t. temperature (K-1) + real(rkind),intent(in) :: volFracIceTrial ! trial value for the volumetric fraction of ice (-) + ! output: residual and derivative + real(rkind),intent(out) :: residual ! residual (J m-3) + real(rkind),intent(out) :: derivative ! derivative (J m-3 K-1) + ! subroutine starts here + residual = -heatCap*(xTemp - tempInit) + meltNrg*(volFracIceTrial - volFracIceInit) ! J m-3 + derivative = heatCap + LH_fus*iden_water*dLiq_dT ! J m-3 K-1 +end subroutine xTempSolve + +end module updateVarsWithPrime_module diff --git a/build/source/engine/varSubstep.f90 b/build/source/engine/varSubstep.f90 old mode 100755 new mode 100644 index c5f5cea08..8127da249 --- a/build/source/engine/varSubstep.f90 +++ b/build/source/engine/varSubstep.f90 @@ -22,10 +22,11 @@ module varSubstep_module ! data types USE nrtype +USE globalData,only: verySmall ! a very small number used as an additive constant to check if substantial difference among real numbers ! access missing values USE globalData,only:integerMissing ! missing integer -USE globalData,only:realMissing ! missing double precision number +USE globalData,only:realMissing ! missing real number USE globalData,only:quadMissing ! missing quadruple precision number ! access the global print flag @@ -42,12 +43,16 @@ module varSubstep_module ! derived types to define the data structures USE data_types,only:& - var_i, & ! data vector (i4b) - var_d, & ! data vector (dp) - var_flagVec, & ! data vector with variable length dimension (i4b) - var_ilength, & ! data vector with variable length dimension (i4b) - var_dlength, & ! data vector with variable length dimension (dp) - model_options ! defines the model decisions + var_i, & ! data vector (i4b) + var_d, & ! data vector (rkind) + var_flagVec, & ! data vector with variable length dimension (i4b) + var_ilength, & ! data vector with variable length dimension (i4b) + var_dlength, & ! data vector with variable length dimension (rkind) + zLookup, & ! lookup tables + model_options, & ! defines the model decisions + in_type_varSubstep, & ! class for intent(in) arguments + io_type_varSubstep, & ! class for intent(inout) arguments + out_type_varSubstep ! class for intent(out) arguments ! provide access to indices that define elements of the data structures USE var_lookup,only:iLookFLUX ! named variables for structure elements @@ -55,951 +60,1315 @@ module varSubstep_module USE var_lookup,only:iLookDIAG ! named variables for structure elements USE var_lookup,only:iLookPARAM ! named variables for structure elements USE var_lookup,only:iLookINDEX ! named variables for structure elements +USE var_lookup,only:iLookDERIV ! named variables for structure elements +USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure ! look up structure for variable types USE var_lookup,only:iLookVarType ! constants USE multiconst,only:& - Tfreeze, & ! freezing temperature (K) - LH_fus, & ! latent heat of fusion (J kg-1) - LH_vap, & ! latent heat of vaporization (J kg-1) - iden_ice, & ! intrinsic density of ice (kg m-3) - iden_water ! intrinsic density of liquid water (kg m-3) + Tfreeze, & ! freezing temperature (K) + LH_fus, & ! latent heat of fusion (J kg-1) + LH_vap, & ! latent heat of vaporization (J kg-1) + iden_ice, & ! intrinsic density of ice (kg m-3) + iden_water ! intrinsic density of liquid water (kg m-3) + +! look-up values for the numerical method +USE mDecisions_module,only: & + homegrown ,& ! homegrown backward Euler solution using concepts from numerical recipes + kinsol ,& ! SUNDIALS backward Euler solution using Kinsol + ida ! SUNDIALS solution using IDA + +! look-up values for the choice of variable in energy equations (BE residual or IDA state variable) +USE mDecisions_module,only: & + closedForm, & ! use temperature with closed form heat capacity + enthalpyFormLU, & ! use enthalpy with soil temperature-enthalpy lookup tables + enthalpyForm ! use enthalpy with soil temperature-enthalpy analytical solution ! safety: set private unless specified otherwise implicit none private public::varSubstep - -! algorithmic parameters -real(rkind),parameter :: verySmall=1.e-6_rkind ! used as an additive constant to check if substantial difference among real numbers - contains - ! ********************************************************************************************************** - ! public subroutine varSubstep: run the model for a collection of substeps for a given state subset - ! ********************************************************************************************************** - subroutine varSubstep(& - ! input: model control - dt, & ! intent(in) : time step (s) - dtInit, & ! intent(in) : initial time step (seconds) - dt_min, & ! intent(in) : minimum time step (seconds) - nState, & ! intent(in) : total number of state variables - doAdjustTemp, & ! intent(in) : flag to indicate if we adjust the temperature - firstSubStep, & ! intent(in) : flag to denote first sub-step - firstFluxCall, & ! intent(inout) : flag to indicate if we are processing the first flux call - computeVegFlux, & ! intent(in) : flag to denote if computing energy flux over vegetation - scalarSolution, & ! intent(in) : flag to denote implementing the scalar solution - iStateSplit, & ! intent(in) : index of the state in the splitting operation - fluxMask, & ! intent(in) : mask for the fluxes used in this given state subset - fluxCount, & ! intent(inout) : number of times that fluxes are updated (should equal nSubsteps) - ! input/output: data structures - model_decisions, & ! intent(in) : model decisions - type_data, & ! intent(in) : type of vegetation and soil - attr_data, & ! intent(in) : spatial attributes - forc_data, & ! intent(in) : model forcing data - mpar_data, & ! intent(in) : model parameters - indx_data, & ! intent(inout) : index data - prog_data, & ! intent(inout) : model prognostic variables for a local HRU - diag_data, & ! intent(inout) : model diagnostic variables for a local HRU - flux_data, & ! intent(inout) : model fluxes for a local HRU - deriv_data, & ! intent(inout) : derivatives in model fluxes w.r.t. relevant state variables - bvar_data, & ! intent(in) : model variables for the local basin - ! output: model control - ixSaturation, & ! intent(inout) : index of the lowest saturated layer (NOTE: only computed on the first iteration) - dtMultiplier, & ! intent(out) : substep multiplier (-) - nSubsteps, & ! intent(out) : number of substeps taken for a given split - failedMinimumStep, & ! intent(out) : flag to denote success of substepping for a given split - reduceCoupledStep, & ! intent(out) : flag to denote need to reduce the length of the coupled step - tooMuchMelt, & ! intent(out) : flag to denote that ice is insufficient to support melt - err,message) ! intent(out) : error code and error message - ! --------------------------------------------------------------------------------------- - ! structure allocations - USE allocspace_module,only:allocLocal ! allocate local data structures - ! simulation of fluxes and residuals given a trial state vector - USE systemSolv_module,only:systemSolv ! solve the system of equations for one time step - USE getVectorz_module,only:popStateVec ! populate the state vector - USE getVectorz_module,only:varExtract ! extract variables from the state vector - USE updateVars_module,only:updateVars ! update prognostic variables - ! identify name of variable type (for error message) - USE get_ixName_module,only:get_varTypeName ! to access type strings for error messages - implicit none - ! --------------------------------------------------------------------------------------- - ! * dummy variables - ! --------------------------------------------------------------------------------------- - ! input: model control - real(rkind),intent(in) :: dt ! time step (seconds) - real(rkind),intent(in) :: dtInit ! initial time step (seconds) - real(rkind),intent(in) :: dt_min ! minimum time step (seconds) - integer(i4b),intent(in) :: nState ! total number of state variables - logical(lgt),intent(in) :: doAdjustTemp ! flag to indicate if we adjust the temperature - logical(lgt),intent(in) :: firstSubStep ! flag to indicate if we are processing the first sub-step - logical(lgt),intent(inout) :: firstFluxCall ! flag to define the first flux call - logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) - logical(lgt),intent(in) :: scalarSolution ! flag to denote implementing the scalar solution - integer(i4b),intent(in) :: iStateSplit ! index of the state in the splitting operation - type(var_flagVec),intent(in) :: fluxMask ! flags to denote if the flux is calculated in the given state subset - type(var_ilength),intent(inout) :: fluxCount ! number of times that the flux is updated (should equal nSubsteps) - ! input/output: data structures - type(model_options),intent(in) :: model_decisions(:) ! model decisions - type(var_i),intent(in) :: type_data ! type of vegetation and soil - type(var_d),intent(in) :: attr_data ! spatial attributes - type(var_d),intent(in) :: forc_data ! model forcing data - type(var_dlength),intent(in) :: mpar_data ! model parameters - type(var_ilength),intent(inout) :: indx_data ! indices for a local HRU - type(var_dlength),intent(inout) :: prog_data ! prognostic variables for a local HRU - type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU - type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU - type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables - type(var_dlength),intent(in) :: bvar_data ! model variables for the local basin - ! output: model control - integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) - real(rkind),intent(out) :: dtMultiplier ! substep multiplier (-) - integer(i4b),intent(out) :: nSubsteps ! number of substeps taken for a given split - logical(lgt),intent(out) :: failedMinimumStep ! flag to denote success of substepping for a given split - logical(lgt),intent(out) :: reduceCoupledStep ! flag to denote need to reduce the length of the coupled step - logical(lgt),intent(out) :: tooMuchMelt ! flag to denote that ice is insufficient to support melt - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! --------------------------------------------------------------------------------------- - ! * general local variables - ! --------------------------------------------------------------------------------------- - ! error control - character(LEN=256) :: cmessage ! error message of downwind routine - ! general local variables - integer(i4b) :: iVar ! index of variables in data structures - integer(i4b) :: iSoil ! index of soil layers - integer(i4b) :: ixLayer ! index in a given domain - integer(i4b), dimension(1) :: ixMin,ixMax ! bounds of a given flux vector - ! time stepping - real(rkind) :: dtSum ! sum of time from successful steps (seconds) - real(rkind) :: dt_wght ! weight given to a given flux calculation - real(rkind) :: dtSubstep ! length of a substep (s) - ! adaptive sub-stepping for the explicit solution - logical(lgt) :: failedSubstep ! flag to denote success of substepping for a given split - real(rkind),parameter :: safety=0.85_rkind ! safety factor in adaptive sub-stepping - real(rkind),parameter :: reduceMin=0.1_rkind ! mimimum factor that time step is reduced - real(rkind),parameter :: increaseMax=4.0_rkind ! maximum factor that time step is increased - ! adaptive sub-stepping for the implicit solution - integer(i4b) :: niter ! number of iterations taken - integer(i4b),parameter :: n_inc=5 ! minimum number of iterations to increase time step - integer(i4b),parameter :: n_dec=15 ! maximum number of iterations to decrease time step - real(rkind),parameter :: F_inc = 1.25_rkind ! factor used to increase time step - real(rkind),parameter :: F_dec = 0.90_rkind ! factor used to decrease time step - ! state and flux vectors - real(rkind) :: untappedMelt(nState) ! un-tapped melt energy (J m-3 s-1) - real(rkind) :: stateVecInit(nState) ! initial state vector (mixed units) - real(rkind) :: stateVecTrial(nState) ! trial state vector (mixed units) - type(var_dlength) :: flux_temp ! temporary model fluxes - ! flags - logical(lgt) :: firstSplitOper ! flag to indicate if we are processing the first flux call in a splitting operation - logical(lgt) :: checkMassBalance ! flag to check the mass balance - logical(lgt) :: waterBalanceError ! flag to denote that there is a water balance error - logical(lgt) :: nrgFluxModified ! flag to denote that the energy fluxes were modified - ! energy fluxes - real(rkind) :: sumCanopyEvaporation ! sum of canopy evaporation/condensation (kg m-2 s-1) - real(rkind) :: sumLatHeatCanopyEvap ! sum of latent heat flux for evaporation from the canopy to the canopy air space (W m-2) - real(rkind) :: sumSenHeatCanopy ! sum of sensible heat flux from the canopy to the canopy air space (W m-2) - real(rkind) :: sumSoilCompress - real(rkind),allocatable :: sumLayerCompress(:) - ! --------------------------------------------------------------------------------------- - ! point to variables in the data structures - ! --------------------------------------------------------------------------------------- - globalVars: associate(& - ! number of layers - nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in): [i4b] number of snow layers - nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1) ,& ! intent(in): [i4b] number of soil layers - nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1) ,& ! intent(in): [i4b] total number of layers - nSoilOnlyHyd => indx_data%var(iLookINDEX%nSoilOnlyHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the soil domain - mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat ,& ! intent(in): [dp(:)] depth of each layer in the snow-soil sub-domain (m) - ! mapping between state vectors and control volumes - ixLayerActive => indx_data%var(iLookINDEX%ixLayerActive)%dat ,& ! intent(in): [i4b(:)] list of indices for all active layers (inactive=integerMissing) - ixMapFull2Subset => indx_data%var(iLookINDEX%ixMapFull2Subset)%dat ,& ! intent(in): [i4b(:)] mapping of full state vector to the state subset - ixControlVolume => indx_data%var(iLookINDEX%ixControlVolume)%dat ,& ! intent(in): [i4b(:)] index of control volume for different domains (veg, snow, soil) - ! model state variables (vegetation canopy) - scalarCanairTemp => prog_data%var(iLookPROG%scalarCanairTemp)%dat(1) ,& ! intent(inout): [dp] temperature of the canopy air space (K) - scalarCanopyTemp => prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1) ,& ! intent(inout): [dp] temperature of the vegetation canopy (K) - scalarCanopyIce => prog_data%var(iLookPROG%scalarCanopyIce)%dat(1) ,& ! intent(inout): [dp] mass of ice on the vegetation canopy (kg m-2) - scalarCanopyLiq => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1) ,& ! intent(inout): [dp] mass of liquid water on the vegetation canopy (kg m-2) - scalarCanopyWat => prog_data%var(iLookPROG%scalarCanopyWat)%dat(1) ,& ! intent(inout): [dp] mass of total water on the vegetation canopy (kg m-2) - ! model state variables (snow and soil domains) - mLayerTemp => prog_data%var(iLookPROG%mLayerTemp)%dat ,& ! intent(inout): [dp(:)] temperature of each snow/soil layer (K) - mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat ,& ! intent(inout): [dp(:)] volumetric fraction of ice (-) - mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat ,& ! intent(inout): [dp(:)] volumetric fraction of liquid water (-) - mLayerVolFracWat => prog_data%var(iLookPROG%mLayerVolFracWat)%dat ,& ! intent(inout): [dp(:)] volumetric fraction of total water (-) - mLayerMatricHead => prog_data%var(iLookPROG%mLayerMatricHead)%dat ,& ! intent(inout): [dp(:)] matric head (m) - mLayerMatricHeadLiq => diag_data%var(iLookDIAG%mLayerMatricHeadLiq)%dat & ! intent(inout): [dp(:)] matric potential of liquid water (m) - ) ! end association with variables in the data structures - ! ********************************************************************************************************************************************************* - ! ********************************************************************************************************************************************************* - ! Procedure starts here - - ! initialize error control - err=0; message='varSubstep/' - - ! initialize flag for the success of the substepping - failedMinimumStep=.false. - - ! initialize the length of the substep - dtSubstep = dtInit - - ! allocate space for the temporary model flux structure - call allocLocal(flux_meta(:),flux_temp,nSnow,nSoil,err,cmessage) - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif - - ! initialize the model fluxes (some model fluxes are not computed in the iterations) - do iVar=1,size(flux_data%var) - flux_temp%var(iVar)%dat(:) = flux_data%var(iVar)%dat(:) - end do - - ! initialize the total energy fluxes (modified in updateProg) - sumCanopyEvaporation = 0._rkind ! canopy evaporation/condensation (kg m-2 s-1) - sumLatHeatCanopyEvap = 0._rkind ! latent heat flux for evaporation from the canopy to the canopy air space (W m-2) - sumSenHeatCanopy = 0._rkind ! sensible heat flux from the canopy to the canopy air space (W m-2) - sumSoilCompress = 0._rkind ! total soil compression - allocate(sumLayerCompress(nSoil)); sumLayerCompress = 0._rkind ! soil compression by layer - - ! define the first flux call in a splitting operation - firstSplitOper = (.not.scalarSolution .or. iStateSplit==1) - - ! initialize subStep - dtSum = 0._rkind ! keep track of the portion of the time step that is completed - nSubsteps = 0 - - ! loop through substeps - ! NOTE: continuous do statement with exit clause - substeps: do - +! ********************************************************************************************************** +! public subroutine varSubstep: run the model for a collection of substeps for a given state subset +! ********************************************************************************************************** +subroutine varSubstep(& + ! input: model control + in_varSubstep, & ! intent(in) : model control + io_varSubstep, & ! intent(inout) : model control + ! input/output: data structures + model_decisions, & ! intent(in) : model decisions + lookup_data, & ! intent(in) : lookup tables + type_data, & ! intent(in) : type of vegetation and soil + attr_data, & ! intent(in) : spatial attributes + forc_data, & ! intent(in) : model forcing data + mpar_data, & ! intent(in) : model parameters + indx_data, & ! intent(inout) : index data + prog_data, & ! intent(inout) : model prognostic variables for a local HRU + diag_data, & ! intent(inout) : model diagnostic variables for a local HRU + flux_data, & ! intent(inout) : model fluxes for a local HRU + flux_mean, & ! intent(inout) : mean model fluxes for a local HRU + deriv_data, & ! intent(inout) : derivatives in model fluxes w.r.t. relevant state variables + bvar_data, & ! intent(in) : model variables for the local basin + ! output: model control + out_varSubstep) ! intent(out) : model control + ! --------------------------------------------------------------------------------------- + ! structure allocations + USE allocspace_module,only:allocLocal ! allocate local data structures + ! simulation of fluxes and residuals given a trial state vector + USE getVectorz_module,only:popStateVec ! populate the state vector + USE getVectorz_module,only:varExtract ! extract variables from the state vector + USE systemSolv_module,only:systemSolv ! solve the system of equations for one time step + ! identify name of variable type (for error message) + USE get_ixName_module,only:get_varTypeName ! to access type strings for error messages + implicit none + ! --------------------------------------------------------------------------------------- + ! * dummy variables + ! --------------------------------------------------------------------------------------- + ! input: model control + type(in_type_varSubstep),intent(in) :: in_varSubstep ! model control + type(io_type_varSubstep),intent(inout) :: io_varSubstep ! model control + ! input/output: data structures + type(model_options),intent(in) :: model_decisions(:) ! model decisions + type(zLookup),intent(in) :: lookup_data ! lookup tables + type(var_i),intent(in) :: type_data ! type of vegetation and soil + type(var_d),intent(in) :: attr_data ! spatial attributes + type(var_d),intent(in) :: forc_data ! model forcing data + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_ilength),intent(inout) :: indx_data ! indices for a local HRU + type(var_dlength),intent(inout) :: prog_data ! prognostic variables for a local HRU + type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(inout) :: flux_mean ! mean model fluxes for a local HRU + type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + type(var_dlength),intent(in) :: bvar_data ! model variables for the local basin + ! output: model control + type(out_type_varSubstep),intent(out) :: out_varSubstep ! model control + ! --------------------------------------------------------------------------------------- + ! * general local variables + ! --------------------------------------------------------------------------------------- + ! error control + character(LEN=256) :: cmessage ! error message of downwind routine + ! general local variables + integer(i4b) :: iVar ! index of variables in data structures + integer(i4b) :: iSoil ! index of soil layers + integer(i4b) :: ixLayer ! index in a given domain + integer(i4b),dimension(1) :: ixMin,ixMax ! bounds of a given flux vector + ! time stepping + real(rkind) :: dtSum ! sum of time from successful steps (seconds) + real(rkind) :: dt_wght ! weight given to a given flux calculation + real(rkind) :: dtSubstep ! length of a substep (s) + real(rkind) :: maxstep ! maximum time step length (seconds) + integer(i4b) :: nSteps ! number of time steps taken in solver + ! adaptive sub-stepping for the solution + logical(lgt) :: failedSubstep ! flag to denote success of substepping for a given split + integer(i4b) :: niter ! number of iterations taken + integer(i4b),parameter :: n_inc=5 ! minimum number of iterations to increase time step + integer(i4b),parameter :: n_dec=15 ! maximum number of iterations to decrease time step + real(rkind),parameter :: F_inc = 1.25_rkind ! factor used to increase time step + real(rkind),parameter :: F_dec = 0.90_rkind ! factor used to decrease time step + ! state and flux vectors (Note: nstate = in_varSubstep % nSubset) + real(rkind) :: untappedMelt(in_varSubstep % nSubset) ! un-tapped melt energy (J m-3 s-1) + real(rkind) :: stateVecInit(in_varSubstep % nSubset) ! initial state vector (mixed units) + real(rkind) :: stateVecTrial(in_varSubstep % nSubset) ! trial state vector (mixed units) + real(rkind) :: stateVecPrime(in_varSubstep % nSubset) ! trial state vector (mixed units) + type(var_dlength) :: flux_temp ! temporary model fluxes + ! flags + logical(lgt) :: firstSplitOper ! flag to indicate if we are processing the first flux call in a splitting operation + logical(lgt) :: waterBalanceError ! flag to denote that there is a water balance error + logical(lgt) :: nrgFluxModified ! flag to denote that the energy fluxes were modified + ! energy fluxes + real(rkind) :: sumCanopyEvaporation ! sum of canopy evaporation/condensation (kg m-2 s-1) + real(rkind) :: sumLatHeatCanopyEvap ! sum of latent heat flux for evaporation from the canopy to the canopy air space (W m-2) + real(rkind) :: sumSenHeatCanopy ! sum of sensible heat flux from the canopy to the canopy air space (W m-2) + real(rkind) :: sumSoilCompress ! sum of total soil compression + real(rkind),allocatable :: sumLayerCompress(:) ! sum of soil compression by layer + ! balances and residual vectors + real(rkind) :: fluxVec(in_varSubstep % nSubset) ! substep flux vector (mixed units) + real(rkind) :: resSink(in_varSubstep % nSubset) ! substep sink terms on the RHS of the state equation + real(qp) :: resVec(in_varSubstep % nSubset) ! substep residual vector + real(rkind) :: balance(in_varSubstep % nSubset) ! substep balance per second + real(rkind) :: sumBalance(in_varSubstep % nSubset) ! sum of substeps balance + logical(lgt),parameter :: computMassBalance = .true. ! flag to compute the mass balance, will affect step length, default true + logical(lgt),parameter :: computNrgBalance = .true. ! flag to compute the energy balance, will not effect solution but will not compute energy balance if false (saves expense) + logical(lgt) :: computeEnthTemp ! flag to compute enthalpy regardless of the model decision + logical(lgt) :: enthalpyStateVec ! flag if enthalpy is a state variable (ida) + logical(lgt) :: use_lookup ! flag to use the lookup table for soil enthalpy, otherwise use analytical solution + + ! --------------------------------------------------------------------------------------- ! initialize error control - err=0; message='varSubstep/' - - !write(*,'(a,1x,3(f13.2,1x))') '***** new subStep: dtSubstep, dtSum, dt = ', dtSubstep, dtSum, dt - !print*, 'scalarCanopyIce = ', prog_data%var(iLookPROG%scalarCanopyIce)%dat(1) - !print*, 'scalarCanopyTemp = ', prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1) - - ! ----- - ! * populate state vectors... - ! --------------------------- - - ! initialize state vectors - call popStateVec(& - ! input - nState, & ! intent(in): number of desired state variables - prog_data, & ! intent(in): model prognostic variables for a local HRU - diag_data, & ! intent(in): model diagnostic variables for a local HRU - indx_data, & ! intent(in): indices defining model states and layers - ! output - stateVecInit, & ! intent(out): initial model state vector (mixed units) - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (check for errors) - - ! ----- - ! * iterative solution... - ! ----------------------- - - ! solve the system of equations for a given state subset - call systemSolv(& - ! input: model control - dtSubstep, & ! intent(in): time step (s) - nState, & ! intent(in): total number of state variables - firstSubStep, & ! intent(in): flag to denote first sub-step - firstFluxCall, & ! intent(inout): flag to indicate if we are processing the first flux call - firstSplitOper, & ! intent(in): flag to indicate if we are processing the first flux call in a splitting operation - computeVegFlux, & ! intent(in): flag to denote if computing energy flux over vegetation - scalarSolution, & ! intent(in): flag to denote if implementing the scalar solution - ! input/output: data structures - type_data, & ! intent(in): type of vegetation and soil - attr_data, & ! intent(in): spatial attributes - forc_data, & ! intent(in): model forcing data - mpar_data, & ! intent(in): model parameters - indx_data, & ! intent(inout): index data - prog_data, & ! intent(inout): model prognostic variables for a local HRU - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - flux_temp, & ! intent(inout): model fluxes for a local HRU - bvar_data, & ! intent(in): model variables for the local basin - model_decisions, & ! intent(in): model decisions - stateVecInit, & ! intent(in): initial state vector - ! output: model control - deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables - ixSaturation, & ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) - untappedMelt, & ! intent(out): un-tapped melt energy (J m-3 s-1) - stateVecTrial, & ! intent(out): updated state vector - reduceCoupledStep, & ! intent(out): flag to reduce the length of the coupled step - tooMuchMelt, & ! intent(out): flag to denote that ice is insufficient to support melt - niter, & ! intent(out): number of iterations taken - err,cmessage) ! intent(out): error code and error message - if(err/=0)then - message=trim(message)//trim(cmessage) - if(err>0) return - endif - - ! if too much melt or need to reduce length of the coupled step then return - ! NOTE: need to go all the way back to coupled_em and merge snow layers, as all splitting operations need to occur with the same layer geometry - if(tooMuchMelt .or. reduceCoupledStep) return - - ! identify failure - failedSubstep = (err<0) - - ! check - if(globalPrintFlag)then - print*, 'niter, failedSubstep, dtSubstep = ', niter, failedSubstep, dtSubstep - print*, trim(cmessage) - endif - - ! reduce step based on failure - if(failedSubstep)then - err=0; message='varSubstep/' ! recover from failed convergence - dtMultiplier = 0.5_rkind ! system failure: step halving - else - - ! ** implicit Euler: adjust step length based on iteration count - if(nitern_dec)then - dtMultiplier = F_dec - else - dtMultiplier = 1._rkind - endif + out_varSubstep % err=0; out_varSubstep % cmessage='varSubstep/' + ! --------------------------------------------------------------------------------------- + ! point to variables in the data structures + ! --------------------------------------------------------------------------------------- + globalVars: associate(& + ! input: model control + dt => in_varSubstep % dt, & ! intent(in): time step (seconds) + dtInit => in_varSubstep % dtInit, & ! intent(in): initial time step (seconds) + dt_min => in_varSubstep % dt_min, & ! intent(in): minimum time step (seconds) + whole_step => in_varSubstep % whole_step, & ! intent(in): length of whole step for surface drainage and average flux + nState => in_varSubstep % nSubset, & ! intent(in): total number of state variables + doAdjustTemp => in_varSubstep % doAdjustTemp, & ! intent(in): flag to indicate if we adjust the temperature + firstSubStep => in_varSubstep % firstSubStep, & ! intent(in): flag to indicate if processing the first sub-step + computeVegFlux => in_varSubstep % computeVegFlux, & ! intent(in): flag to indicate if computing fluxes over vegetation (.false. means veg is buried with snow) + scalarSolution => in_varSubstep % scalarSolution, & ! intent(in): flag to denote implementing the scalar solution + iStateSplit => in_varSubstep % iStateSplit, & ! intent(in): index of the state in the splitting operation + fluxMask => in_varSubstep % fluxMask, & ! intent(in): flags to denote if the flux is calculated in the given state subset + firstFluxCall => io_varSubstep % firstFluxCall, & ! intent(inout): flag to define the first flux call + fluxCount => io_varSubstep % fluxCount, & ! intent(inout): number of times that the flux is updated (should equal nSubsteps) + ixSaturation => io_varSubstep % ixSaturation, & ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) + ! model decisions + ixNumericalMethod => model_decisions(iLookDECISIONS%num_method)%iDecision ,& ! intent(in): [i4b] choice of numerical solver + ixNrgConserv => model_decisions(iLookDECISIONS%nrgConserv)%iDecision ,& ! intent(in): [i4b] choice of variable in either energy backward Euler residual or IDA state variable + ! number of layers + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in): [i4b] number of snow layers + nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1) ,& ! intent(in): [i4b] number of soil layers + nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1) ,& ! intent(in): [i4b] total number of layers + nSoilOnlyHyd => indx_data%var(iLookINDEX%nSoilOnlyHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the soil domain + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat ,& ! intent(in): [dp(:)] depth of each layer in the snow-soil sub-domain (m) + ! get indices for balances + ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy air space energy state variable + ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable + ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) + ixTopNrg => indx_data%var(iLookINDEX%ixTopNrg)%dat(1) ,& ! intent(in): [i4b] index of upper-most energy state in the snow+soil subdomain + ixTopHyd => indx_data%var(iLookINDEX%ixTopHyd)%dat(1) ,& ! intent(in): [i4b] index of upper-most hydrology state in the snow+soil subdomain + ixAqWat => indx_data%var(iLookINDEX%ixAqWat)%dat(1) ,& ! intent(in): [i4b] index of water storage in the aquifer + ixSoilOnlyHyd => indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the soil domain + ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the snow+soil domain + ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the snow+soil domain + nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg)%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow+soil domain + nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd)%dat(1) ,& ! intent(in): [i4b] number of hydrology state variables in the snow+soil domain + ! mapping between state vectors and control volumes + ixLayerActive => indx_data%var(iLookINDEX%ixLayerActive)%dat ,& ! intent(in): [i4b(:)] list of indices for all active layers (inactive=integerMissing) + ixMapFull2Subset => indx_data%var(iLookINDEX%ixMapFull2Subset)%dat ,& ! intent(in): [i4b(:)] mapping of full state vector to the state subset + ixControlVolume => indx_data%var(iLookINDEX%ixControlVolume)%dat ,& ! intent(in): [i4b(:)] index of control volume for different domains (veg, snow, soil) + ! model state variables (vegetation canopy) + scalarCanairTemp => prog_data%var(iLookPROG%scalarCanairTemp)%dat(1) ,& ! intent(inout): [dp] temperature of the canopy air space (K) + scalarCanopyTemp => prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1) ,& ! intent(inout): [dp] temperature of the vegetation canopy (K) + scalarCanopyIce => prog_data%var(iLookPROG%scalarCanopyIce)%dat(1) ,& ! intent(inout): [dp] mass of ice on the vegetation canopy (kg m-2) + scalarCanopyLiq => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1) ,& ! intent(inout): [dp] mass of liquid water on the vegetation canopy (kg m-2) + scalarCanopyWat => prog_data%var(iLookPROG%scalarCanopyWat)%dat(1) ,& ! intent(inout): [dp] mass of total water on the vegetation canopy (kg m-2) + ! model state variables (snow and soil domains) + mLayerTemp => prog_data%var(iLookPROG%mLayerTemp)%dat ,& ! intent(inout): [dp(:)] temperature of each snow/soil layer (K) + mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat ,& ! intent(inout): [dp(:)] volumetric fraction of ice (-) + mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat ,& ! intent(inout): [dp(:)] volumetric fraction of liquid water (-) + mLayerVolFracWat => prog_data%var(iLookPROG%mLayerVolFracWat)%dat ,& ! intent(inout): [dp(:)] volumetric fraction of total water (-) + mLayerMatricHead => prog_data%var(iLookPROG%mLayerMatricHead)%dat ,& ! intent(inout): [dp(:)] matric head (m) + mLayerMatricHeadLiq => diag_data%var(iLookDIAG%mLayerMatricHeadLiq)%dat ,& ! intent(inout): [dp(:)] matric potential of liquid water (m) + ! model control + dtMultiplier => out_varSubstep % dtMultiplier ,& ! intent(out): substep multiplier (-) + nSubsteps => out_varSubstep % nSubsteps ,& ! intent(out): number of substeps taken for a given split + failedMinimumStep => out_varSubstep % failedMinimumStep ,& ! intent(out): flag to denote success of substepping for a given split + reduceCoupledStep => out_varSubstep % reduceCoupledStep ,& ! intent(out): flag to denote need to reduce the length of the coupled step + tooMuchMelt => out_varSubstep % tooMuchMelt ,& ! intent(out): flag to denote that ice is insufficient to support melt + err => out_varSubstep % err ,& ! intent(out): error code + message => out_varSubstep % cmessage & ! intent(out): error message + ) ! end association with variables in the data structures + ! ********************************************************************************************************************************************************* + + ! initialize flag for the success of the substepping + failedMinimumStep=.false. + + ! set the flag to compute enthalpy, may want to have this true always if want to output enthalpy + computeEnthTemp = .false. + enthalpyStateVec = .false. + use_lookup = .false. + if((ixNrgConserv .ne. closedForm .or. computNrgBalance) .and. ixNumericalMethod .ne. ida) computeEnthTemp = .true. ! use enthTemp to conserve energy or compute energy balance + if(ixNrgConserv .ne. closedForm .and. ixNumericalMethod==ida) enthalpyStateVec = .true. ! enthalpy as state variable + if(ixNrgConserv==enthalpyFormLU) use_lookup = .true. ! use lookup tables for soil enthalpy instead of analytical solution + + ! initialize the length of the substep + dtSubstep = dtInit + + ! change maxstep with hard code here to make only the newton step loop in systemSolv* happen more frequently + ! NOTE: this may just be amplifying the splitting error if maxstep is smaller than the full possible step + maxstep = mpar_data%var(iLookPARAM%maxstep)%dat(1) ! maximum time step (s). + + ! allocate space for the temporary model flux structure + call allocLocal(flux_meta(:),flux_temp,nSnow,nSoil,err,cmessage) + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif + + ! initialize the model fluxes (some model fluxes are not computed in the iterations) + do iVar=1,size(flux_data%var) + flux_temp%var(iVar)%dat(:) = flux_data%var(iVar)%dat(:) + end do + + ! initialize the total energy fluxes (modified in updateProg) + sumCanopyEvaporation = 0._rkind ! canopy evaporation/condensation (kg m-2 s-1) + sumLatHeatCanopyEvap = 0._rkind ! latent heat flux for evaporation from the canopy to the canopy air space (W m-2) + sumSenHeatCanopy = 0._rkind ! sensible heat flux from the canopy to the canopy air space (W m-2) + sumSoilCompress = 0._rkind ! total soil compression + allocate(sumLayerCompress(nSoil)); sumLayerCompress = 0._rkind ! soil compression by layer + + ! initialize balances + sumBalance = 0._rkind + + ! define the first flux call in a splitting operation + firstSplitOper = (.not.scalarSolution .or. iStateSplit==1) + + ! initialize subStep + dtSum = 0._rkind ! keep track of the portion of the time step that is completed + nSubsteps = 0 + + ! loop through substeps + ! NOTE: continuous do statement with exit clause + substeps: do + dtSubstep = min(dtSubstep,maxstep) + + ! ----- + ! * populate state vectors... + ! --------------------------- + + ! initialize state vectors + call popStateVec(& + ! input + nState, & ! intent(in): number of desired state variables + enthalpyStateVec, & ! intent(in): flag to use enthalpy as a state variable + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(in): model diagnostic variables for a local HRU + indx_data, & ! intent(in): indices defining model states and layers + ! output + stateVecInit, & ! intent(out): initial model state vector (mixed units) + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (check for errors) + + ! ----- + ! * iterative solution... + ! ----------------------- + ! solve the system of equations for a given state subset + call systemSolv(& + ! input: model control + dtSubstep, & ! intent(in): time step (s) + whole_step, & ! intent(in): entire time step (s) + nState, & ! intent(in): total number of state variables + nLayers, & ! intent(in): total number of layers + firstSubStep, & ! intent(in): flag to denote first sub-step + firstFluxCall, & ! intent(inout): flag to indicate if we are processing the first flux call + firstSplitOper, & ! intent(in): flag to indicate if we are processing the first flux call in a splitting operation + computeVegFlux, & ! intent(in): flag to denote if computing energy flux over vegetation + scalarSolution, & ! intent(in): flag to denote if implementing the scalar solution + computMassBalance, & ! intent(in): flag to compute mass balance + computNrgBalance, & ! intent(in): flag to compute energy balance + ! input/output: data structures + lookup_data, & ! intent(in): lookup tables + type_data, & ! intent(in): type of vegetation and soil + attr_data, & ! intent(in): spatial attributes + forc_data, & ! intent(in): model forcing data + mpar_data, & ! intent(in): model parameters + indx_data, & ! intent(inout): index data + prog_data, & ! intent(inout): model prognostic variables for a local HRU + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + flux_temp, & ! intent(inout): model fluxes for a local HRU + bvar_data, & ! intent(in): model variables for the local basin + model_decisions, & ! intent(in): model decisions + stateVecInit, & ! intent(in): initial state vector + ! output: model control + deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables + ixSaturation, & ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) + stateVecTrial, & ! intent(out): updated state vector + stateVecPrime, & ! intent(out): updated state vector if need the prime space (ida) + fluxVec, & ! intent(out): model flux vector + resSink, & ! intent(out): additional (sink) terms on the RHS of the state equation + resVec, & ! intent(out): residual vector + untappedMelt, & ! intent(out): un-tapped melt energy (J m-3 s-1) + ! output: balances (only computed at this level for ida) + balance, & ! intent(out): balance per state variable + ! output model control + niter, & ! intent(out): number of iterations taken (homegrown solver) + nSteps, & ! intent(out): number of time steps taken in solver + reduceCoupledStep, & ! intent(out): flag to reduce the length of the coupled step + tooMuchMelt, & ! intent(out): flag to denote that ice is insufficient to support melt + err,cmessage) ! intent(out): error code and error message + if(err/=0)then ! (check for errors, but do not fail yet) + message=trim(message)//trim(cmessage) + if(err>0) return + endif + + ! if too much melt or need to reduce length of the coupled step then return + ! NOTE: need to go all the way back to coupled_em and merge snow layers, as all splitting operations need to occur with the same layer geometry + if(tooMuchMelt .or. reduceCoupledStep)then + deallocate(sumLayerCompress) + return + endif - endif ! switch between failure and success - - ! check if we failed the substep - if(failedSubstep)then - - ! check that the substep is greater than the minimum step - if(dtSubstep*dtMultiplier exit, and either (1) try another solution method; or (2) reduce coupled step - failedMinimumStep=.true. - exit subSteps - - else ! step is still OK - dtSubstep = dtSubstep*dtMultiplier - cycle subSteps - endif ! if step is less than the minimum - - endif ! if failed the substep - - ! ----- - ! * update model fluxes... - ! ------------------------ - - ! NOTE: if we get to here then we are accepting the step - - ! NOTE: we get to here if iterations are successful - if(err/=0)then - message=trim(message)//'expect err=0 if updating fluxes' - return - endif - - ! identify the need to check the mass balance - checkMassBalance = .true. ! (.not.scalarSolution) - - ! update prognostic variables - call updateProg(dtSubstep,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappedMelt,stateVecTrial,checkMassBalance, & ! input: model control - mpar_data,indx_data,flux_temp,prog_data,diag_data,deriv_data, & ! input-output: data structures - waterBalanceError,nrgFluxModified,tooMuchMelt,err,cmessage) ! output: flags and error control - if(err/=0)then - message=trim(message)//trim(cmessage) - if(err>0) return - endif - - ! if water balance error then reduce the length of the coupled step - if(waterBalanceError .or. tooMuchMelt)then - message=trim(message)//'water balance error' - reduceCoupledStep=.true. - err=-20; return - endif - - if(globalPrintFlag)& - print*, trim(cmessage)//': dt = ', dtSubstep - - ! recover from errors in prognostic update - if(err<0)then - - ! modify step - err=0 ! error recovery - dtSubstep = dtSubstep/2._rkind - - ! check minimum: fail minimum step if there is an error in the update - if(dtSubstep0) then - ! scalar compression - if(.not.scalarSolution .or. iStateSplit==nSoil)& - sumSoilCompress = sumSoilCompress + diag_data%var(iLookDIAG%scalarSoilCompress)%dat(1) ! total soil compression - ! vector compression - do iSoil=1,nSoil - if(indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat(iSoil)/=integerMissing)& - sumLayerCompress(iSoil) = sumLayerCompress(iSoil) + diag_data%var(iLookDIAG%mLayerCompress)%dat(iSoil) ! soil compression in layers - end do - endif - - ! print progress - if(globalPrintFlag)& - write(*,'(a,1x,3(f13.2,1x))') 'updating: dtSubstep, dtSum, dt = ', dtSubstep, dtSum, dt - - ! increment fluxes - dt_wght = dtSubstep/dt ! (define weight applied to each splitting operation) - do iVar=1,size(flux_meta) - if(count(fluxMask%var(iVar)%dat)>0) then - - !print*, flux_meta(iVar)%varname, fluxMask%var(iVar)%dat - - ! ** no domain splitting - if(count(ixLayerActive/=integerMissing)==nLayers)then - flux_data%var(iVar)%dat(:) = flux_data%var(iVar)%dat(:) + flux_temp%var(iVar)%dat(:)*dt_wght - fluxCount%var(iVar)%dat(:) = fluxCount%var(iVar)%dat(:) + 1 - - ! ** domain splitting - else - ixMin=lbound(flux_data%var(iVar)%dat) - ixMax=ubound(flux_data%var(iVar)%dat) - do ixLayer=ixMin(1),ixMax(1) - if(fluxMask%var(iVar)%dat(ixLayer)) then + ! identify failure + failedSubstep = (err<0) - ! special case of the transpiration sink from soil layers: only computed for the top soil layer - if(iVar==iLookFlux%mLayerTranspire)then - if(ixLayer==1) flux_data%var(iVar)%dat(:) = flux_data%var(iVar)%dat(:) + flux_temp%var(iVar)%dat(:)*dt_wght + ! check + if(globalPrintFlag)then + print*, 'niter, failedSubstep, dtSubstep = ', niter, failedSubstep, dtSubstep + print*, trim(cmessage) + endif - ! standard case - else - flux_data%var(iVar)%dat(ixLayer) = flux_data%var(iVar)%dat(ixLayer) + flux_temp%var(iVar)%dat(ixLayer)*dt_wght - endif - fluxCount%var(iVar)%dat(ixLayer) = fluxCount%var(iVar)%dat(ixLayer) + 1 + ! reduce step based on failure + if(failedSubstep)then + err=0; message='varSubstep/' ! recover from failed convergence + dtMultiplier = 0.5_rkind ! system failure: step halving + else + ! ** implicit Euler: adjust step length based on iteration count + if(nitern_dec)then + dtMultiplier = F_dec + else + dtMultiplier = 1._rkind + endif + endif ! switch between failure and success + + ! check if we failed the substep + if(failedSubstep)then + + ! check that the substep is greater than the minimum step + if(dtSubstep*dtMultiplier exit, and either (1) try another solution method; or (2) reduce coupled step + failedMinimumStep=.true. + exit subSteps + + else ! step is still OK + dtSubstep = dtSubstep*dtMultiplier + cycle subSteps + endif ! if step is less than the minimum + + endif ! if failed the substep + + ! ----- + ! * update model fluxes... + ! ------------------------ + + ! NOTE: if we get to here then we are accepting the step of dtSubstep + if(err/=0)then + message=trim(message)//'expect err=0 if updating fluxes' + return + endif + ! update prognostic variables, update balances, and check them for possible step reduction if homegrown or kinsol solver + call updateProg(dtSubstep,nSnow,nSoil,nLayers,untappedMelt,stateVecTrial,stateVecPrime, & ! input: states + doAdjustTemp,computeVegFlux,computMassBalance,computNrgBalance,computeEnthTemp,enthalpyStateVec,use_lookup,& ! input: model control + model_decisions,lookup_data,mpar_data,indx_data,flux_temp,prog_data,diag_data,deriv_data, & ! input-output: data structures + fluxVec,resVec,balance,waterBalanceError,nrgFluxModified,err,message) ! input-output: balances, flags, and error control + if(err/=0)then + message=trim(message)//trim(cmessage) + if(err>0) return endif - end do - endif ! (domain splitting) - - endif ! (if the flux is desired) - end do ! (loop through fluxes) - - ! ------------------------------------------------------ - ! ------------------------------------------------------ - - ! increment the number of substeps - nSubsteps = nSubsteps+1 - - ! increment the sub-step legth - dtSum = dtSum + dtSubstep - !print*, 'dtSum, dtSubstep, dt, nSubsteps = ', dtSum, dtSubstep, dt, nSubsteps - - ! check that we have completed the sub-step - if(dtSum >= dt-verySmall)then - failedMinimumStep=.false. - exit subSteps - endif - - ! adjust length of the sub-step (make sure that we don't exceed the step) - dtSubstep = min(dt - dtSum, max(dtSubstep*dtMultiplier, dt_min) ) - - end do substeps ! time steps for variable-dependent sub-stepping - - ! save the energy fluxes - flux_data%var(iLookFLUX%scalarCanopyEvaporation)%dat(1) = sumCanopyEvaporation /dt ! canopy evaporation/condensation (kg m-2 s-1) - flux_data%var(iLookFLUX%scalarLatHeatCanopyEvap)%dat(1) = sumLatHeatCanopyEvap /dt ! latent heat flux for evaporation from the canopy to the canopy air space (W m-2) - flux_data%var(iLookFLUX%scalarSenHeatCanopy)%dat(1) = sumSenHeatCanopy /dt ! sensible heat flux from the canopy to the canopy air space (W m-2) - - ! save the soil compression diagnostics - diag_data%var(iLookDIAG%scalarSoilCompress)%dat(1) = sumSoilCompress - do iSoil=1,nSoil - if(indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat(iSoil)/=integerMissing)& - diag_data%var(iLookDIAG%mLayerCompress)%dat(iSoil) = sumLayerCompress(iSoil) - end do - deallocate(sumLayerCompress) - - ! end associate statements - end associate globalVars - - ! update error codes - if(failedMinimumStep)then - err=-20 ! negative = recoverable error - message=trim(message)//'failed minimum step' - endif - - end subroutine varSubstep - - - ! ********************************************************************************************************** - ! private subroutine updateProg: update prognostic variables - ! ********************************************************************************************************** - subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,computeVegFlux,untappedMelt,stateVecTrial,checkMassBalance, & ! input: model control - mpar_data,indx_data,flux_data,prog_data,diag_data,deriv_data, & ! input-output: data structures - waterBalanceError,nrgFluxModified,tooMuchMelt,err,message) ! output: flags and error control - USE getVectorz_module,only:varExtract ! extract variables from the state vector - USE updateVars_module,only:updateVars ! update prognostic variables - implicit none - ! model control - real(rkind) ,intent(in) :: dt ! time step (s) - integer(i4b) ,intent(in) :: nSnow ! number of snow layers - integer(i4b) ,intent(in) :: nSoil ! number of soil layers - integer(i4b) ,intent(in) :: nLayers ! total number of layers - logical(lgt) ,intent(in) :: doAdjustTemp ! flag to indicate if we adjust the temperature - logical(lgt) ,intent(in) :: computeVegFlux ! flag to compute the vegetation flux - real(rkind) ,intent(in) :: untappedMelt(:) ! un-tapped melt energy (J m-3 s-1) - real(rkind) ,intent(in) :: stateVecTrial(:) ! trial state vector (mixed units) - logical(lgt) ,intent(in) :: checkMassBalance ! flag to check the mass balance - ! data structures - type(var_dlength),intent(in) :: mpar_data ! model parameters - type(var_ilength),intent(in) :: indx_data ! indices for a local HRU - type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU - type(var_dlength),intent(inout) :: prog_data ! prognostic variables for a local HRU - type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU - type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables - ! flags and error control - logical(lgt) ,intent(out) :: waterBalanceError ! flag to denote that there is a water balance error - logical(lgt) ,intent(out) :: nrgFluxModified ! flag to denote that the energy fluxes were modified - logical(lgt) ,intent(out) :: tooMuchMelt ! flag to denote that the energy fluxes were modified - integer(i4b) ,intent(out) :: err ! error code - character(*) ,intent(out) :: message ! error message - ! ================================================================================================================== - ! general - integer(i4b) :: iState ! index of model state variable - integer(i4b) :: ixSubset ! index within the state subset - integer(i4b) :: ixFullVector ! index within full state vector - integer(i4b) :: ixControlIndex ! index within a given domain - real(rkind) :: volMelt ! volumetric melt (kg m-3) - real(rkind),parameter :: verySmall=epsilon(1._rkind)*2._rkind ! a very small number (deal with precision issues) - ! mass balance - real(rkind) :: canopyBalance0,canopyBalance1 ! canopy storage at start/end of time step - real(rkind) :: soilBalance0,soilBalance1 ! soil storage at start/end of time step - real(rkind) :: vertFlux ! change in storage due to vertical fluxes - real(rkind) :: tranSink,baseSink,compSink ! change in storage due to sink terms - real(rkind) :: liqError ! water balance error - real(rkind) :: fluxNet ! net water fluxes (kg m-2 s-1) - real(rkind) :: superflousWat ! superflous water used for evaporation (kg m-2 s-1) - real(rkind) :: superflousNrg ! superflous energy that cannot be used for evaporation (W m-2 [J m-2 s-1]) - character(LEN=256) :: cmessage ! error message of downwind routine - ! trial state variables - real(rkind) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) - real(rkind) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) - real(rkind) :: scalarCanopyWatTrial ! trial value for liquid water storage in the canopy (kg m-2) - real(rkind),dimension(nLayers) :: mLayerTempTrial ! trial vector for temperature of layers in the snow and soil domains (K) - real(rkind),dimension(nLayers) :: mLayerVolFracWatTrial ! trial vector for volumetric fraction of total water (-) - real(rkind),dimension(nSoil) :: mLayerMatricHeadTrial ! trial vector for total water matric potential (m) - real(rkind),dimension(nSoil) :: mLayerMatricHeadLiqTrial ! trial vector for liquid water matric potential (m) - real(rkind) :: scalarAquiferStorageTrial ! trial value for storage of water in the aquifer (m) - ! diagnostic variables - real(rkind) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) - real(rkind) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) - real(rkind),dimension(nLayers) :: mLayerVolFracLiqTrial ! trial vector for volumetric fraction of liquid water (-) - real(rkind),dimension(nLayers) :: mLayerVolFracIceTrial ! trial vector for volumetric fraction of ice (-) - ! ------------------------------------------------------------------------------------------------------------------- - - ! ------------------------------------------------------------------------------------------------------------------- - ! point to flux variables in the data structure - associate(& - ! get indices for mass balance - ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in) : [i4b] index of canopy hydrology state variable (mass) - ixSoilOnlyHyd => indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat ,& ! intent(in) : [i4b(:)] index in the state subset for hydrology state variables in the soil domain - ! get indices for the un-tapped melt - ixNrgOnly => indx_data%var(iLookINDEX%ixNrgOnly)%dat ,& ! intent(in) : [i4b(:)] list of indices for all energy states - ixDomainType => indx_data%var(iLookINDEX%ixDomainType)%dat ,& ! intent(in) : [i4b(:)] indices defining the domain of the state (iname_veg, iname_snow, iname_soil) - ixControlVolume => indx_data%var(iLookINDEX%ixControlVolume)%dat ,& ! intent(in) : [i4b(:)] index of the control volume for different domains (veg, snow, soil) - ixMapSubset2Full => indx_data%var(iLookINDEX%ixMapSubset2Full)%dat ,& ! intent(in) : [i4b(:)] [state subset] list of indices of the full state vector in the state subset - ! water fluxes - scalarRainfall => flux_data%var(iLookFLUX%scalarRainfall)%dat(1) ,& ! intent(in) : [dp] rainfall rate (kg m-2 s-1) - scalarThroughfallRain => flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1) ,& ! intent(in) : [dp] rain reaches ground without touching the canopy (kg m-2 s-1) - scalarCanopyEvaporation => flux_data%var(iLookFLUX%scalarCanopyEvaporation)%dat(1) ,& ! intent(in) : [dp] canopy evaporation/condensation (kg m-2 s-1) - scalarCanopyTranspiration => flux_data%var(iLookFLUX%scalarCanopyTranspiration)%dat(1) ,& ! intent(in) : [dp] canopy transpiration (kg m-2 s-1) - scalarCanopyLiqDrainage => flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) ,& ! intent(in) : [dp] drainage liquid water from vegetation canopy (kg m-2 s-1) - iLayerLiqFluxSoil => flux_data%var(iLookFLUX%iLayerLiqFluxSoil)%dat ,& ! intent(in) : [dp(0:)] vertical liquid water flux at soil layer interfaces (-) - mLayerTranspire => flux_data%var(iLookFLUX%mLayerTranspire)%dat ,& ! intent(in) : [dp(:)] transpiration loss from each soil layer (m s-1) - mLayerBaseflow => flux_data%var(iLookFLUX%mLayerBaseflow)%dat ,& ! intent(in) : [dp(:)] baseflow from each soil layer (m s-1) - mLayerCompress => diag_data%var(iLookDIAG%mLayerCompress)%dat ,& ! intent(in) : [dp(:)] change in storage associated with compression of the soil matrix (-) - scalarCanopySublimation => flux_data%var(iLookFLUX%scalarCanopySublimation)%dat(1) ,& ! intent(in) : [dp] sublimation of ice from the vegetation canopy (kg m-2 s-1) - scalarSnowSublimation => flux_data%var(iLookFLUX%scalarSnowSublimation)%dat(1) ,& ! intent(in) : [dp] sublimation of ice from the snow surface (kg m-2 s-1) - ! energy fluxes - scalarLatHeatCanopyEvap => flux_data%var(iLookFLUX%scalarLatHeatCanopyEvap)%dat(1) ,& ! intent(in) : [dp] latent heat flux for evaporation from the canopy to the canopy air space (W m-2) - scalarSenHeatCanopy => flux_data%var(iLookFLUX%scalarSenHeatCanopy)%dat(1) ,& ! intent(in) : [dp] sensible heat flux from the canopy to the canopy air space (W m-2) - ! domain depth - canopyDepth => diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1) ,& ! intent(in) : [dp ] canopy depth (m) - mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat ,& ! intent(in) : [dp(:)] depth of each layer in the snow-soil sub-domain (m) - ! model state variables (vegetation canopy) - scalarCanairTemp => prog_data%var(iLookPROG%scalarCanairTemp)%dat(1) ,& ! intent(inout) : [dp] temperature of the canopy air space (K) - scalarCanopyTemp => prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1) ,& ! intent(inout) : [dp] temperature of the vegetation canopy (K) - scalarCanopyIce => prog_data%var(iLookPROG%scalarCanopyIce)%dat(1) ,& ! intent(inout) : [dp] mass of ice on the vegetation canopy (kg m-2) - scalarCanopyLiq => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1) ,& ! intent(inout) : [dp] mass of liquid water on the vegetation canopy (kg m-2) - scalarCanopyWat => prog_data%var(iLookPROG%scalarCanopyWat)%dat(1) ,& ! intent(inout) : [dp] mass of total water on the vegetation canopy (kg m-2) - ! model state variables (snow and soil domains) - mLayerTemp => prog_data%var(iLookPROG%mLayerTemp)%dat ,& ! intent(inout) : [dp(:)] temperature of each snow/soil layer (K) - mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat ,& ! intent(inout) : [dp(:)] volumetric fraction of ice (-) - mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat ,& ! intent(inout) : [dp(:)] volumetric fraction of liquid water (-) - mLayerVolFracWat => prog_data%var(iLookPROG%mLayerVolFracWat)%dat ,& ! intent(inout) : [dp(:)] volumetric fraction of total water (-) - mLayerMatricHead => prog_data%var(iLookPROG%mLayerMatricHead)%dat ,& ! intent(inout) : [dp(:)] matric head (m) - mLayerMatricHeadLiq => diag_data%var(iLookDIAG%mLayerMatricHeadLiq)%dat ,& ! intent(inout) : [dp(:)] matric potential of liquid water (m) - ! model state variables (aquifer) - scalarAquiferStorage => prog_data%var(iLookPROG%scalarAquiferStorage)%dat(1) ,& ! intent(inout) : [dp(:)] storage of water in the aquifer (m) - ! error tolerance - absConvTol_liquid => mpar_data%var(iLookPARAM%absConvTol_liquid)%dat(1) & ! intent(in) : [dp] absolute convergence tolerance for vol frac liq water (-) - ) ! associating flux variables in the data structure - ! ------------------------------------------------------------------------------------------------------------------- - ! initialize error control - err=0; message='updateProg/' - - ! initialize water balance error - waterBalanceError=.false. - - ! get storage at the start of the step - canopyBalance0 = merge(scalarCanopyWat, realMissing, computeVegFlux) - soilBalance0 = sum( (mLayerVolFracLiq(nSnow+1:nLayers) + mLayerVolFracIce(nSnow+1:nLayers) )*mLayerDepth(nSnow+1:nLayers) ) - - ! ----- - ! * update states... - ! ------------------ - - ! extract states from the state vector - call varExtract(& - ! input - stateVecTrial, & ! intent(in): model state vector (mixed units) - diag_data, & ! intent(in): model diagnostic variables for a local HRU - prog_data, & ! intent(in): model prognostic variables for a local HRU - indx_data, & ! intent(in): indices defining model states and layers - ! output: variables for the vegetation canopy - scalarCanairTempTrial, & ! intent(out): trial value of canopy air temperature (K) - scalarCanopyTempTrial, & ! intent(out): trial value of canopy temperature (K) - scalarCanopyWatTrial, & ! intent(out): trial value of canopy total water (kg m-2) - scalarCanopyLiqTrial, & ! intent(out): trial value of canopy liquid water (kg m-2) - scalarCanopyIceTrial, & ! intent(out): trial value of canopy ice content (kg m-2) - ! output: variables for the snow-soil domain - mLayerTempTrial, & ! intent(out): trial vector of layer temperature (K) - mLayerVolFracWatTrial, & ! intent(out): trial vector of volumetric total water content (-) - mLayerVolFracLiqTrial, & ! intent(out): trial vector of volumetric liquid water content (-) - mLayerVolFracIceTrial, & ! intent(out): trial vector of volumetric ice water content (-) - mLayerMatricHeadTrial, & ! intent(out): trial vector of total water matric potential (m) - mLayerMatricHeadLiqTrial, & ! intent(out): trial vector of liquid water matric potential (m) - ! output: variables for the aquifer - scalarAquiferStorageTrial,& ! intent(out): trial value of storage of water in the aquifer (m) - ! output: error control - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - !print*, 'after varExtract: scalarCanopyTempTrial =', scalarCanopyTempTrial ! trial value of canopy temperature (K) - !print*, 'after varExtract: scalarCanopyWatTrial =', scalarCanopyWatTrial ! trial value of canopy total water (kg m-2) - !print*, 'after varExtract: scalarCanopyLiqTrial =', scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) - !print*, 'after varExtract: scalarCanopyIceTrial =', scalarCanopyIceTrial ! trial value of canopy ice content (kg m-2) + ! if water balance error then reduce the length of the coupled step + if(waterBalanceError)then + message=trim(message)//'water balance error' + reduceCoupledStep=.true. + deallocate(sumLayerCompress) + err=-20; return + endif - ! check if there was too much melt - if(nSnow>0) tooMuchMelt = (mLayerTempTrial(1)>Tfreeze) + if(globalPrintFlag)& + print*, trim(cmessage)//': dt = ', dtSubstep + + ! recover from errors in prognostic update + if(err<0)then + + ! modify step + err=0 ! error recovery + dtSubstep = dtSubstep/2._rkind + + ! check minimum: fail minimum step if there is an error in the update + if(dtSubstep0) then + do concurrent (ixLayer=1:nLayers,ixSnowSoilNrg(ixLayer)/=integerMissing) + if(ixSnowSoilNrg(ixLayer)/=integerMissing) sumBalance(ixSnowSoilNrg(ixLayer)) = sumBalance(ixSnowSoilNrg(ixLayer)) + dtSubstep*balance(ixSnowSoilNrg(ixLayer)) + end do + endif + if(ixVegHyd/=integerMissing) sumBalance(ixVegHyd) = sumBalance(ixVegHyd) + dtSubstep*balance(ixVegHyd) + if(nSnowSoilHyd>0) then + do concurrent (ixLayer=1:nLayers,ixSnowSoilHyd(ixLayer)/=integerMissing) + if(ixSnowSoilHyd(ixLayer)/=integerMissing) sumBalance(ixSnowSoilHyd(ixLayer)) = sumBalance(ixSnowSoilHyd(ixLayer)) + dtSubstep*balance(ixSnowSoilHyd(ixLayer)) + end do + endif + if(ixAqWat/=integerMissing) sumBalance(ixAqWat) = sumBalance(ixAqWat) + dtSubstep*balance(ixAqWat) + + ! get the total energy fluxes (modified in updateProg), have to do differently + if(nrgFluxModified .or. ixVegNrg/=integerMissing)then + sumCanopyEvaporation = sumCanopyEvaporation + dtSubstep*flux_temp%var(iLookFLUX%scalarCanopyEvaporation)%dat(1) ! canopy evaporation/condensation (kg m-2 s-1) + sumLatHeatCanopyEvap = sumLatHeatCanopyEvap + dtSubstep*flux_temp%var(iLookFLUX%scalarLatHeatCanopyEvap)%dat(1) ! latent heat flux for evaporation from the canopy to the canopy air space (W m-2) + sumSenHeatCanopy = sumSenHeatCanopy + dtSubstep*flux_temp%var(iLookFLUX%scalarSenHeatCanopy)%dat(1) ! sensible heat flux from the canopy to the canopy air space (W m-2) + else + sumCanopyEvaporation = sumCanopyEvaporation + dtSubstep*flux_data%var(iLookFLUX%scalarCanopyEvaporation)%dat(1) ! canopy evaporation/condensation (kg m-2 s-1) + sumLatHeatCanopyEvap = sumLatHeatCanopyEvap + dtSubstep*flux_data%var(iLookFLUX%scalarLatHeatCanopyEvap)%dat(1) ! latent heat flux for evaporation from the canopy to the canopy air space (W m-2) + sumSenHeatCanopy = sumSenHeatCanopy + dtSubstep*flux_data%var(iLookFLUX%scalarSenHeatCanopy)%dat(1) ! sensible heat flux from the canopy to the canopy air space (W m-2) + endif ! if energy fluxes were modified + + ! get the total soil compression + if (count(ixSoilOnlyHyd/=integerMissing)>0) then + ! scalar compression + if(.not.scalarSolution .or. iStateSplit==nSoil)& + sumSoilCompress = sumSoilCompress + dtSubstep*diag_data%var(iLookDIAG%scalarSoilCompress)%dat(1) ! total soil compression + ! vector compression + do iSoil=1,nSoil + if(ixSoilOnlyHyd(iSoil)/=integerMissing)& + sumLayerCompress(iSoil) = sumLayerCompress(iSoil) + dtSubstep*diag_data%var(iLookDIAG%mLayerCompress)%dat(iSoil) ! soil compression in layers + end do + endif - ! update diagnostic variables - call updateVars(& - ! input - doAdjustTemp, & ! intent(in): logical flag to adjust temperature to account for the energy used in melt+freeze - mpar_data, & ! intent(in): model parameters for a local HRU - indx_data, & ! intent(in): indices defining model states and layers - prog_data, & ! intent(in): model prognostic variables for a local HRU - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables - ! output: variables for the vegetation canopy - scalarCanopyTempTrial, & ! intent(inout): trial value of canopy temperature (K) - scalarCanopyWatTrial, & ! intent(inout): trial value of canopy total water (kg m-2) - scalarCanopyLiqTrial, & ! intent(inout): trial value of canopy liquid water (kg m-2) - scalarCanopyIceTrial, & ! intent(inout): trial value of canopy ice content (kg m-2) - ! output: variables for the snow-soil domain - mLayerTempTrial, & ! intent(inout): trial vector of layer temperature (K) - mLayerVolFracWatTrial, & ! intent(inout): trial vector of volumetric total water content (-) - mLayerVolFracLiqTrial, & ! intent(inout): trial vector of volumetric liquid water content (-) - mLayerVolFracIceTrial, & ! intent(inout): trial vector of volumetric ice water content (-) - mLayerMatricHeadTrial, & ! intent(inout): trial vector of total water matric potential (m) - mLayerMatricHeadLiqTrial, & ! intent(inout): trial vector of liquid water matric potential (m) - ! output: error control - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - - !print*, 'after updateVars: scalarCanopyTempTrial =', scalarCanopyTempTrial ! trial value of canopy temperature (K) - !print*, 'after updateVars: scalarCanopyWatTrial =', scalarCanopyWatTrial ! trial value of canopy total water (kg m-2) - !print*, 'after updateVars: scalarCanopyLiqTrial =', scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) - !print*, 'after updateVars: scalarCanopyIceTrial =', scalarCanopyIceTrial ! trial value of canopy ice content (kg m-2) - - ! ----- - ! * check mass balance... - ! ----------------------- - - ! NOTE: should not need to do this, since mass balance is checked in the solver - if(checkMassBalance)then - - ! check mass balance for the canopy - if(ixVegHyd/=integerMissing)then - - ! handle cases where fluxes empty the canopy - fluxNet = scalarRainfall + scalarCanopyEvaporation - scalarThroughfallRain - scalarCanopyLiqDrainage - if(-fluxNet*dt > canopyBalance0)then - - ! --> first add water - canopyBalance1 = canopyBalance0 + (scalarRainfall - scalarThroughfallRain)*dt - - ! --> next, remove canopy evaporation -- put the unsatisfied evap into sensible heat - canopyBalance1 = canopyBalance1 + scalarCanopyEvaporation*dt - if(canopyBalance1 < 0._rkind)then - ! * get superfluous water and energy - superflousWat = -canopyBalance1/dt ! kg m-2 s-1 - superflousNrg = superflousWat*LH_vap ! W m-2 (J m-2 s-1) - ! * update fluxes and states - canopyBalance1 = 0._rkind - scalarCanopyEvaporation = scalarCanopyEvaporation + superflousWat - scalarLatHeatCanopyEvap = scalarLatHeatCanopyEvap + superflousNrg - scalarSenHeatCanopy = scalarSenHeatCanopy - superflousNrg - endif + ! print progress + if(globalPrintFlag)& + write(*,'(a,1x,3(f13.2,1x))') 'updating: dtSubstep, dtSum, dt = ', dtSubstep, dtSum, dt + + ! increment fluxes + dt_wght = dtSubstep/dt ! define weight applied to each sub-step + do iVar=1,size(flux_meta) + if(count(fluxMask%var(iVar)%dat)>0) then + + ! ** no domain splitting + if(count(ixLayerActive/=integerMissing)==nLayers)then + flux_mean%var(iVar)%dat(:) = flux_mean%var(iVar)%dat(:) + flux_temp%var(iVar)%dat(:)*dt_wght + fluxCount%var(iVar)%dat(:) = fluxCount%var(iVar)%dat(:) + 1 + + ! ** domain splitting + else + ixMin=lbound(flux_data%var(iVar)%dat) + ixMax=ubound(flux_data%var(iVar)%dat) + do ixLayer=ixMin(1),ixMax(1) + if(fluxMask%var(iVar)%dat(ixLayer)) then + ! special case of the transpiration sink from soil layers: only computed for the top soil layer + if(iVar==iLookFLUX%mLayerTranspire)then + if(ixLayer==1) flux_mean%var(iVar)%dat(:) = flux_mean%var(iVar)%dat(:) + flux_temp%var(iVar)%dat(:)*dt_wght + ! standard case + else + flux_mean%var(iVar)%dat(ixLayer) = flux_mean%var(iVar)%dat(ixLayer) + flux_temp%var(iVar)%dat(ixLayer)*dt_wght + endif + fluxCount%var(iVar)%dat(ixLayer) = fluxCount%var(iVar)%dat(ixLayer) + 1 + endif + end do + endif ! (domain splitting) + + endif ! (if the flux is desired) + end do ! (loop through fluxes) + + ! increment the number of substeps + nSubsteps = nSubsteps + nSteps + + ! increment the sub-step legth + dtSum = dtSum + dtSubstep + + ! check that we have completed the sub-step + if(dtSum >= dt-verySmall)then + failedMinimumStep=.false. + exit subSteps + endif - ! --> next, remove canopy drainage - canopyBalance1 = canopyBalance1 - scalarCanopyLiqDrainage*dt - if(canopyBalance1 < 0._rkind)then - superflousWat = -canopyBalance1/dt ! kg m-2 s-1 - canopyBalance1 = 0._rkind - scalarCanopyLiqDrainage = scalarCanopyLiqDrainage + superflousWat + ! adjust length of the sub-step (make sure that we don't exceed the step) + dtSubstep = min(dt - dtSum, max(dtSubstep*dtMultiplier, dt_min) ) + + end do substeps ! time steps for variable-dependent sub-stepping + ! NOTE: if we get to here then we are accepting then dtSum should dt + + ! save the fluxes as averages + do iVar=1,size(flux_meta) + if(count(fluxMask%var(iVar)%dat)>0) flux_data%var(iVar)%dat(:) = flux_mean%var(iVar)%dat(:) + enddo + + ! save the energy fluxes as averages + flux_data%var(iLookFLUX%scalarCanopyEvaporation)%dat(1) = sumCanopyEvaporation /dt ! canopy evaporation/condensation (kg m-2 s-1) + flux_data%var(iLookFLUX%scalarLatHeatCanopyEvap)%dat(1) = sumLatHeatCanopyEvap /dt ! latent heat flux for evaporation from the canopy to the canopy air space (W m-2) + flux_data%var(iLookFLUX%scalarSenHeatCanopy)%dat(1) = sumSenHeatCanopy /dt ! sensible heat flux from the canopy to the canopy air space (W m-2) + + ! save the soil compression diagnostics as averages + diag_data%var(iLookDIAG%scalarSoilCompress)%dat(1) = sumSoilCompress/dt + do iSoil=1,nSoil + if(ixSoilOnlyHyd(iSoil)/=integerMissing)& + diag_data%var(iLookDIAG%mLayerCompress)%dat(iSoil) = sumLayerCompress(iSoil)/dt + end do + deallocate(sumLayerCompress) + + ! save the balance diagnostics as averages + if(ixCasNrg/=integerMissing) diag_data%var(iLookDIAG%balanceCasNrg)%dat(1) = sumBalance(ixCasNrg)/dt + if(ixVegNrg/=integerMissing) diag_data%var(iLookDIAG%balanceVegNrg)%dat(1) = sumBalance(ixVegNrg)/dt + if(nSnowSoilNrg>0) then + do concurrent (ixLayer=1:nLayers,ixSnowSoilNrg(ixLayer)/=integerMissing) + diag_data%var(iLookDIAG%balanceLayerNrg)%dat(ixLayer) = sumBalance(ixSnowSoilNrg(ixLayer))/dt + end do endif - - ! update the trial state - scalarCanopyWatTrial = canopyBalance1 - - ! set the modification flag - nrgFluxModified = .true. - - else - canopyBalance1 = canopyBalance0 + fluxNet*dt + if(ixVegHyd/=integerMissing) diag_data%var(iLookDIAG%balanceVegMass)%dat(1) = sumBalance(ixVegHyd)/dt + if(nSnowSoilHyd>0) then + do concurrent (ixLayer=1:nLayers,ixSnowSoilHyd(ixLayer)/=integerMissing) + diag_data%var(iLookDIAG%balanceLayerMass)%dat(ixLayer) = sumBalance(ixSnowSoilHyd(ixLayer))/dt + end do + endif + if(ixAqWat/=integerMissing) diag_data%var(iLookDIAG%balanceAqMass)%dat(1) = sumBalance(ixAqWat)/dt + + ! update error codes + if (failedMinimumStep) then + err=-20 ! negative = recoverable error + message=trim(message)//'failed minimum step' + end if + ! end associate statements + end associate globalVars +end subroutine varSubstep + + +! ********************************************************************************************************** +! private subroutine updateProg: update prognostic variables +! ********************************************************************************************************** +subroutine updateProg(dt,nSnow,nSoil,nLayers,untappedMelt,stateVecTrial,stateVecPrime, & ! input: states + doAdjustTemp,computeVegFlux,computMassBalance,computNrgBalance,computeEnthTemp,enthalpyStateVec,use_lookup,& ! input: model control + model_decisions,lookup_data,mpar_data,indx_data,flux_data,prog_data,diag_data,deriv_data, & ! input-output: data structures + fluxVec,resVec,balance,waterBalanceError,nrgFluxModified,err,message) ! input-output: balances, flags, and error control +USE getVectorz_module,only:varExtract ! extract variables from the state vector +#ifdef SUNDIALS_ACTIVE + USE updateVarsWithPrime_module,only:updateVarsWithPrime ! update prognostic variables +#endif + USE updateVars_module,only:updateVars ! update prognostic variables + USE enthalpyTemp_module,only:enthTemp_or_enthalpy ! add phase change terms to delta temperature component of enthalpy + implicit none + ! model control + real(rkind) ,intent(in) :: dt ! time step (s) + integer(i4b) ,intent(in) :: nSnow ! number of snow layers + integer(i4b) ,intent(in) :: nSoil ! number of soil layers + integer(i4b) ,intent(in) :: nLayers ! total number of layers + logical(lgt) ,intent(in) :: doAdjustTemp ! flag to indicate if we adjust the temperature + logical(lgt) ,intent(in) :: computeVegFlux ! flag to compute the vegetation flux + real(rkind) ,intent(in) :: untappedMelt(:) ! un-tapped melt energy (J m-3 s-1) + real(rkind) ,intent(in) :: stateVecTrial(:) ! trial state vector (mixed units) + real(rkind) ,intent(in) :: stateVecPrime(:) ! trial state vector (mixed units) + logical(lgt) ,intent(in) :: computMassBalance ! flag to check the mass balance + logical(lgt) ,intent(in) :: computNrgBalance ! flag to check the energy balance + logical(lgt) ,intent(in) :: computeEnthTemp ! flag to compute enthalpy + logical(lgt) ,intent(in) :: enthalpyStateVec ! flag if enthalpy is a state variable (ida) + logical(lgt) ,intent(in) :: use_lookup ! flag to use the lookup table for soil enthalpy, otherwise use analytical solution + ! data structures + type(model_options),intent(in) :: model_decisions(:) ! model decisions + type(zLookup),intent(in) :: lookup_data ! lookup tables + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_ilength),intent(in) :: indx_data ! indices for a local HRU + type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(inout) :: prog_data ! prognostic variables for a local HRU + type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + ! balances, flags, and error control + real(rkind) ,intent(in) :: fluxVec(:) ! flux vector (mixed units) + real(qp) ,intent(in) :: resVec(:) ! NOTE: qp ! residual vector + real(rkind) ,intent(inout) :: balance(:) ! balance of energy per domain per second + logical(lgt) ,intent(out) :: waterBalanceError ! flag to denote that there is a water balance error + logical(lgt) ,intent(out) :: nrgFluxModified ! flag to denote that the energy fluxes were modified + integer(i4b) ,intent(out) :: err ! error code + character(*) ,intent(out) :: message ! error message + ! ================================================================================================================== + ! general + integer(i4b) :: i ! indices + integer(i4b) :: iState ! index of model state variable + integer(i4b) :: ixSubset ! index within the state subset + integer(i4b) :: ixFullVector ! index within full state vector + integer(i4b) :: ixControlIndex ! index within a given domain + real(rkind) :: volMelt ! volumetric melt (kg m-3) + real(rkind),parameter :: eps=epsilon(1._rkind) ! a very small number (deal with precision issues) + real(rkind) :: eps_veg ! precision needs to vary based on set canopy water tolerance for IDA + real(rkind) :: eps_snow ! precision needs to vary based on set snow water tolerance for IDA + ! mass balance + real(rkind) :: canopyBalance0,canopyBalance1 ! canopy storage at start/end of time step + real(rkind) :: soilBalance0,soilBalance1 ! soil storage at start/end of time step + real(rkind) :: vertFlux ! change in storage due to vertical fluxes + real(rkind) :: tranSink,baseSink,compSink ! change in storage due to sink terms + real(rkind) :: liqError ! water balance error + real(rkind) :: fluxNet ! net water fluxes (kg m-2 s-1) + real(rkind) :: superflousWat ! superflous water used for evaporation (kg m-2 s-1) + real(rkind) :: superflousNrg ! superflous energy that cannot be used for evaporation (W m-2 [J m-2 s-1]) + character(LEN=256) :: cmessage ! error message of downwind routine + logical(lgt),parameter :: printFlag=.false. ! flag to print water balance error information + ! trial state variables + real(rkind) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) + real(rkind) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) + real(rkind) :: scalarCanopyWatTrial ! trial value for liquid water storage in the canopy (kg m-2) + real(rkind),dimension(nLayers) :: mLayerTempTrial ! trial vector of temperature of layers in the snow and soil domains (K) + real(rkind),dimension(nLayers) :: mLayerVolFracWatTrial ! trial vector of volumetric fraction of total water (-) + real(rkind),dimension(nSoil) :: mLayerMatricHeadTrial ! trial vector of total water matric potential (m) + real(rkind),dimension(nSoil) :: mLayerMatricHeadLiqTrial ! trial vector of liquid water matric potential (m) + real(rkind) :: scalarAquiferStorageTrial ! trial value for storage of water in the aquifer (m) + real(rkind) :: scalarCanairEnthalpyTrial ! trial value for enthalpy of the canopy air space (J m-3) + real(rkind) :: scalarCanopyEnthTempTrial ! trial value for temperature component of enthalpy of the vegetation canopy (J m-3) + real(rkind),dimension(nLayers) :: mLayerEnthTempTrial ! trial vector of temperature component of enthalpy of snow + soil (J m-3) + real(rkind) :: scalarCanopyEnthalpyTrial ! trial value for enthalpy of the vegetation canopy (J m-3) + real(rkind),dimension(nLayers) :: mLayerEnthalpyTrial ! trial vector of enthalpy of each snow and soil layer (J m-3) + ! diagnostic variables + real(rkind) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) + real(rkind) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) + real(rkind),dimension(nLayers) :: mLayerVolFracLiqTrial ! trial vector of volumetric fraction of liquid water (-) + real(rkind),dimension(nLayers) :: mLayerVolFracIceTrial ! trial vector of volumetric fraction of ice (-) + ! prime state variables + real(rkind) :: scalarCanairTempPrime ! trial value for temperature of the canopy air space (K) + real(rkind) :: scalarCanopyTempPrime ! trial value for temperature of the vegetation canopy (K) + real(rkind) :: scalarCanopyWatPrime ! trial value for liquid water storage in the canopy (kg m-2) + real(rkind),dimension(nLayers) :: mLayerTempPrime ! trial vector of temperature of layers in the snow and soil domains (K) + real(rkind),dimension(nLayers) :: mLayerVolFracWatPrime ! trial vector of volumetric fraction of total water (-) + real(rkind),dimension(nSoil) :: mLayerMatricHeadPrime ! trial vector of total water matric potential (m) + real(rkind),dimension(nSoil) :: mLayerMatricHeadLiqPrime ! trial vector of liquid water matric potential (m) + real(rkind) :: scalarAquiferStoragePrime ! trial value for storage of water in the aquifer (m) + ! diagnostic prime or delta variables + real(rkind) :: scalarCanopyLiqPrime ! trial value for mass of liquid water on the vegetation canopy (kg m-2) + real(rkind) :: scalarCanopyIcePrime ! trial value for mass of ice on the vegetation canopy (kg m-2) + real(rkind) :: scalarCanopyIceDelta ! delta value for mass of ice on the vegetation canopy (kg m-2) + real(rkind) :: scalarCanopyHDelta ! delta value for enthalpy of the vegetation canopy (J m-3) + real(rkind),dimension(nLayers) :: mLayerVolFracLiqPrime ! trial vector of volumetric fraction of liquid water (-) + real(rkind),dimension(nLayers) :: mLayerVolFracIcePrime ! trial vector of volumetric fraction of ice (-) + real(rkind),dimension(nLayers) :: mLayerVolFracIceDelta ! delta vector volumetric fraction of ice of snow + soil (-) + real(rkind),dimension(nLayers) :: mLayerHDelta ! delta vector of enthalpy of snow+soil (J m-3) + ! dummy state variables + real(rkind) :: scalarCanairNrgTrial ! trial value for energy of the canopy air space + real(rkind) :: scalarCanopyNrgTrial ! trial value for energy of the vegetation canopy + real(rkind),dimension(nLayers) :: mLayerNrgTrial ! trial vector of energy of each snow and soil layer + real(rkind) :: scalarCanairNrgPrime ! prime value for energy of the canopy air space + real(rkind) :: scalarCanopyNrgPrime ! prime value for energy of the vegetation canopy + real(rkind),dimension(nLayers) :: mLayerNrgPrime ! prime vector of energy of each snow and soil layer + ! ------------------------------------------------------------------------------------------------------------------- + ! ------------------------------------------------------------------------------------------------------------------- + ! point to flux variables in the data structure + associate(& + ! model decisions + ixNumericalMethod => model_decisions(iLookDECISIONS%num_method)%iDecision ,& ! intent(in): [i4b] choice of numerical solver + ! get indices for balances + ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1) ,& ! intent(in) : [i4b] index of canopy air space energy state variable + ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in) : [i4b] index of canopy energy state variable + ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in) : [i4b] index of canopy hydrology state variable (mass) + ixTopNrg => indx_data%var(iLookINDEX%ixTopNrg)%dat(1) ,& ! intent(in) : [i4b] index of upper-most energy state in the snow+soil subdomain + ixTopHyd => indx_data%var(iLookINDEX%ixTopHyd)%dat(1) ,& ! intent(in) : [i4b] index of upper-most hydrology state in the snow+soil subdomain + ixAqWat => indx_data%var(iLookINDEX%ixAqWat)%dat(1) ,& ! intent(in) : [i4b] index of water storage in the aquifer + ixSoilOnlyHyd => indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat ,& ! intent(in) : [i4b(:)] index in the state subset for hydrology state variables in the soil domain + ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in) : [i4b(:)] index in the state subset for energy state variables in the snow+soil domain + ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in) : [i4b(:)] index in the state subset for hydrology state variables in the snow+soil domain + nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg)%dat(1) ,& ! intent(in) : [i4b] number of energy state variables in the snow+soil domain + nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd)%dat(1) ,& ! intent(in) : [i4b] number of hydrology state variables in the snow+soil domain + ! get indices for the un-tapped melt + ixNrgOnly => indx_data%var(iLookINDEX%ixNrgOnly)%dat ,& ! intent(in) : [i4b(:)] list of indices for all energy states + ixDomainType => indx_data%var(iLookINDEX%ixDomainType)%dat ,& ! intent(in) : [i4b(:)] indices defining the domain of the state (iname_veg, iname_snow, iname_soil) + ixControlVolume => indx_data%var(iLookINDEX%ixControlVolume)%dat ,& ! intent(in) : [i4b(:)] index of the control volume for different domains (veg, snow, soil) + ixMapSubset2Full => indx_data%var(iLookINDEX%ixMapSubset2Full)%dat ,& ! intent(in) : [i4b(:)] [state subset] list of indices of the full state vector in the state subset + ! water fluxes + scalarRainfall => flux_data%var(iLookFLUX%scalarRainfall)%dat(1) ,& ! intent(in) : [dp] rainfall rate (kg m-2 s-1) + scalarThroughfallRain => flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1) ,& ! intent(in) : [dp] rain reaches ground without touching the canopy (kg m-2 s-1) + scalarCanopyEvaporation => flux_data%var(iLookFLUX%scalarCanopyEvaporation)%dat(1) ,& ! intent(in) : [dp] canopy evaporation/condensation (kg m-2 s-1) + scalarCanopyLiqDrainage => flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) ,& ! intent(in) : [dp] drainage liquid water from vegetation canopy (kg m-2 s-1) + iLayerLiqFluxSoil => flux_data%var(iLookFLUX%iLayerLiqFluxSoil)%dat ,& ! intent(in) : [dp(0:)] vertical liquid water flux at soil layer interfaces (-) + iLayerNrgFlux => flux_data%var(iLookFLUX%iLayerNrgFlux)%dat ,& ! intent(in) : + mLayerNrgFlux => flux_data%var(iLookFLUX%mLayerNrgFlux)%dat ,& ! intent(out) : [dp] net energy flux for each layer within the snow+soil domain (J m-3 s-1) + mLayerTranspire => flux_data%var(iLookFLUX%mLayerTranspire)%dat ,& ! intent(in) : [dp(:)] transpiration loss from each soil layer (m s-1) + mLayerBaseflow => flux_data%var(iLookFLUX%mLayerBaseflow)%dat ,& ! intent(in) : [dp(:)] baseflow from each soil layer (m s-1) + mLayerCompress => diag_data%var(iLookDIAG%mLayerCompress)%dat ,& ! intent(in) : [dp(:)] change in storage associated with compression of the soil matrix (-) + ! energy fluxes + scalarLatHeatCanopyEvap => flux_data%var(iLookFLUX%scalarLatHeatCanopyEvap)%dat(1) ,& ! intent(in) : [dp] latent heat flux for evaporation from the canopy to the canopy air space (W m-2) + scalarSenHeatCanopy => flux_data%var(iLookFLUX%scalarSenHeatCanopy)%dat(1) ,& ! intent(in) : [dp] sensible heat flux from the canopy to the canopy air space (W m-2) + ! domain depth + canopyDepth => diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1) ,& ! intent(in) : [dp ] canopy depth (m) + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat ,& ! intent(in) : [dp(:)] depth of each layer in the snow-soil sub-domain (m) + ! model state variables (vegetation canopy) + scalarCanairTemp => prog_data%var(iLookPROG%scalarCanairTemp)%dat(1) ,& ! intent(inout): [dp] temperature of the canopy air space (K) + scalarCanopyTemp => prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1) ,& ! intent(inout): [dp] temperature of the vegetation canopy (K) + scalarCanopyIce => prog_data%var(iLookPROG%scalarCanopyIce)%dat(1) ,& ! intent(inout): [dp] mass of ice on the vegetation canopy (kg m-2) + scalarCanopyLiq => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1) ,& ! intent(inout): [dp] mass of liquid water on the vegetation canopy (kg m-2) + scalarCanopyWat => prog_data%var(iLookPROG%scalarCanopyWat)%dat(1) ,& ! intent(inout): [dp] mass of total water on the vegetation canopy (kg m-2) + ! model state variables (snow and soil domains) + mLayerTemp => prog_data%var(iLookPROG%mLayerTemp)%dat ,& ! intent(inout): [dp(:)] temperature of each snow/soil layer (K) + mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat ,& ! intent(inout): [dp(:)] volumetric fraction of ice (-) + mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat ,& ! intent(inout): [dp(:)] volumetric fraction of liquid water (-) + mLayerVolFracWat => prog_data%var(iLookPROG%mLayerVolFracWat)%dat ,& ! intent(inout): [dp(:)] volumetric fraction of total water (-) + mLayerMatricHead => prog_data%var(iLookPROG%mLayerMatricHead)%dat ,& ! intent(inout): [dp(:)] matric head (m) + mLayerMatricHeadLiq => diag_data%var(iLookDIAG%mLayerMatricHeadLiq)%dat ,& ! intent(inout): [dp(:)] matric potential of liquid water (m) + ! enthalpy + scalarCanairEnthalpy => prog_data%var(iLookPROG%scalarCanairEnthalpy)%dat(1) ,& ! intent(inout): [dp] enthalpy of the canopy air space (J m-3) + scalarCanopyEnthalpy => prog_data%var(iLookPROG%scalarCanopyEnthalpy)%dat(1) ,& ! intent(inout): [dp] enthalpy of the vegetation canopy (J m-3) + scalarCanopyEnthTemp => diag_data%var(iLookDIAG%scalarCanopyEnthTemp)%dat(1) ,& ! intent(inout): [dp] temperature component of enthalpy of the vegetation canopy (J m-3) + mLayerEnthalpy => prog_data%var(iLookPROG%mLayerEnthalpy)%dat ,& ! intent(inout): [dp(:)] enthalpy of the snow+soil layers (J m-3) + mLayerEnthTemp => diag_data%var(iLookDIAG%mLayerEnthTemp)%dat ,& ! intent(inout): [dp(:)] temperature component of enthalpy of the snow+soil layers (J m-3) + ! model state variables (aquifer) + scalarAquiferStorage => prog_data%var(iLookPROG%scalarAquiferStorage)%dat(1) ,& ! intent(inout): [dp(:)] storage of water in the aquifer (m) + ! error tolerance + absConvTol_liquid => mpar_data%var(iLookPARAM%absConvTol_liquid)%dat(1) & ! intent(in) : [dp] absolute convergence tolerance for vol frac liq water (-) + ) ! associating flux variables in the data structure + ! ------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message='updateProg/' + + ! initialize flags for water balance error and energy flux modification + waterBalanceError=.false. nrgFluxModified = .false. - endif ! cases where fluxes empty the canopy - - ! check the mass balance - fluxNet = scalarRainfall + scalarCanopyEvaporation - scalarThroughfallRain - scalarCanopyLiqDrainage - liqError = (canopyBalance0 + fluxNet*dt) - scalarCanopyWatTrial - !write(*,'(a,1x,f20.10)') 'dt = ', dt - !write(*,'(a,1x,f20.10)') 'scalarCanopyWatTrial = ', scalarCanopyWatTrial - !write(*,'(a,1x,f20.10)') 'canopyBalance0 = ', canopyBalance0 - !write(*,'(a,1x,f20.10)') 'canopyBalance1 = ', canopyBalance1 - !write(*,'(a,1x,f20.10)') 'scalarRainfall*dt = ', scalarRainfall*dt - !write(*,'(a,1x,f20.10)') 'scalarCanopyLiqDrainage*dt = ', scalarCanopyLiqDrainage*dt - !write(*,'(a,1x,f20.10)') 'scalarCanopyEvaporation*dt = ', scalarCanopyEvaporation*dt - !write(*,'(a,1x,f20.10)') 'scalarThroughfallRain*dt = ', scalarThroughfallRain*dt - !write(*,'(a,1x,f20.10)') 'liqError = ', liqError - if(abs(liqError) > absConvTol_liquid*10._rkind)then ! *10 because of precision issues - waterBalanceError = .true. - return - endif ! if there is a water balance error - endif ! if veg canopy - - ! check mass balance for soil - ! NOTE: fatal errors, though possible to recover using negative error codes - if(count(ixSoilOnlyHyd/=integerMissing)==nSoil)then - soilBalance1 = sum( (mLayerVolFracLiqTrial(nSnow+1:nLayers) + mLayerVolFracIceTrial(nSnow+1:nLayers) )*mLayerDepth(nSnow+1:nLayers) ) - vertFlux = -(iLayerLiqFluxSoil(nSoil) - iLayerLiqFluxSoil(0))*dt ! m s-1 --> m - tranSink = sum(mLayerTranspire)*dt ! m s-1 --> m - baseSink = sum(mLayerBaseflow)*dt ! m s-1 --> m - compSink = sum(mLayerCompress(1:nSoil) * mLayerDepth(nSnow+1:nLayers) ) ! dimensionless --> m - liqError = soilBalance1 - (soilBalance0 + vertFlux + tranSink - baseSink - compSink) - if(abs(liqError) > absConvTol_liquid*10._rkind)then ! *10 because of precision issues - !write(*,'(a,1x,f20.10)') 'dt = ', dt - !write(*,'(a,1x,f20.10)') 'soilBalance0 = ', soilBalance0 - !write(*,'(a,1x,f20.10)') 'soilBalance1 = ', soilBalance1 - !write(*,'(a,1x,f20.10)') 'vertFlux = ', vertFlux - !write(*,'(a,1x,f20.10)') 'tranSink = ', tranSink - !write(*,'(a,1x,f20.10)') 'baseSink = ', baseSink - !write(*,'(a,1x,f20.10)') 'compSink = ', compSink - !write(*,'(a,1x,f20.10)') 'liqError = ', liqError - !write(*,'(a,1x,f20.10)') 'absConvTol_liquid = ', absConvTol_liquid - waterBalanceError = .true. - return - endif ! if there is a water balance error - endif ! if hydrology states exist in the soil domain - - endif ! if checking the mass balance - - ! ----- - ! * remove untapped melt energy... - ! -------------------------------- - - ! only work with energy state variables - if(size(ixNrgOnly)>0)then ! energy state variables exist - - ! loop through energy state variables - do iState=1,size(ixNrgOnly) - - ! get index of the control volume within the domain - ixSubset = ixNrgOnly(iState) ! index within the state subset - ixFullVector = ixMapSubset2Full(ixSubset) ! index within full state vector - ixControlIndex = ixControlVolume(ixFullVector) ! index within a given domain - - ! compute volumetric melt (kg m-3) - volMelt = dt*untappedMelt(ixSubset)/LH_fus ! (kg m-3) - - ! update ice content - select case( ixDomainType(ixFullVector) ) - case(iname_cas); cycle ! do nothing, since there is no snow stored in the canopy air space - case(iname_veg); scalarCanopyIceTrial = scalarCanopyIceTrial - volMelt*canopyDepth ! (kg m-2) - case(iname_snow); mLayerVolFracIceTrial(ixControlIndex) = mLayerVolFracIceTrial(ixControlIndex) - volMelt/iden_ice ! (-) - case(iname_soil); mLayerVolFracIceTrial(ixControlIndex+nSnow) = mLayerVolFracIceTrial(ixControlIndex+nSnow) - volMelt/iden_water ! (-) - case default; err=20; message=trim(message)//'unable to identify domain type [remove untapped melt energy]'; return - end select - - ! update liquid water content - select case( ixDomainType(ixFullVector) ) - case(iname_cas); cycle ! do nothing, since there is no snow stored in the canopy air space - case(iname_veg); scalarCanopyLiqTrial = scalarCanopyLiqTrial + volMelt*canopyDepth ! (kg m-2) - case(iname_snow); mLayerVolFracLiqTrial(ixControlIndex) = mLayerVolFracLiqTrial(ixControlIndex) + volMelt/iden_water ! (-) - case(iname_soil); mLayerVolFracLiqTrial(ixControlIndex+nSnow) = mLayerVolFracLiqTrial(ixControlIndex+nSnow) + volMelt/iden_water ! (-) - case default; err=20; message=trim(message)//'unable to identify domain type [remove untapped melt energy]'; return - end select - - end do ! looping through energy variables - - ! ======================================================================================================== - - ! *** ice - - ! --> check if we removed too much water - if(scalarCanopyIceTrial < 0._rkind .or. any(mLayerVolFracIceTrial < 0._rkind) )then - - ! ** - ! canopy within numerical precision - if(scalarCanopyIceTrial < 0._rkind)then - - if(scalarCanopyIceTrial > -verySmall)then - scalarCanopyLiqTrial = scalarCanopyLiqTrial - scalarCanopyIceTrial - scalarCanopyIceTrial = 0._rkind - - ! encountered an inconsistency: spit the dummy - else - print*, 'dt = ', dt - print*, 'untappedMelt = ', untappedMelt - print*, 'untappedMelt*dt = ', untappedMelt*dt - print*, 'scalarCanopyiceTrial = ', scalarCanopyIceTrial - message=trim(message)//'melted more than the available water' - err=20; return - endif ! (inconsistency) - - endif ! if checking the canopy - - ! ** - ! snow+soil within numerical precision - do iState=1,size(mLayerVolFracIceTrial) - - ! snow layer within numerical precision - if(mLayerVolFracIceTrial(iState) < 0._rkind)then - - if(mLayerVolFracIceTrial(iState) > -verySmall)then - mLayerVolFracLiqTrial(iState) = mLayerVolFracLiqTrial(iState) - mLayerVolFracIceTrial(iState) - mLayerVolFracIceTrial(iState) = 0._rkind - - ! encountered an inconsistency: spit the dummy - else - print*, 'dt = ', dt - print*, 'untappedMelt = ', untappedMelt - print*, 'untappedMelt*dt = ', untappedMelt*dt - print*, 'mLayerVolFracIceTrial = ', mLayerVolFracIceTrial - message=trim(message)//'melted more than the available water' - err=20; return - endif ! (inconsistency) - - endif ! if checking a snow layer - - end do ! (looping through state variables) - - endif ! (if we removed too much water) - ! ======================================================================================================== - - ! *** liquid water + ! get storage at the start of the step + canopyBalance0 = merge(scalarCanopyLiq + scalarCanopyIce, realMissing, computeVegFlux) + soilBalance0 = sum( (mLayerVolFracLiq(nSnow+1:nLayers) + mLayerVolFracIce(nSnow+1:nLayers) )*mLayerDepth(nSnow+1:nLayers) ) + + ! ----- + ! * update states... + ! ------------------ + + ! initialize to state variable from the last update + scalarCanairTempTrial = scalarCanairTemp + scalarCanairEnthalpyTrial = scalarCanairEnthalpy + scalarCanopyTempTrial = scalarCanopyTemp + scalarCanopyEnthalpyTrial = scalarCanopyEnthalpy + scalarCanopyEnthTempTrial = scalarCanopyEnthTemp + scalarCanopyWatTrial = scalarCanopyWat + scalarCanopyLiqTrial = scalarCanopyLiq + scalarCanopyIceTrial = scalarCanopyIce + mLayerTempTrial = mLayerTemp + mLayerEnthalpyTrial = mLayerEnthalpy + mLayerEnthTempTrial = mLayerEnthTemp + mLayerVolFracWatTrial = mLayerVolFracWat + mLayerVolFracLiqTrial = mLayerVolFracLiq + mLayerVolFracIceTrial = mLayerVolFracIce + mLayerMatricHeadTrial = mLayerMatricHead + mLayerMatricHeadLiqTrial = mLayerMatricHeadLiq + scalarAquiferStorageTrial = scalarAquiferStorage + + if(enthalpyStateVec)then ! use state variable as enthalpy + scalarCanairNrgTrial = scalarCanairEnthalpy + scalarCanopyNrgTrial = realMissing ! currently not splitting in ida so no need to update + mLayerNrgTrial = realMissing ! currently not splitting in ida so no need to update + else + scalarCanairNrgTrial = scalarCanairTemp + scalarCanopyNrgTrial = scalarCanopyTemp + mLayerNrgTrial = mLayerTemp + endif + + ! extract states from the state vector + call varExtract(& + ! input + stateVecTrial, & ! intent(in): model state vector (mixed units) + indx_data, & ! intent(in): indices defining model states and layers + ! output: variables for the vegetation canopy + scalarCanairNrgTrial, & ! intent(inout): trial value of energy of the canopy air space, temperature (K) or enthalpy (J m-3) + scalarCanopyNrgTrial, & ! intent(inout): trial value of energy of the vegetation canopy, temperature (K) or enthalpy (J m-3) + scalarCanopyWatTrial, & ! intent(inout): trial value of canopy total water (kg m-2) + scalarCanopyLiqTrial, & ! intent(inout): trial value of canopy liquid water (kg m-2) + ! output: variables for the snow-soil domain + mLayerNrgTrial, & ! intent(inout): trial vector of energy, temperature (K) or enthalpy (J m-3) + mLayerVolFracWatTrial, & ! intent(inout): trial vector of volumetric total water content (-) + mLayerVolFracLiqTrial, & ! intent(inout): trial vector of volumetric liquid water content (-) + mLayerMatricHeadTrial, & ! intent(inout): trial vector of total water matric potential (m) + mLayerMatricHeadLiqTrial, & ! intent(inout): trial vector of liquid water matric potential (m) + ! output: variables for the aquifer + scalarAquiferStorageTrial, & ! intent(inout): trial value of storage of water in the aquifer (m) + ! output: error control + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) + + if(enthalpyStateVec)then ! use state variable as enthalpy + scalarCanairEnthalpyTrial = scalarCanairNrgTrial + scalarCanopyEnthalpyTrial = scalarCanopyNrgTrial + mLayerEnthalpyTrial = mLayerNrgTrial + else + scalarCanairTempTrial = scalarCanairNrgTrial + scalarCanopyTempTrial = scalarCanopyNrgTrial + mLayerTempTrial = mLayerNrgTrial + endif - ! --> check if we removed too much water - if(scalarCanopyLiqTrial < 0._rkind .or. any(mLayerVolFracLiqTrial < 0._rkind) )then + ! Placeholder: if we decide to use splitting, we need to pass all the previous values of the state variables + scalarCanairNrgPrime = realMissing + scalarCanopyNrgPrime = realMissing + scalarCanopyWatPrime = realMissing + scalarCanopyLiqPrime = realMissing + scalarCanopyIcePrime = realMissing + mLayerNrgPrime = realMissing + mLayerVolFracWatPrime = realMissing + mLayerVolFracLiqPrime = realMissing + mLayerVolFracIcePrime = realMissing + mLayerMatricHeadPrime = realMissing + mLayerMatricHeadLiqPrime = realMissing + scalarAquiferStoragePrime = realMissing + + ! set the default precision + eps_veg = eps*2._rkind + eps_snow = eps*2._rkind + + select case(ixNumericalMethod) + case(ida) +#ifdef SUNDIALS_ACTIVE + ! IDA precision needs to vary based on set tolerances + eps_veg = mpar_data%var(iLookPARAM%absTolWatVeg)%dat(1)*2._rkind + eps_snow = mpar_data%var(iLookPARAM%absTolWatSnow)%dat(1)*2._rkind + + ! extract the derivatives from the state vector + call varExtract(& + ! input + stateVecPrime, & ! intent(in): derivative of model state vector (mixed units) + indx_data, & ! intent(in): indices defining model states and layers + ! output: variables for the vegetation canopy + scalarCanairNrgPrime, & ! intent(inout): derivative of energy of the canopy air space, temperature (K s-1) or enthalpy (W m-3) + scalarCanopyNrgPrime, & ! intent(inout): derivative of energy of the vegetation canopy, temperature (K s-1) or enthalpy (W m-3) + scalarCanopyWatPrime, & ! intent(inout): derivative of canopy total water (kg m-2 s-1) + scalarCanopyLiqPrime, & ! intent(inout): derivative of canopy liquid water (kg m-2 s-1) + ! output: variables for the snow-soil domain + mLayerNrgPrime, & ! intent(inout): derivative of energy of each snow and soil layer, temperature (K s-1) or enthalpy (W m-3) + mLayerVolFracWatPrime, & ! intent(inout): derivative of volumetric total water content (-) + mLayerVolFracLiqPrime, & ! intent(inout): derivative of volumetric liquid water content (-) + mLayerMatricHeadPrime, & ! intent(inout): derivative of total water matric potential (m) + mLayerMatricHeadLiqPrime, & ! intent(inout): derivative of liquid water matric potential (m) + ! output: variables for the aquifer + scalarAquiferStoragePrime, & ! intent(inout): derivative of storage of water in the aquifer (m) + ! output: error control + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) + + if(enthalpyStateVec)then ! use state variable as enthalpy, need to compute temperature + ! do not use these variables + scalarCanairTempPrime = realMissing + scalarCanopyTempPrime = realMissing + mLayerTempPrime = realMissing + else ! use state variable as temperature + scalarCanairTempPrime = scalarCanairNrgPrime + scalarCanopyTempPrime = scalarCanopyNrgPrime + mLayerTempPrime = mLayerNrgPrime + endif !(choice of how conservation of energy is implemented) + + ! update diagnostic variables + call updateVarsWithPrime(& + ! input + enthalpyStateVec, & ! intent(in): flag if enthalpy is used as state variable + use_lookup, & ! intent(in): flag to use the lookup table for soil enthalpy + .false., & ! intent(in): logical flag if computing for Jacobian update + doAdjustTemp, & ! intent(in): logical flag to adjust temperature to account for the energy used in melt+freeze + mpar_data, & ! intent(in): model parameters for a local HRU + indx_data, & ! intent(in): indices defining model states and layers + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables + lookup_data, & ! intent(in): lookup table data structure + ! input: enthalpy state variables + scalarCanairEnthalpyTrial, & ! intent(in): trial value for enthalpy of the canopy air space (J m-3) + scalarCanopyEnthalpyTrial, & ! intent(in): trial value for enthalpy of the vegetation canopy (J m-3) + mLayerEnthalpyTrial, & ! intent(in): trial vector of enthalpy of each snow+soil layer (J m-3) + ! output: variables for the vegetation canopy + scalarCanairTempTrial, & ! intent(inout): trial value of canopy air space temperature (K) + scalarCanopyTempTrial, & ! intent(inout): trial value of canopy temperature (K) + scalarCanopyWatTrial, & ! intent(inout): trial value of canopy total water (kg m-2) + scalarCanopyLiqTrial, & ! intent(inout): trial value of canopy liquid water (kg m-2) + scalarCanopyIceTrial, & ! intent(inout): trial value of canopy ice content (kg m-2) + scalarCanopyTempPrime, & ! intent(inout): trial value of canopy temperature (K) + scalarCanopyWatPrime, & ! intent(inout): trial value of canopy total water (kg m-2) + scalarCanopyLiqPrime, & ! intent(inout): trial value of canopy liquid water (kg m-2) + scalarCanopyIcePrime, & ! intent(inout): trial value of canopy ice content (kg m-2) + ! output: variables for the snow-soil domain + mLayerTempTrial, & ! intent(inout): trial vector of layer temperature (K) + mLayerVolFracWatTrial, & ! intent(inout): trial vector of volumetric total water content (-) + mLayerVolFracLiqTrial, & ! intent(inout): trial vector of volumetric liquid water content (-) + mLayerVolFracIceTrial, & ! intent(inout): trial vector of volumetric ice water content (-) + mLayerMatricHeadTrial, & ! intent(inout): trial vector of total water matric potential (m) + mLayerMatricHeadLiqTrial, & ! intent(inout): trial vector of liquid water matric potential (m) + mLayerTempPrime, & ! intent(inout): Prime vector of layer temperature (K) + mLayerVolFracWatPrime, & ! intent(inout): Prime vector of volumetric total water content (-) + mLayerVolFracLiqPrime, & ! intent(inout): Prime vector of volumetric liquid water content (-) + mLayerVolFracIcePrime, & ! intent(inout): Prime vector of volumetric ice water content (-) + mLayerMatricHeadPrime, & ! intent(inout): Prime vector of total water matric potential (m) + mLayerMatricHeadLiqPrime, & ! intent(inout): Prime vector of liquid water matric potential (m) + ! output: error control + err,cmessage) ! intent(out): error control +#endif + case(kinsol, homegrown) + ! update diagnostic variables + call updateVars(& + ! input + computeEnthTemp, & ! intent(in): flag if computing temperature component of enthalpy + use_lookup, & ! intent(in): flag to use the lookup table for soil enthalpy + doAdjustTemp, & ! intent(in): logical flag to adjust temperature to account for the energy used in melt+freeze + mpar_data, & ! intent(in): model parameters for a local HRU + indx_data, & ! intent(in): indices defining model states and layers + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + deriv_data, & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables + lookup_data, & ! intent(in): lookup table data structure + scalarCanairTempTrial, & ! intent(in): trial value of canopy air space temperature (K) + ! output: variables for the vegetation canopy + scalarCanopyTempTrial, & ! intent(inout): trial value of canopy temperature (K) + scalarCanopyWatTrial, & ! intent(inout): trial value of canopy total water (kg m-2) + scalarCanopyLiqTrial, & ! intent(inout): trial value of canopy liquid water (kg m-2) + scalarCanopyIceTrial, & ! intent(inout): trial value of canopy ice content (kg m-2) + ! output: variables for the snow-soil domain + mLayerTempTrial, & ! intent(inout): trial vector of layer temperature (K) + mLayerVolFracWatTrial, & ! intent(inout): trial vector of volumetric total water content (-) + mLayerVolFracLiqTrial, & ! intent(inout): trial vector of volumetric liquid water content (-) + mLayerVolFracIceTrial, & ! intent(inout): trial vector of volumetric ice water content (-) + mLayerMatricHeadTrial, & ! intent(inout): trial vector of total water matric potential (m) + mLayerMatricHeadLiqTrial, & ! intent(inout): trial vector of liquid water matric potential (m) + ! output: enthalpy state variables + scalarCanairEnthalpyTrial, & ! intent(inout): trial value for enthalpy of the canopy air space (J m-3) + scalarCanopyEnthTempTrial, & ! intent(inout): trial value for temperature component of enthalpy of the vegetation canopy (J m-3) + mLayerEnthTempTrial, & ! intent(inout): trial vector of temperature component of enthalpy of each snow+soil layer (J m-3) + ! output: error control + err,cmessage) ! intent(out): error control + + end select + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) + + if(computNrgBalance)then + ! compute energy balance if didn't do inside solver substeps + select case(ixNumericalMethod) + case(ida); ! do nothing, already computed + case(kinsol, homegrown) + ! calculate delta ice + scalarCanopyIceDelta = scalarCanopyIceTrial - scalarCanopyIce + mLayerVolFracIceDelta = mLayerVolFracIceTrial - mLayerVolFracIce(1:nLayers) + + ! initialize delta enthalpy (HDelta) to delta temperature component of enthalpy, no difference in canopy air space + scalarCanopyHDelta = scalarCanopyEnthTempTrial - scalarCanopyEnthTemp + mLayerHDelta = mLayerEnthTempTrial - mLayerEnthTemp(1:nLayers) + + ! compute mixture enthalpy for current values, do on delta value so only have to do once + call enthTemp_or_enthalpy(& + ! input: data structures + .true., & ! intent(in): flag to convert enthTemp to enthalpy + diag_data, & ! intent(in): model diagnostic variables for a local HRU + indx_data, & ! intent(in): model indices + ! input: ice content change + scalarCanopyIceDelta, & ! intent(in): delta value for canopy ice content (kg m-2) + mLayerVolFracIceDelta, & ! intent(in): delta vector of volumetric ice water content (-) + ! input/output: enthalpy + scalarCanopyHDelta, & ! intent(inout): delta value for enthalpy of the vegetation canopy (J m-3) + mLayerHDelta, & ! intent(inout): delta vector of enthalpy of each snow+soil layer (J m-3) + ! output: error control + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! compute energy balance, maybe should use to check for step reduction + if(ixCasNrg/=integerMissing) balance(ixCasNrg) = (scalarCanairEnthalpyTrial - scalarCanairEnthalpy)/dt - fluxVec(ixCasNrg) + if(ixVegNrg/=integerMissing) balance(ixVegNrg) = scalarCanopyHDelta/dt - fluxVec(ixVegNrg) + if(nSnowSoilNrg>0)then + do concurrent (i=1:nLayers,ixSnowSoilNrg(i)/=integerMissing) + balance(ixSnowSoilNrg(i)) = mLayerHDelta(i)/dt - fluxVec(ixSnowSoilNrg(i)) + enddo + endif + ! This is equivalent to above if, and only if, ixNrgConserv.ne.closedForm + !!if(ixCasNrg/=integerMissing) balance(ixCasNrg) = resVec(ixCasNrg)/dt + !if(ixVegNrg/=integerMissing) balance(ixVegNrg) = resVec(ixVegNrg)/dt + !if(nSnowSoilNrg>0)then + ! do concurrent (i=1:nLayers,ixSnowSoilNrg(i)/=integerMissing) + ! balance(ixSnowSoilNrg(i)) = resVec(ixSnowSoilNrg(i))/dt + ! enddo + !endif + + end select + else ! if not checking energy balance set balance to missing + if(ixCasNrg/=integerMissing) balance(ixCasNrg) = realMissing + if(ixVegNrg/=integerMissing) balance(ixVegNrg) = realMissing + if(nSnowSoilNrg>0)then + do concurrent (i=1:nLayers,ixSnowSoilNrg(i)/=integerMissing) + balance(ixSnowSoilNrg(i)) = realMissing + enddo + endif + endif ! if checking energy balance + + ! ----- + ! * check mass balance... + ! ----------------------- + + ! NOTE: currently this will only fail with kinsol solver, since mass balance is checked in the homegrown solver and not checked for ida solver + ! Negative error code will mean step will be failed and retried with smaller step size + if(computMassBalance)then + + if(ixVegHyd/=integerMissing)then ! check for complete drainage + + ! handle cases where fluxes empty the canopy + fluxNet = scalarRainfall + scalarCanopyEvaporation - scalarThroughfallRain - scalarCanopyLiqDrainage + if(-fluxNet*dt > canopyBalance0)then + + ! --> first add water + canopyBalance1 = canopyBalance0 + (scalarRainfall - scalarThroughfallRain)*dt + + ! --> next, remove canopy evaporation -- put the unsatisfied evap into sensible heat + canopyBalance1 = canopyBalance1 + scalarCanopyEvaporation*dt + if(canopyBalance1 < 0._rkind)then + ! * get superfluous water and energy + superflousWat = -canopyBalance1/dt ! kg m-2 s-1 + superflousNrg = superflousWat*LH_vap ! W m-2 (J m-2 s-1) + ! * update fluxes and states + canopyBalance1 = 0._rkind + scalarCanopyEvaporation = scalarCanopyEvaporation + superflousWat + scalarLatHeatCanopyEvap = scalarLatHeatCanopyEvap + superflousNrg + scalarSenHeatCanopy = scalarSenHeatCanopy - superflousNrg + endif + + ! --> next, remove canopy drainage + canopyBalance1 = canopyBalance1 -scalarCanopyLiqDrainage*dt + if(canopyBalance1 < 0._rkind)then + superflousWat = -canopyBalance1/dt ! kg m-2 s-1 + canopyBalance1 = 0._rkind + scalarCanopyLiqDrainage = scalarCanopyLiqDrainage + superflousWat + endif + + ! update the trial state + scalarCanopyWatTrial = canopyBalance1 + + ! set the modification flag + nrgFluxModified = .true. + + else + canopyBalance1 = canopyBalance0 + fluxNet*dt + nrgFluxModified = .false. + endif ! cases where fluxes empty the canopy + + endif ! check for complete drainage + + ! compute mass balance if didn't do inside solver substeps + select case(ixNumericalMethod) + case(ida); ! do nothing + case(kinsol, homegrown) + ! old mass balance checks + if(ixVegHyd/=integerMissing)then + ! check the mass balance for the canopy for step reduction (ida and kinsol should have done this already unless modified canopy water above) + fluxNet = scalarRainfall + scalarCanopyEvaporation - scalarThroughfallRain - scalarCanopyLiqDrainage + liqError = (canopyBalance0 + fluxNet*dt) - scalarCanopyWatTrial + if(abs(liqError) > absConvTol_liquid*10._rkind)then ! *10 because of precision issues + if(printFlag)then + write(*,'(a,1x,f20.10)') 'dt = ', dt + write(*,'(a,1x,f20.10)') 'scalarCanopyWatTrial = ', scalarCanopyWatTrial + write(*,'(a,1x,f20.10)') 'canopyBalance0 = ', canopyBalance0 + write(*,'(a,1x,f20.10)') 'canopyBalance1 = ', canopyBalance1 + write(*,'(a,1x,f20.10)') 'scalarRainfall*dt = ', scalarRainfall*dt + write(*,'(a,1x,f20.10)') 'scalarCanopyLiqDrainage*dt = ', scalarCanopyLiqDrainage*dt + write(*,'(a,1x,f20.10)') 'scalarCanopyEvaporation*dt = ', scalarCanopyEvaporation*dt + write(*,'(a,1x,f20.10)') 'scalarThroughfallRain*dt = ', scalarThroughfallRain*dt + write(*,'(a,1x,f20.10)') 'liqError = ', liqError + endif + waterBalanceError = .true. + return + endif ! if there is a water balance error + endif ! if veg canopy + + ! check mass balance for soil domain for step reduction (ida and kinsol should have done this already + if(count(ixSoilOnlyHyd/=integerMissing)==nSoil)then + soilBalance1 = sum( (mLayerVolFracLiqTrial(nSnow+1:nLayers) + mLayerVolFracIceTrial(nSnow+1:nLayers) )*mLayerDepth(nSnow+1:nLayers) ) + vertFlux = -(iLayerLiqFluxSoil(nSoil) - iLayerLiqFluxSoil(0))*dt ! m s-1 --> m + tranSink = sum(mLayerTranspire)*dt ! m s-1 --> m + baseSink = sum(mLayerBaseflow)*dt ! m s-1 --> m + compSink = sum(mLayerCompress(1:nSoil) * mLayerDepth(nSnow+1:nLayers) )*dt ! m s-1 --> m + liqError = soilBalance1 - (soilBalance0 + vertFlux + tranSink - baseSink - compSink) + if(abs(liqError) > absConvTol_liquid*10._rkind)then ! *10 because of precision issues + if(printFlag)then + write(*,'(a,1x,f20.10)') 'dt = ', dt + write(*,'(a,1x,f20.10)') 'soilBalance0 = ', soilBalance0 + write(*,'(a,1x,f20.10)') 'soilBalance1 = ', soilBalance1 + write(*,'(a,1x,f20.10)') 'vertFlux = ', vertFlux + write(*,'(a,1x,f20.10)') 'tranSink = ', tranSink + write(*,'(a,1x,f20.10)') 'baseSink = ', baseSink + write(*,'(a,1x,f20.10)') 'compSink = ', compSink + write(*,'(a,1x,f20.10)') 'liqError = ', liqError + endif + waterBalanceError = .true. + return + endif ! if there is a water balance error + endif ! if hydrology states exist in the soil domain + + ! compute mass balance, maybe should use to check for step reduction + ! resVec is the residual vector from the solver over dt + if(ixVegHyd/=integerMissing) balance(ixVegHyd) = resVec(ixVegHyd)/dt + if(nSnowSoilHyd>0)then + do concurrent (i=1:nLayers,ixSnowSoilHyd(i)/=integerMissing) + balance(ixSnowSoilHyd(i)) = resVec(ixSnowSoilHyd(i))/dt + end do + endif + if(ixAqWat/=integerMissing) balance(ixAqWat) = resVec(ixAqWat)/dt + + end select + else ! if not checking mass balance set balance to missing + if(ixVegHyd/=integerMissing) balance(ixVegHyd) = realMissing + if(nSnowSoilHyd>0)then + do concurrent (i=1:nLayers,ixSnowSoilHyd(i)/=integerMissing) + balance(ixSnowSoilHyd(i)) = realMissing + end do + endif + if(ixAqWat/=integerMissing) balance(ixAqWat) = realMissing + endif ! if checking the mass balance - ! ** - ! canopy within numerical precision - if(scalarCanopyLiqTrial < 0._rkind)then + ! ----- + ! * remove untapped melt energy... always 0 at the moment but if use should be in solved as affects state + ! -------------------------------- - if(scalarCanopyLiqTrial > -verySmall)then - scalarCanopyIceTrial = scalarCanopyIceTrial - scalarCanopyLiqTrial - scalarCanopyLiqTrial = 0._rkind + ! only work with energy state variables + if(size(ixNrgOnly)>0)then ! energy state variables exist - ! encountered an inconsistency: spit the dummy - else - print*, 'dt = ', dt - print*, 'untappedMelt = ', untappedMelt - print*, 'untappedMelt*dt = ', untappedMelt*dt - print*, 'scalarCanopyLiqTrial = ', scalarCanopyLiqTrial - message=trim(message)//'frozen more than the available water' - err=20; return - endif ! (inconsistency) - - endif ! checking the canopy - - ! ** - ! snow+soil within numerical precision - do iState=1,size(mLayerVolFracLiqTrial) - - ! snow layer within numerical precision - if(mLayerVolFracLiqTrial(iState) < 0._rkind)then - - if(mLayerVolFracLiqTrial(iState) > -verySmall)then - mLayerVolFracIceTrial(iState) = mLayerVolFracIceTrial(iState) - mLayerVolFracLiqTrial(iState) - mLayerVolFracLiqTrial(iState) = 0._rkind - - ! encountered an inconsistency: spit the dummy - else - print*, 'dt = ', dt - print*, 'untappedMelt = ', untappedMelt - print*, 'untappedMelt*dt = ', untappedMelt*dt - print*, 'mLayerVolFracLiqTrial = ', mLayerVolFracLiqTrial - message=trim(message)//'frozen more than the available water' - err=20; return - endif ! (inconsistency) - - endif ! checking a snow layer - - end do ! (looping through state variables) - - endif ! (if we removed too much water) - - endif ! (if energy state variables exist) - - ! ----- - ! * update prognostic variables... - ! -------------------------------- - - ! update state variables for the vegetation canopy - scalarCanairTemp = scalarCanairTempTrial ! trial value of canopy air temperature (K) - scalarCanopyTemp = scalarCanopyTempTrial ! trial value of canopy temperature (K) - scalarCanopyWat = scalarCanopyWatTrial ! trial value of canopy total water (kg m-2) - scalarCanopyLiq = scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) - scalarCanopyIce = scalarCanopyIceTrial ! trial value of canopy ice content (kg m-2) - - ! update state variables for the snow+soil domain - mLayerTemp = mLayerTempTrial ! trial vector of layer temperature (K) - mLayerVolFracWat = mLayerVolFracWatTrial ! trial vector of volumetric total water content (-) - mLayerVolFracLiq = mLayerVolFracLiqTrial ! trial vector of volumetric liquid water content (-) - mLayerVolFracIce = mLayerVolFracIceTrial ! trial vector of volumetric ice water content (-) - mLayerMatricHead = mLayerMatricHeadTrial ! trial vector of matric head (m) - mLayerMatricHeadLiq = mLayerMatricHeadLiqTrial ! trial vector of matric head (m) - - ! update state variables for the aquifer - scalarAquiferStorage = scalarAquiferStorageTrial - - ! end associations to info in the data structures - end associate - - end subroutine updateProg + ! loop through energy state variables + do iState=1,size(ixNrgOnly) + + ! get index of the control volume within the domain + ixSubset = ixNrgOnly(iState) ! index within the state subset + ixFullVector = ixMapSubset2Full(ixSubset) ! index within full state vector + ixControlIndex = ixControlVolume(ixFullVector) ! index within a given domain + + ! compute volumetric melt (kg m-3) + volMelt = dt*untappedMelt(ixSubset)/LH_fus ! (kg m-3) + + ! update ice content + select case( ixDomainType(ixFullVector) ) + case(iname_cas); cycle ! do nothing, since there is no snow stored in the canopy air space + case(iname_veg); scalarCanopyIceTrial = scalarCanopyIceTrial - volMelt*canopyDepth ! (kg m-2) + case(iname_snow); mLayerVolFracIceTrial(ixControlIndex) = mLayerVolFracIceTrial(ixControlIndex) - volMelt/iden_ice ! (-) + case(iname_soil); mLayerVolFracIceTrial(ixControlIndex+nSnow) = mLayerVolFracIceTrial(ixControlIndex+nSnow) - volMelt/iden_water ! (-) + case default; err=20; message=trim(message)//'unable to identify domain type [remove untapped melt energy]'; return + end select + + ! update liquid water content + select case( ixDomainType(ixFullVector) ) + case(iname_cas); cycle ! do nothing, since there is no snow stored in the canopy air space + case(iname_veg); scalarCanopyLiqTrial = scalarCanopyLiqTrial + volMelt*canopyDepth ! (kg m-2) + case(iname_snow); mLayerVolFracLiqTrial(ixControlIndex) = mLayerVolFracLiqTrial(ixControlIndex) + volMelt/iden_water ! (-) + case(iname_soil); mLayerVolFracLiqTrial(ixControlIndex+nSnow) = mLayerVolFracLiqTrial(ixControlIndex+nSnow) + volMelt/iden_water ! (-) + case default; err=20; message=trim(message)//'unable to identify domain type [remove untapped melt energy]'; return + end select + + end do ! looping through energy variables + + ! ======================================================================================================== + + ! *** ice + + ! --> check if we removed too much water + if(scalarCanopyIceTrial < 0._rkind .or. any(mLayerVolFracIceTrial < 0._rkind) )then + + ! ** + ! canopy within numerical precision + if(scalarCanopyIceTrial < 0._rkind)then + + if(scalarCanopyIceTrial > -eps_veg)then + scalarCanopyLiqTrial = scalarCanopyLiqTrial - scalarCanopyIceTrial + scalarCanopyIceTrial = 0._rkind + + ! encountered an inconsistency: spit the dummy + else + print*, 'dt = ', dt + print*, 'untappedMelt = ', untappedMelt + print*, 'untappedMelt*dt = ', untappedMelt*dt + print*, 'scalarCanopyiceTrial = ', scalarCanopyIceTrial + message=trim(message)//'melted more than the available water' + err=20; return + endif ! (inconsistency) + + endif ! if checking the canopy + ! ** + ! snow+soil within numerical precision + do iState=1,size(mLayerVolFracIceTrial) + + ! snow layer within numerical precision + if(mLayerVolFracIceTrial(iState) < 0._rkind)then + + if(mLayerVolFracIceTrial(iState) > -eps_snow)then + mLayerVolFracLiqTrial(iState) = mLayerVolFracLiqTrial(iState) - mLayerVolFracIceTrial(iState) + mLayerVolFracIceTrial(iState) = 0._rkind + + ! encountered an inconsistency: spit the dummy + else + print*, 'dt = ', dt + print*, 'untappedMelt = ', untappedMelt + print*, 'untappedMelt*dt = ', untappedMelt*dt + print*, 'mLayerVolFracIceTrial = ', mLayerVolFracIceTrial + message=trim(message)//'melted more than the available water' + err=20; return + endif ! (inconsistency) + + endif ! if checking a snow layer + + end do ! (looping through state variables) + + endif ! (if we removed too much water) + + ! ======================================================================================================== + + ! *** liquid water + + ! --> check if we removed too much water + if(scalarCanopyLiqTrial < 0._rkind .or. any(mLayerVolFracLiqTrial < 0._rkind) )then + + ! ** + ! canopy within numerical precision + if(scalarCanopyLiqTrial < 0._rkind)then + + if(scalarCanopyLiqTrial > -eps_veg)then + scalarCanopyIceTrial = scalarCanopyIceTrial - scalarCanopyLiqTrial + scalarCanopyLiqTrial = 0._rkind + + ! encountered an inconsistency: spit the dummy + else + print*, 'dt = ', dt + print*, 'untappedMelt = ', untappedMelt + print*, 'untappedMelt*dt = ', untappedMelt*dt + print*, 'scalarCanopyLiqTrial = ', scalarCanopyLiqTrial + message=trim(message)//'frozen more than the available water' + err=20; return + endif ! (inconsistency) + endif ! checking the canopy + + ! ** + ! snow+soil within numerical precision + do iState=1,size(mLayerVolFracLiqTrial) + + ! snow layer within numerical precision + if(mLayerVolFracLiqTrial(iState) < 0._rkind)then + + if(mLayerVolFracLiqTrial(iState) > -eps_snow)then + mLayerVolFracIceTrial(iState) = mLayerVolFracIceTrial(iState) - mLayerVolFracLiqTrial(iState) + mLayerVolFracLiqTrial(iState) = 0._rkind + + ! encountered an inconsistency: spit the dummy + else + print*, 'dt = ', dt + print*, 'untappedMelt = ', untappedMelt + print*, 'untappedMelt*dt = ', untappedMelt*dt + print*, 'mLayerVolFracLiqTrial = ', mLayerVolFracLiqTrial + message=trim(message)//'frozen more than the available water' + err=20; return + endif ! (inconsistency) + + endif ! checking a snow layer + + end do ! (looping through state variables) + + endif ! (if we removed too much water) + + endif ! (if energy state variables exist) + + ! ----- + ! * update enthalpy as a diagnostic variable... + ! if computeEnthTemp then enthTemp will change, if enthalpyStateVec then enthalpy will change + ! -------------------------------- + scalarCanairEnthalpy = scalarCanairEnthalpyTrial ! equivalent to scalarCanairEnthTemp + scalarCanopyEnthTemp = scalarCanopyEnthTempTrial + scalarCanopyEnthalpy = scalarCanopyEnthalpyTrial + mLayerEnthTemp = mLayerEnthTempTrial + mLayerEnthalpy = mLayerEnthalpyTrial + + ! ----- + ! * update prognostic variables... + ! -------------------------------- + ! update state variables for the vegetation canopy + scalarCanairTemp = scalarCanairTempTrial ! trial value of canopy air temperature (K) + scalarCanopyTemp = scalarCanopyTempTrial ! trial value of canopy temperature (K) + scalarCanopyWat = scalarCanopyWatTrial ! trial value of canopy total water (kg m-2) + scalarCanopyLiq = scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) + scalarCanopyIce = scalarCanopyIceTrial ! trial value of canopy ice content (kg m-2) + + ! update state variables for the snow+soil domain + mLayerTemp = mLayerTempTrial ! trial vector of layer temperature (K) + mLayerVolFracWat = mLayerVolFracWatTrial ! trial vector of volumetric total water content (-) + mLayerVolFracLiq = mLayerVolFracLiqTrial ! trial vector of volumetric liquid water content (-) + mLayerVolFracIce = mLayerVolFracIceTrial ! trial vector of volumetric ice water content (-) + mLayerMatricHead = mLayerMatricHeadTrial ! trial vector of matric head (m) + mLayerMatricHeadLiq = mLayerMatricHeadLiqTrial ! trial vector of matric head (m) + + ! update state variables for the aquifer + scalarAquiferStorage = scalarAquiferStorageTrial + + ! end associations to info in the data structures + end associate + +end subroutine updateProg end module varSubstep_module diff --git a/build/source/engine/var_derive.f90 b/build/source/engine/var_derive.f90 old mode 100755 new mode 100644 index dfd8a65d9..e3808d992 --- a/build/source/engine/var_derive.f90 +++ b/build/source/engine/var_derive.f90 @@ -25,19 +25,15 @@ module var_derive_module ! derived types to define the data structures USE data_types,only:var_ilength ! x%var(:)%dat (i4b) -USE data_types,only:var_dlength ! x%var(:)%dat (dp) - +USE data_types,only:var_dlength ! x%var(:)%dat (rkind) ! named variables for snow and soil USE globalData,only:iname_snow ! named variables for snow USE globalData,only:iname_soil ! named variables for soil - ! named variables USE globalData,only:data_step ! time step of forcing data - ! named variables USE var_lookup,only:iLookPARAM,iLookINDEX,iLookPROG,iLookDIAG,iLookFLUX ! HRU: named variables for structure elements USE var_lookup,only:iLookBVAR,iLookBPAR ! GRU: named variables for structure elements - ! model decision structures USE globalData,only:model_decisions ! model decision structure USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure @@ -49,8 +45,8 @@ module var_derive_module ! look-up values for the choice of groundwater parameterization USE mDecisions_module,only: & - bigBucket, & ! a big bucket (lumped aquifer model) - noExplicit ! no explicit groundwater parameterization + bigBucket, & ! a big bucket (lumped aquifer model) + noExplicit ! no explicit groundwater parameterization ! look-up values for the choice of groundwater parameterization USE mDecisions_module,only: & @@ -58,9 +54,9 @@ module var_derive_module powerLaw_profile ! power-law profile ! look-up values for the sub-grid routing method -USE mDecisions_module,only: & - timeDelay,& ! time-delay histogram - qInstant ! instantaneous routing +USE mDecisions_module,only: & + timeDelay, & ! time-delay histogram + qInstant ! instantaneous routing ! privacy implicit none @@ -122,12 +118,6 @@ subroutine calcHeight(& iLayerHeight(iLayer) = iLayerHeight(iLayer-1) + mLayerDepth(iLayer) end do ! (looping through layers) - !print*, 'layerType = ', layerType - !print*, 'mLayerDepth = ', mLayerDepth - !print*, 'mLayerHeight = ', mLayerHeight - !print*, 'iLayerHeight = ', iLayerHeight - !print*, '************** ' - ! end association to variables in the data structure end associate @@ -149,10 +139,11 @@ subroutine rootDensty(mpar_data,indx_data,prog_data,diag_data,err,message) character(*),intent(out) :: message ! error message ! declare local variables integer(i4b) :: iLayer ! loop through layers - real(rkind) :: fracRootLower ! fraction of the rooting depth at the lower interface - real(rkind) :: fracRootUpper ! fraction of the rooting depth at the upper interface - real(rkind), parameter :: rootTolerance = 0.05_rkind ! tolerance for error in doubleExp rooting option - real(rkind) :: error ! machine precision error in rooting distribution + real(rkind) :: fracRootLower ! fraction of the rooting depth at the lower interface + real(rkind) :: fracRootUpper ! fraction of the rooting depth at the upper interface + real(rkind), parameter :: rootTolerance = 0.05_rkind ! tolerance for error in doubleExp rooting option + real(rkind) :: error ! machine precision error in rooting distribution + real(rkind) :: total_soil_depth ! total soil depth (m) ! initialize error control err=0; message='rootDensty/' @@ -178,10 +169,8 @@ subroutine rootDensty(mpar_data,indx_data,prog_data,diag_data,err,message) ) ! end associate ! ---------------------------------------------------------------------------------- - !print*, 'nSnow = ', nSnow - !print*, 'nLayers = ', nLayers - ! compute the fraction of roots in each soil layer + total_soil_depth = iLayerHeight(nLayers) - iLayerHeight(nSnow) do iLayer=nSnow+1,nLayers ! different options for the rooting profile @@ -194,17 +183,15 @@ subroutine rootDensty(mpar_data,indx_data,prog_data,diag_data,err,message) if(iLayer==nSnow+1)then ! height=0; avoid precision issues fracRootLower = 0._rkind else - fracRootLower = iLayerHeight(iLayer-1)/rootingDepth + fracRootLower = iLayerHeight(iLayer-1)/min(rootingDepth,total_soil_depth) end if - fracRootUpper = iLayerHeight(iLayer)/rootingDepth + fracRootUpper = iLayerHeight(iLayer)/min(rootingDepth,total_soil_depth) if(fracRootUpper>1._rkind) fracRootUpper=1._rkind ! compute the root density mLayerRootDensity(iLayer-nSnow) = fracRootUpper**rootDistExp - fracRootLower**rootDistExp else mLayerRootDensity(iLayer-nSnow) = 0._rkind end if - !write(*,'(a,10(f11.5,1x))') 'mLayerRootDensity(iLayer-nSnow), fracRootUpper, fracRootLower = ', & - ! mLayerRootDensity(iLayer-nSnow), fracRootUpper, fracRootLower ! ** option 2: double expoential profile of Zeng et al. (JHM 2001) case(doubleExp) @@ -213,9 +200,7 @@ subroutine rootDensty(mpar_data,indx_data,prog_data,diag_data,err,message) fracRootUpper = 1._rkind - 0.5_rkind*(exp(-iLayerHeight(iLayer )*rootScaleFactor1) + exp(-iLayerHeight(iLayer )*rootScaleFactor2) ) ! compute the root density mLayerRootDensity(iLayer-nSnow) = fracRootUpper - fracRootLower - !write(*,'(a,10(f11.5,1x))') 'mLayerRootDensity(iLayer-nSnow), fracRootUpper, fracRootLower = ', & - ! mLayerRootDensity(iLayer-nSnow), fracRootUpper, fracRootLower - + ! ** check case default; err=20; message=trim(message)//'unable to identify option for rooting profile'; return @@ -223,11 +208,11 @@ subroutine rootDensty(mpar_data,indx_data,prog_data,diag_data,err,message) end do ! (looping thru layers) - ! check that root density is within some reaosnable version of machine tolerance + ! check that root density is within some reasonable version of machine tolerance ! This is the case when root density is greater than 1. Can only happen with powerLaw option. error = sum(mLayerRootDensity) - 1._rkind if (error > 2._rkind*epsilon(rootingDepth)) then - message=trim(message)//'problem with the root density calaculation' + message=trim(message)//'problem with the root density calculation' err=20; return else mLayerRootDensity = mLayerRootDensity - error/real(nSoil,kind(rkind)) @@ -274,8 +259,8 @@ subroutine satHydCond(mpar_data,indx_data,prog_data,flux_data,err,message) character(*),intent(out) :: message ! error message ! declare local variables integer(i4b) :: iLayer ! loop through layers - real(rkind) :: ifcDepthScaleFactor ! depth scaling factor (layer interfaces) - real(rkind) :: midDepthScaleFactor ! depth scaling factor (layer midpoints) + real(rkind) :: ifcDepthScaleFactor ! depth scaling factor (layer interfaces) + real(rkind) :: midDepthScaleFactor ! depth scaling factor (layer midpoints) ! initialize error control err=0; message='satHydCond/' ! ---------------------------------------------------------------------------------- @@ -352,12 +337,6 @@ subroutine satHydCond(mpar_data,indx_data,prog_data,flux_data,err,message) mLayerSatHydCondMP(iLayer-nSnow) = k_macropore(iLayer-nSnow) * midDepthScaleFactor end if - !print*, 'compactedDepth = ', compactedDepth - !print*, 'k_macropore = ', k_macropore - !print*, 'mLayerHeight(iLayer) = ', mLayerHeight(iLayer) - !print*, 'iLayerHeight(nLayers) = ', iLayerHeight(nLayers) - !print*, 'iLayer, mLayerSatHydCondMP(iLayer-nSnow) = ', mLayerSatHydCondMP(iLayer-nSnow) - ! error check (errors checked earlier also, so should not get here) case default message=trim(message)//"unknown hydraulic conductivity profile [option="//trim(model_decisions(iLookDECISIONS%hc_profile)%cDecision)//"]" @@ -366,20 +345,16 @@ subroutine satHydCond(mpar_data,indx_data,prog_data,flux_data,err,message) end select ! check that the hydraulic conductivity for macropores is greater than for micropores - if(iLayer > 0)then + if (iLayer > nSnow) then if( mLayerSatHydCondMP(iLayer-nSnow) < mLayerSatHydCond(iLayer-nSnow) )then write(*,'(2(a,e12.6),a,i0)')trim(message)//'WARNING: hydraulic conductivity for macropores [', mLayerSatHydCondMP(iLayer-nSnow), & '] is less than the hydraulic conductivity for micropores [', mLayerSatHydCond(iLayer-nSnow), & ']: resetting macropore conductivity to equal micropore value. Layer = ', iLayer mLayerSatHydCondMP(iLayer-nSnow) = mLayerSatHydCond(iLayer-nSnow) endif ! if mLayerSatHydCondMP < mLayerSatHydCond - endif ! if iLayer>0 - !if(iLayer > nSnow)& ! avoid layer 0 - ! write(*,'(a,1x,i4,1x,2(f11.5,1x,e20.10,1x))') 'satHydCond: ', iLayer, mLayerHeight(iLayer), mLayerSatHydCond(iLayer-nSnow), iLayerHeight(iLayer), iLayerSatHydCond(iLayer-nSnow) + end if ! if iLayer > nSnow end do ! looping through soil layers - !print*, trim(model_decisions(iLookDECISIONS%hc_profile)%cDecision) - !print*, 'k_soil, k_macropore, zScale_TOPMODEL = ', k_soil, k_macropore, zScale_TOPMODEL - !pause ' in satHydCond' + end associate end subroutine satHydCond @@ -390,24 +365,24 @@ end subroutine satHydCond ! ********************************************************************************************************** subroutine fracFuture(bpar_data,bvar_data,err,message) ! external functions - USE soil_utils_module,only:gammp ! compute the cumulative probabilty based on the Gamma distribution + USE soil_utils_module,only:gammp ! compute the cumulative probabilty based on the Gamma distribution implicit none ! input variables - real(rkind),intent(in) :: bpar_data(:) ! vector of basin-average model parameters + real(rkind),intent(in) :: bpar_data(:) ! vector of basin-average model parameters ! output variables - type(var_dlength),intent(inout) :: bvar_data ! data structure of basin-average model variables - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + type(var_dlength),intent(inout) :: bvar_data ! data structure of basin-average model variables + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message ! internal - real(rkind) :: dt ! data time step (s) - integer(i4b) :: nTDH ! number of points in the time-delay histogram - integer(i4b) :: iFuture ! index in time delay histogram - real(rkind) :: tFuture ! future time (end of step) - real(rkind) :: pSave ! cumulative probability at the start of the step - real(rkind) :: cumProb ! cumulative probability at the end of the step - real(rkind) :: sumFrac ! sum of runoff fractions in all steps - real(rkind),parameter :: tolerFrac=0.01_rkind ! tolerance for missing fractional runoff by truncating histogram + real(rkind) :: dt ! data time step (s) + integer(i4b) :: nTDH ! number of points in the time-delay histogram + integer(i4b) :: iFuture ! index in time delay histogram + real(rkind) :: tFuture ! future time (end of step) + real(rkind) :: pSave ! cumulative probability at the start of the step + real(rkind) :: cumProb ! cumulative probability at the end of the step + real(rkind) :: sumFrac ! sum of runoff fractions in all steps + real(rkind),parameter :: tolerFrac=0.01_rkind ! tolerance for missing fractional runoff by truncating histogram ! initialize error control err=0; message='fracFuture/' ! ---------------------------------------------------------------------------------- @@ -450,10 +425,9 @@ subroutine fracFuture(bpar_data,bvar_data,err,message) do iFuture = 1,nTDH ! get weight for a given bin tFuture = real(iFuture, kind(dt))*dt ! future time (end of step) - cumProb = gammp(routingGammaShape,tFuture/routingGammaScale) ! cumulative probability at the end of the step - fractionFuture(iFuture) = max(0._rkind, cumProb - pSave) ! fraction of runoff in the current step + cumProb = gammp(routingGammaShape,tFuture/routingGammaScale) ! cumulative probability at the end of the step + fractionFuture(iFuture) = max(0._rkind, cumProb - pSave) ! fraction of runoff in the current step pSave = cumProb ! save the cumulative probability for use in the next step - !write(*,'(a,1x,i4,1x,3(f20.10,1x))') trim(message), iFuture, tFuture, cumProb, fractionFuture(iFuture) ! set remaining bins to zero if(fractionFuture(iFuture) < tiny(dt))then fractionFuture(iFuture:nTDH) = 0._rkind @@ -462,7 +436,7 @@ subroutine fracFuture(bpar_data,bvar_data,err,message) end do ! (looping through future time steps) ! check that we have enough bins - sumFrac = sum(fractionFuture) + sumFrac = sum(fractionFuture(1:nTDH)) if(abs(1._rkind - sumFrac) > tolerFrac)then write(*,*) 'WARNING: The fraction of basin runoff histogram being accounted for by time delay vector is ', sumFrac write(*,*) 'This is less than allowed by tolerFrac = ', tolerFrac @@ -473,7 +447,7 @@ subroutine fracFuture(bpar_data,bvar_data,err,message) write(*,*) ' -- note that nTimeDelay defines the number of time steps in the time delay histogram' end if ! ensure the fraction sums to one - fractionFuture = fractionFuture/sumFrac + fractionFuture(1:nTDH) = fractionFuture(1:nTDH)/sumFrac ! ** error checking case default; err=20; message=trim(message)//'cannot find option for sub-grid routing'; return @@ -502,8 +476,8 @@ subroutine v_shortcut(mpar_data,diag_data,err,message) ! associate variables in data structure associate(& ! associate values in the parameter structures - vGn_n =>mpar_data%var(iLookPARAM%vGn_n)%dat, & ! van Genutchen "n" parameter (-) - vGn_m =>diag_data%var(iLookDIAG%scalarVGn_m)%dat & ! van Genutchen "m" parameter (-) + vGn_n =>mpar_data%var(iLookPARAM%vGn_n)%dat, & ! van Genutchen "n" parameter (-) + vGn_m =>diag_data%var(iLookDIAG%scalarVGn_m)%dat & ! van Genutchen "m" parameter (-) ) ! end associate ! ---------------------------------------------------------------------------------- diff --git a/build/source/engine/vegLiqFlux.f90 b/build/source/engine/vegLiqFlux.f90 old mode 100755 new mode 100644 index 59e1151b2..a8d58dbf5 --- a/build/source/engine/vegLiqFlux.f90 +++ b/build/source/engine/vegLiqFlux.f90 @@ -24,8 +24,10 @@ module vegLiqFlux_module USE nrtype ! data types -USE data_types,only:var_d ! x%var(:) (dp) -USE data_types,only:var_dlength ! x%var(:)%dat (dp) +USE data_types,only:var_d ! x%var(:) (rkind) +USE data_types,only:var_dlength ! x%var(:)%dat (rkind) +USE data_types,only:in_type_vegLiqFlux ! class type for intent(in) arguments +USE data_types,only:out_type_vegLiqFlux ! class type for intent(out) arguments ! named variables USE var_lookup,only:iLookPARAM,iLookDIAG ! named variables for structure elements @@ -34,119 +36,102 @@ module vegLiqFlux_module USE globalData,only:model_decisions ! model decision structure USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure -! decisions on canopy interception parameterization +! decisions on canopy interception parameterization USE mDecisions_module,only: & - unDefined, & ! original model (no flexibility in canopy interception): 100% of rainfall is intercepted by the vegetation canopy - sparseCanopy, & ! fraction of rainfall that never hits the canopy (throughfall); drainage above threshold - storageFunc ! throughfall a function of canopy storage; 100% throughfall when canopy is at capacity + unDefined, & ! original model (no flexibility in canopy interception): 100% of rainfall is intercepted by the vegetation canopy + sparseCanopy, & ! fraction of rainfall that never hits the canopy (throughfall); drainage above threshold + storageFunc ! throughfall a function of canopy storage; 100% throughfall when canopy is at capacity ! privacy implicit none private -public::vegLiqFlux +public :: vegLiqFlux contains - - - ! ************************************************************************************************ - ! public subroutine vegLiqFlux: compute water balance for the vegetation canopy - ! ************************************************************************************************ - subroutine vegLiqFlux(& - ! input - computeVegFlux, & ! intent(in): flag to denote if computing energy flux over vegetation - scalarCanopyLiqTrial, & ! intent(in): trial mass of liquid water on the vegetation canopy at the current iteration (kg m-2) - scalarRainfall, & ! intent(in): rainfall rate (kg m-2 s-1) - ! input-output: data structures - mpar_data, & ! intent(in): model parameters - diag_data, & ! intent(in): local HRU model diagnostic variables - ! output - scalarThroughfallRain, & ! intent(out): rain that reaches the ground without ever touching the canopy (kg m-2 s-1) - scalarCanopyLiqDrainage, & ! intent(out): drainage of liquid water from the vegetation canopy (kg m-2 s-1) - scalarThroughfallRainDeriv, & ! intent(out): derivative in throughfall w.r.t. canopy liquid water (s-1) - scalarCanopyLiqDrainageDeriv, & ! intent(out): derivative in canopy drainage w.r.t. canopy liquid water (s-1) - err,message) ! intent(out): error control - implicit none - ! input - logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) - real(rkind),intent(in) :: scalarCanopyLiqTrial ! trial mass of liquid water on the vegetation canopy at the current iteration (kg m-2) - real(rkind),intent(in) :: scalarRainfall ! rainfall (kg m-2 s-1) - ! input-output: data structures - type(var_dlength),intent(in) :: mpar_data ! model parameters - type(var_dlength),intent(inout) :: diag_data ! model diagnostic variables for the local basin - ! output - real(rkind),intent(out) :: scalarThroughfallRain ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) - real(rkind),intent(out) :: scalarCanopyLiqDrainage ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) - real(rkind),intent(out) :: scalarThroughfallRainDeriv ! derivative in throughfall w.r.t. canopy liquid water (s-1) - real(rkind),intent(out) :: scalarCanopyLiqDrainageDeriv ! derivative in canopy drainage w.r.t. canopy liquid water (s-1) - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! ------------------------------------------------------------------------------------------------------------------------------------------------------ - ! make association of local variables with information in the data structures - associate(& - ixCanopyInterception => model_decisions(iLookDECISIONS%cIntercept)%iDecision, & ! intent(in): index defining choice of parameterization for canopy interception - scalarCanopyLiqMax => diag_data%var(iLookDIAG%scalarCanopyLiqMax)%dat(1), & ! intent(in): maximum storage before canopy drainage begins (kg m-2 s-1) - scalarThroughfallScaleRain => mpar_data%var(iLookPARAM%throughfallScaleRain)%dat(1),& ! intent(in): fraction of rain that hits the ground without touching the canopy (-) - scalarCanopyDrainageCoeff => mpar_data%var(iLookPARAM%canopyDrainageCoeff)%dat(1) & ! intent(in): canopy drainage coefficient (s-1) - ) ! associating local variables with information in the data structures - ! ------------------------------------------------------------------------------------------------------------------------------------------------------ - ! initialize error control - err=0; message="vegLiqFlux/" - - ! set throughfall to inputs if vegetation is completely buried with snow - if(.not.computeVegFlux)then - scalarThroughfallRain = scalarRainfall - scalarCanopyLiqDrainage = 0._rkind - scalarThroughfallRainDeriv = 0._rkind - scalarCanopyLiqDrainageDeriv = 0._rkind - return - end if - - ! compute throughfall - select case(ixCanopyInterception) - - ! original model (no flexibility in canopy interception): 100% of rainfall is intercepted by the vegetation canopy - ! NOTE: this could be done with scalarThroughfallScaleRain=0, though requires setting scalarThroughfallScaleRain in all test cases - case(unDefined) - scalarThroughfallRain = 0._rkind - scalarThroughfallRainDeriv = 0._rkind - - ! fraction of rainfall hits the ground without ever touching the canopy - case(sparseCanopy) - scalarThroughfallRain = scalarThroughfallScaleRain*scalarRainfall - scalarThroughfallRainDeriv = 0._rkind - - ! throughfall a function of canopy storage - case(storageFunc) - - ! throughfall during wetting-up phase - if(scalarCanopyLiqTrial < scalarCanopyLiqMax)then - scalarThroughfallRain = scalarRainfall*(scalarCanopyLiqTrial/scalarCanopyLiqMax) - scalarThroughfallRainDeriv = scalarRainfall/scalarCanopyLiqMax - - ! all rain falls through the canopy when the canopy is at capacity - else - scalarThroughfallRain = scalarRainfall - scalarThroughfallRainDeriv = 0._rkind - end if - - case default; err=20; message=trim(message)//'unable to identify option for canopy interception'; return - - end select ! (option for canopy interception) - - ! compute canopy drainage - if(scalarCanopyLiqTrial > scalarCanopyLiqMax)then - scalarCanopyLiqDrainage = scalarCanopyDrainageCoeff*(scalarCanopyLiqTrial - scalarCanopyLiqMax) - scalarCanopyLiqDrainageDeriv = scalarCanopyDrainageCoeff - else - scalarCanopyLiqDrainage = 0._rkind - scalarCanopyLiqDrainageDeriv = 0._rkind - end if - - !write(*,'(a,1x,f25.15)') 'scalarCanopyLiqDrainage = ', scalarCanopyLiqDrainage - - ! end association of local variables with information in the data structures - end associate - - end subroutine vegLiqFlux - +! ************************************************************************************************ +! public subroutine vegLiqFlux: compute water balance for the vegetation canopy +! ************************************************************************************************ +subroutine vegLiqFlux(& + ! input: + in_vegLiqFlux, & ! intent(in): model control, trial value, and rainfall rate + ! input-output: data structures + mpar_data, & ! intent(in): model parameters + diag_data, & ! intent(in): local HRU model diagnostic variables + ! output + out_vegLiqFlux) ! intent(out): output rates, derivatives, and error control + implicit none + ! input + type(in_type_vegLiqFlux) :: in_vegLiqFlux ! model control, trial value, and rainfall rate + ! input-output: data structures + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_dlength),intent(inout) :: diag_data ! model diagnostic variables for the local basin + ! output + type(out_type_vegLiqFlux) :: out_vegLiqFlux ! output rates, derivatives, and error control + ! ------------------------------------------------------------------------------------------------------------------------------------------------------ + ! make association of local variables with information in the data structures + associate(& + computeVegFlux => in_vegLiqFlux % computeVegFlux, & ! intent(in): flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) + scalarCanopyLiqTrial => in_vegLiqFlux % scalarCanopyLiqTrial, & ! intent(in): trial mass of liquid water on the vegetation canopy at the current iteration (kg m-2) + scalarRainfall => in_vegLiqFlux % scalarRainfall, & ! intent(in): rainfall (kg m-2 s-1) + ixCanopyInterception => model_decisions(iLookDECISIONS%cIntercept)%iDecision, & ! intent(in): index defining choice of parameterization for canopy interception + scalarCanopyLiqMax => diag_data%var(iLookDIAG%scalarCanopyLiqMax)%dat(1), & ! intent(in): maximum storage before canopy drainage begins (kg m-2 s-1) + scalarThroughfallScaleRain => mpar_data%var(iLookPARAM%throughfallScaleRain)%dat(1),& ! intent(in): fraction of rain that hits the ground without touching the canopy (-) + scalarCanopyDrainageCoeff => mpar_data%var(iLookPARAM%canopyDrainageCoeff)%dat(1), & ! intent(in): canopy drainage coefficient (s-1) + scalarThroughfallRain => out_vegLiqFlux % scalarThroughfallRain, & ! intent(out): rain that reaches the ground without ever touching the canopy (kg m-2 s-1) + scalarCanopyLiqDrainage => out_vegLiqFlux % scalarCanopyLiqDrainage, & ! intent(out): drainage of liquid water from the vegetation canopy (kg m-2 s-1) + scalarThroughfallRainDeriv => out_vegLiqFlux % scalarThroughfallRainDeriv, & ! intent(out): derivative in throughfall w.r.t. canopy liquid water (s-1) + scalarCanopyLiqDrainageDeriv => out_vegLiqFlux % scalarCanopyLiqDrainageDeriv, & ! intent(out): derivative in canopy drainage w.r.t. canopy liquid water (s-1) + err => out_vegLiqFlux % err, & ! intent(out): error code + message => out_vegLiqFlux % cmessage & ! intent(out): error message + ) + ! ------------------------------------------------------------------------------------------------------------------------------------------------------ + ! initialize error control + err=0; message="vegLiqFlux/" + + ! set throughfall to inputs if vegetation is completely buried with snow + if (.not.computeVegFlux) then + scalarThroughfallRain = scalarRainfall + scalarCanopyLiqDrainage = 0._rkind + scalarThroughfallRainDeriv = 0._rkind + scalarCanopyLiqDrainageDeriv = 0._rkind + return + end if + + ! compute throughfall + select case(ixCanopyInterception) + ! original model (no flexibility in canopy interception): 100% of rainfall is intercepted by the vegetation canopy + ! NOTE: this could be done with scalarThroughfallScaleRain=0, though requires setting scalarThroughfallScaleRain in all test cases + case(unDefined) + scalarThroughfallRain = 0._rkind + scalarThroughfallRainDeriv = 0._rkind + ! fraction of rainfall hits the ground without ever touching the canopy + case(sparseCanopy) + scalarThroughfallRain = scalarThroughfallScaleRain*scalarRainfall + scalarThroughfallRainDeriv = 0._rkind + ! throughfall a function of canopy storage + case(storageFunc) + ! throughfall during wetting-up phase + if(scalarCanopyLiqTrial < scalarCanopyLiqMax)then + scalarThroughfallRain = scalarRainfall*(scalarCanopyLiqTrial/scalarCanopyLiqMax) + scalarThroughfallRainDeriv = scalarRainfall/scalarCanopyLiqMax + ! all rain falls through the canopy when the canopy is at capacity + else + scalarThroughfallRain = scalarRainfall + scalarThroughfallRainDeriv = 0._rkind + end if + case default; err=20; message=trim(message)//'unable to identify option for canopy interception'; return + end select ! (option for canopy interception) + + ! compute canopy drainage + if(scalarCanopyLiqTrial > scalarCanopyLiqMax)then + scalarCanopyLiqDrainage = scalarCanopyDrainageCoeff*(scalarCanopyLiqTrial - scalarCanopyLiqMax) + scalarCanopyLiqDrainageDeriv = scalarCanopyDrainageCoeff + else + scalarCanopyLiqDrainage = 0._rkind + scalarCanopyLiqDrainageDeriv = 0._rkind + end if + + end associate ! end association of local variables with information in the data structures + +end subroutine vegLiqFlux end module vegLiqFlux_module diff --git a/build/source/engine/vegNrgFlux.f90 b/build/source/engine/vegNrgFlux.f90 old mode 100755 new mode 100644 index dc8dea90c..c0b891c52 --- a/build/source/engine/vegNrgFlux.f90 +++ b/build/source/engine/vegNrgFlux.f90 @@ -23,13 +23,21 @@ module vegNrgFlux_module ! data types USE nrtype +! global variables +USE globalData,only:& + verySmall, & ! a very small number used as an additive constant to check if substantial difference among real numbers + realMissing, & ! missing value for real numbers + minExpLogHgtFac ! factor for minimum height of transition from the exponential to the logarithmic wind profile + ! derived types to define the data structures USE data_types,only:& - var_i, & ! data vector (i4b) - var_d, & ! data vector (dp) - var_ilength, & ! data vector with variable length dimension (i4b) - var_dlength, & ! data vector with variable length dimension (dp) - model_options ! defines the model decisions + var_i, & ! data vector (i4b) + var_d, & ! data vector (rkind) + var_ilength, & ! data vector with variable length dimension (i4b) + var_dlength, & ! data vector with variable length dimension (rkind) + model_options, & ! defines the model decisions + in_type_vegNrgFlux, & ! intent(in) arguments for vegNrgFlux call + out_type_vegNrgFlux ! intent(out) arguments for vegNrgFlux call ! indices that define elements of the data structures USE var_lookup,only:iLookTYPE ! named variables for structure elements @@ -40,3022 +48,2350 @@ module vegNrgFlux_module USE var_lookup,only:iLookPARAM ! named variables for structure elements USE var_lookup,only:iLookINDEX ! named variables for structure elements USE var_lookup,only:iLookBVAR ! named variables for structure elements -USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure +USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure ! constants -USE multiconst,only:gravity ! acceleration of gravity (m s-2) -USE multiconst,only:vkc ! von Karman's constant (-) -USE multiconst,only:w_ratio ! molecular ratio water to dry air (-) -USE multiconst,only:R_wv ! gas constant for water vapor (Pa K-1 m3 kg-1; J kg-1 K-1) -USE multiconst,only:Cp_air ! specific heat of air (J kg-1 K-1) -USE multiconst,only:Cp_ice ! specific heat of ice (J kg-1 K-1) -USE multiconst,only:Cp_soil ! specific heat of soil (J kg-1 K-1) -USE multiconst,only:Cp_water ! specific heat of liquid water (J kg-1 K-1) -USE multiconst,only:Tfreeze ! temperature at freezing (K) -USE multiconst,only:LH_fus ! latent heat of fusion (J kg-1) -USE multiconst,only:LH_vap ! latent heat of vaporization (J kg-1) -USE multiconst,only:LH_sub ! latent heat of sublimation (J kg-1) -USE multiconst,only:sb ! Stefan Boltzman constant (W m-2 K-4) -USE multiconst,only:iden_air ! intrinsic density of air (kg m-3) -USE multiconst,only:iden_ice ! intrinsic density of ice (kg m-3) -USE multiconst,only:iden_water ! intrinsic density of liquid water (kg m-3) +USE multiconst,only:& + gravity, & ! acceleration of gravity (m s-2) + vkc, & ! von Karman's constant (-) + w_ratio, & ! molecular ratio water to dry air (-) + R_wv, & ! gas constant for water vapor (Pa K-1 m3 kg-1; J kg-1 K-1) + Cp_air, & ! specific heat of air (J kg-1 K-1) + Cp_ice, & ! specific heat of ice (J kg-1 K-1) + Cp_water, & ! specific heat of liquid water (J kg-1 K-1) + Tfreeze, & ! temperature at freezing (K) + LH_vap, & ! latent heat of vaporization (J kg-1) + LH_sub, & ! latent heat of sublimation (J kg-1) + sb, & ! Stefan Boltzman constant (W m-2 K-4) + iden_air ! intrinsic density of air (kg m-3) ! look-up values for method used to compute derivative USE mDecisions_module,only: & - numerical, & ! numerical solution - analytical ! analytical solution - + numerical, & ! numerical solution + analytical ! analytical solution ! look-up values for choice of boundary conditions for thermodynamics USE mDecisions_module,only: & - prescribedTemp, & ! prescribed temperature - energyFlux, & ! energy flux - zeroFlux ! zero flux - + prescribedTemp, & ! prescribed temperature + energyFlux, & ! energy flux + zeroFlux ! zero flux ! look-up values for the choice of parameterization for vegetation roughness length and displacement height USE mDecisions_module,only: & - Raupach_BLM1994, & ! Raupach (BLM 1994) "Simplified expressions..." - CM_QJRMS1988, & ! Choudhury and Monteith (QJRMS 1988) "A four layer model for the heat budget..." - vegTypeTable ! constant parameters dependent on the vegetation type - + Raupach_BLM1994, & ! Raupach (BLM 1994) "Simplified expressions..." + CM_QJRMS1988, & ! Choudhury and Monteith (QJRMS 1988) "A four layer model for the heat budget..." + vegTypeTable ! constant parameters dependent on the vegetation type ! look-up values for the choice of parameterization for canopy emissivity USE mDecisions_module,only: & - simplExp, & ! simple exponential function - difTrans ! parameterized as a function of diffuse transmissivity - + simplExp, & ! simple exponential function + difTrans ! parameterized as a function of diffuse transmissivity ! look-up values for the choice of canopy wind profile USE mDecisions_module,only: & - exponential, & ! exponential wind profile extends to the surface - logBelowCanopy ! logarithmic profile below the vegetation canopy - + exponential, & ! exponential wind profile extends to the surface + logBelowCanopy ! logarithmic profile below the vegetation canopy ! look-up values for choice of stability function USE mDecisions_module,only: & - standard, & ! standard MO similarity, a la Anderson (1976) - louisInversePower, & ! Louis (1979) inverse power function - mahrtExponential ! Mahrt (1987) exponential - + standard, & ! standard MO similarity, a la Anderson (1976) + louisInversePower, & ! Louis (1979) inverse power function + mahrtExponential ! Mahrt (1987) exponential ! look-up values for the choice of groundwater representation (local-column, or single-basin) USE mDecisions_module,only: & - localColumn, & ! separate groundwater representation in each local soil column - singleBasin ! single groundwater store over the entire basin - + localColumn, & ! separate groundwater representation in each local soil column + singleBasin ! single groundwater store over the entire basin ! ------------------------------------------------------------------------------------------------- ! privacy implicit none private -public::vegNrgFlux -public::wettedFrac -! dimensions -integer(i4b),parameter :: nBands=2 ! number of spectral bands for shortwave radiation +public :: vegNrgFlux +public :: wettedFrac ! named variables -integer(i4b),parameter :: ist = 1 ! Surface type: IST=1 => soil; IST=2 => lake -integer(i4b),parameter :: isc = 4 ! Soil color type -integer(i4b),parameter :: ice = 0 ! Surface type: ICE=0 => soil; ICE=1 => sea-ice +integer(i4b),parameter :: ist = 1 ! Surface type: IST=1 => soil; IST=2 => lake +integer(i4b),parameter :: isc = 4 ! Soil color type +integer(i4b),parameter :: ice = 0 ! Surface type: ICE=0 => soil; ICE=1 => sea-ice ! spatial indices -integer(i4b),parameter :: iLoc = 1 ! i-location -integer(i4b),parameter :: jLoc = 1 ! j-location +integer(i4b),parameter :: iLoc = 1 ! i-location +integer(i4b),parameter :: jLoc = 1 ! j-location ! algorithmic parameters -real(rkind),parameter :: missingValue=-9999._rkind ! missing value, used when diagnostic or state variables are undefined -real(rkind),parameter :: verySmall=1.e-6_rkind ! used as an additive constant to check if substantial difference among real numbers -real(rkind),parameter :: tinyVal=epsilon(1._rkind) ! used as an additive constant to check if substantial difference among real numbers -real(rkind),parameter :: mpe=1.e-6_rkind ! prevents overflow error if division by zero -real(rkind),parameter :: dx=1.e-11_rkind ! finite difference increment -! control -logical(lgt) :: printflag ! flag to turn on printing -contains - - ! ******************************************************************************************************* - ! public subroutine vegNrgFlux: muster program to compute energy fluxes at vegetation and ground surfaces - ! ******************************************************************************************************* - subroutine vegNrgFlux(& - ! input: model control - firstSubStep, & ! intent(in): flag to indicate if we are processing the first sub-step - firstFluxCall, & ! intent(in): flag to indicate if we are processing the first flux call - computeVegFlux, & ! intent(in): flag to indicate if we need to compute fluxes over vegetation - - ! input: model state variables - upperBoundTemp, & ! intent(in): temperature of the upper boundary (K) --> NOTE: use air temperature - canairTempTrial, & ! intent(in): trial value of the canopy air space temperature (K) - canopyTempTrial, & ! intent(in): trial value of canopy temperature (K) - groundTempTrial, & ! intent(in): trial value of ground temperature (K) - canopyIceTrial, & ! intent(in): trial value of mass of ice on the vegetation canopy (kg m-2) - canopyLiqTrial, & ! intent(in): trial value of mass of liquid water on the vegetation canopy (kg m-2) - - ! input: model derivatives - dCanLiq_dTcanopy, & ! intent(in): derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) - - ! input/output: data structures - type_data, & ! intent(in): type of vegetation and soil - forc_data, & ! intent(in): model forcing data - mpar_data, & ! intent(in): model parameters - indx_data, & ! intent(in): state vector geometry - prog_data, & ! intent(in): model prognostic variables for a local HRU - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - flux_data, & ! intent(inout): model fluxes for a local HRU - bvar_data, & ! intent(in): model variables for the local basin - model_decisions, & ! intent(in): model decisions - - ! output: liquid water fluxes associated with evaporation/transpiration (needed for coupling) - returnCanopyTranspiration, & ! intent(out): canopy transpiration (kg m-2 s-1) - returnCanopyEvaporation, & ! intent(out): canopy evaporation/condensation (kg m-2 s-1) - returnGroundEvaporation, & ! intent(out): ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) - - ! output: fluxes - canairNetFlux, & ! intent(out): net energy flux for the canopy air space (W m-2) - canopyNetFlux, & ! intent(out): net energy flux for the vegetation canopy (W m-2) - groundNetFlux, & ! intent(out): net energy flux for the ground surface (W m-2) - - ! output: energy flux derivatives - dCanairNetFlux_dCanairTemp, & ! intent(out): derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) - dCanairNetFlux_dCanopyTemp, & ! intent(out): derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) - dCanairNetFlux_dGroundTemp, & ! intent(out): derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) - dCanopyNetFlux_dCanairTemp, & ! intent(out): derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) - dCanopyNetFlux_dCanopyTemp, & ! intent(out): derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) - dCanopyNetFlux_dGroundTemp, & ! intent(out): derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) - dGroundNetFlux_dCanairTemp, & ! intent(out): derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) - dGroundNetFlux_dCanopyTemp, & ! intent(out): derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) - dGroundNetFlux_dGroundTemp, & ! intent(out): derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) - - ! output liquid water flux derivarives (canopy evap) - dCanopyEvaporation_dCanLiq, & ! intent(out): derivative in canopy evaporation w.r.t. canopy liquid water content (s-1) - dCanopyEvaporation_dTCanair, & ! intent(out): derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) - dCanopyEvaporation_dTCanopy, & ! intent(out): derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) - dCanopyEvaporation_dTGround, & ! intent(out): derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) - - ! output: liquid water flux derivarives (ground evap) - dGroundEvaporation_dCanLiq, & ! intent(out): derivative in ground evaporation w.r.t. canopy liquid water content (s-1) - dGroundEvaporation_dTCanair, & ! intent(out): derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) - dGroundEvaporation_dTCanopy, & ! intent(out): derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) - dGroundEvaporation_dTGround, & ! intent(out): derivative in ground evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) - - ! output: cross derivative terms - dCanopyNetFlux_dCanLiq, & ! intent(out): derivative in net canopy fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - dGroundNetFlux_dCanLiq, & ! intent(out): derivative in net ground fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - - ! output: error control - err,message) ! intent(out): error control - - ! utilities - USE expIntegral_module,only:expInt ! function to calculate the exponential integral - ! conversion functions - USE conv_funcs_module,only:satVapPress ! function to compute the saturated vapor pressure (Pa) - USE conv_funcs_module,only:getLatentHeatValue ! function to identify latent heat of vaporization/sublimation (J kg-1) - ! stomatal resistance - USE stomResist_module,only:stomResist ! subroutine to calculate stomatal resistance - ! compute energy and mass fluxes for vegetation - implicit none - - ! --------------------------------------------------------------------------------------- - ! * dummy variables - ! --------------------------------------------------------------------------------------- - ! input: model control - logical(lgt),intent(in) :: firstSubStep ! flag to indicate if we are processing the first sub-step - logical(lgt),intent(in) :: firstFluxCall ! flag to indicate if we are processing the first flux call - logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation - - ! input: model state variables - real(rkind),intent(in) :: upperBoundTemp ! temperature of the upper boundary (K) --> NOTE: use air temperature - real(rkind),intent(in) :: canairTempTrial ! trial value of canopy air space temperature (K) - real(rkind),intent(in) :: canopyTempTrial ! trial value of canopy temperature (K) - real(rkind),intent(in) :: groundTempTrial ! trial value of ground temperature (K) - real(rkind),intent(in) :: canopyIceTrial ! trial value of mass of ice on the vegetation canopy (kg m-2) - real(rkind),intent(in) :: canopyLiqTrial ! trial value of mass of liquid water on the vegetation canopy (kg m-2) - - ! input: model derivatives - real(rkind),intent(in) :: dCanLiq_dTcanopy ! intent(in): derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) - - ! input/output: data structures - type(var_i),intent(in) :: type_data ! type of vegetation and soil - type(var_d),intent(in) :: forc_data ! model forcing data - type(var_dlength),intent(in) :: mpar_data ! model parameters - type(var_ilength),intent(in) :: indx_data ! state vector geometry - type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU - type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU - type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU - type(var_dlength),intent(in) :: bvar_data ! model variables for the local basin - type(model_options),intent(in) :: model_decisions(:) ! model decisions - - ! output: liquid water fluxes associated with evaporation/transpiration (needed for coupling) - real(rkind),intent(out) :: returnCanopyTranspiration ! canopy transpiration (kg m-2 s-1) - real(rkind),intent(out) :: returnCanopyEvaporation ! canopy evaporation/condensation (kg m-2 s-1) - real(rkind),intent(out) :: returnGroundEvaporation ! ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) - - ! output: fluxes - real(rkind),intent(out) :: canairNetFlux ! net energy flux for the canopy air space (W m-2) - real(rkind),intent(out) :: canopyNetFlux ! net energy flux for the vegetation canopy (W m-2) - real(rkind),intent(out) :: groundNetFlux ! net energy flux for the ground surface (W m-2) - - ! output: energy flux derivatives - real(rkind),intent(out) :: dCanairNetFlux_dCanairTemp ! derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) - real(rkind),intent(out) :: dCanairNetFlux_dCanopyTemp ! derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) - real(rkind),intent(out) :: dCanairNetFlux_dGroundTemp ! derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) - real(rkind),intent(out) :: dCanopyNetFlux_dCanairTemp ! derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) - real(rkind),intent(out) :: dCanopyNetFlux_dCanopyTemp ! derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) - real(rkind),intent(out) :: dCanopyNetFlux_dGroundTemp ! derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) - real(rkind),intent(out) :: dGroundNetFlux_dCanairTemp ! derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) - real(rkind),intent(out) :: dGroundNetFlux_dCanopyTemp ! derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) - real(rkind),intent(out) :: dGroundNetFlux_dGroundTemp ! derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) - - ! output: liquid flux derivatives (canopy evap) - real(rkind),intent(out) :: dCanopyEvaporation_dCanLiq ! derivative in canopy evaporation w.r.t. canopy liquid water content (s-1) - real(rkind),intent(out) :: dCanopyEvaporation_dTCanair ! derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) - real(rkind),intent(out) :: dCanopyEvaporation_dTCanopy ! derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) - real(rkind),intent(out) :: dCanopyEvaporation_dTGround ! derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) - - ! output: liquid flux derivatives (ground evap) - real(rkind),intent(out) :: dGroundEvaporation_dCanLiq ! derivative in ground evaporation w.r.t. canopy liquid water content (s-1) - real(rkind),intent(out) :: dGroundEvaporation_dTCanair ! derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) - real(rkind),intent(out) :: dGroundEvaporation_dTCanopy ! derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) - real(rkind),intent(out) :: dGroundEvaporation_dTGround ! derivative in ground evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) - - ! output: cross derivative terms - real(rkind),intent(out) :: dCanopyNetFlux_dCanLiq ! derivative in net canopy fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - real(rkind),intent(out) :: dGroundNetFlux_dCanLiq ! derivative in net ground fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - - ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - - ! --------------------------------------------------------------------------------------- - ! * local variables - ! --------------------------------------------------------------------------------------- - ! local (general) - character(LEN=256) :: cmessage ! error message of downwind routine - real(rkind) :: VAI ! vegetation area index (m2 m-2) - real(rkind) :: exposedVAI ! exposed vegetation area index (m2 m-2) - real(rkind) :: totalCanopyWater ! total water on the vegetation canopy (kg m-2) - real(rkind) :: scalarAquiferStorage ! aquifer storage (m) - - ! local (compute numerical derivatives) - integer(i4b),parameter :: unperturbed=1 ! named variable to identify the case of unperturbed state variables - integer(i4b),parameter :: perturbStateGround=2 ! named variable to identify the case where we perturb the ground temperature - integer(i4b),parameter :: perturbStateCanopy=3 ! named variable to identify the case where we perturb the canopy temperature - integer(i4b),parameter :: perturbStateCanair=4 ! named variable to identify the case where we perturb the canopy air temperature - integer(i4b),parameter :: perturbStateCanLiq=5 ! named variable to identify the case where we perturb the canopy liquid water content - integer(i4b) :: itry ! index of flux evaluation - integer(i4b) :: nFlux ! number of flux evaluations - real(rkind) :: groundTemp ! value of ground temperature used in flux calculations (may be perturbed) - real(rkind) :: canopyTemp ! value of canopy temperature used in flux calculations (may be perturbed) - real(rkind) :: canairTemp ! value of canopy air temperature used in flux calculations (may be perturbed) - real(rkind) :: try0,try1 ! trial values to evaluate specific derivatives (testing only) - - ! local (saturation vapor pressure of veg) - real(rkind) :: TV_celcius ! vegetaion temperature (C) - real(rkind) :: TG_celcius ! ground temperature (C) - real(rkind) :: dSVPCanopy_dCanopyTemp ! derivative in canopy saturated vapor pressure w.r.t. vegetation temperature (Pa/K) - real(rkind) :: dSVPGround_dGroundTemp ! derivative in ground saturated vapor pressure w.r.t. ground temperature (Pa/K) - - ! local (wetted canopy area) - real(rkind) :: fracLiquidCanopy ! fraction of liquid water in the canopy (-) - real(rkind) :: canopyWetFraction ! trial value of the canopy wetted fraction (-) - real(rkind) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) - real(rkind) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) - - ! local (longwave radiation) - real(rkind) :: expi ! exponential integral - real(rkind) :: scaleLAI ! scaled LAI (computing diffuse transmissivity) - real(rkind) :: diffuseTrans ! diffuse transmissivity (-) - real(rkind) :: groundEmissivity ! emissivity of the ground surface (-) - real(rkind),parameter :: vegEmissivity=0.98_rkind ! emissivity of vegetation (0.9665 in JULES) (-) - real(rkind),parameter :: soilEmissivity=0.98_rkind ! emmisivity of the soil (0.9665 in JULES) (-) - real(rkind),parameter :: snowEmissivity=0.99_rkind ! emissivity of snow (-) - real(rkind) :: dLWNetCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) - real(rkind) :: dLWNetGround_dTGround ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) - real(rkind) :: dLWNetCanopy_dTGround ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) - real(rkind) :: dLWNetGround_dTCanopy ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) - - ! local (aerodynamic resistance) - real(rkind) :: scalarCanopyStabilityCorrection_old ! stability correction for the canopy (-) - real(rkind) :: scalarGroundStabilityCorrection_old ! stability correction for the ground surface (-) - - ! local (turbulent heat transfer) - real(rkind) :: z0Ground ! roughness length of the ground (ground below the canopy or non-vegetated surface) (m) - real(rkind) :: soilEvapFactor ! soil water control on evaporation from non-vegetated surfaces - real(rkind) :: soilRelHumidity_noSnow ! relative humidity in the soil pores [0-1] - real(rkind) :: scalarLeafConductance ! leaf conductance (m s-1) - real(rkind) :: scalarCanopyConductance ! canopy conductance (m s-1) - real(rkind) :: scalarGroundConductanceSH ! ground conductance for sensible heat (m s-1) - real(rkind) :: scalarGroundConductanceLH ! ground conductance for latent heat -- includes soil resistance (m s-1) - real(rkind) :: scalarEvapConductance ! conductance for evaporation (m s-1) - real(rkind) :: scalarTransConductance ! conductance for transpiration (m s-1) - real(rkind) :: scalarTotalConductanceSH ! total conductance for sensible heat (m s-1) - real(rkind) :: scalarTotalConductanceLH ! total conductance for latent heat (m s-1) - real(rkind) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) - real(rkind) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) - real(rkind) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) - real(rkind) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - real(rkind) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) - real(rkind) :: turbFluxCanair ! total turbulent heat fluxes exchanged at the canopy air space (W m-2) - real(rkind) :: turbFluxCanopy ! total turbulent heat fluxes from the canopy to the canopy air space (W m-2) - real(rkind) :: turbFluxGround ! total turbulent heat fluxes from the ground to the canopy air space (W m-2) - - ! local (turbulent heat transfer -- compute numerical derivatives) - ! (temporary scalar resistances when states are perturbed) - real(rkind) :: trialLeafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) - real(rkind) :: trialGroundResistance ! below canopy aerodynamic resistance (s m-1) - real(rkind) :: trialCanopyResistance ! above canopy aerodynamic resistance (s m-1) - real(rkind) :: notUsed_RiBulkCanopy ! bulk Richardson number for the canopy (-) - real(rkind) :: notUsed_RiBulkGround ! bulk Richardson number for the ground surface (-) - real(rkind) :: notUsed_z0Canopy ! roughness length of the vegetation canopy (m) - real(rkind) :: notUsed_WindReductionFactor ! canopy wind reduction factor (-) - real(rkind) :: notUsed_ZeroPlaneDisplacement ! zero plane displacement (m) - real(rkind) :: notUsed_scalarCanopyStabilityCorrection ! stability correction for the canopy (-) - real(rkind) :: notUsed_scalarGroundStabilityCorrection ! stability correction for the ground surface (-) - real(rkind) :: notUsed_EddyDiffusCanopyTop ! eddy diffusivity for heat at the top of the canopy (m2 s-1) - real(rkind) :: notUsed_FrictionVelocity ! friction velocity (m s-1) - real(rkind) :: notUsed_WindspdCanopyTop ! windspeed at the top of the canopy (m s-1) - real(rkind) :: notUsed_WindspdCanopyBottom ! windspeed at the height of the bottom of the canopy (m s-1) - real(rkind) :: notUsed_dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) - real(rkind) :: notUsed_dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) - real(rkind) :: notUsed_dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) - real(rkind) :: notUsed_dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - real(rkind) :: notUsed_dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) - - ! (fluxes after perturbations in model states -- canopy air space) - real(rkind) :: turbFluxCanair_dStateCanair ! turbulent exchange from the canopy air space to the atmosphere, after canopy air temperature is perturbed (W m-2) - real(rkind) :: turbFluxCanair_dStateCanopy ! turbulent exchange from the canopy air space to the atmosphere, after canopy temperature is perturbed (W m-2) - real(rkind) :: turbFluxCanair_dStateGround ! turbulent exchange from the canopy air space to the atmosphere, after ground temperature is perturbed (W m-2) - real(rkind) :: turbFluxCanair_dStateCanliq ! turbulent exchange from the canopy air space to the atmosphere, after canopy liquid water content is perturbed (W m-2) - ! (fluxes after perturbations in model states -- vegetation canopy) - real(rkind) :: turbFluxCanopy_dStateCanair ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy air temperature is perturbed (W m-2) - real(rkind) :: turbFluxCanopy_dStateCanopy ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy temperature is perturbed (W m-2) - real(rkind) :: turbFluxCanopy_dStateGround ! total turbulent heat fluxes from the canopy to the canopy air space, after ground temperature is perturbed (W m-2) - real(rkind) :: turbFluxCanopy_dStateCanLiq ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy liquid water content is perturbed (W m-2) - - ! (fluxes after perturbations in model states -- ground surface) - real(rkind) :: turbFluxGround_dStateCanair ! total turbulent heat fluxes from the ground to the canopy air space, after canopy air temperature is perturbed (W m-2) - real(rkind) :: turbFluxGround_dStateCanopy ! total turbulent heat fluxes from the ground to the canopy air space, after canopy temperature is perturbed (W m-2) - real(rkind) :: turbFluxGround_dStateGround ! total turbulent heat fluxes from the ground to the canopy air space, after ground temperature is perturbed (W m-2) - real(rkind) :: turbFluxGround_dStateCanLiq ! total turbulent heat fluxes from the ground to the canopy air space, after canopy liquid water content is perturbed (W m-2) - - ! (fluxes after perturbations in model states -- canopy evaporation) - real(rkind) :: latHeatCanEvap_dStateCanair ! canopy evaporation after canopy air temperature is perturbed (W m-2) - real(rkind) :: latHeatCanEvap_dStateCanopy ! canopy evaporation after canopy temperature is perturbed (W m-2) - real(rkind) :: latHeatCanEvap_dStateGround ! canopy evaporation after ground temperature is perturbed (W m-2) - real(rkind) :: latHeatCanEvap_dStateCanLiq ! canopy evaporation after canopy liquid water content is perturbed (W m-2) - - ! (flux derivatives -- canopy air space) - real(rkind) :: dTurbFluxCanair_dTCanair ! derivative in net canopy air space fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(rkind) :: dTurbFluxCanair_dTCanopy ! derivative in net canopy air space fluxes w.r.t. canopy temperature (W m-2 K-1) - real(rkind) :: dTurbFluxCanair_dTGround ! derivative in net canopy air space fluxes w.r.t. ground temperature (W m-2 K-1) - real(rkind) :: dTurbFluxCanair_dCanLiq ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - - ! (flux derivatives -- vegetation canopy) - real(rkind) :: dTurbFluxCanopy_dTCanair ! derivative in net canopy turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(rkind) :: dTurbFluxCanopy_dTCanopy ! derivative in net canopy turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) - real(rkind) :: dTurbFluxCanopy_dTGround ! derivative in net canopy turbulent fluxes w.r.t. ground temperature (W m-2 K-1) - real(rkind) :: dTurbFluxCanopy_dCanLiq ! derivative in net canopy turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - - ! (flux derivatives -- ground surface) - real(rkind) :: dTurbFluxGround_dTCanair ! derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(rkind) :: dTurbFluxGround_dTCanopy ! derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) - real(rkind) :: dTurbFluxGround_dTGround ! derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) - real(rkind) :: dTurbFluxGround_dCanLiq ! derivative in net ground turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - - ! (liquid water flux derivatives -- canopy evap) - real(rkind) :: dLatHeatCanopyEvap_dCanLiq ! derivative in latent heat of canopy evaporation w.r.t. canopy liquid water content (W kg-1) - real(rkind) :: dLatHeatCanopyEvap_dTCanair ! derivative in latent heat of canopy evaporation w.r.t. canopy air temperature (W m-2 K-1) - real(rkind) :: dLatHeatCanopyEvap_dTCanopy ! derivative in latent heat of canopy evaporation w.r.t. canopy temperature (W m-2 K-1) - real(rkind) :: dLatHeatCanopyEvap_dTGround ! derivative in latent heat of canopy evaporation w.r.t. ground temperature (W m-2 K-1) - - ! (liquid water flux derivatives -- ground evap) - real(rkind) :: dLatHeatGroundEvap_dCanLiq ! derivative in latent heat of ground evaporation w.r.t. canopy liquid water content (J kg-1 s-1) - real(rkind) :: dLatHeatGroundEvap_dTCanair ! derivative in latent heat of ground evaporation w.r.t. canopy air temperature (W m-2 K-1) - real(rkind) :: dLatHeatGroundEvap_dTCanopy ! derivative in latent heat of ground evaporation w.r.t. canopy temperature (W m-2 K-1) - real(rkind) :: dLatHeatGroundEvap_dTGround ! derivative in latent heat of ground evaporation w.r.t. ground temperature (W m-2 K-1) - - ! --------------------------------------------------------------------------------------- - ! point to variables in the data structure - ! --------------------------------------------------------------------------------------- - associate(& - - ! input: model decisions - ix_bcUpprTdyn => model_decisions(iLookDECISIONS%bcUpprTdyn)%iDecision, & ! intent(in): [i4b] choice of upper boundary condition for thermodynamics - ix_fDerivMeth => model_decisions(iLookDECISIONS%fDerivMeth)%iDecision, & ! intent(in): [i4b] choice of method to compute derivatives - ix_veg_traits => model_decisions(iLookDECISIONS%veg_traits)%iDecision, & ! intent(in): [i4b] choice of parameterization for vegetation roughness length and displacement height - ix_canopyEmis => model_decisions(iLookDECISIONS%canopyEmis)%iDecision, & ! intent(in): [i4b] choice of parameterization for canopy emissivity - ix_windPrfile => model_decisions(iLookDECISIONS%windPrfile)%iDecision, & ! intent(in): [i4b] choice of canopy wind profile - ix_astability => model_decisions(iLookDECISIONS%astability)%iDecision, & ! intent(in): [i4b] choice of stability function - ix_soilStress => model_decisions(iLookDECISIONS%soilStress)%iDecision, & ! intent(in): [i4b] choice of function for the soil moisture control on stomatal resistance - ix_groundwatr => model_decisions(iLookDECISIONS%groundwatr)%iDecision, & ! intent(in): [i4b] choice of groundwater parameterization - ix_stomResist => model_decisions(iLookDECISIONS%stomResist)%iDecision, & ! intent(in): [i4b] choice of function for stomatal resistance - ix_spatial_gw => model_decisions(iLookDECISIONS%spatial_gw)%iDecision, & ! intent(in): [i4b] choice of groundwater representation (local, basin) - - ! input: layer geometry - nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1), & ! intent(in): [i4b] number of snow layers - nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1), & ! intent(in): [i4b] number of soil layers - nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1), & ! intent(in): [i4b] total number of layers - - ! input: physical attributes - vegTypeIndex => type_data%var(iLookTYPE%vegTypeIndex), & ! intent(in): [i4b] vegetation type index - soilTypeIndex => type_data%var(iLookTYPE%soilTypeIndex), & ! intent(in): [i4b] soil type index - - ! input: vegetation parameters - heightCanopyTop => mpar_data%var(iLookPARAM%heightCanopyTop)%dat(1), & ! intent(in): [dp] height at the top of the vegetation canopy (m) - heightCanopyBottom => mpar_data%var(iLookPARAM%heightCanopyBottom)%dat(1), & ! intent(in): [dp] height at the bottom of the vegetation canopy (m) - canopyWettingFactor => mpar_data%var(iLookPARAM%canopyWettingFactor)%dat(1), & ! intent(in): [dp] maximum wetted fraction of the canopy (-) - canopyWettingExp => mpar_data%var(iLookPARAM%canopyWettingExp)%dat(1), & ! intent(in): [dp] exponent in canopy wetting function (-) - scalarCanopyIceMax => diag_data%var(iLookDIAG%scalarCanopyIceMax)%dat(1), & ! intent(in): [dp] maximum interception storage capacity for ice (kg m-2) - scalarCanopyLiqMax => diag_data%var(iLookDIAG%scalarCanopyLiqMax)%dat(1), & ! intent(in): [dp] maximum interception storage capacity for liquid water (kg m-2) - - ! input: vegetation phenology - scalarLAI => diag_data%var(iLookDIAG%scalarLAI)%dat(1), & ! intent(in): [dp] one-sided leaf area index (m2 m-2) - scalarSAI => diag_data%var(iLookDIAG%scalarSAI)%dat(1), & ! intent(in): [dp] one-sided stem area index (m2 m-2) - scalarExposedLAI => diag_data%var(iLookDIAG%scalarExposedLAI)%dat(1), & ! intent(in): [dp] exposed leaf area index after burial by snow (m2 m-2) - scalarExposedSAI => diag_data%var(iLookDIAG%scalarExposedSAI)%dat(1), & ! intent(in): [dp] exposed stem area index after burial by snow (m2 m-2) - scalarGrowingSeasonIndex => diag_data%var(iLookDIAG%scalarGrowingSeasonIndex)%dat(1), & ! intent(in): [dp] growing season index (0=off, 1=on) - scalarFoliageNitrogenFactor => diag_data%var(iLookDIAG%scalarFoliageNitrogenFactor)%dat(1), & ! intent(in): [dp] foliage nitrogen concentration (1.0 = saturated) - - ! input: aerodynamic resistance parameters - z0Snow => mpar_data%var(iLookPARAM%z0Snow)%dat(1), & ! intent(in): [dp] roughness length of snow (m) - z0Soil => mpar_data%var(iLookPARAM%z0Soil)%dat(1), & ! intent(in): [dp] roughness length of soil (m) - z0CanopyParam => mpar_data%var(iLookPARAM%z0Canopy)%dat(1), & ! intent(in): [dp] roughness length of the canopy (m) - zpdFraction => mpar_data%var(iLookPARAM%zpdFraction)%dat(1), & ! intent(in): [dp] zero plane displacement / canopy height (-) - critRichNumber => mpar_data%var(iLookPARAM%critRichNumber)%dat(1), & ! intent(in): [dp] critical value for the bulk Richardson number where turbulence ceases (-) - Louis79_bparam => mpar_data%var(iLookPARAM%Louis79_bparam)%dat(1), & ! intent(in): [dp] parameter in Louis (1979) stability function - Louis79_cStar => mpar_data%var(iLookPARAM%Louis79_cStar)%dat(1), & ! intent(in): [dp] parameter in Louis (1979) stability function - Mahrt87_eScale => mpar_data%var(iLookPARAM%Mahrt87_eScale)%dat(1), & ! intent(in): [dp] exponential scaling factor in the Mahrt (1987) stability function - windReductionParam => mpar_data%var(iLookPARAM%windReductionParam)%dat(1), & ! intent(in): [dp] canopy wind reduction parameter (-) - leafExchangeCoeff => mpar_data%var(iLookPARAM%leafExchangeCoeff)%dat(1), & ! intent(in): [dp] turbulent exchange coeff between canopy surface and canopy air ( m s-(1/2) ) - leafDimension => mpar_data%var(iLookPARAM%leafDimension)%dat(1), & ! intent(in): [dp] characteristic leaf dimension (m) - - ! input: soil stress parameters - theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat(1), & ! intent(in): [dp] soil porosity (-) - theta_res => mpar_data%var(iLookPARAM%theta_res)%dat(1), & ! intent(in): [dp] residual volumetric liquid water content (-) - plantWiltPsi => mpar_data%var(iLookPARAM%plantWiltPsi)%dat(1), & ! intent(in): [dp] matric head at wilting point (m) - soilStressParam => mpar_data%var(iLookPARAM%soilStressParam)%dat(1), & ! intent(in): [dp] parameter in the exponential soil stress function (-) - critSoilWilting => mpar_data%var(iLookPARAM%critSoilWilting)%dat, & ! intent(in): [dp] critical vol. liq. water content when plants are wilting (-) - critSoilTranspire => mpar_data%var(iLookPARAM%critSoilTranspire)%dat, & ! intent(in): [dp] critical vol. liq. water content when transpiration is limited (-) - critAquiferTranspire => mpar_data%var(iLookPARAM%critAquiferTranspire)%dat(1), & ! intent(in): [dp] critical aquifer storage value when transpiration is limited (m) - minStomatalResistance => mpar_data%var(iLookPARAM%minStomatalResistance)%dat(1), & ! intent(in): [dp] mimimum stomatal resistance (s m-1) - - ! input: forcing at the upper boundary - mHeight => diag_data%var(iLookDIAG%scalarAdjMeasHeight)%dat(1), & ! intent(in): [dp] measurement height (m) - airtemp => forc_data%var(iLookFORCE%airtemp), & ! intent(in): [dp] air temperature at some height above the surface (K) - windspd => forc_data%var(iLookFORCE%windspd), & ! intent(in): [dp] wind speed at some height above the surface (m s-1) - airpres => forc_data%var(iLookFORCE%airpres), & ! intent(in): [dp] air pressure at some height above the surface (Pa) - LWRadAtm => forc_data%var(iLookFORCE%LWRadAtm), & ! intent(in): [dp] downwelling longwave radiation at the upper boundary (W m-2) - scalarVPair => diag_data%var(iLookDIAG%scalarVPair)%dat(1), & ! intent(in): [dp] vapor pressure at some height above the surface (Pa) - scalarO2air => diag_data%var(iLookDIAG%scalarO2air)%dat(1), & ! intent(in): [dp] atmospheric o2 concentration (Pa) - scalarCO2air => diag_data%var(iLookDIAG%scalarCO2air)%dat(1), & ! intent(in): [dp] atmospheric co2 concentration (Pa) - scalarTwetbulb => diag_data%var(iLookDIAG%scalarTwetbulb)%dat(1), & ! intent(in): [dp] wetbulb temperature (K) - scalarRainfall => flux_data%var(iLookFLUX%scalarRainfall)%dat(1), & ! intent(in): [dp] computed rainfall rate (kg m-2 s-1) - scalarSnowfall => flux_data%var(iLookFLUX%scalarSnowfall)%dat(1), & ! intent(in): [dp] computed snowfall rate (kg m-2 s-1) - scalarThroughfallRain => flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1), & ! intent(in): [dp] rainfall through the vegetation canopy (kg m-2 s-1) - scalarThroughfallSnow => flux_data%var(iLookFLUX%scalarThroughfallSnow)%dat(1), & ! intent(in): [dp] snowfall through the vegetation canopy (kg m-2 s-1) - - ! input: water storage - ! NOTE: soil stress only computed at the start of the substep (firstFluxCall=.true.) - scalarSWE => prog_data%var(iLookPROG%scalarSWE)%dat(1), & ! intent(in): [dp] snow water equivalent on the ground (kg m-2) - scalarSnowDepth => prog_data%var(iLookPROG%scalarSnowDepth)%dat(1), & ! intent(in): [dp] snow depth on the ground surface (m) - mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat, & ! intent(in): [dp(:)] volumetric fraction of liquid water in each layer (-) - mLayerMatricHead => prog_data%var(iLookPROG%mLayerMatricHead)%dat, & ! intent(in): [dp(:)] matric head in each soil layer (m) - localAquiferStorage => prog_data%var(iLookPROG%scalarAquiferStorage)%dat(1), & ! intent(in): [dp] aquifer storage for the local column (m) - basinAquiferStorage => bvar_data%var(iLookBVAR%basin__AquiferStorage)%dat(1), & ! intent(in): [dp] aquifer storage for the single basin (m) - - ! input: shortwave radiation fluxes - scalarCanopySunlitLAI => diag_data%var(iLookDIAG%scalarCanopySunlitLAI)%dat(1), & ! intent(in): [dp] sunlit leaf area (-) - scalarCanopyShadedLAI => diag_data%var(iLookDIAG%scalarCanopyShadedLAI)%dat(1), & ! intent(in): [dp] shaded leaf area (-) - scalarCanopySunlitPAR => flux_data%var(iLookFLUX%scalarCanopySunlitPAR)%dat(1), & ! intent(in): [dp] average absorbed par for sunlit leaves (w m-2) - scalarCanopyShadedPAR => flux_data%var(iLookFLUX%scalarCanopyShadedPAR)%dat(1), & ! intent(in): [dp] average absorbed par for shaded leaves (w m-2) - scalarCanopyAbsorbedSolar => flux_data%var(iLookFLUX%scalarCanopyAbsorbedSolar)%dat(1), & ! intent(in): [dp] solar radiation absorbed by canopy (W m-2) - scalarGroundAbsorbedSolar => flux_data%var(iLookFLUX%scalarGroundAbsorbedSolar)%dat(1), & ! intent(in): [dp] solar radiation absorbed by ground (W m-2) - - ! output: fraction of wetted canopy area and fraction of snow on the ground - scalarCanopyWetFraction => diag_data%var(iLookDIAG%scalarCanopyWetFraction)%dat(1), & ! intent(out): [dp] fraction of canopy that is wet - scalarGroundSnowFraction => diag_data%var(iLookDIAG%scalarGroundSnowFraction)%dat(1), & ! intent(out): [dp] fraction of ground covered with snow (-) - - ! output: longwave radiation fluxes - scalarCanopyEmissivity => diag_data%var(iLookDIAG%scalarCanopyEmissivity)%dat(1), & ! intent(out): [dp] effective emissivity of the canopy (-) - scalarLWRadCanopy => flux_data%var(iLookFLUX%scalarLWRadCanopy)%dat(1), & ! intent(out): [dp] longwave radiation emitted from the canopy (W m-2) - scalarLWRadGround => flux_data%var(iLookFLUX%scalarLWRadGround)%dat(1), & ! intent(out): [dp] longwave radiation emitted at the ground surface (W m-2) - scalarLWRadUbound2Canopy => flux_data%var(iLookFLUX%scalarLWRadUbound2Canopy)%dat(1), & ! intent(out): [dp] downward atmospheric longwave radiation absorbed by the canopy (W m-2) - scalarLWRadUbound2Ground => flux_data%var(iLookFLUX%scalarLWRadUbound2Ground)%dat(1), & ! intent(out): [dp] downward atmospheric longwave radiation absorbed by the ground (W m-2) - scalarLWRadUbound2Ubound => flux_data%var(iLookFLUX%scalarLWRadUbound2Ubound)%dat(1), & ! intent(out): [dp] atmospheric radiation reflected by the ground and lost thru upper boundary (W m-2) - scalarLWRadCanopy2Ubound => flux_data%var(iLookFLUX%scalarLWRadCanopy2Ubound)%dat(1), & ! intent(out): [dp] longwave radiation emitted from canopy lost thru upper boundary (W m-2) - scalarLWRadCanopy2Ground => flux_data%var(iLookFLUX%scalarLWRadCanopy2Ground)%dat(1), & ! intent(out): [dp] longwave radiation emitted from canopy absorbed by the ground (W m-2) - scalarLWRadCanopy2Canopy => flux_data%var(iLookFLUX%scalarLWRadCanopy2Canopy)%dat(1), & ! intent(out): [dp] canopy longwave reflected from ground and absorbed by the canopy (W m-2) - scalarLWRadGround2Ubound => flux_data%var(iLookFLUX%scalarLWRadGround2Ubound)%dat(1), & ! intent(out): [dp] longwave radiation emitted from ground lost thru upper boundary (W m-2) - scalarLWRadGround2Canopy => flux_data%var(iLookFLUX%scalarLWRadGround2Canopy)%dat(1), & ! intent(out): [dp] longwave radiation emitted from ground and absorbed by the canopy (W m-2) - scalarLWNetCanopy => flux_data%var(iLookFLUX%scalarLWNetCanopy)%dat(1), & ! intent(out): [dp] net longwave radiation at the canopy (W m-2) - scalarLWNetGround => flux_data%var(iLookFLUX%scalarLWNetGround)%dat(1), & ! intent(out): [dp] net longwave radiation at the ground surface (W m-2) - scalarLWNetUbound => flux_data%var(iLookFLUX%scalarLWNetUbound)%dat(1), & ! intent(out): [dp] net longwave radiation at the upper boundary (W m-2) - - ! output: aerodynamic resistance - scalarZ0Canopy => diag_data%var(iLookDIAG%scalarZ0Canopy)%dat(1), & ! intent(out): [dp] roughness length of the canopy (m) - scalarWindReductionFactor => diag_data%var(iLookDIAG%scalarWindReductionFactor)%dat(1), & ! intent(out): [dp] canopy wind reduction factor (-) - scalarZeroPlaneDisplacement => diag_data%var(iLookDIAG%scalarZeroPlaneDisplacement)%dat(1), & ! intent(out): [dp] zero plane displacement (m) - scalarRiBulkCanopy => diag_data%var(iLookDIAG%scalarRiBulkCanopy)%dat(1), & ! intent(out): [dp] bulk Richardson number for the canopy (-) - scalarRiBulkGround => diag_data%var(iLookDIAG%scalarRiBulkGround)%dat(1), & ! intent(out): [dp] bulk Richardson number for the ground surface (-) - scalarEddyDiffusCanopyTop => flux_data%var(iLookFLUX%scalarEddyDiffusCanopyTop)%dat(1), & ! intent(out): [dp] eddy diffusivity for heat at the top of the canopy (m2 s-1) - scalarFrictionVelocity => flux_data%var(iLookFLUX%scalarFrictionVelocity)%dat(1), & ! intent(out): [dp] friction velocity (m s-1) - scalarWindspdCanopyTop => flux_data%var(iLookFLUX%scalarWindspdCanopyTop)%dat(1), & ! intent(out): [dp] windspeed at the top of the canopy (m s-1) - scalarWindspdCanopyBottom => flux_data%var(iLookFLUX%scalarWindspdCanopyBottom)%dat(1), & ! intent(out): [dp] windspeed at the height of the bottom of the canopy (m s-1) - scalarLeafResistance => flux_data%var(iLookFLUX%scalarLeafResistance)%dat(1), & ! intent(out): [dp] mean leaf boundary layer resistance per unit leaf area (s m-1) - scalarGroundResistance => flux_data%var(iLookFLUX%scalarGroundResistance)%dat(1), & ! intent(out): [dp] below canopy aerodynamic resistance (s m-1) - scalarCanopyResistance => flux_data%var(iLookFLUX%scalarCanopyResistance)%dat(1), & ! intent(out): [dp] above canopy aerodynamic resistance (s m-1) - - ! input/output: soil resistance -- intent(in) and intent(inout) because only called at the first flux call - mLayerRootDensity => diag_data%var(iLookDIAG%mLayerRootDensity)%dat, & ! intent(in): [dp] root density in each layer (-) - scalarAquiferRootFrac => diag_data%var(iLookDIAG%scalarAquiferRootFrac)%dat(1), & ! intent(in): [dp] fraction of roots below the lowest soil layer (-) - scalarTranspireLim => diag_data%var(iLookDIAG%scalarTranspireLim)%dat(1), & ! intent(inout): [dp] weighted average of the transpiration limiting factor (-) - mLayerTranspireLim => diag_data%var(iLookDIAG%mLayerTranspireLim)%dat, & ! intent(inout): [dp] transpiration limiting factor in each layer (-) - scalarTranspireLimAqfr => diag_data%var(iLookDIAG%scalarTranspireLimAqfr)%dat(1), & ! intent(inout): [dp] transpiration limiting factor for the aquifer (-) - scalarSoilRelHumidity => diag_data%var(iLookDIAG%scalarSoilRelHumidity)%dat(1), & ! intent(inout): [dp] relative humidity in the soil pores [0-1] - scalarSoilResistance => flux_data%var(iLookFLUX%scalarSoilResistance)%dat(1), & ! intent(inout): [dp] resistance from the soil (s m-1) - - ! input/output: stomatal resistance -- intent(inout) because only called at the first flux call - scalarStomResistSunlit => flux_data%var(iLookFLUX%scalarStomResistSunlit)%dat(1), & ! intent(inout): [dp] stomatal resistance for sunlit leaves (s m-1) - scalarStomResistShaded => flux_data%var(iLookFLUX%scalarStomResistShaded)%dat(1), & ! intent(inout): [dp] stomatal resistance for shaded leaves (s m-1) - scalarPhotosynthesisSunlit => flux_data%var(iLookFLUX%scalarPhotosynthesisSunlit)%dat(1), & ! intent(inout): [dp] sunlit photosynthesis (umolco2 m-2 s-1) - scalarPhotosynthesisShaded => flux_data%var(iLookFLUX%scalarPhotosynthesisShaded)%dat(1), & ! intent(inout): [dp] shaded photosynthesis (umolco2 m-2 s-1) - - ! output: turbulent heat fluxes - scalarLatHeatSubVapCanopy => diag_data%var(iLookDIAG%scalarLatHeatSubVapCanopy)%dat(1), & ! intent(inout): [dp] latent heat of sublimation/vaporization for the vegetation canopy (J kg-1) - scalarLatHeatSubVapGround => diag_data%var(iLookDIAG%scalarLatHeatSubVapGround)%dat(1), & ! intent(inout): [dp] latent heat of sublimation/vaporization for the ground surface (J kg-1) - scalarSatVP_canopyTemp => diag_data%var(iLookDIAG%scalarSatVP_CanopyTemp)%dat(1), & ! intent(out): [dp] saturation vapor pressure at the temperature of the vegetation canopy (Pa) - scalarSatVP_groundTemp => diag_data%var(iLookDIAG%scalarSatVP_GroundTemp)%dat(1), & ! intent(out): [dp] saturation vapor pressure at the temperature of the ground surface (Pa) - scalarSenHeatTotal => flux_data%var(iLookFLUX%scalarSenHeatTotal)%dat(1), & ! intent(out): [dp] sensible heat from the canopy air space to the atmosphere (W m-2) - scalarSenHeatCanopy => flux_data%var(iLookFLUX%scalarSenHeatCanopy)%dat(1), & ! intent(out): [dp] sensible heat flux from the canopy to the canopy air space (W m-2) - scalarSenHeatGround => flux_data%var(iLookFLUX%scalarSenHeatGround)%dat(1), & ! intent(out): [dp] sensible heat flux from ground surface below vegetation (W m-2) - scalarLatHeatTotal => flux_data%var(iLookFLUX%scalarLatHeatTotal)%dat(1), & ! intent(out): [dp] latent heat from the canopy air space to the atmosphere (W m-2) - scalarLatHeatCanopyEvap => flux_data%var(iLookFLUX%scalarLatHeatCanopyEvap)%dat(1), & ! intent(out): [dp] latent heat flux for evaporation from the canopy to the canopy air space (W m-2) - scalarLatHeatCanopyTrans => flux_data%var(iLookFLUX%scalarLatHeatCanopyTrans)%dat(1), & ! intent(out): [dp] latent heat flux for transpiration from the canopy to the canopy air space (W m-2) - scalarLatHeatGround => flux_data%var(iLookFLUX%scalarLatHeatGround)%dat(1), & ! intent(out): [dp] latent heat flux from ground surface below vegetation (W m-2) - - ! output: advective heat fluxes - scalarCanopyAdvectiveHeatFlux => flux_data%var(iLookFLUX%scalarCanopyAdvectiveHeatFlux)%dat(1), & ! intent(out): [dp] heat advected to the canopy surface with rain + snow (W m-2) - scalarGroundAdvectiveHeatFlux => flux_data%var(iLookFLUX%scalarGroundAdvectiveHeatFlux)%dat(1), & ! intent(out): [dp] heat advected to the ground surface with throughfall (W m-2) - - ! output: mass fluxes - scalarCanopySublimation => flux_data%var(iLookFLUX%scalarCanopySublimation)%dat(1), & ! intent(out): [dp] canopy sublimation/frost (kg m-2 s-1) - scalarSnowSublimation => flux_data%var(iLookFLUX%scalarSnowSublimation)%dat(1), & ! intent(out): [dp] snow sublimation/frost -- below canopy or non-vegetated (kg m-2 s-1) - - ! input/output: canopy air space variables - scalarVP_CanopyAir => diag_data%var(iLookDIAG%scalarVP_CanopyAir)%dat(1), & ! intent(inout): [dp] vapor pressure of the canopy air space (Pa) - scalarCanopyStabilityCorrection => diag_data%var(iLookDIAG%scalarCanopyStabilityCorrection)%dat(1),& ! intent(inout): [dp] stability correction for the canopy (-) - scalarGroundStabilityCorrection => diag_data%var(iLookDIAG%scalarGroundStabilityCorrection)%dat(1),& ! intent(inout): [dp] stability correction for the ground surface (-) - - ! output: liquid water fluxes - scalarCanopyTranspiration => flux_data%var(iLookFLUX%scalarCanopyTranspiration)%dat(1), & ! intent(out): [dp] canopy transpiration (kg m-2 s-1) - scalarCanopyEvaporation => flux_data%var(iLookFLUX%scalarCanopyEvaporation)%dat(1), & ! intent(out): [dp] canopy evaporation/condensation (kg m-2 s-1) - scalarGroundEvaporation => flux_data%var(iLookFLUX%scalarGroundEvaporation)%dat(1), & ! intent(out): [dp] ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) - - ! output: derived fluxes - scalarTotalET => flux_data%var(iLookFLUX%scalarTotalET)%dat(1), & ! intent(out): [dp] total ET (kg m-2 s-1) - scalarNetRadiation => flux_data%var(iLookFLUX%scalarNetRadiation)%dat(1) & ! intent(out): [dp] net radiation (W m-2) - ) - ! --------------------------------------------------------------------------------------- - ! initialize error control - err=0; message="vegNrgFlux/" - - ! initialize printflag - printflag = .false. - - ! identify the type of boundary condition for thermodynamics - select case(ix_bcUpprTdyn) +real(rkind),parameter :: mpe=1.e-6_rkind ! prevents overflow error if division by zero, from NOAH mpe value +real(rkind),parameter :: dx=1.e-11_rkind ! finite difference increment - ! ***** - ! (1) DIRICHLET OR ZERO FLUX BOUNDARY CONDITION... - ! ************************************************ - - ! NOTE: Vegetation fluxes are not computed in this case - - ! ** prescribed temperature or zero flux at the upper boundary of the snow-soil system - case(prescribedTemp,zeroFlux) - - ! derived fluxes - scalarTotalET = 0._rkind ! total ET (kg m-2 s-1) - scalarNetRadiation = 0._rkind ! net radiation (W m-2) - ! liquid water fluxes associated with evaporation/transpiration - scalarCanopyTranspiration = 0._rkind ! canopy transpiration (kg m-2 s-1) - scalarCanopyEvaporation = 0._rkind ! canopy evaporation/condensation (kg m-2 s-1) - scalarGroundEvaporation = 0._rkind ! ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) - ! solid water fluxes associated with sublimation/frost - scalarCanopySublimation = 0._rkind ! sublimation from the vegetation canopy ((kg m-2 s-1) - scalarSnowSublimation = 0._rkind ! sublimation from the snow surface ((kg m-2 s-1) - ! set canopy fluxes to zero (no canopy) - canairNetFlux = 0._rkind ! net energy flux for the canopy air space (W m-2) - canopyNetFlux = 0._rkind ! net energy flux for the vegetation canopy (W m-2) - ! set canopy derivatives to zero - dCanairNetFlux_dCanairTemp = 0._rkind ! derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) - dCanairNetFlux_dCanopyTemp = 0._rkind ! derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) - dCanairNetFlux_dGroundTemp = 0._rkind ! derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) - dCanopyNetFlux_dCanairTemp = 0._rkind ! derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) - dCanopyNetFlux_dCanopyTemp = 0._rkind ! derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) - dCanopyNetFlux_dGroundTemp = 0._rkind ! derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) - dGroundNetFlux_dCanairTemp = 0._rkind ! derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) - dGroundNetFlux_dCanopyTemp = 0._rkind ! derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) - ! set liquid flux derivatives to zero (canopy evap) - dCanopyEvaporation_dCanLiq = 0._rkind ! derivative in canopy evaporation w.r.t. canopy liquid water content (s-1) - dCanopyEvaporation_dTCanair= 0._rkind ! derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) - dCanopyEvaporation_dTCanopy= 0._rkind ! derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) - dCanopyEvaporation_dTGround= 0._rkind ! derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) - ! set liquid flux derivatives to zero (ground evap) - dGroundEvaporation_dCanLiq = 0._rkind ! derivative in ground evaporation w.r.t. canopy liquid water content (s-1) - dGroundEvaporation_dTCanair= 0._rkind ! derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) - dGroundEvaporation_dTCanopy= 0._rkind ! derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) - dGroundEvaporation_dTGround= 0._rkind ! derivative in ground evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) - - ! compute fluxes and derivatives -- separate approach for prescribed temperature and zero flux - if(ix_bcUpprTdyn == prescribedTemp)then - ! compute ground net flux (W m-2) - groundNetFlux = -diag_data%var(iLookDIAG%iLayerThermalC)%dat(0)*(groundTempTrial - upperBoundTemp)/(prog_data%var(iLookPROG%mLayerDepth)%dat(1)*0.5_rkind) - ! compute derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) - dGroundNetFlux_dGroundTemp = -diag_data%var(iLookDIAG%iLayerThermalC)%dat(0)/(prog_data%var(iLookPROG%mLayerDepth)%dat(1)*0.5_rkind) - elseif(model_decisions(iLookDECISIONS%bcUpprTdyn)%iDecision == zeroFlux)then - groundNetFlux = 0._rkind - dGroundNetFlux_dGroundTemp = 0._rkind - else - err=20; message=trim(message)//'unable to identify upper boundary condition for thermodynamics: expect the case to be prescribedTemp or zeroFlux'; return - end if - - ! ***** - ! (2) NEUMANN BOUNDARY CONDITION... - ! ********************************* - - ! NOTE 1: This is the main routine for calculating vegetation fluxes - ! NOTE 2: This routine also calculates surface fluxes for the case where vegetation is buried with snow (or bare soil) - - ! ******************************************************************************************************************************************************************* - ! ******************************************************************************************************************************************************************* - ! ***** PRELIMINARIES ********************************************************************************************************************************************** - ! ******************************************************************************************************************************************************************* - ! ******************************************************************************************************************************************************************* - - ! * flux boundary condition - case(energyFlux) - - ! identify the appropriate groundwater variable - select case(ix_spatial_gw) - case(singleBasin); scalarAquiferStorage = basinAquiferStorage - case(localColumn); scalarAquiferStorage = localAquiferStorage - case default; err=20; message=trim(message)//'unable to identify spatial representation of groundwater'; return - end select ! (modify the groundwater representation for this single-column implementation) - - ! set canopy stability corrections to the previous values - scalarCanopyStabilityCorrection_old = scalarCanopyStabilityCorrection ! stability correction for the canopy (-) - scalarGroundStabilityCorrection_old = scalarGroundStabilityCorrection ! stability correction for the ground surface (-) - - ! initialize variables to compute stomatal resistance - if(firstFluxCall .and. firstSubStep)then - ! vapor pressure in the canopy air space initialized as vapor pressure of air above the vegetation canopy - ! NOTE: this is needed for the stomatal resistance calculations - if(scalarVP_CanopyAir < 0._rkind)then - scalarVP_CanopyAir = scalarVPair - 1._rkind ! "small" offset used to assist in checking initial derivative calculations - end if - end if - - ! set latent heat of sublimation/vaporization for canopy and ground surface (Pa/K) - ! NOTE: variables are constant over the substep, to simplify relating energy and mass fluxes - if(firstFluxCall)then - scalarLatHeatSubVapCanopy = getLatentHeatValue(canopyTempTrial) - ! case when there is snow on the ground (EXCLUDE "snow without a layer" -- in this case, evaporate from the soil) - if(nSnow > 0)then - if(groundTempTrial > Tfreeze)then; err=20; message=trim(message)//'do not expect ground temperature > 0 when snow is on the ground'; return; end if - scalarLatHeatSubVapGround = LH_sub ! sublimation from snow - scalarGroundSnowFraction = 1._rkind - ! case when the ground is snow-free - else - scalarLatHeatSubVapGround = LH_vap ! evaporation of water in the soil pores: this occurs even if frozen because of super-cooled water - scalarGroundSnowFraction = 0._rkind - end if ! (if there is snow on the ground) - end if ! (if the first flux call) - !write(*,'(a,1x,10(f30.10,1x))') 'groundTempTrial, scalarLatHeatSubVapGround = ', groundTempTrial, scalarLatHeatSubVapGround - - ! compute the roughness length of the ground (ground below the canopy or non-vegetated surface) - z0Ground = z0soil*(1._rkind - scalarGroundSnowFraction) + z0Snow*scalarGroundSnowFraction ! roughness length (m) - - ! compute the total vegetation area index (leaf plus stem) - VAI = scalarLAI + scalarSAI ! vegetation area index - exposedVAI = scalarExposedLAI + scalarExposedSAI ! exposed vegetation area index - - ! compute emissivity of the canopy (-) - if(computeVegFlux)then - select case(ix_canopyEmis) - ! *** simple exponential function - case(simplExp) - scalarCanopyEmissivity = 1._rkind - exp(-exposedVAI) ! effective emissivity of the canopy (-) - ! *** canopy emissivity parameterized as a function of diffuse transmissivity - case(difTrans) - ! compute the exponential integral - scaleLAI = 0.5_rkind*exposedVAI - expi = expInt(scaleLAI) - ! compute diffuse transmissivity (-) - diffuseTrans = (1._rkind - scaleLAI)*exp(-scaleLAI) + (scaleLAI**2._rkind)*expi - ! compute the canopy emissivity - scalarCanopyEmissivity = (1._rkind - diffuseTrans)*vegEmissivity - ! *** check we found the correct option - case default - err=20; message=trim(message)//'unable to identify option for canopy emissivity'; return - end select - end if - - ! ensure canopy longwave fluxes are zero when not computing canopy fluxes - if(.not.computeVegFlux) scalarCanopyEmissivity=0._rkind - - ! compute emissivity of the ground surface (-) - groundEmissivity = scalarGroundSnowFraction*snowEmissivity + (1._rkind - scalarGroundSnowFraction)*soilEmissivity ! emissivity of the ground surface (-) +contains - ! compute the fraction of canopy that is wet - ! NOTE: we either sublimate or evaporate over the entire substep - if(computeVegFlux)then +! ******************************************************************************************************* +! public subroutine vegNrgFlux: muster program to compute energy fluxes at vegetation and ground surfaces +! ******************************************************************************************************* +subroutine vegNrgFlux(& + ! input: model control, model state variables, and derivatives + in_vegNrgFlux, & ! intent(in): model control, model state variables, and derivatives + ! input/output: data structures + type_data, & ! intent(in): type of vegetation and soil + forc_data, & ! intent(in): model forcing data + mpar_data, & ! intent(in): model parameters + indx_data, & ! intent(in): state vector geometry + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + flux_data, & ! intent(inout): model fluxes for a local HRU + bvar_data, & ! intent(in): model variables for the local basin + model_decisions, & ! intent(in): model decisions + ! output: fluxes, derivatives, and error control + out_vegNrgFlux) ! intent(out): fluxes, derivatives, and error control + + ! utilities + USE expIntegral_module,only:expInt ! function to calculate the exponential integral + ! conversion functions + USE conv_funcs_module,only:satVapPress ! function to compute the saturated vapor pressure (Pa) + USE conv_funcs_module,only:getLatentHeatValue ! function to identify latent heat of vaporization/sublimation (J kg-1) + ! stomatal resistance + USE stomResist_module,only:stomResist ! subroutine to calculate stomatal resistance + ! phase changes + USE snow_utils_module,only:fracliquid ! compute fraction of liquid water at a given temperature + + ! compute energy and mass fluxes for vegetation + implicit none + + ! --------------------------------------------------------------------------------------- + ! * dummy variables + ! --------------------------------------------------------------------------------------- + ! input: model control, model state variables, and derivatives + type(in_type_vegNrgFlux),intent(in) :: in_vegNrgFlux ! model control, model state variables, and derivatives + ! input/output: data structures + type(var_i),intent(in) :: type_data ! type of vegetation and soil + type(var_d),intent(in) :: forc_data ! model forcing data + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_ilength),intent(in) :: indx_data ! state vector geometry + type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU + type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(in) :: bvar_data ! model variables for the local basin + type(model_options),intent(in) :: model_decisions(:) ! model decisions + ! output: fluxes, derivatives, and error control + type(out_type_vegNrgFlux),intent(out) :: out_vegNrgFlux ! data structure for vegNrgFlux arguments + ! --------------------------------------------------------------------------------------- + ! * local variables + ! --------------------------------------------------------------------------------------- + ! general) + character(LEN=256) :: cmessage ! error message of downwind routine + real(rkind) :: VAI ! vegetation area index (m2 m-2) + real(rkind) :: exposedVAI ! exposed vegetation area index (m2 m-2) + real(rkind) :: totalCanopyWater ! total water on the vegetation canopy (kg m-2) + real(rkind) :: scalarAquiferStorage ! aquifer storage (m) + ! saturation vapor pressure of veg + real(rkind) :: TV_celcius ! vegetaion temperature (C) + real(rkind) :: TG_celcius ! ground temperature (C) + real(rkind) :: dSVPCanopy_dCanopyTemp ! derivative in canopy saturated vapor pressure w.r.t. vegetation temperature (Pa/K) + real(rkind) :: dSVPGround_dGroundTemp ! derivative in ground saturated vapor pressure w.r.t. ground temperature (Pa/K) + ! wetted canopy area + real(rkind) :: fracLiquidCanopy ! fraction of liquid water in the canopy (-) + real(rkind) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) + real(rkind) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) + ! longwave radiation + real(rkind) :: expi ! exponential integral + real(rkind) :: scaleLAI ! scaled LAI (computing diffuse transmissivity) + real(rkind) :: diffuseTrans ! diffuse transmissivity (-) + real(rkind) :: groundEmissivity ! emissivity of the ground surface (-) + real(rkind),parameter :: leafEmissivity=0.98_rkind ! emissivity of the canopy if 0 diffuse transmissivity (-) in line with Ma et al. 2019 + real(rkind),parameter :: soilEmissivity=0.96_rkind ! emmisivity of the soil (-) as in Jin and Liang 2006 + real(rkind),parameter :: snowEmissivity=0.98_rkind ! emissivity of snow (-) as in Hori et al. 2006, Jin and Liang 2006 + real(rkind) :: dLWNetCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) + real(rkind) :: dLWNetGround_dTGround ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) + real(rkind) :: dLWNetCanopy_dTGround ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) + real(rkind) :: dLWNetGround_dTCanopy ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) + ! aerodynamic resistance + real(rkind) :: scalarCanopyStabilityCorrection_old ! stability correction for the canopy (-) + real(rkind) :: scalarGroundStabilityCorrection_old ! stability correction for the ground surface (-) + ! turbulent heat transfer + real(rkind) :: z0Ground ! roughness length of the ground (ground below the canopy or non-vegetated surface) (m) + real(rkind) :: soilEvapFactor ! soil water control on evaporation from non-vegetated surfaces + real(rkind) :: soilRelHumidity_noSnow ! relative humidity in the soil pores [0-1] + real(rkind) :: scalarLeafConductance ! leaf conductance (m s-1) + real(rkind) :: scalarCanopyConductance ! canopy conductance (m s-1) + real(rkind) :: scalarGroundConductanceSH ! ground conductance for sensible heat (m s-1) + real(rkind) :: scalarGroundConductanceLH ! ground conductance for latent heat -- includes soil resistance (m s-1) + real(rkind) :: scalarEvapConductance ! conductance for evaporation (m s-1) + real(rkind) :: scalarTransConductance ! conductance for transpiration (m s-1) + real(rkind) :: scalarTotalConductanceSH ! total conductance for sensible heat (m s-1) + real(rkind) :: scalarTotalConductanceLH ! total conductance for latent heat (m s-1) + real(rkind) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) + real(rkind) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + real(rkind) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) + real(rkind) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + real(rkind) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) + real(rkind) :: turbFluxCanair ! total turbulent heat fluxes exchanged at the canopy air space (W m-2) + real(rkind) :: turbFluxCanopy ! total turbulent heat fluxes from the canopy to the canopy air space (W m-2) + real(rkind) :: turbFluxGround ! total turbulent heat fluxes from the ground to the canopy air space (W m-2) + ! flux derivatives -- canopy air space + real(rkind) :: dTurbFluxCanair_dTCanair ! derivative in net canopy air space fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(rkind) :: dTurbFluxCanair_dTCanopy ! derivative in net canopy air space fluxes w.r.t. canopy temperature (W m-2 K-1) + real(rkind) :: dTurbFluxCanair_dTGround ! derivative in net canopy air space fluxes w.r.t. ground temperature (W m-2 K-1) + real(rkind) :: dTurbFluxCanair_dCanWat ! derivative in net canopy air space fluxes w.r.t. canopy total water content (J kg-1 s-1) + ! flux derivatives -- vegetation canopy + real(rkind) :: dTurbFluxCanopy_dTCanair ! derivative in net canopy turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(rkind) :: dTurbFluxCanopy_dTCanopy ! derivative in net canopy turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) + real(rkind) :: dTurbFluxCanopy_dTGround ! derivative in net canopy turbulent fluxes w.r.t. ground temperature (W m-2 K-1) + real(rkind) :: dTurbFluxCanopy_dCanWat ! derivative in net canopy turbulent fluxes w.r.t. canopy total water content (J kg-1 s-1) + ! flux derivatives -- ground surface + real(rkind) :: dTurbFluxGround_dTCanair ! derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(rkind) :: dTurbFluxGround_dTCanopy ! derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) + real(rkind) :: dTurbFluxGround_dTGround ! derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) + real(rkind) :: dTurbFluxGround_dCanWat ! derivative in net ground turbulent fluxes w.r.t. canopy total water content (J kg-1 s-1) + ! liquid water flux derivatives -- canopy evap + real(rkind) :: dLatHeatCanopyEvap_dCanWat ! derivative in latent heat of canopy evaporation w.r.t. canopy total water content (W kg-1) + real(rkind) :: dLatHeatCanopyEvap_dTCanair ! derivative in latent heat of canopy evaporation w.r.t. canopy air temperature (W m-2 K-1) + real(rkind) :: dLatHeatCanopyEvap_dTCanopy ! derivative in latent heat of canopy evaporation w.r.t. canopy temperature (W m-2 K-1) + real(rkind) :: dLatHeatCanopyEvap_dTGround ! derivative in latent heat of canopy evaporation w.r.t. ground temperature (W m-2 K-1) + ! liquid water flux derivatives -- ground evap + real(rkind) :: dLatHeatGroundEvap_dCanWat ! derivative in latent heat of ground evaporation w.r.t. canopy total water content (J kg-1 s-1) + real(rkind) :: dLatHeatGroundEvap_dTCanair ! derivative in latent heat of ground evaporation w.r.t. canopy air temperature (W m-2 K-1) + real(rkind) :: dLatHeatGroundEvap_dTCanopy ! derivative in latent heat of ground evaporation w.r.t. canopy temperature (W m-2 K-1) + real(rkind) :: dLatHeatGroundEvap_dTGround ! derivative in latent heat of ground evaporation w.r.t. ground temperature (W m-2 K-1) + ! latent heat flux derivatives -- canopy trans + real(rkind) :: dLatHeatCanopyTrans_dCanWat ! derivative in the latent heat of canopy transpiration w.r.t. canopy total water (J kg-1 s-1) + real(rkind) :: dLatHeatCanopyTrans_dTCanair ! derivative in the latent heat of canopy transpiration w.r.t. canopy air temperature + real(rkind) :: dLatHeatCanopyTrans_dTCanopy ! derivative in the latent heat of canopy transpiration w.r.t. canopy temperature + real(rkind) :: dLatHeatCanopyTrans_dTGround ! derivative in the latent heat of canopy transpiration w.r.t. ground temperature + + ! --------------------------------------------------------------------------------------- + ! point to variables in the data structure + ! --------------------------------------------------------------------------------------- + associate(& + ! input: model control + firstSubStep => in_vegNrgFlux % firstSubStep, & ! intent(in): [dp] flag to indicate if we are processing the first sub-step + firstFluxCall => in_vegNrgFlux % firstFluxCall, & ! intent(in): [dp] flag to indicate if we are processing the first flux call + computeVegFlux => in_vegNrgFlux % computeVegFlux, & ! intent(in): [dp] flag to indicate if computing fluxes over vegetation + checkLWBalance => in_vegNrgFlux % checkLWBalance, & ! intent(in): [dp] flag to check longwave balance + ! input: model state variables + upperBoundTemp => in_vegNrgFlux % upperBoundTemp, & ! intent(in): [dp] temperature of the upper boundary (K) --> NOTE: use air temperature + canairTempTrial => in_vegNrgFlux % scalarCanairTempTrial, & ! intent(in): [dp] trial value of canopy air space temperature (K) + canopyTempTrial => in_vegNrgFlux % scalarCanopyTempTrial, & ! intent(in): [dp] trial value of canopy temperature (K) + groundTempTrial => in_vegNrgFlux % mLayerTempTrial_1, & ! intent(in): [dp] trial value of ground temperature (K) + canopyIceTrial => in_vegNrgFlux % scalarCanopyIceTrial, & ! intent(in): [dp] trial value of mass of ice on the vegetation canopy (kg m-2) + canopyLiqTrial => in_vegNrgFlux % scalarCanopyLiqTrial, & ! intent(in): [dp] trial value of mass of liquid water on the vegetation canopy (kg m-2) + ! input: model derivatives + dCanLiq_dTcanopy => in_vegNrgFlux % dCanLiq_dTcanopy, & ! intent(in): [dp] derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) + ! input: model decisions + ix_bcUpprTdyn => model_decisions(iLookDECISIONS%bcUpprTdyn)%iDecision, & ! intent(in): [i4b] choice of upper boundary condition for thermodynamics + ix_veg_traits => model_decisions(iLookDECISIONS%veg_traits)%iDecision, & ! intent(in): [i4b] choice of parameterization for vegetation roughness length and displacement height + ix_canopyEmis => model_decisions(iLookDECISIONS%canopyEmis)%iDecision, & ! intent(in): [i4b] choice of parameterization for canopy emissivity + ix_windPrfile => model_decisions(iLookDECISIONS%windPrfile)%iDecision, & ! intent(in): [i4b] choice of canopy wind profile + ix_astability => model_decisions(iLookDECISIONS%astability)%iDecision, & ! intent(in): [i4b] choice of stability function + ix_soilStress => model_decisions(iLookDECISIONS%soilStress)%iDecision, & ! intent(in): [i4b] choice of function for the soil moisture control on stomatal resistance + ix_groundwatr => model_decisions(iLookDECISIONS%groundwatr)%iDecision, & ! intent(in): [i4b] choice of groundwater parameterization + ix_stomResist => model_decisions(iLookDECISIONS%stomResist)%iDecision, & ! intent(in): [i4b] choice of function for stomatal resistance + ix_spatial_gw => model_decisions(iLookDECISIONS%spatial_gw)%iDecision, & ! intent(in): [i4b] choice of groundwater representation (local, basin) + ! input: layer geometry + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1), & ! intent(in): [i4b] number of snow layers + nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1), & ! intent(in): [i4b] number of soil layers + nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1), & ! intent(in): [i4b] total number of layers + ! input: physical attributes + vegTypeIndex => type_data%var(iLookTYPE%vegTypeIndex), & ! intent(in): [i4b] vegetation type index + soilTypeIndex => type_data%var(iLookTYPE%soilTypeIndex), & ! intent(in): [i4b] soil type index + ! input: vegetation parameters + heightCanopyTop => mpar_data%var(iLookPARAM%heightCanopyTop)%dat(1), & ! intent(in): [dp] height at the top of the vegetation canopy (m) + heightCanopyBottom => mpar_data%var(iLookPARAM%heightCanopyBottom)%dat(1), & ! intent(in): [dp] height at the bottom of the vegetation canopy (m) + canopyWettingFactor => mpar_data%var(iLookPARAM%canopyWettingFactor)%dat(1), & ! intent(in): [dp] maximum wetted fraction of the canopy (-) + canopyWettingExp => mpar_data%var(iLookPARAM%canopyWettingExp)%dat(1), & ! intent(in): [dp] exponent in canopy wetting function (-) + scalarCanopyIceMax => diag_data%var(iLookDIAG%scalarCanopyIceMax)%dat(1), & ! intent(in): [dp] maximum interception storage capacity for ice (kg m-2) + scalarCanopyLiqMax => diag_data%var(iLookDIAG%scalarCanopyLiqMax)%dat(1), & ! intent(in): [dp] maximum interception storage capacity for liquid water (kg m-2) + ! input: vegetation phenology + scalarLAI => diag_data%var(iLookDIAG%scalarLAI)%dat(1), & ! intent(in): [dp] one-sided leaf area index (m2 m-2) + scalarSAI => diag_data%var(iLookDIAG%scalarSAI)%dat(1), & ! intent(in): [dp] one-sided stem area index (m2 m-2) + scalarExposedLAI => diag_data%var(iLookDIAG%scalarExposedLAI)%dat(1), & ! intent(in): [dp] exposed leaf area index after burial by snow (m2 m-2) + scalarExposedSAI => diag_data%var(iLookDIAG%scalarExposedSAI)%dat(1), & ! intent(in): [dp] exposed stem area index after burial by snow (m2 m-2) + scalarGrowingSeasonIndex => diag_data%var(iLookDIAG%scalarGrowingSeasonIndex)%dat(1), & ! intent(in): [dp] growing season index (0=off, 1=on) + scalarFoliageNitrogenFactor => diag_data%var(iLookDIAG%scalarFoliageNitrogenFactor)%dat(1), & ! intent(in): [dp] foliage nitrogen concentration (1.0 = saturated) + ! input: aerodynamic resistance parameters + z0Snow => mpar_data%var(iLookPARAM%z0Snow)%dat(1), & ! intent(in): [dp] roughness length of snow (m) + z0Soil => mpar_data%var(iLookPARAM%z0Soil)%dat(1), & ! intent(in): [dp] roughness length of soil (m) + z0CanopyParam => mpar_data%var(iLookPARAM%z0Canopy)%dat(1), & ! intent(in): [dp] roughness length of the canopy (m) + zpdFraction => mpar_data%var(iLookPARAM%zpdFraction)%dat(1), & ! intent(in): [dp] zero plane displacement / canopy height (-) + critRichNumber => mpar_data%var(iLookPARAM%critRichNumber)%dat(1), & ! intent(in): [dp] critical value for the bulk Richardson number where turbulence ceases (-) + Louis79_bparam => mpar_data%var(iLookPARAM%Louis79_bparam)%dat(1), & ! intent(in): [dp] parameter in Louis (1979) stability function + Louis79_cStar => mpar_data%var(iLookPARAM%Louis79_cStar)%dat(1), & ! intent(in): [dp] parameter in Louis (1979) stability function + Mahrt87_eScale => mpar_data%var(iLookPARAM%Mahrt87_eScale)%dat(1), & ! intent(in): [dp] exponential scaling factor in the Mahrt (1987) stability function + windReductionParam => mpar_data%var(iLookPARAM%windReductionParam)%dat(1), & ! intent(in): [dp] canopy wind reduction parameter (-) + leafExchangeCoeff => mpar_data%var(iLookPARAM%leafExchangeCoeff)%dat(1), & ! intent(in): [dp] turbulent exchange coeff between canopy surface and canopy air ( m s-(1/2) ) + leafDimension => mpar_data%var(iLookPARAM%leafDimension)%dat(1), & ! intent(in): [dp] characteristic leaf dimension (m) + ! input: soil stress parameters + theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat(1), & ! intent(in): [dp] soil porosity (-) + theta_res => mpar_data%var(iLookPARAM%theta_res)%dat(1), & ! intent(in): [dp] residual volumetric liquid water content (-) + plantWiltPsi => mpar_data%var(iLookPARAM%plantWiltPsi)%dat(1), & ! intent(in): [dp] matric head at wilting point (m) + soilStressParam => mpar_data%var(iLookPARAM%soilStressParam)%dat(1), & ! intent(in): [dp] parameter in the exponential soil stress function (-) + critSoilWilting => mpar_data%var(iLookPARAM%critSoilWilting)%dat(1), & ! intent(in): [dp] critical vol. liq. water content when plants are wilting (-) + critSoilTranspire => mpar_data%var(iLookPARAM%critSoilTranspire)%dat(1), & ! intent(in): [dp] critical vol. liq. water content when transpiration is limited (-) + critAquiferTranspire => mpar_data%var(iLookPARAM%critAquiferTranspire)%dat(1), & ! intent(in): [dp] critical aquifer storage value when transpiration is limited (m) + minStomatalResistance => mpar_data%var(iLookPARAM%minStomatalResistance)%dat(1), & ! intent(in): [dp] mimimum stomatal resistance (s m-1) + ! input: forcing at the upper boundary + mHeight => diag_data%var(iLookDIAG%scalarAdjMeasHeight)%dat(1), & ! intent(in): [dp] measurement height, adjusted to be above vegetation canopy and snow (m) + airtemp => forc_data%var(iLookFORCE%airtemp), & ! intent(in): [dp] air temperature at adjusted measurement height (K) + windspd => forc_data%var(iLookFORCE%windspd), & ! intent(in): [dp] wind speed at adjusted measurement height (m s-1) + airpres => forc_data%var(iLookFORCE%airpres), & ! intent(in): [dp] air pressure at adjusted measurement height (Pa) + LWRadAtm => forc_data%var(iLookFORCE%LWRadAtm), & ! intent(in): [dp] downwelling longwave radiation at the upper boundary (W m-2) + scalarVPair => diag_data%var(iLookDIAG%scalarVPair)%dat(1), & ! intent(in): [dp] vapor pressure at adjusted measurement height (Pa) + scalarO2air => diag_data%var(iLookDIAG%scalarO2air)%dat(1), & ! intent(in): [dp] atmospheric o2 concentration (Pa) + scalarCO2air => diag_data%var(iLookDIAG%scalarCO2air)%dat(1), & ! intent(in): [dp] atmospheric co2 concentration (Pa) + scalarTwetbulb => diag_data%var(iLookDIAG%scalarTwetbulb)%dat(1), & ! intent(in): [dp] wetbulb temperature (K) + scalarRainfall => flux_data%var(iLookFLUX%scalarRainfall)%dat(1), & ! intent(in): [dp] computed rainfall rate (kg m-2 s-1) + scalarSnowfall => flux_data%var(iLookFLUX%scalarSnowfall)%dat(1), & ! intent(in): [dp] computed snowfall rate (kg m-2 s-1) + scalarThroughfallRain => flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1), & ! intent(in): [dp] rainfall through the vegetation canopy (kg m-2 s-1) + scalarThroughfallSnow => flux_data%var(iLookFLUX%scalarThroughfallSnow)%dat(1), & ! intent(in): [dp] snowfall through the vegetation canopy (kg m-2 s-1) + ! input: water storage + ! NOTE: soil stress only computed at the start of the substep (firstFluxCall=.true.) + scalarSWE => prog_data%var(iLookPROG%scalarSWE)%dat(1), & ! intent(in): [dp] snow water equivalent on the ground (kg m-2) + scalarSnowDepth => prog_data%var(iLookPROG%scalarSnowDepth)%dat(1), & ! intent(in): [dp] snow depth on the ground surface (m) + scalarGroundSnowFraction => diag_data%var(iLookDIAG%scalarGroundSnowFraction)%dat(1), & ! intent(in): [dp] fraction of ground covered with snow (-) + mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat, & ! intent(in): [dp(:)] volumetric fraction of liquid water in each layer (-) + mLayerMatricHead => prog_data%var(iLookPROG%mLayerMatricHead)%dat, & ! intent(in): [dp(:)] matric head in each soil layer (m) + localAquiferStorage => prog_data%var(iLookPROG%scalarAquiferStorage)%dat(1), & ! intent(in): [dp] aquifer storage for the local column (m) + basinAquiferStorage => bvar_data%var(iLookBVAR%basin__AquiferStorage)%dat(1), & ! intent(in): [dp] aquifer storage for the single basin (m) + ! input: shortwave radiation fluxes + scalarCanopySunlitLAI => diag_data%var(iLookDIAG%scalarCanopySunlitLAI)%dat(1), & ! intent(in): [dp] sunlit leaf area (-) + scalarCanopyShadedLAI => diag_data%var(iLookDIAG%scalarCanopyShadedLAI)%dat(1), & ! intent(in): [dp] shaded leaf area (-) + scalarCanopySunlitPAR => flux_data%var(iLookFLUX%scalarCanopySunlitPAR)%dat(1), & ! intent(in): [dp] average absorbed par for sunlit leaves (w m-2) + scalarCanopyShadedPAR => flux_data%var(iLookFLUX%scalarCanopyShadedPAR)%dat(1), & ! intent(in): [dp] average absorbed par for shaded leaves (w m-2) + scalarCanopyAbsorbedSolar => flux_data%var(iLookFLUX%scalarCanopyAbsorbedSolar)%dat(1), & ! intent(in): [dp] solar radiation absorbed by canopy (W m-2) + scalarGroundAbsorbedSolar => flux_data%var(iLookFLUX%scalarGroundAbsorbedSolar)%dat(1), & ! intent(in): [dp] solar radiation absorbed by ground (W m-2) + ! output: fraction of wetted canopy area + scalarCanopyWetFraction => diag_data%var(iLookDIAG%scalarCanopyWetFraction)%dat(1), & ! intent(out): [dp] fraction of canopy that is wet + ! output: longwave radiation fluxes + scalarCanopyEmissivity => diag_data%var(iLookDIAG%scalarCanopyEmissivity)%dat(1), & ! intent(out): [dp] effective emissivity of the canopy (-) + scalarLWRadCanopy => flux_data%var(iLookFLUX%scalarLWRadCanopy)%dat(1), & ! intent(out): [dp] longwave radiation emitted from the canopy (W m-2) + scalarLWRadGround => flux_data%var(iLookFLUX%scalarLWRadGround)%dat(1), & ! intent(out): [dp] longwave radiation emitted at the ground surface (W m-2) + scalarLWRadUbound2Canopy => flux_data%var(iLookFLUX%scalarLWRadUbound2Canopy)%dat(1), & ! intent(out): [dp] downward atmospheric longwave radiation absorbed by the canopy (W m-2) + scalarLWRadUbound2Ground => flux_data%var(iLookFLUX%scalarLWRadUbound2Ground)%dat(1), & ! intent(out): [dp] downward atmospheric longwave radiation absorbed by the ground (W m-2) + scalarLWRadUbound2Ubound => flux_data%var(iLookFLUX%scalarLWRadUbound2Ubound)%dat(1), & ! intent(out): [dp] atmospheric radiation reflected by the ground and lost thru upper boundary (W m-2) + scalarLWRadCanopy2Ubound => flux_data%var(iLookFLUX%scalarLWRadCanopy2Ubound)%dat(1), & ! intent(out): [dp] longwave radiation emitted from canopy lost thru upper boundary (W m-2) + scalarLWRadCanopy2Ground => flux_data%var(iLookFLUX%scalarLWRadCanopy2Ground)%dat(1), & ! intent(out): [dp] longwave radiation emitted from canopy absorbed by the ground (W m-2) + scalarLWRadCanopy2Canopy => flux_data%var(iLookFLUX%scalarLWRadCanopy2Canopy)%dat(1), & ! intent(out): [dp] canopy longwave reflected from ground and absorbed by the canopy (W m-2) + scalarLWRadGround2Ubound => flux_data%var(iLookFLUX%scalarLWRadGround2Ubound)%dat(1), & ! intent(out): [dp] longwave radiation emitted from ground lost thru upper boundary (W m-2) + scalarLWRadGround2Canopy => flux_data%var(iLookFLUX%scalarLWRadGround2Canopy)%dat(1), & ! intent(out): [dp] longwave radiation emitted from ground and absorbed by the canopy (W m-2) + scalarLWNetCanopy => flux_data%var(iLookFLUX%scalarLWNetCanopy)%dat(1), & ! intent(out): [dp] net longwave radiation at the canopy (W m-2) + scalarLWNetGround => flux_data%var(iLookFLUX%scalarLWNetGround)%dat(1), & ! intent(out): [dp] net longwave radiation at the ground surface (W m-2) + scalarLWNetUbound => flux_data%var(iLookFLUX%scalarLWNetUbound)%dat(1), & ! intent(out): [dp] net longwave radiation at the upper boundary (W m-2) + ! output: aerodynamic resistance + scalarZ0Canopy => diag_data%var(iLookDIAG%scalarZ0Canopy)%dat(1), & ! intent(out): [dp] roughness length of the canopy (m) + scalarWindReductionFactor => diag_data%var(iLookDIAG%scalarWindReductionFactor)%dat(1), & ! intent(out): [dp] canopy wind reduction factor (-) + scalarZeroPlaneDisplacement => diag_data%var(iLookDIAG%scalarZeroPlaneDisplacement)%dat(1), & ! intent(out): [dp] zero plane displacement (m) + scalarRiBulkCanopy => diag_data%var(iLookDIAG%scalarRiBulkCanopy)%dat(1), & ! intent(out): [dp] bulk Richardson number for the canopy (-) + scalarRiBulkGround => diag_data%var(iLookDIAG%scalarRiBulkGround)%dat(1), & ! intent(out): [dp] bulk Richardson number for the ground surface (-) + scalarEddyDiffusCanopyTop => flux_data%var(iLookFLUX%scalarEddyDiffusCanopyTop)%dat(1), & ! intent(out): [dp] eddy diffusivity for heat at the top of the canopy (m2 s-1) + scalarFrictionVelocity => flux_data%var(iLookFLUX%scalarFrictionVelocity)%dat(1), & ! intent(out): [dp] friction velocity (m s-1) + scalarWindspdCanopyTop => flux_data%var(iLookFLUX%scalarWindspdCanopyTop)%dat(1), & ! intent(out): [dp] windspeed at the top of the canopy (m s-1) + scalarWindspdCanopyBottom => flux_data%var(iLookFLUX%scalarWindspdCanopyBottom)%dat(1), & ! intent(out): [dp] windspeed at the height of the bottom of the canopy (m s-1) + scalarLeafResistance => flux_data%var(iLookFLUX%scalarLeafResistance)%dat(1), & ! intent(out): [dp] mean leaf boundary layer resistance per unit leaf area (s m-1) + scalarGroundResistance => flux_data%var(iLookFLUX%scalarGroundResistance)%dat(1), & ! intent(out): [dp] below canopy aerodynamic resistance (s m-1) + scalarCanopyResistance => flux_data%var(iLookFLUX%scalarCanopyResistance)%dat(1), & ! intent(out): [dp] above canopy aerodynamic resistance (s m-1) + ! input/output: soil resistance -- intent(in) and intent(inout) because only called at the first flux call + mLayerRootDensity => diag_data%var(iLookDIAG%mLayerRootDensity)%dat, & ! intent(in): [dp] root density in each layer (-) + scalarAquiferRootFrac => diag_data%var(iLookDIAG%scalarAquiferRootFrac)%dat(1), & ! intent(in): [dp] fraction of roots below the lowest soil layer (-) + scalarTranspireLim => diag_data%var(iLookDIAG%scalarTranspireLim)%dat(1), & ! intent(inout): [dp] weighted average of the transpiration limiting factor (-) + mLayerTranspireLim => diag_data%var(iLookDIAG%mLayerTranspireLim)%dat, & ! intent(inout): [dp] transpiration limiting factor in each layer (-) + scalarTranspireLimAqfr => diag_data%var(iLookDIAG%scalarTranspireLimAqfr)%dat(1), & ! intent(inout): [dp] transpiration limiting factor for the aquifer (-) + scalarSoilRelHumidity => diag_data%var(iLookDIAG%scalarSoilRelHumidity)%dat(1), & ! intent(inout): [dp] relative humidity in the soil pores [0-1] + scalarSoilResistance => flux_data%var(iLookFLUX%scalarSoilResistance)%dat(1), & ! intent(inout): [dp] resistance from the soil (s m-1) + ! input/output: stomatal resistance -- intent(inout) because only called at the first flux call + scalarStomResistSunlit => flux_data%var(iLookFLUX%scalarStomResistSunlit)%dat(1), & ! intent(inout): [dp] stomatal resistance for sunlit leaves (s m-1) + scalarStomResistShaded => flux_data%var(iLookFLUX%scalarStomResistShaded)%dat(1), & ! intent(inout): [dp] stomatal resistance for shaded leaves (s m-1) + scalarPhotosynthesisSunlit => flux_data%var(iLookFLUX%scalarPhotosynthesisSunlit)%dat(1), & ! intent(inout): [dp] sunlit photosynthesis (umolco2 m-2 s-1) + scalarPhotosynthesisShaded => flux_data%var(iLookFLUX%scalarPhotosynthesisShaded)%dat(1), & ! intent(inout): [dp] shaded photosynthesis (umolco2 m-2 s-1) + ! output: turbulent heat fluxes + scalarLatHeatSubVapCanopy => diag_data%var(iLookDIAG%scalarLatHeatSubVapCanopy)%dat(1), & ! intent(inout): [dp] latent heat of sublimation/vaporization for the vegetation canopy (J kg-1) + scalarLatHeatSubVapGround => diag_data%var(iLookDIAG%scalarLatHeatSubVapGround)%dat(1), & ! intent(inout): [dp] latent heat of sublimation/vaporization for the ground surface (J kg-1) + scalarSatVP_canopyTemp => diag_data%var(iLookDIAG%scalarSatVP_CanopyTemp)%dat(1), & ! intent(out): [dp] saturation vapor pressure at the temperature of the vegetation canopy (Pa) + scalarSatVP_groundTemp => diag_data%var(iLookDIAG%scalarSatVP_GroundTemp)%dat(1), & ! intent(out): [dp] saturation vapor pressure at the temperature of the ground surface (Pa) + scalarSenHeatTotal => flux_data%var(iLookFLUX%scalarSenHeatTotal)%dat(1), & ! intent(out): [dp] sensible heat from the canopy air space to the atmosphere (W m-2) + scalarSenHeatCanopy => flux_data%var(iLookFLUX%scalarSenHeatCanopy)%dat(1), & ! intent(out): [dp] sensible heat flux from the canopy to the canopy air space (W m-2) + scalarSenHeatGround => flux_data%var(iLookFLUX%scalarSenHeatGround)%dat(1), & ! intent(out): [dp] sensible heat flux from ground surface below vegetation (W m-2) + scalarLatHeatTotal => flux_data%var(iLookFLUX%scalarLatHeatTotal)%dat(1), & ! intent(out): [dp] latent heat from the canopy air space to the atmosphere (W m-2) + scalarLatHeatCanopyEvap => flux_data%var(iLookFLUX%scalarLatHeatCanopyEvap)%dat(1), & ! intent(out): [dp] latent heat flux for evaporation from the canopy to the canopy air space (W m-2) + scalarLatHeatCanopyTrans => flux_data%var(iLookFLUX%scalarLatHeatCanopyTrans)%dat(1), & ! intent(out): [dp] latent heat flux for transpiration from the canopy to the canopy air space (W m-2) + scalarLatHeatGround => flux_data%var(iLookFLUX%scalarLatHeatGround)%dat(1), & ! intent(out): [dp] latent heat flux from ground surface below vegetation (W m-2) + ! output: advective heat fluxes + scalarCanopyAdvectiveHeatFlux => flux_data%var(iLookFLUX%scalarCanopyAdvectiveHeatFlux)%dat(1), & ! intent(out): [dp] heat advected to the canopy surface with rain + snow (W m-2) + scalarGroundAdvectiveHeatFlux => flux_data%var(iLookFLUX%scalarGroundAdvectiveHeatFlux)%dat(1), & ! intent(out): [dp] heat advected to the ground surface with throughfall (W m-2) + ! output: mass fluxes + scalarCanopySublimation => flux_data%var(iLookFLUX%scalarCanopySublimation)%dat(1), & ! intent(out): [dp] canopy sublimation/frost (kg m-2 s-1) + scalarSnowSublimation => flux_data%var(iLookFLUX%scalarSnowSublimation)%dat(1), & ! intent(out): [dp] snow sublimation/frost -- below canopy or non-vegetated (kg m-2 s-1) + ! input/output: canopy air space variables + scalarVP_CanopyAir => diag_data%var(iLookDIAG%scalarVP_CanopyAir)%dat(1), & ! intent(inout): [dp] vapor pressure of the canopy air space (Pa) + scalarCanopyStabilityCorrection => diag_data%var(iLookDIAG%scalarCanopyStabilityCorrection)%dat(1),& ! intent(inout): [dp] stability correction for the canopy (-) + scalarGroundStabilityCorrection => diag_data%var(iLookDIAG%scalarGroundStabilityCorrection)%dat(1),& ! intent(inout): [dp] stability correction for the ground surface (-) + ! output: liquid water fluxes + scalarCanopyTranspiration => flux_data%var(iLookFLUX%scalarCanopyTranspiration)%dat(1), & ! intent(out): [dp] canopy transpiration (kg m-2 s-1) + scalarCanopyEvaporation => flux_data%var(iLookFLUX%scalarCanopyEvaporation)%dat(1), & ! intent(out): [dp] canopy evaporation/condensation (kg m-2 s-1) + scalarGroundEvaporation => flux_data%var(iLookFLUX%scalarGroundEvaporation)%dat(1), & ! intent(out): [dp] ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) + ! output: derived fluxes + scalarTotalET => flux_data%var(iLookFLUX%scalarTotalET)%dat(1), & ! intent(out): [dp] total ET (kg m-2 s-1) + scalarNetRadiation => flux_data%var(iLookFLUX%scalarNetRadiation)%dat(1), & ! intent(out): [dp] net radiation (W m-2) + ! output: liquid water fluxes associated with evaporation/transpiration (needed for coupling) + returnCanopyTranspiration => out_vegNrgFlux % scalarCanopyTranspiration, & ! intent(out): [dp] canopy transpiration (kg m-2 s-1) + returnCanopyEvaporation => out_vegNrgFlux % scalarCanopyEvaporation, & ! intent(out): [dp] canopy evaporation/condensation (kg m-2 s-1) + returnGroundEvaporation => out_vegNrgFlux % scalarGroundEvaporation, & ! intent(out): [dp] ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) + ! output: fluxes + canairNetFlux => out_vegNrgFlux % scalarCanairNetNrgFlux, & ! intent(out): [dp] net energy flux for the canopy air space (W m-2) + canopyNetFlux => out_vegNrgFlux % scalarCanopyNetNrgFlux, & ! intent(out): [dp] net energy flux for the vegetation canopy (W m-2) + groundNetFlux => out_vegNrgFlux % scalarGroundNetNrgFlux, & ! intent(out): [dp] net energy flux for the ground surface (W m-2) + ! output: energy flux derivatives + dCanairNetFlux_dCanairTemp => out_vegNrgFlux % dCanairNetFlux_dCanairTemp,& ! intent(out): [dp] derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) + dCanairNetFlux_dCanopyTemp => out_vegNrgFlux % dCanairNetFlux_dCanopyTemp,& ! intent(out): [dp] derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) + dCanairNetFlux_dGroundTemp => out_vegNrgFlux % dCanairNetFlux_dGroundTemp,& ! intent(out): [dp] derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) + dCanopyNetFlux_dCanairTemp => out_vegNrgFlux % dCanopyNetFlux_dCanairTemp,& ! intent(out): [dp] derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) + dCanopyNetFlux_dCanopyTemp => out_vegNrgFlux % dCanopyNetFlux_dCanopyTemp,& ! intent(out): [dp] derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) + dCanopyNetFlux_dGroundTemp => out_vegNrgFlux % dCanopyNetFlux_dGroundTemp,& ! intent(out): [dp] derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) + dGroundNetFlux_dCanairTemp => out_vegNrgFlux % dGroundNetFlux_dCanairTemp,& ! intent(out): [dp] derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) + dGroundNetFlux_dCanopyTemp => out_vegNrgFlux % dGroundNetFlux_dCanopyTemp,& ! intent(out): [dp] derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) + dGroundNetFlux_dGroundTemp => out_vegNrgFlux % dGroundNetFlux_dGroundTemp,& ! intent(out): [dp] derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) + ! output: liquid flux derivatives (canopy evap) + dCanopyEvaporation_dCanWat => out_vegNrgFlux % dCanopyEvaporation_dCanWat, & ! intent(out): [dp] derivative in canopy evaporation w.r.t. canopy total water content (s-1) + dCanopyEvaporation_dTCanair => out_vegNrgFlux % dCanopyEvaporation_dTCanair, & ! intent(out): [dp] derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + dCanopyEvaporation_dTCanopy => out_vegNrgFlux % dCanopyEvaporation_dTCanopy, & ! intent(out): [dp] derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + dCanopyEvaporation_dTGround => out_vegNrgFlux % dCanopyEvaporation_dTGround, & ! intent(out): [dp] derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) + ! output: liquid flux derivatives (ground evap) + dGroundEvaporation_dCanWat => out_vegNrgFlux % dGroundEvaporation_dCanWat, & ! intent(out): [dp] derivative in ground evaporation w.r.t. canopy total water content (s-1) + dGroundEvaporation_dTCanair => out_vegNrgFlux % dGroundEvaporation_dTCanair, & ! intent(out): [dp] derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + dGroundEvaporation_dTCanopy => out_vegNrgFlux % dGroundEvaporation_dTCanopy, & ! intent(out): [dp] derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + dGroundEvaporation_dTGround => out_vegNrgFlux % dGroundEvaporation_dTGround, & ! intent(out): [dp] derivative in ground evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) + ! output: transpiration derivatives + dCanopyTrans_dCanWat => out_vegNrgFlux % dCanopyTrans_dCanWat, & ! intent(out): [dp] derivative in canopy transpiration w.r.t. canopy total water content (s-1) + dCanopyTrans_dTCanair => out_vegNrgFlux % dCanopyTrans_dTCanair, & ! intent(out): [dp] derivative in canopy transpiration w.r.t. canopy air temperature (kg m-2 s-1 K-1) + dCanopyTrans_dTCanopy => out_vegNrgFlux % dCanopyTrans_dTCanopy, & ! intent(out): [dp] derivative in canopy transpiration w.r.t. canopy temperature (kg m-2 s-1 K-1) + dCanopyTrans_dTGround => out_vegNrgFlux % dCanopyTrans_dTGround, & ! intent(out): [dp] derivative in canopy transpiration w.r.t. ground temperature (kg m-2 s-1 K-1) + ! output: cross derivative terms + dCanopyNetFlux_dCanWat => out_vegNrgFlux % dCanopyNetFlux_dCanWat, & ! intent(out): [dp] derivative in net canopy fluxes w.r.t. canopy total water content (J kg-1 s-1) + dGroundNetFlux_dCanWat =>out_vegNrgFlux % dGroundNetFlux_dCanWat, & ! intent(out): [dp] derivative in net ground fluxes w.r.t. canopy total water content (J kg-1 s-1) + ! output: error control + err => out_vegNrgFlux % err, & ! intent(out): [i4b] error code + message => out_vegNrgFlux % cmessage & ! intent(out): [character] error message + ) + ! --------------------------------------------------------------------------------------- + ! initialize error control + err=0; message="vegNrgFlux/" + + ! identify the type of boundary condition for thermodynamics + select case(ix_bcUpprTdyn) + ! ***** + ! (1) DIRICHLET OR ZERO FLUX BOUNDARY CONDITION... + ! ** prescribed temperature or zero flux at the upper boundary of the snow-soil system + ! NOTE: Vegetation fluxes are not computed in this case + ! ************************************************ + case(prescribedTemp,zeroFlux) + ! derived fluxes + scalarTotalET = 0._rkind ! total ET (kg m-2 s-1) + scalarNetRadiation = 0._rkind ! net radiation (W m-2) + ! liquid water fluxes associated with evaporation/transpiration + scalarCanopyTranspiration = 0._rkind ! canopy transpiration (kg m-2 s-1) + scalarCanopyEvaporation = 0._rkind ! canopy evaporation/condensation (kg m-2 s-1) + scalarGroundEvaporation = 0._rkind ! ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) + ! solid water fluxes associated with sublimation/frost + scalarCanopySublimation = 0._rkind ! sublimation from the vegetation canopy ((kg m-2 s-1) + scalarSnowSublimation = 0._rkind ! sublimation from the snow surface ((kg m-2 s-1) + ! set canopy fluxes to zero (no canopy) + canairNetFlux = 0._rkind ! net energy flux for the canopy air space (W m-2) + canopyNetFlux = 0._rkind ! net energy flux for the vegetation canopy (W m-2) + ! set canopy derivatives to zero + dCanairNetFlux_dCanairTemp = 0._rkind ! derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) + dCanairNetFlux_dCanopyTemp = 0._rkind ! derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) + dCanairNetFlux_dGroundTemp = 0._rkind ! derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) + dCanopyNetFlux_dCanairTemp = 0._rkind ! derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) + dCanopyNetFlux_dCanopyTemp = 0._rkind ! derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) + dCanopyNetFlux_dGroundTemp = 0._rkind ! derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) + dGroundNetFlux_dCanairTemp = 0._rkind ! derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) + dGroundNetFlux_dCanopyTemp = 0._rkind ! derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) + ! set liquid flux derivatives to zero (canopy evap) + dCanopyEvaporation_dCanWat = 0._rkind ! derivative in canopy evaporation w.r.t. canopy total water content (s-1) + dCanopyEvaporation_dTCanair= 0._rkind ! derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + dCanopyEvaporation_dTCanopy= 0._rkind ! derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + dCanopyEvaporation_dTGround= 0._rkind ! derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) + ! set liquid flux derivatives to zero (ground evap) + dGroundEvaporation_dCanWat = 0._rkind ! derivative in ground evaporation w.r.t. canopy total water content (s-1) + dGroundEvaporation_dTCanair= 0._rkind ! derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + dGroundEvaporation_dTCanopy= 0._rkind ! derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + dGroundEvaporation_dTGround= 0._rkind ! derivative in ground evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) + ! set transpiration derivatives to zero + dCanopyTrans_dCanWat = 0._rkind ! derivative in canopy transpiration w.r.t. canopy total water content (s-1) + dCanopyTrans_dTCanair= 0._rkind ! derivative in canopy transpiration w.r.t. canopy air temperature (kg m-2 s-1 K-1) + dCanopyTrans_dTCanopy= 0._rkind ! derivative in canopy transpiration w.r.t. canopy temperature (kg m-2 s-1 K-1) + dCanopyTrans_dTGround= 0._rkind ! derivative in canopy transpiration w.r.t. ground temperature (kg m-2 s-1 K-1) + + ! compute fluxes and derivatives -- separate approach for prescribed temperature and zero flux, + ! derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) computed inside snow lake soil ice (snLaSoGl) energy flux routine + if (ix_bcUpprTdyn == prescribedTemp) then + groundNetFlux = -diag_data%var(iLookDIAG%iLayerThermalC)%dat(0)*(groundTempTrial - upperBoundTemp)/(prog_data%var(iLookPROG%mLayerDepth)%dat(1)*0.5_rkind) + elseif (ix_bcUpprTdyn == zeroFlux) then + groundNetFlux = 0._rkind + else + err=20; message=trim(message)//'unable to identify upper boundary condition for thermodynamics: expect the case to be prescribedTemp or zeroFlux'; return + end if + + ! ***** + ! (2) NEUMANN BOUNDARY CONDITION... + ! ** flux boundary condition + ! NOTE 1: This is the main routine for calculating vegetation fluxes + ! NOTE 2: This routine also calculates surface fluxes for the case where vegetation is buried with snow (or bare soil) + ! ************************************************ + case(energyFlux) + ! ***** PRELIMINARIES ***************************************************************************************************************************************** + ! identify the appropriate groundwater variable + select case(ix_spatial_gw) + case(singleBasin); scalarAquiferStorage = basinAquiferStorage + case(localColumn); scalarAquiferStorage = localAquiferStorage + case default; err=20; message=trim(message)//'unable to identify spatial representation of groundwater'; return + end select ! (modify the groundwater representation for this single-column implementation) + + ! set canopy stability corrections to the previous values + scalarCanopyStabilityCorrection_old = scalarCanopyStabilityCorrection ! stability correction for the canopy (-) + scalarGroundStabilityCorrection_old = scalarGroundStabilityCorrection ! stability correction for the ground surface (-) + + ! initialize variables to compute stomatal resistance + if (firstFluxCall .and. firstSubStep) then + ! vapor pressure in the canopy air space initialized as vapor pressure of air above the vegetation canopy + ! NOTE: this is needed for the stomatal resistance calculations + if (scalarVP_CanopyAir < 0._rkind) then + scalarVP_CanopyAir = scalarVPair - 1._rkind ! "small" offset used to assist in checking initial derivative calculations + end if + end if + + ! set latent heat of sublimation/vaporization for canopy and ground surface (Pa/K) + ! NOTE: variables are constant over the substep, to simplify relating energy and mass fluxes + if (firstFluxCall) then + scalarLatHeatSubVapCanopy = getLatentHeatValue(canopyTempTrial) + if (nSnow > 0) then ! case when there is snow on the ground (EXCLUDE "snow without a layer" -- in this case, evaporate from the soil) + if (groundTempTrial > Tfreeze) then; err=20; message=trim(message)//'do not expect ground temperature > 0 when snow is on the ground'; return; end if + scalarLatHeatSubVapGround = LH_sub ! sublimation from snow + else ! case when the ground is less than a layer of snow (e.g., bare soil or snow without a layer) + scalarLatHeatSubVapGround = LH_vap ! evaporation of water in the soil pores: this occurs even if frozen because of super-cooled water + end if ! (there is snow enough for a layer on the ground) + end if ! (first flux call) + + ! compute the roughness length of the ground (ground below the canopy or non-vegetated surface) + z0Ground = z0Soil*(1._rkind - scalarGroundSnowFraction) + z0Snow*scalarGroundSnowFraction ! roughness length (m) + + ! compute the total vegetation area index (leaf plus stem) + VAI = scalarLAI + scalarSAI ! vegetation area index + exposedVAI = scalarExposedLAI + scalarExposedSAI ! exposed vegetation area index + + ! compute emissivity of the canopy (-) + if (computeVegFlux) then + select case(ix_canopyEmis) + case(simplExp) ! *** simple exponential function + scalarCanopyEmissivity = 1._rkind - exp(-exposedVAI) ! effective emissivity of the canopy (-) + case(difTrans) ! *** canopy emissivity parameterized as a function of diffuse transmissivity + scaleLAI = 0.5_rkind*exposedVAI + expi = expInt(scaleLAI) ! compute the exponential integral + diffuseTrans = (1._rkind - scaleLAI)*exp(-scaleLAI) + (scaleLAI**2_i4b)*expi ! compute diffuse transmissivity (-) + scalarCanopyEmissivity = (1._rkind - diffuseTrans)*leafEmissivity ! compute the canopy emissivity + case default + err=20; message=trim(message)//'unable to identify option for canopy emissivity'; return + end select + end if + + ! ensure canopy longwave fluxes are zero when not computing canopy fluxes + if (.not.computeVegFlux) scalarCanopyEmissivity=0._rkind + + ! compute emissivity of the ground surface (-) + groundEmissivity = scalarGroundSnowFraction*snowEmissivity + (1._rkind - scalarGroundSnowFraction)*soilEmissivity ! emissivity of the ground surface (-) + + ! compute the fraction of canopy that is wet + ! NOTE: we either sublimate or evaporate over the entire substep + if (computeVegFlux) then + ! compute the fraction of liquid water in the canopy (-) + totalCanopyWater = canopyLiqTrial + canopyIceTrial + if (totalCanopyWater > tiny(1.0_rkind)) then + fracLiquidCanopy = canopyLiqTrial / totalCanopyWater + else + fracLiquidCanopy = 0._rkind + end if + + ! get wetted fraction and derivatives + call wettedFrac(& + ! input + .true., & ! flag to denote if derivative is desired + (scalarLatHeatSubVapCanopy > LH_vap+verySmall), & ! flag to denote if the canopy is frozen + dCanLiq_dTcanopy, & ! derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) + fracLiquidCanopy, & ! fraction of liquid water on the canopy (-) + canopyLiqTrial, & ! canopy liquid water (kg m-2) + canopyIceTrial, & ! canopy ice (kg m-2) + scalarCanopyLiqMax, & ! maximum canopy liquid water (kg m-2) + scalarCanopyIceMax, & ! maximum canopy ice content (kg m-2) + canopyWettingFactor, & ! maximum wetted fraction of the canopy (-) + canopyWettingExp, & ! exponent in canopy wetting function (-) + ! output + scalarCanopyWetFraction, & ! canopy wetted fraction (-) + dCanopyWetFraction_dWat, & ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) + dCanopyWetFraction_dT, & ! derivative in wetted fraction w.r.t. canopy temperature (K-1) + err,cmessage) + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if + else + scalarCanopyWetFraction = 0._rkind ! canopy wetted fraction (-) + dCanopyWetFraction_dWat = 0._rkind ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) + dCanopyWetFraction_dT = 0._rkind ! derivative in wetted fraction w.r.t. canopy temperature (K-1) + end if + + ! ***** AERODYNAMIC RESISTANCE ************************************************************************************************************************** + ! NOTE: compute for all iterations + ! Refs: Choudhury and Monteith (4-layer model for heat budget of homogenous surfaces; QJRMS, 1988) + ! Niu and Yang (Canopy effects on snow processes; JGR, 2004) + ! Mahat et al. (Below-canopy turbulence in a snowmelt model, WRR, 2012) + call aeroResist(& + ! input: model control + computeVegFlux, & ! intent(in): logical flag to compute vegetation fluxes (.false. if veg buried by snow) + ix_veg_traits, & ! intent(in): choice of parameterization for vegetation roughness length and displacement height + ix_windPrfile, & ! intent(in): choice of canopy wind profile + ix_astability, & ! intent(in): choice of stability function + ! input: above-canopy forcing data + mHeight, & ! intent(in): measurement height (m) + airtemp, & ! intent(in): air temperature at measurement height (K) + windspd, & ! intent(in): wind speed at measurement height (m s-1) + ! input: canopy and ground temperature + canairTempTrial, & ! intent(in): temperature of the canopy air space (K) + groundTempTrial, & ! intent(in): temperature of the ground surface (K) + ! input: diagnostic variables + exposedVAI, & ! intent(in): exposed vegetation area index -- leaf plus stem (m2 m-2) + scalarSnowDepth, & ! intent(in): snow depth (m) + ! input: parameters + z0Ground, & ! intent(in): roughness length of the ground (below canopy or non-vegetated surface [snow]) (m) + z0CanopyParam, & ! intent(in): roughness length of the canopy (m) + zpdFraction, & ! intent(in): zero plane displacement / canopy height (-) + critRichNumber, & ! intent(in): critical value for the bulk Richardson number where turbulence ceases (-) + Louis79_bparam, & ! intent(in): parameter in Louis (1979) stability function + Mahrt87_eScale, & ! intent(in): exponential scaling factor in the Mahrt (1987) stability function + windReductionParam, & ! intent(in): canopy wind reduction parameter (-) + leafExchangeCoeff, & ! intent(in): turbulent exchange coeff between canopy surface and canopy air ( m s-(1/2) ) + leafDimension, & ! intent(in): characteristic leaf dimension (m) + heightCanopyTop, & ! intent(in): height at the top of the vegetation canopy (m) + heightCanopyBottom, & ! intent(in): height at the bottom of the vegetation canopy (m) + ! output: stability corrections + scalarRiBulkCanopy, & ! intent(out): bulk Richardson number for the canopy (-) + scalarRiBulkGround, & ! intent(out): bulk Richardson number for the ground surface (-) + scalarCanopyStabilityCorrection, & ! intent(out): stability correction for the canopy (-) + scalarGroundStabilityCorrection, & ! intent(out): stability correction for the ground surface (-) + ! output: scalar resistances + scalarZ0Canopy, & ! intent(out): roughness length of the canopy (m) + scalarWindReductionFactor, & ! intent(out): canopy wind reduction factor (-) + scalarZeroPlaneDisplacement, & ! intent(out): zero plane displacement (m) + scalarEddyDiffusCanopyTop, & ! intent(out): eddy diffusivity for heat at the top of the canopy (m2 s-1) + scalarFrictionVelocity, & ! intent(out): friction velocity (m s-1) + scalarWindspdCanopyTop, & ! intent(out): windspeed at the top of the canopy (m s-1) + scalarWindspdCanopyBottom, & ! intent(out): windspeed at the height of the bottom of the canopy (m s-1) + scalarLeafResistance, & ! intent(out): mean leaf boundary layer resistance per unit leaf area (s m-1) + scalarGroundResistance, & ! intent(out): below canopy aerodynamic resistance (s m-1) + scalarCanopyResistance, & ! intent(out): above canopy aerodynamic resistance (s m-1) + ! output: derivatives in scalar resistances + dGroundResistance_dTGround, & ! intent(out): derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) + dGroundResistance_dTCanopy, & ! intent(out): derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + dGroundResistance_dTCanair, & ! intent(out): derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) + dCanopyResistance_dTCanopy, & ! intent(out): derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + dCanopyResistance_dTCanair, & ! intent(out): derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) + ! output: error control + err,cmessage ) ! intent(out): error control + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if + + ! ***** STOMATAL RESISTANCE ****************************************************************************************************************************** + ! stomatal resistance is constant over the SUBSTEP + ! NOTE: This is a simplification, as stomatal resistance does depend on canopy temperature + ! This is a "short-cut" made because: + ! (1) computations are expensive; + ! (2) derivative calculations are rather complex (iterations within the Ball-Berry routine); and + ! (3) stomatal resistance does not change rapidly + if (firstFluxCall) then + ! compute soil moisture factor controlling stomatal resistance + call soilResist(& + ! input (model decisions) + ix_soilStress, & ! intent(in): choice of function for the soil moisture control on stomatal resistance + ix_groundwatr, & ! intent(in): groundwater parameterization + ! input (state variables) + mLayerMatricHead(1:nSoil), & ! intent(in): matric head in each soil layer (m) + mLayerVolFracLiq(nSnow+1:nLayers), & ! intent(in): volumetric fraction of liquid water in each soil layer (-) + scalarAquiferStorage, & ! intent(in): aquifer storage (m) + ! input (diagnostic variables) + mLayerRootDensity(1:nSoil), & ! intent(in): root density in each layer (-) + scalarAquiferRootFrac, & ! intent(in): fraction of roots below the lowest soil layer (-) + ! input (parameters) + plantWiltPsi, & ! intent(in): matric head at wilting point (m) + soilStressParam, & ! intent(in): parameter in the exponential soil stress function (-) + critSoilWilting, & ! intent(in): critical vol. liq. water content when plants are wilting (-) + critSoilTranspire, & ! intent(in): critical vol. liq. water content when transpiration is limited (-) + critAquiferTranspire, & ! intent(in): critical aquifer storage value when transpiration is limited (m) + ! output + scalarTranspireLim, & ! intent(out): weighted average of the transpiration limiting factor (-) + mLayerTranspireLim(1:nSoil), & ! intent(out): transpiration limiting factor in each layer (-) + scalarTranspireLimAqfr, & ! intent(out): transpiration limiting factor for the aquifer (-) + err,cmessage ) ! intent(out): error control + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if + + ! compute the saturation vapor pressure for vegetation temperature + TV_celcius = canopyTempTrial - Tfreeze + call satVapPress(TV_celcius, scalarSatVP_CanopyTemp, dSVPCanopy_dCanopyTemp) + ! compute stomatal resistance + call stomResist(& + ! input (state and diagnostic variables) + canopyTempTrial, & ! intent(in): temperature of the vegetation canopy (K) + scalarSatVP_CanopyTemp, & ! intent(in): saturation vapor pressure at the temperature of the veg canopy (Pa) + scalarVP_CanopyAir, & ! intent(in): canopy air vapor pressure (Pa) + ! input: data structures + type_data, & ! intent(in): type of vegetation and soil + forc_data, & ! intent(in): model forcing data + mpar_data, & ! intent(in): model parameters + model_decisions, & ! intent(in): model decisions + ! input-output: data structures + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + flux_data, & ! intent(inout): model fluxes for a local HRU + ! output: error control + err,cmessage ) ! intent(out): error control + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if + end if ! end if the first flux call in a given sub-step + + ! ***** LONGWAVE RADIATION **************************************************************************************************************************** + ! compute canopy longwave radiation balance + call longwaveBal(& + ! input: model control + computeVegFlux, & ! intent(in): flag to compute fluxes over vegetation + checkLWBalance, & ! intent(in): flag to check longwave balance + ! input: canopy and ground temperature + canopyTempTrial, & ! intent(in): temperature of the vegetation canopy (K) + groundTempTrial, & ! intent(in): temperature of the ground surface (K) + ! input: canopy and ground emissivity + scalarCanopyEmissivity, & ! intent(in): canopy emissivity (-) + groundEmissivity, & ! intent(in): ground emissivity (-) + ! input: forcing + LWRadAtm, & ! intent(in): downwelling longwave radiation at the upper boundary (W m-2) + ! output: emitted radiation from the canopy and ground + scalarLWRadCanopy, & ! intent(out): longwave radiation emitted from the canopy (W m-2) + scalarLWRadGround, & ! intent(out): longwave radiation emitted at the ground surface (W m-2) + ! output: individual fluxes + scalarLWRadUbound2Canopy, & ! intent(out): downward atmospheric longwave radiation absorbed by the canopy (W m-2) + scalarLWRadUbound2Ground, & ! intent(out): downward atmospheric longwave radiation absorbed by the ground (W m-2) + scalarLWRadUbound2Ubound, & ! intent(out): atmospheric radiation reflected by the ground and lost thru upper boundary (W m-2) + scalarLWRadCanopy2Ubound, & ! intent(out): longwave radiation emitted from canopy lost thru upper boundary (W m-2) + scalarLWRadCanopy2Ground, & ! intent(out): longwave radiation emitted from canopy absorbed by the ground (W m-2) + scalarLWRadCanopy2Canopy, & ! intent(out): canopy longwave reflected from ground and absorbed by the canopy (W m-2) + scalarLWRadGround2Ubound, & ! intent(out): longwave radiation emitted from ground lost thru upper boundary (W m-2) + scalarLWRadGround2Canopy, & ! intent(out): longwave radiation emitted from ground and absorbed by the canopy (W m-2) + ! output: net fluxes + scalarLWNetCanopy, & ! intent(out): net longwave radiation at the canopy (W m-2) + scalarLWNetGround, & ! intent(out): net longwave radiation at the ground surface (W m-2) + scalarLWNetUbound, & ! intent(out): net longwave radiation at the upper boundary (W m-2) + ! output: flux derivatives + dLWNetCanopy_dTCanopy, & ! intent(out): derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) + dLWNetGround_dTGround, & ! intent(out): derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) + dLWNetCanopy_dTGround, & ! intent(out): derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) + dLWNetGround_dTCanopy, & ! intent(out): derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) + ! output: error control + err,cmessage ) ! intent(out): error control + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if + + ! ***** TURBULENT HEAT FLUXES ************************************************************************************************************************** + ! compute the saturation vapor pressure for vegetation temperature + ! NOTE: saturated vapor pressure derivatives don't seem that accurate.... + TV_celcius = canopyTempTrial - Tfreeze + call satVapPress(TV_celcius, scalarSatVP_CanopyTemp, dSVPCanopy_dCanopyTemp) + + ! compute the saturation vapor pressure for ground temperature + ! NOTE: saturated vapor pressure derivatives don't seem that accurate.... + TG_celcius = groundTempTrial - Tfreeze + call satVapPress(TG_celcius, scalarSatVP_GroundTemp, dSVPGround_dGroundTemp) + + ! compute the relative humidity in the top soil layer and the resistance at the ground surface + ! NOTE: computations are based on start-of-step values, so only compute for the first flux call + if (firstFluxCall) then + ! soil water evaporation factor [0-1] + soilEvapFactor = mLayerVolFracLiq(nSnow+1)/(theta_sat - theta_res) + ! resistance from the soil [s m-1] + scalarSoilResistance = scalarGroundSnowFraction*1._rkind + (1._rkind - scalarGroundSnowFraction)*EXP(8.25_rkind - 4.225_rkind*soilEvapFactor) ! Sellers (1992) + !scalarSoilResistance = scalarGroundSnowFraction*0._rkind + (1._rkind - scalarGroundSnowFraction)*exp(8.25_rkind - 6.0_rkind*soilEvapFactor) ! Niu adjustment to decrease resitance for wet soil + ! relative humidity in the soil pores [0-1] + if (mLayerMatricHead(1) > -1.e+6_rkind) then ! avoid problems with numerical precision when soil is very dry + if (groundTempTrial < 0._rkind) then + soilRelHumidity_noSnow = exp( (mLayerMatricHead(1)*gravity) / (groundTempTrial*R_wv) ) + if (soilRelHumidity_noSnow > 1._rkind) then; soilRelHumidity_noSnow = 1._rkind; end if + else + soilRelHumidity_noSnow = 1._rkind + end if ! end if ground temperature is positive + else + soilRelHumidity_noSnow = 0._rkind + end if ! end if matric head is very low + ! scalarSoilRelHumidity = scalarGroundSnowFraction*1._rkind + (1._rkind - scalarGroundSnowFraction)*soilRelHumidity_noSnow ! original + scalarSoilRelHumidity = scalarGroundSnowFraction + (1._rkind - scalarGroundSnowFraction)*soilRelHumidity_noSnow ! factor of unity removed for speed + end if ! end if the first flux call + + ! compute turbulent heat fluxes + call turbFluxes(& + ! input: model control + computeVegFlux, & ! intent(in): logical flag to compute vegetation fluxes (.false. if veg buried by snow) + ! input: above-canopy forcing data + airtemp, & ! intent(in): air temperature of the air above the vegetation canopy (K) + airpres, & ! intent(in): air pressure of the air above the vegetation canopy (Pa) + scalarVPair, & ! intent(in): vapor pressure of the air above the vegetation canopy (Pa) + ! input: latent heat of sublimation/vaporization + scalarLatHeatSubVapCanopy, & ! intent(in): latent heat of sublimation/vaporization for the vegetation canopy (J kg-1) + scalarLatHeatSubVapGround, & ! intent(in): latent heat of sublimation/vaporization for the ground surface (J kg-1) + ! input: canopy/ground temperature and saturated vapor pressure + canairTempTrial, & ! intent(in): temperature of the canopy air space (K) + canopyTempTrial, & ! intent(in): canopy temperature (K) + groundTempTrial, & ! intent(in): ground temperature (K) + scalarSatVP_CanopyTemp, & ! intent(in): saturation vapor pressure at the temperature of the veg canopy (Pa) + scalarSatVP_GroundTemp, & ! intent(in): saturation vapor pressure at the temperature of the ground (Pa) + dSVPCanopy_dCanopyTemp, & ! intent(in): derivative in canopy saturation vapor pressure w.r.t. canopy temperature (Pa K-1) + dSVPGround_dGroundTemp, & ! intent(in): derivative in ground saturation vapor pressure w.r.t. ground temperature (Pa K-1) + ! input: diagnostic variables + exposedVAI, & ! intent(in): exposed vegetation area index -- leaf plus stem (m2 m-2) + scalarCanopyWetFraction, & ! intent(in): trial value for the fraction of canopy that is wet [0-1] + dCanopyWetFraction_dWat, & ! intent(in): derivative in the canopy wetted fraction w.r.t. total water content (kg-1 m-2) + dCanopyWetFraction_dT, & ! intent(in): derivative in wetted fraction w.r.t. canopy temperature (K-1) + scalarCanopySunlitLAI, & ! intent(in): sunlit leaf area (-) + scalarCanopyShadedLAI, & ! intent(in): shaded leaf area (-) + scalarSoilRelHumidity, & ! intent(in): relative humidity in the soil pores [0-1] + scalarSoilResistance, & ! intent(in): resistance from the soil (s m-1) + scalarLeafResistance, & ! intent(in): mean leaf boundary layer resistance per unit leaf area (s m-1) + scalarGroundResistance, & ! intent(in): below canopy aerodynamic resistance (s m-1) + scalarCanopyResistance, & ! intent(in): above canopy aerodynamic resistance (s m-1) + scalarStomResistSunlit, & ! intent(in): stomatal resistance for sunlit leaves (s m-1) + scalarStomResistShaded, & ! intent(in): stomatal resistance for shaded leaves (s m-1) + ! input: derivatives in scalar resistances + dGroundResistance_dTGround, & ! intent(in): derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) + dGroundResistance_dTCanopy, & ! intent(in): derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + dGroundResistance_dTCanair, & ! intent(in): derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) + dCanopyResistance_dTCanopy, & ! intent(in): derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + dCanopyResistance_dTCanair, & ! intent(in): derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) + ! output: conductances (used to check derivative calculations) + scalarLeafConductance, & ! intent(out): leaf conductance (m s-1) + scalarCanopyConductance, & ! intent(out): canopy conductance (m s-1) + scalarGroundConductanceSH, & ! intent(out): ground conductance for sensible heat (m s-1) + scalarGroundConductanceLH, & ! intent(out): ground conductance for latent heat -- includes soil resistance (m s-1) + scalarEvapConductance, & ! intent(out): conductance for evaporation (m s-1) + scalarTransConductance, & ! intent(out): conductance for transpiration (m s-1) + scalarTotalConductanceSH, & ! intent(out): total conductance for sensible heat (m s-1) + scalarTotalConductanceLH, & ! intent(out): total conductance for latent heat (m s-1) + ! output: canopy air space variables + scalarVP_CanopyAir, & ! intent(out): vapor pressure of the canopy air space (Pa) + ! output: fluxes from the vegetation canopy + scalarSenHeatCanopy, & ! intent(out): sensible heat flux from the canopy to the canopy air space (W m-2) + scalarLatHeatCanopyEvap, & ! intent(out): latent heat flux associated with evaporation from the canopy to the canopy air space (W m-2) + scalarLatHeatCanopyTrans, & ! intent(out): latent heat flux associated with transpiration from the canopy to the canopy air space (W m-2) + ! output: fluxes from non-vegetated surfaces (ground surface below vegetation, bare ground, or snow covered vegetation) + scalarSenHeatGround, & ! intent(out): sensible heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) + scalarLatHeatGround, & ! intent(out): latent heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) + ! output: total heat fluxes to the atmosphere + scalarSenHeatTotal, & ! intent(out): total sensible heat flux to the atmosphere (W m-2) + scalarLatHeatTotal, & ! intent(out): total latent heat flux to the atmosphere (W m-2) + ! output: net fluxes + turbFluxCanair, & ! intent(out): net turbulent heat fluxes at the canopy air space (W m-2) + turbFluxCanopy, & ! intent(out): net turbulent heat fluxes at the canopy (W m-2) + turbFluxGround, & ! intent(out): net turbulent heat fluxes at the ground surface (W m-2) + ! output: energy flux derivatives + dTurbFluxCanair_dTCanair, & ! intent(out): derivative in net canopy air space fluxes w.r.t. canopy air temperature (W m-2 K-1) + dTurbFluxCanair_dTCanopy, & ! intent(out): derivative in net canopy air space fluxes w.r.t. canopy temperature (W m-2 K-1) + dTurbFluxCanair_dTGround, & ! intent(out): derivative in net canopy air space fluxes w.r.t. ground temperature (W m-2 K-1) + dTurbFluxCanopy_dTCanair, & ! intent(out): derivative in net canopy turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) + dTurbFluxCanopy_dTCanopy, & ! intent(out): derivative in net canopy turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) + dTurbFluxCanopy_dTGround, & ! intent(out): derivative in net canopy turbulent fluxes w.r.t. ground temperature (W m-2 K-1) + dTurbFluxGround_dTCanair, & ! intent(out): derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) + dTurbFluxGround_dTCanopy, & ! intent(out): derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) + dTurbFluxGround_dTGround, & ! intent(out): derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) + ! output: liquid flux derivatives (canopy evap) + dLatHeatCanopyEvap_dCanWat, & ! intent(out): derivative in latent heat of canopy evaporation w.r.t. canopy total water content (W kg-1) + dLatHeatCanopyEvap_dTCanair, & ! intent(out): derivative in latent heat of canopy evaporation w.r.t. canopy air temperature (W m-2 K-1) + dLatHeatCanopyEvap_dTCanopy, & ! intent(out): derivative in latent heat of canopy evaporation w.r.t. canopy temperature (W m-2 K-1) + dLatHeatCanopyEvap_dTGround, & ! intent(out): derivative in latent heat of canopy evaporation w.r.t. ground temperature (W m-2 K-1) + ! output: liquid flux derivatives (ground evap) + dLatHeatGroundEvap_dCanWat, & ! intent(out): derivative in latent heat of ground evaporation w.r.t. canopy total water content (J kg-1 s-1) + dLatHeatGroundEvap_dTCanair, & ! intent(out): derivative in latent heat of ground evaporation w.r.t. canopy air temperature + dLatHeatGroundEvap_dTCanopy, & ! intent(out): derivative in latent heat of ground evaporation w.r.t. canopy temperature + dLatHeatGroundEvap_dTGround, & ! intent(out): derivative in latent heat of ground evaporation w.r.t. ground temperature + ! output: latent heat flux derivatives (canopy trans) + dLatHeatCanopyTrans_dCanWat, & ! intent(out): derivative in the latent heat of canopy transpiration w.r.t. canopy total water (J kg-1 s-1) + dLatHeatCanopyTrans_dTCanair, & ! intent(out): derivative in the latent heat of canopy transpiration w.r.t. canopy air temperature + dLatHeatCanopyTrans_dTCanopy, & ! intent(out): derivative in the latent heat of canopy transpiration w.r.t. canopy temperature + dLatHeatCanopyTrans_dTGround, & ! intent(out): derivative in the latent heat of canopy transpiration w.r.t. ground temperature + ! output: cross derivatives + dTurbFluxCanair_dCanWat, & ! intent(out): derivative in net canopy air space fluxes w.r.t. canopy total water content (J kg-1 s-1) + dTurbFluxCanopy_dCanWat, & ! intent(out): derivative in net canopy turbulent fluxes w.r.t. canopy total water content (J kg-1 s-1) + dTurbFluxGround_dCanWat, & ! intent(out): derivative in net ground turbulent fluxes w.r.t. canopy total water content (J kg-1 s-1) + ! output: error control + err,cmessage ) ! intent(out): error control + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if + + ! compute the heat advected with precipitation (W m-2) + ! NOTE: fluxes are in kg m-2 s-1, so no need to use density of water/ice here + scalarCanopyAdvectiveHeatFlux = -Cp_water*(scalarRainfall - scalarThroughfallRain)*(canopyTempTrial - scalarTwetbulb) + & + (-Cp_ice)*(scalarSnowfall - scalarThroughfallSnow)*(canopyTempTrial - scalarTwetbulb) + scalarGroundAdvectiveHeatFlux = -Cp_water*scalarThroughfallRain*(groundTempTrial - scalarTwetbulb) + & + (-Cp_ice)*scalarThroughfallSnow*(groundTempTrial - scalarTwetbulb) + + ! compute the mass flux associated with transpiration and evaporation/sublimation (J m-2 s-1 --> kg m-2 s-1) + ! NOTE: remove water from the snow on the ground in preference to removing water from the water in soil pores + if (scalarLatHeatSubVapCanopy > LH_vap+verySmall) then ! canopy sublimation + scalarCanopyEvaporation = 0._rkind + scalarCanopySublimation = scalarLatHeatCanopyEvap/LH_sub + if (scalarLatHeatCanopyTrans > 0._rkind) then ! flux directed towards the veg + scalarCanopySublimation = scalarCanopySublimation + scalarLatHeatCanopyTrans/LH_sub ! frost + scalarCanopyTranspiration = 0._rkind + else + scalarCanopyTranspiration = scalarLatHeatCanopyTrans/LH_vap ! transpiration is always vapor + end if + else ! canopy evaporation + scalarCanopyEvaporation = scalarLatHeatCanopyEvap/LH_vap + scalarCanopySublimation = 0._rkind + if (scalarLatHeatCanopyTrans > 0._rkind) then ! flux directed towards the veg + scalarCanopyEvaporation = scalarCanopyEvaporation + scalarLatHeatCanopyTrans/LH_vap + scalarCanopyTranspiration = 0._rkind + else + scalarCanopyTranspiration = scalarLatHeatCanopyTrans/LH_vap + end if + end if + if (scalarLatHeatSubVapGround > LH_vap+verySmall) then ! ground sublimation + ! NOTE: this should only occur when we have formed snow layers, so check + if (nSnow == 0) then; err=20; message=trim(message)//'only expect snow sublimation when we have formed some snow layers'; return; end if + scalarGroundEvaporation = 0._rkind ! ground evaporation is zero once the snowpack has formed + scalarSnowSublimation = scalarLatHeatGround/LH_sub + else + ! NOTE: this should only occur when we have no snow layers, so check + if (nSnow > 0) then; err=20; message=trim(message)//'only expect ground evaporation when there are no snow layers'; return; end if + scalarGroundEvaporation = scalarLatHeatGround/LH_vap + scalarSnowSublimation = 0._rkind ! no sublimation from snow if no snow layers have formed + end if + + ! ***** AND STITCH EVERYTHING TOGETHER ***************************************************************************************************************** + + ! compute derived fluxes + scalarTotalET = scalarGroundEvaporation + scalarCanopyEvaporation + scalarCanopyTranspiration + scalarNetRadiation = scalarCanopyAbsorbedSolar + scalarLWNetCanopy + scalarGroundAbsorbedSolar + scalarLWNetGround + + ! compute net fluxes at the canopy and ground surface + canairNetFlux = turbFluxCanair + canopyNetFlux = scalarCanopyAbsorbedSolar + scalarLWNetCanopy + turbFluxCanopy + scalarCanopyAdvectiveHeatFlux + groundNetFlux = scalarGroundAbsorbedSolar + scalarLWNetGround + turbFluxGround + scalarGroundAdvectiveHeatFlux + + ! compute the energy derivatives + dCanairNetFlux_dCanairTemp = dTurbFluxCanair_dTCanair + dCanairNetFlux_dCanopyTemp = dTurbFluxCanair_dTCanopy + dCanairNetFlux_dGroundTemp = dTurbFluxCanair_dTGround + dCanopyNetFlux_dCanairTemp = dTurbFluxCanopy_dTCanair + dCanopyNetFlux_dCanopyTemp = dLWNetCanopy_dTCanopy + dTurbFluxCanopy_dTCanopy - Cp_water*(scalarRainfall - scalarThroughfallRain) - Cp_ice*(scalarSnowfall - scalarThroughfallSnow) + dCanopyNetFlux_dGroundTemp = dLWNetCanopy_dTGround + dTurbFluxCanopy_dTGround + dGroundNetFlux_dCanairTemp = dTurbFluxGround_dTCanair + dGroundNetFlux_dCanopyTemp = dLWNetGround_dTCanopy + dTurbFluxGround_dTCanopy + dGroundNetFlux_dGroundTemp = dLWNetGround_dTGround + dTurbFluxGround_dTGround - Cp_water*scalarThroughfallRain - Cp_ice*scalarThroughfallSnow + + ! check if evaporation or sublimation + if (scalarLatHeatSubVapCanopy < LH_vap+verySmall) then ! evaporation + ! compute the liquid water derivarives + dCanopyEvaporation_dCanWat = dLatHeatCanopyEvap_dCanWat/LH_vap ! (s-1) + dCanopyEvaporation_dTCanair = dLatHeatCanopyEvap_dTCanair/LH_vap ! (kg m-2 s-1 K-1) + dCanopyEvaporation_dTCanopy = dLatHeatCanopyEvap_dTCanopy/LH_vap ! (kg m-2 s-1 K-1) + dCanopyEvaporation_dTGround = dLatHeatCanopyEvap_dTGround/LH_vap ! (kg m-2 s-1 K-1) + else ! sublimation + dCanopyEvaporation_dCanWat = 0._rkind ! (s-1) + dCanopyEvaporation_dTCanair = 0._rkind ! (kg m-2 s-1 K-1) + dCanopyEvaporation_dTCanopy = 0._rkind ! (kg m-2 s-1 K-1) + dCanopyEvaporation_dTGround = 0._rkind ! (kg m-2 s-1 K-1) + end if + + ! transpiration + if (scalarLatHeatCanopyTrans > 0._rkind) then ! flux directed towards the veg + dCanopyTrans_dCanWat = 0._rkind + dCanopyTrans_dTCanair= 0._rkind + dCanopyTrans_dTCanopy= 0._rkind + dCanopyTrans_dTGround= 0._rkind + else + dCanopyTrans_dCanWat= dLatHeatCanopyTrans_dCanWat/LH_vap ! transpiration is always vapor + dCanopyTrans_dTCanair= dLatHeatCanopyTrans_dTCanair/LH_vap + dCanopyTrans_dTCanopy= dLatHeatCanopyTrans_dTCanopy/LH_vap + dCanopyTrans_dTGround= dLatHeatCanopyTrans_dTGround/LH_vap + end if + + ! compute the liquid water derivarives (ground evap) + dGroundEvaporation_dCanWat = dLatHeatGroundEvap_dCanWat/LH_vap ! (s-1) + dGroundEvaporation_dTCanair = dLatHeatGroundEvap_dTCanair/LH_vap ! (kg m-2 s-1 K-1) + dGroundEvaporation_dTCanopy = dLatHeatGroundEvap_dTCanopy/LH_vap ! (kg m-2 s-1 K-1) + dGroundEvaporation_dTGround = dLatHeatGroundEvap_dTGround/LH_vap ! (kg m-2 s-1 K-1) + + ! compute the cross derivative terms (only related to turbulent fluxes; specifically canopy evaporation and transpiration) + dCanopyNetFlux_dCanWat = dTurbFluxCanopy_dCanWat ! derivative in net canopy fluxes w.r.t. canopy total water content (J kg-1 s-1) + dGroundNetFlux_dCanWat = dTurbFluxGround_dCanWat ! derivative in net ground fluxes w.r.t. canopy total water content (J kg-1 s-1) + + ! * check upper boundary condition + case default; err=10; message=trim(message)//'unable to identify upper boundary condition for thermodynamics'; return + ! end case statement + end select ! upper boundary condition for thermodynamics + + ! return liquid fluxes (needed for coupling) + returnCanopyTranspiration = scalarCanopyTranspiration ! canopy transpiration (kg m-2 s-1) + returnCanopyEvaporation = scalarCanopyEvaporation ! canopy evaporation/condensation (kg m-2 s-1) + returnGroundEvaporation = scalarGroundEvaporation ! ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) + + end associate ! end associations + +end subroutine vegNrgFlux + +! ******************************************************************************************************* +! public subroutine wettedFrac: compute wetted fraction of the canopy +! ******************************************************************************************************* +subroutine wettedFrac(& + ! input + deriv, & ! flag to denote if derivative is desired + frozen, & ! flag to denote if the canopy is frozen + dLiq_dT, & ! derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) + fracLiq, & ! fraction of liquid water on the canopy (-) + canopyLiq, & ! canopy liquid water (kg m-2) + canopyIce, & ! canopy ice (kg m-2) + canopyLiqMax, & ! maximum canopy liquid water (kg m-2) + canopyIceMax, & ! maximum canopy ice content (kg m-2) + canopyWettingFactor, & ! maximum wetted fraction of the canopy (-) + canopyWettingExp, & ! exponent in canopy wetting function (-) + ! output + canopyWetFraction, & ! canopy wetted fraction (-) + dCanopyWetFraction_dWat,& ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) + dCanopyWetFraction_dT, & ! derivative in wetted fraction w.r.t. canopy temperature (K-1) + err,message) ! error control + implicit none + ! input + logical(lgt),intent(in) :: deriv ! flag to denote if derivative is desired + logical(lgt),intent(in) :: frozen ! flag to denote if the canopy is frozen + real(rkind),intent(in) :: dLiq_dT ! derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) + real(rkind),intent(in) :: fracLiq ! fraction of liquid water on the canopy (-) + real(rkind),intent(in) :: canopyLiq ! canopy liquid water (kg m-2) + real(rkind),intent(in) :: canopyIce ! canopy ice (kg m-2) + real(rkind),intent(in) :: canopyLiqMax ! maximum canopy liquid water (kg m-2) + real(rkind),intent(in) :: canopyIceMax ! maximum canopy ice content (kg m-2) + real(rkind),intent(in) :: canopyWettingFactor ! maximum wetted fraction of the canopy (-) + real(rkind),intent(in) :: canopyWettingExp ! exponent in canopy wetting function (-) + ! output + real(rkind),intent(out) :: canopyWetFraction ! canopy wetted fraction (-) + real(rkind),intent(out) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) + real(rkind),intent(out) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! local variables + logical(lgt),parameter :: smoothing=.true. ! flag to denote that smoothing is required + real(rkind) :: canopyWetFractionDeriv ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) + ! ----------------------------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message='wettedFrac/' + + ! compute case where the canopy is frozen + if (frozen) then + ! compute fraction of liquid water on the canopy + call wetFraction(deriv,smoothing,canopyIce,canopyIceMax,canopyWettingFactor,canopyWettingExp,canopyWetFraction,canopyWetFractionDeriv) + + ! scale derivative by the fraction of water + ! NOTE: dIce/dWat = (1._rkind - fracLiq), hence dWet/dWat = dIce/dWat . dWet/dLiq + dCanopyWetFraction_dWat = canopyWetFractionDeriv*(1._rkind - fracLiq) + dCanopyWetFraction_dT = -canopyWetFractionDeriv*dLiq_dT ! NOTE: dIce/dT = -dLiq/dT + return + end if - ! compute the fraction of liquid water in the canopy (-) - totalCanopyWater = canopyLiqTrial + canopyIceTrial - if(totalCanopyWater > tiny(1.0_rkind))then - fracLiquidCanopy = canopyLiqTrial / (canopyLiqTrial + canopyIceTrial) - else - fracLiquidCanopy = 0._rkind - end if + ! compute fraction of liquid water on the canopy + ! NOTE: if(.not.deriv) canopyWetFractionDeriv = 0._rkind + call wetFraction(deriv,smoothing,canopyLiq,canopyLiqMax,canopyWettingFactor,canopyWettingExp,canopyWetFraction,canopyWetFractionDeriv) - ! get wetted fraction and derivatives - call wettedFrac(& - ! input - .true., & ! flag to denote if derivative is desired - (ix_fDerivMeth == numerical), & ! flag to denote that numerical derivatives are required (otherwise, analytical derivatives are calculated) - (scalarLatHeatSubVapCanopy > LH_vap+verySmall), & ! flag to denote if the canopy is frozen - dCanLiq_dTcanopy, & ! derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) - fracLiquidCanopy, & ! fraction of liquid water on the canopy (-) - canopyLiqTrial, & ! canopy liquid water (kg m-2) - canopyIceTrial, & ! canopy ice (kg m-2) - scalarCanopyLiqMax, & ! maximum canopy liquid water (kg m-2) - scalarCanopyIceMax, & ! maximum canopy ice content (kg m-2) - canopyWettingFactor, & ! maximum wetted fraction of the canopy (-) - canopyWettingExp, & ! exponent in canopy wetting function (-) - ! output - scalarCanopyWetFraction, & ! canopy wetted fraction (-) - dCanopyWetFraction_dWat, & ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) - dCanopyWetFraction_dT, & ! derivative in wetted fraction w.r.t. canopy temperature (K-1) - err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if - - else - scalarCanopyWetFraction = 0._rkind ! canopy wetted fraction (-) - dCanopyWetFraction_dWat = 0._rkind ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) - dCanopyWetFraction_dT = 0._rkind ! derivative in wetted fraction w.r.t. canopy temperature (K-1) - end if - !write(*,'(a,1x,L1,1x,f25.15,1x))') 'computeVegFlux, scalarCanopyWetFraction = ', computeVegFlux, scalarCanopyWetFraction - !print*, 'dCanopyWetFraction_dWat = ', dCanopyWetFraction_dWat - !print*, 'dCanopyWetFraction_dT = ', dCanopyWetFraction_dT - !print*, 'canopyLiqTrial = ', canopyLiqTrial - !print*, 'canopyIceTrial = ', canopyIceTrial - !print*, 'scalarCanopyLiqMax = ', scalarCanopyLiqMax - !print*, 'scalarCanopyIceMax = ', scalarCanopyIceMax - - ! ******************************************************************************************************************************************************************* - ! ******************************************************************************************************************************************************************* - ! ***** AERODYNAMIC RESISTANCE ***************************************************************************************************************************************** - ! ******************************************************************************************************************************************************************* - ! ******************************************************************************************************************************************************************* - - ! NOTE: compute for all iterations - - ! compute aerodynamic resistances - ! Refs: Choudhury and Monteith (4-layer model for heat budget of homogenous surfaces; QJRMS, 1988) - ! Niu and Yang (Canopy effects on snow processes; JGR, 2004) - ! Mahat et al. (Below-canopy turbulence in a snowmelt model, WRR, 2012) - call aeroResist(& - ! input: model control - computeVegFlux, & ! intent(in): logical flag to compute vegetation fluxes (.false. if veg buried by snow) - (ix_fDerivMeth == analytical), & ! intent(in): logical flag if would like to compute analytical derivaties - ix_veg_traits, & ! intent(in): choice of parameterization for vegetation roughness length and displacement height - ix_windPrfile, & ! intent(in): choice of canopy wind profile - ix_astability, & ! intent(in): choice of stability function - ! input: above-canopy forcing data - mHeight, & ! intent(in): measurement height (m) - airtemp, & ! intent(in): air temperature at some height above the surface (K) - windspd, & ! intent(in): wind speed at some height above the surface (m s-1) - ! input: canopy and ground temperature - canairTempTrial, & ! intent(in): temperature of the canopy air space (K) - groundTempTrial, & ! intent(in): temperature of the ground surface (K) - ! input: diagnostic variables - exposedVAI, & ! intent(in): exposed vegetation area index -- leaf plus stem (m2 m-2) - scalarSnowDepth, & ! intent(in): snow depth (m) - ! input: parameters - z0Ground, & ! intent(in): roughness length of the ground (below canopy or non-vegetated surface [snow]) (m) - z0CanopyParam, & ! intent(in): roughness length of the canopy (m) - zpdFraction, & ! intent(in): zero plane displacement / canopy height (-) - critRichNumber, & ! intent(in): critical value for the bulk Richardson number where turbulence ceases (-) - Louis79_bparam, & ! intent(in): parameter in Louis (1979) stability function - Mahrt87_eScale, & ! intent(in): exponential scaling factor in the Mahrt (1987) stability function - windReductionParam, & ! intent(in): canopy wind reduction parameter (-) - leafExchangeCoeff, & ! intent(in): turbulent exchange coeff between canopy surface and canopy air ( m s-(1/2) ) - leafDimension, & ! intent(in): characteristic leaf dimension (m) - heightCanopyTop, & ! intent(in): height at the top of the vegetation canopy (m) - heightCanopyBottom, & ! intent(in): height at the bottom of the vegetation canopy (m) - ! output: stability corrections - scalarRiBulkCanopy, & ! intent(out): bulk Richardson number for the canopy (-) - scalarRiBulkGround, & ! intent(out): bulk Richardson number for the ground surface (-) - scalarCanopyStabilityCorrection, & ! intent(out): stability correction for the canopy (-) - scalarGroundStabilityCorrection, & ! intent(out): stability correction for the ground surface (-) - ! output: scalar resistances - scalarZ0Canopy, & ! intent(out): roughness length of the canopy (m) - scalarWindReductionFactor, & ! intent(out): canopy wind reduction factor (-) - scalarZeroPlaneDisplacement, & ! intent(out): zero plane displacement (m) - scalarEddyDiffusCanopyTop, & ! intent(out): eddy diffusivity for heat at the top of the canopy (m2 s-1) - scalarFrictionVelocity, & ! intent(out): friction velocity (m s-1) - scalarWindspdCanopyTop, & ! intent(out): windspeed at the top of the canopy (m s-1) - scalarWindspdCanopyBottom, & ! intent(out): windspeed at the height of the bottom of the canopy (m s-1) - scalarLeafResistance, & ! intent(out): mean leaf boundary layer resistance per unit leaf area (s m-1) - scalarGroundResistance, & ! intent(out): below canopy aerodynamic resistance (s m-1) - scalarCanopyResistance, & ! intent(out): above canopy aerodynamic resistance (s m-1) - ! output: derivatives in scalar resistances - dGroundResistance_dTGround, & ! intent(out): derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) - dGroundResistance_dTCanopy, & ! intent(out): derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) - dGroundResistance_dTCanair, & ! intent(out): derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) - dCanopyResistance_dTCanopy, & ! intent(out): derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - dCanopyResistance_dTCanair, & ! intent(out): derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) - ! output: error control - err,cmessage ) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if - !print*, scalarLeafResistance, & ! mean leaf boundary layer resistance per unit leaf area (s m-1) - ! scalarGroundResistance, & ! below canopy aerodynamic resistance (s m-1) - ! scalarCanopyResistance, & ! above canopy aerodynamic resistance (s m-1) - ! '(leaf, ground, canopy)' - - ! ******************************************************************************************************************************************************************* - ! ******************************************************************************************************************************************************************* - ! ***** STOMATAL RESISTANCE ***************************************************************************************************************************************** - ! ******************************************************************************************************************************************************************* - ! ******************************************************************************************************************************************************************* - - ! stomatal resistance is constant over the SUBSTEP - ! NOTE: This is a simplification, as stomatal resistance does depend on canopy temperature - ! This "short-cut" made because: - ! (1) computations are expensive; - ! (2) derivative calculations are rather complex (iterations within the Ball-Berry routine); and - ! (3) stomatal resistance does not change rapidly - if(firstFluxCall)then - - ! compute the saturation vapor pressure for vegetation temperature - TV_celcius = canopyTempTrial - Tfreeze - call satVapPress(TV_celcius, scalarSatVP_CanopyTemp, dSVPCanopy_dCanopyTemp) - - ! compute soil moisture factor controlling stomatal resistance - call soilResist(& - ! input (model decisions) - ix_soilStress, & ! intent(in): choice of function for the soil moisture control on stomatal resistance - ix_groundwatr, & ! intent(in): groundwater parameterization - ! input (state variables) - mLayerMatricHead(1:nSoil), & ! intent(in): matric head in each soil layer (m) - mLayerVolFracLiq(nSnow+1:nLayers), & ! intent(in): volumetric fraction of liquid water in each soil layer (-) - scalarAquiferStorage, & ! intent(in): aquifer storage (m) - ! input (diagnostic variables) - mLayerRootDensity(1:nSoil), & ! intent(in): root density in each layer (-) - scalarAquiferRootFrac, & ! intent(in): fraction of roots below the lowest soil layer (-) - ! input (parameters) - plantWiltPsi, & ! intent(in): matric head at wilting point (m) - soilStressParam, & ! intent(in): parameter in the exponential soil stress function (-) - critSoilWilting, & ! intent(in): critical vol. liq. water content when plants are wilting (-) - critSoilTranspire, & ! intent(in): critical vol. liq. water content when transpiration is limited (-) - critAquiferTranspire, & ! intent(in): critical aquifer storage value when transpiration is limited (m) - ! output - scalarTranspireLim, & ! intent(out): weighted average of the transpiration limiting factor (-) - mLayerTranspireLim(1:nSoil), & ! intent(out): transpiration limiting factor in each layer (-) - scalarTranspireLimAqfr, & ! intent(out): transpiration limiting factor for the aquifer (-) - err,cmessage ) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if - !print*, 'weighted average of the soil moiture factor controlling stomatal resistance (-) = ', scalarTranspireLim - - !write(*,'(a,1x,10(f20.10,1x))') 'canopyTempTrial, scalarSatVP_CanopyTemp, scalarVP_CanopyAir = ', & - ! canopyTempTrial, scalarSatVP_CanopyTemp, scalarVP_CanopyAir - - ! compute stomatal resistance - call stomResist(& - ! input (state and diagnostic variables) - canopyTempTrial, & ! intent(in): temperature of the vegetation canopy (K) - scalarSatVP_CanopyTemp, & ! intent(in): saturation vapor pressure at the temperature of the veg canopy (Pa) - scalarVP_CanopyAir, & ! intent(in): canopy air vapor pressure (Pa) - ! input: data structures - type_data, & ! intent(in): type of vegetation and soil - forc_data, & ! intent(in): model forcing data - mpar_data, & ! intent(in): model parameters - model_decisions, & ! intent(in): model decisions - ! input-output: data structures - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - flux_data, & ! intent(inout): model fluxes for a local HRU - ! output: error control - err,cmessage ) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if - - end if ! (if the first flux call in a given sub-step) - - - ! ******************************************************************************************************************************************************************* - ! ******************************************************************************************************************************************************************* - ! ***** LONGWAVE RADIATION ***************************************************************************************************************************************** - ! ******************************************************************************************************************************************************************* - ! ******************************************************************************************************************************************************************* - - ! compute canopy longwave radiation balance - call longwaveBal(& - ! input: model control - ix_fDerivMeth, & ! intent(in): method used to calculate flux derivatives - computeVegFlux, & ! intent(in): flag to compute fluxes over vegetation - ! input: canopy and ground temperature - canopyTempTrial, & ! intent(in): temperature of the vegetation canopy (K) - groundTempTrial, & ! intent(in): temperature of the ground surface (K) - ! input: canopy and ground emissivity - scalarCanopyEmissivity, & ! intent(in): canopy emissivity (-) - groundEmissivity, & ! intent(in): ground emissivity (-) - ! input: forcing - LWRadAtm, & ! intent(in): downwelling longwave radiation at the upper boundary (W m-2) - ! output: emitted radiation from the canopy and ground - scalarLWRadCanopy, & ! intent(out): longwave radiation emitted from the canopy (W m-2) - scalarLWRadGround, & ! intent(out): longwave radiation emitted at the ground surface (W m-2) - ! output: individual fluxes - scalarLWRadUbound2Canopy, & ! intent(out): downward atmospheric longwave radiation absorbed by the canopy (W m-2) - scalarLWRadUbound2Ground, & ! intent(out): downward atmospheric longwave radiation absorbed by the ground (W m-2) - scalarLWRadUbound2Ubound, & ! intent(out): atmospheric radiation reflected by the ground and lost thru upper boundary (W m-2) - scalarLWRadCanopy2Ubound, & ! intent(out): longwave radiation emitted from canopy lost thru upper boundary (W m-2) - scalarLWRadCanopy2Ground, & ! intent(out): longwave radiation emitted from canopy absorbed by the ground (W m-2) - scalarLWRadCanopy2Canopy, & ! intent(out): canopy longwave reflected from ground and absorbed by the canopy (W m-2) - scalarLWRadGround2Ubound, & ! intent(out): longwave radiation emitted from ground lost thru upper boundary (W m-2) - scalarLWRadGround2Canopy, & ! intent(out): longwave radiation emitted from ground and absorbed by the canopy (W m-2) - ! output: net fluxes - scalarLWNetCanopy, & ! intent(out): net longwave radiation at the canopy (W m-2) - scalarLWNetGround, & ! intent(out): net longwave radiation at the ground surface (W m-2) - scalarLWNetUbound, & ! intent(out): net longwave radiation at the upper boundary (W m-2) - ! output: flux derivatives - dLWNetCanopy_dTCanopy, & ! intent(out): derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) - dLWNetGround_dTGround, & ! intent(out): derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) - dLWNetCanopy_dTGround, & ! intent(out): derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) - dLWNetGround_dTCanopy, & ! intent(out): derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) - ! output: error control - err,cmessage ) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if - !print*, 'dLWNetCanopy_dTGround = ', dLWNetCanopy_dTGround - - - ! ******************************************************************************************************************************************************************* - ! ******************************************************************************************************************************************************************* - ! ***** TURBULENT HEAT FLUXES ************************************************************************************************************************************** - ! ******************************************************************************************************************************************************************* - ! ******************************************************************************************************************************************************************* - - ! check the need to compute numerical derivatives - if(ix_fDerivMeth == numerical)then - nFlux=5 ! compute the derivatives using one-sided finite differences - else - nFlux=1 ! compute analytical derivatives - end if - - ! either one or multiple flux calls, depending on if using analytical or numerical derivatives - do itry=nFlux,1,-1 ! (work backwards to ensure all computed fluxes come from the un-perturbed case) - - ! ------------------------------------------------------------------------------------- - ! state perturbations for numerical deriavtives with one-sided finite differences - ! note: no perturbations performed using analytical derivatives (nFlux=1) - ! ------------------------------------------------------------------------------------- - - ! identify the type of perturbation - select case(itry) - - ! un-perturbed case - case(unperturbed) - groundTemp = groundTempTrial - canopyTemp = canopyTempTrial - canairTemp = canairTempTrial - canopyWetFraction = scalarCanopyWetFraction - - ! perturb ground temperature - case(perturbStateGround) - groundTemp = groundTempTrial + dx - canopyTemp = canopyTempTrial - canairTemp = canairTempTrial - canopyWetFraction = scalarCanopyWetFraction - - ! perturb canopy temperature - case(perturbStateCanopy) - groundTemp = groundTempTrial - canopyTemp = canopyTempTrial + dx - canairTemp = canairTempTrial - canopyWetFraction = scalarCanopyWetFraction - - ! perturb canopy air temperature - case(perturbStateCanair) - groundTemp = groundTempTrial - canopyTemp = canopyTempTrial - canairTemp = canairTempTrial + dx - canopyWetFraction = scalarCanopyWetFraction - - ! perturb canopy liquid water content - case(perturbStateCanLiq) - groundTemp = groundTempTrial - canopyTemp = canopyTempTrial - canairTemp = canairTempTrial - - ! perturbations in canopy liquid water content affect canopy wetted fraction - if(computeVegFlux)then - call wettedFrac(& - ! input - .false., & ! flag to denote if derivative is desired - (ix_fDerivMeth == numerical), & ! flag to denote that numerical derivatives are required (otherwise, analytical derivatives are calculated) - (scalarLatHeatSubVapCanopy > LH_vap+verySmall), & ! flag to denote if the canopy is frozen - dCanLiq_dTcanopy, & ! derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) - fracLiquidCanopy, & ! fraction of liquid water on the canopy (-) - canopyLiqTrial+dx, & ! canopy liquid water (kg m-2) - canopyIceTrial, & ! canopy ice (kg m-2) - scalarCanopyLiqMax, & ! maximum canopy liquid water (kg m-2) - scalarCanopyIceMax, & ! maximum canopy ice content (kg m-2) - canopyWettingFactor, & ! maximum wetted fraction of the canopy (-) - canopyWettingExp, & ! exponent in canopy wetting function (-) - ! output - canopyWetFraction, & ! canopy wetted fraction (-) - dCanopyWetFraction_dWat, & ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) - dCanopyWetFraction_dT, & ! derivative in wetted fraction w.r.t. canopy temperature (K-1) - err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + ! scale derivative by the fraction of water + ! NOTE: dLiq/dWat = fracLiq, hence dWet/dWat = dLiq/dWat . dWet/dLiq + dCanopyWetFraction_dWat = canopyWetFractionDeriv*fracLiq + dCanopyWetFraction_dT = canopyWetFractionDeriv*dLiq_dT + +end subroutine wettedFrac + +! ******************************************************************************************************* +! private subroutine wetFraction: compute fraction of canopy covered with liquid water +! ******************************************************************************************************* +subroutine wetFraction(derDesire,smoothing,canopyLiq,canopyMax,canopyWettingFactor,canopyWettingExp,canopyWetFraction,canopyWetFractionDeriv) + implicit none + ! dummy variables + logical(lgt),intent(in) :: derDesire ! flag to denote if analytical derivatives are desired + logical(lgt),intent(in) :: smoothing ! flag to denote if smoothing is required + real(rkind),intent(in) :: canopyLiq ! liquid water content (kg m-2) + real(rkind),intent(in) :: canopyMax ! liquid water content (kg m-2) + real(rkind),intent(in) :: canopyWettingFactor ! maximum wetted fraction of the canopy (-) + real(rkind),intent(in) :: canopyWettingExp ! exponent in canopy wetting function (-) + real(rkind),intent(out) :: canopyWetFraction ! canopy wetted fraction (-) + real(rkind),intent(out) :: canopyWetFractionDeriv ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) + ! local variables + real(rkind) :: relativeCanopyWater ! water stored on vegetation canopy, expressed as a fraction of maximum storage (-) + real(rkind) :: rawCanopyWetFraction ! initial value of the canopy wet fraction (before smoothing) + real(rkind) :: rawWetFractionDeriv ! derivative in canopy wet fraction w.r.t. storage (kg-1 m2) + real(rkind) :: smoothTheta ! smoothing function of water used to improve numerical stability at times with limited water storage (-) + real(rkind) :: smoothThetaDeriv ! derivative in the smoothing water w.r.t.canopy storage (kg-1 m2) + real(rkind) :: eps=epsilon(1._rkind) ! machine precision for real numbers + ! -------------------------------------------------------------------------------------------------------------- + ! compute relative canopy water + if (smoothing) then ! smooth canopy wetted fraction by smoothing canopy liquid water content as in Kavetski and Kuczera (2007) + call thetaSmoother(derDesire,canopyLiq,smoothTheta,smoothThetaDeriv) + relativeCanopyWater = smoothTheta/canopyMax + else + relativeCanopyWater = canopyLiq/canopyMax + end if - else - canopyWetFraction = 0._rkind - end if - !print*, 'wetted fraction derivative = ', (canopyWetFraction - scalarCanopyWetFraction)/dx - !pause - - ! check for an unknown perturbation - case default; err=10; message=trim(message)//"unknown perturbation"; return - - end select ! (type of perturbation) - - ! compute the saturation vapor pressure for vegetation temperature - ! NOTE: saturated vapor pressure derivatives don't seem that accurate.... - TV_celcius = canopyTemp - Tfreeze - call satVapPress(TV_celcius, scalarSatVP_CanopyTemp, dSVPCanopy_dCanopyTemp) - - ! compute the saturation vapor pressure for ground temperature - ! NOTE: saturated vapor pressure derivatives don't seem that accurate.... - TG_celcius = groundTemp - Tfreeze - call satVapPress(TG_celcius, scalarSatVP_GroundTemp, dSVPGround_dGroundTemp) - - ! ------------------------------------------------------------------------------------- - ! calculation block (unperturbed fluxes returned [computed last]) - ! ------------------------------------------------------------------------------------- - - ! re-compute aerodynamic resistances for perturbed cases - ! NOTE: unperturbed fluxes computed earlier, and not over-written - if(itry /= unperturbed)then - call aeroResist(& - ! input: model control - computeVegFlux, & ! intent(in): logical flag to compute vegetation fluxes (.false. if veg buried by snow) - .false., & ! intent(in): logical flag if would like to compute analytical derivaties - ix_veg_traits, & ! intent(in): choice of parameterization for vegetation roughness length and displacement height - ix_windPrfile, & ! intent(in): choice of canopy wind profile - ix_astability, & ! intent(in): choice of stability function - ! input: above-canopy forcing data - mHeight, & ! intent(in): measurement height (m) - airtemp, & ! intent(in): air temperature at some height above the surface (K) - windspd, & ! intent(in): wind speed at some height above the surface (m s-1) - ! input: temperature (canopy, ground, canopy air space) - canairTemp, & ! intent(in): temperature of the canopy air space (K) - groundTemp, & ! intent(in): ground temperature (K) - ! input: diagnostic variables - exposedVAI, & ! intent(in): exposed vegetation area index -- leaf plus stem (m2 m-2) - scalarSnowDepth, & ! intent(in): snow depth (m) - ! input: parameters - z0Ground, & ! intent(in): roughness length of the ground (below canopy or non-vegetated surface [snow]) (m) - z0CanopyParam, & ! intent(in): roughness length of the canopy (m) - zpdFraction, & ! intent(in): zero plane displacement / canopy height (-) - critRichNumber, & ! intent(in): critical value for the bulk Richardson number where turbulence ceases (-) - Louis79_bparam, & ! intent(in): parameter in Louis (1979) stability function - Mahrt87_eScale, & ! intent(in): exponential scaling factor in the Mahrt (1987) stability function - windReductionParam, & ! intent(in): canopy wind reduction parameter (-) - leafExchangeCoeff, & ! intent(in): turbulent exchange coeff between canopy surface and canopy air ( m s-(1/2) ) - leafDimension, & ! intent(in): characteristic leaf dimension (m) - heightCanopyTop, & ! intent(in): height at the top of the vegetation canopy (m) - heightCanopyBottom, & ! intent(in): height at the bottom of the vegetation canopy (m) - ! output: stability corrections - notUsed_RiBulkCanopy, & ! intent(out): bulk Richardson number for the canopy (-) - notUsed_RiBulkGround, & ! intent(out): bulk Richardson number for the ground surface (-) - notUsed_scalarCanopyStabilityCorrection, & ! intent(out): stability correction for the canopy (-) - notUsed_scalarGroundStabilityCorrection, & ! intent(out): stability correction for the ground surface (-) - ! output: scalar resistances - notUsed_z0Canopy, & ! intent(out): roughness length of the canopy (m) - notUsed_WindReductionFactor, & ! intent(out): canopy wind reduction factor (-) - notUsed_ZeroPlaneDisplacement, & ! intent(out): zero plane displacement (m) - notUsed_EddyDiffusCanopyTop, & ! intent(out): eddy diffusivity for heat at the top of the canopy (m2 s-1) - notUsed_FrictionVelocity, & ! intent(out): friction velocity (m s-1) - notUsed_WindspdCanopyTop, & ! intent(out): windspeed at the top of the canopy (m s-1) - notUsed_WindspdCanopyBottom, & ! intent(out): windspeed at the height of the bottom of the canopy (m s-1) - trialLeafResistance, & ! intent(out): mean leaf boundary layer resistance per unit leaf area (s m-1) - trialGroundResistance, & ! intent(out): below canopy aerodynamic resistance (s m-1) - trialCanopyResistance, & ! intent(out): above canopy aerodynamic resistance (s m-1) - ! output: derivatives in scalar resistances - notUsed_dGroundResistance_dTGround, & ! intent(out): derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) - notUsed_dGroundResistance_dTCanopy, & ! intent(out): derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) - notUsed_dGroundResistance_dTCanair, & ! intent(out): derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) - notUsed_dCanopyResistance_dTCanopy, & ! intent(out): derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - notUsed_dCanopyResistance_dTCanair, & ! intent(out): derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) - ! output: error control - err,cmessage ) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if - - - ! assign scalar resistances for un-perturbed cases + ! compute an initial value of the canopy wet fraction + ! - canopy below value where canopy is 100% wet + if (relativeCanopyWater < 0._rkind .and. .not.smoothing) then ! will only happen inside Sundials Solver, otherwise would be infeasible + rawCanopyWetFraction = 0._rkind + rawWetFractionDeriv = 0._rkind + ! - canopy is at capacity (canopyWettingFactor) + elseif (relativeCanopyWater < 1._rkind) then + rawCanopyWetFraction = canopyWettingFactor*(relativeCanopyWater**canopyWettingExp) + if (derDesire .and. relativeCanopyWater>eps) then + rawWetFractionDeriv = (canopyWettingFactor*canopyWettingExp/canopyMax)*relativeCanopyWater**(canopyWettingExp - 1._rkind) else - trialLeafResistance = scalarLeafResistance - trialGroundResistance = scalarGroundResistance - trialCanopyResistance = scalarCanopyResistance - - end if ! (re-computing resistances for perturbed cases) - !print*, 'trialLeafResistance = ', trialLeafResistance - !print*, 'trialGroundResistance = ', trialGroundResistance - !print*, 'trialCanopyResistance = ', trialCanopyResistance - - ! compute the relative humidity in the top soil layer and the resistance at the ground surface - ! NOTE: computations are based on start-of-step values, so only compute for the first flux call - if(firstFluxCall)then - ! (soil water evaporation factor [0-1]) - soilEvapFactor = mLayerVolFracLiq(nSnow+1)/(theta_sat - theta_res) - ! (resistance from the soil [s m-1]) - scalarSoilResistance = scalarGroundSnowFraction*1._rkind + (1._rkind - scalarGroundSnowFraction)*EXP(8.25_rkind - 4.225_rkind*soilEvapFactor) ! Sellers (1992) - !scalarSoilResistance = scalarGroundSnowFraction*0._rkind + (1._rkind - scalarGroundSnowFraction)*exp(8.25_rkind - 6.0_rkind*soilEvapFactor) ! Niu adjustment to decrease resitance for wet soil - ! (relative humidity in the soil pores [0-1]) - if(mLayerMatricHead(1) > -1.e+6_rkind)then ! avoid problems with numerical precision when soil is very dry - soilRelHumidity_noSnow = exp( (mLayerMatricHead(1)*gravity) / (groundTemp*R_wv) ) - else - soilRelHumidity_noSnow = 0._rkind - end if ! (if matric head is very low) - scalarSoilRelHumidity = scalarGroundSnowFraction*1._rkind + (1._rkind - scalarGroundSnowFraction)*soilRelHumidity_noSnow - !print*, 'mLayerMatricHead(1), scalarSoilRelHumidity = ', mLayerMatricHead(1), scalarSoilRelHumidity - end if ! (if the first flux call) - - ! compute turbulent heat fluxes - call turbFluxes(& - ! input: model control - computeVegFlux, & ! intent(in): logical flag to compute vegetation fluxes (.false. if veg buried by snow) - ix_fDerivMeth, & ! intent(in): method used to calculate flux derivatives - ! input: above-canopy forcing data - airtemp, & ! intent(in): air temperature at some height above the surface (K) - airpres, & ! intent(in): air pressure of the air above the vegetation canopy (Pa) - scalarVPair, & ! intent(in): vapor pressure of the air above the vegetation canopy (Pa) - ! input: latent heat of sublimation/vaporization - scalarLatHeatSubVapCanopy, & ! intent(in): latent heat of sublimation/vaporization for the vegetation canopy (J kg-1) - scalarLatHeatSubVapGround, & ! intent(in): latent heat of sublimation/vaporization for the ground surface (J kg-1) - ! input: canopy/ground temperature and saturated vapor pressure - canairTemp, & ! intent(in): temperature of the canopy air space (K) - canopyTemp, & ! intent(in): canopy temperature (K) - groundTemp, & ! intent(in): ground temperature (K) - scalarSatVP_CanopyTemp, & ! intent(in): saturation vapor pressure at the temperature of the veg canopy (Pa) - scalarSatVP_GroundTemp, & ! intent(in): saturation vapor pressure at the temperature of the ground (Pa) - dSVPCanopy_dCanopyTemp, & ! intent(in): derivative in canopy saturation vapor pressure w.r.t. canopy temperature (Pa K-1) - dSVPGround_dGroundTemp, & ! intent(in): derivative in ground saturation vapor pressure w.r.t. ground temperature (Pa K-1) - ! input: diagnostic variables - exposedVAI, & ! intent(in): exposed vegetation area index -- leaf plus stem (m2 m-2) - canopyWetFraction, & ! intent(in): trial value for the fraction of canopy that is wet [0-1] - dCanopyWetFraction_dWat, & ! intent(in): derivative in the canopy wetted fraction w.r.t. total water content (kg-1 m-2) - dCanopyWetFraction_dT, & ! intent(in): derivative in wetted fraction w.r.t. canopy temperature (K-1) - scalarCanopySunlitLAI, & ! intent(in): sunlit leaf area (-) - scalarCanopyShadedLAI, & ! intent(in): shaded leaf area (-) - scalarSoilRelHumidity, & ! intent(in): relative humidity in the soil pores [0-1] - scalarSoilResistance, & ! intent(in): resistance from the soil (s m-1) - trialLeafResistance, & ! intent(in): mean leaf boundary layer resistance per unit leaf area (s m-1) - trialGroundResistance, & ! intent(in): below canopy aerodynamic resistance (s m-1) - trialCanopyResistance, & ! intent(in): above canopy aerodynamic resistance (s m-1) - scalarStomResistSunlit, & ! intent(in): stomatal resistance for sunlit leaves (s m-1) - scalarStomResistShaded, & ! intent(in): stomatal resistance for shaded leaves (s m-1) - ! input: derivatives in scalar resistances - dGroundResistance_dTGround, & ! intent(in): derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) - dGroundResistance_dTCanopy, & ! intent(in): derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) - dGroundResistance_dTCanair, & ! intent(in): derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) - dCanopyResistance_dTCanopy, & ! intent(in): derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - dCanopyResistance_dTCanair, & ! intent(in): derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) - ! output: conductances (used to check derivative calculations) - scalarLeafConductance, & ! intent(out): leaf conductance (m s-1) - scalarCanopyConductance, & ! intent(out): canopy conductance (m s-1) - scalarGroundConductanceSH, & ! intent(out): ground conductance for sensible heat (m s-1) - scalarGroundConductanceLH, & ! intent(out): ground conductance for latent heat -- includes soil resistance (m s-1) - scalarEvapConductance, & ! intent(out): conductance for evaporation (m s-1) - scalarTransConductance, & ! intent(out): conductance for transpiration (m s-1) - scalarTotalConductanceSH, & ! intent(out): total conductance for sensible heat (m s-1) - scalarTotalConductanceLH, & ! intent(out): total conductance for latent heat (m s-1) - ! output: canopy air space variables - scalarVP_CanopyAir, & ! intent(out): vapor pressure of the canopy air space (Pa) - ! output: fluxes from the vegetation canopy - scalarSenHeatCanopy, & ! intent(out): sensible heat flux from the canopy to the canopy air space (W m-2) - scalarLatHeatCanopyEvap, & ! intent(out): latent heat flux associated with evaporation from the canopy to the canopy air space (W m-2) - scalarLatHeatCanopyTrans, & ! intent(out): latent heat flux associated with transpiration from the canopy to the canopy air space (W m-2) - ! output: fluxes from non-vegetated surfaces (ground surface below vegetation, bare ground, or snow covered vegetation) - scalarSenHeatGround, & ! intent(out): sensible heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) - scalarLatHeatGround, & ! intent(out): latent heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) - ! output: total heat fluxes to the atmosphere - scalarSenHeatTotal, & ! intent(out): total sensible heat flux to the atmosphere (W m-2) - scalarLatHeatTotal, & ! intent(out): total latent heat flux to the atmosphere (W m-2) - ! output: net fluxes - turbFluxCanair, & ! intent(out): net turbulent heat fluxes at the canopy air space (W m-2) - turbFluxCanopy, & ! intent(out): net turbulent heat fluxes at the canopy (W m-2) - turbFluxGround, & ! intent(out): net turbulent heat fluxes at the ground surface (W m-2) - ! output: energy flux derivatives - dTurbFluxCanair_dTCanair, & ! intent(out): derivative in net canopy air space fluxes w.r.t. canopy air temperature (W m-2 K-1) - dTurbFluxCanair_dTCanopy, & ! intent(out): derivative in net canopy air space fluxes w.r.t. canopy temperature (W m-2 K-1) - dTurbFluxCanair_dTGround, & ! intent(out): derivative in net canopy air space fluxes w.r.t. ground temperature (W m-2 K-1) - dTurbFluxCanopy_dTCanair, & ! intent(out): derivative in net canopy turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) - dTurbFluxCanopy_dTCanopy, & ! intent(out): derivative in net canopy turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) - dTurbFluxCanopy_dTGround, & ! intent(out): derivative in net canopy turbulent fluxes w.r.t. ground temperature (W m-2 K-1) - dTurbFluxGround_dTCanair, & ! intent(out): derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) - dTurbFluxGround_dTCanopy, & ! intent(out): derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) - dTurbFluxGround_dTGround, & ! intent(out): derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) - ! output: liquid flux derivatives (canopy evap) - dLatHeatCanopyEvap_dCanLiq, & ! intent(out): derivative in latent heat of canopy evaporation w.r.t. canopy liquid water content (W kg-1) - dLatHeatCanopyEvap_dTCanair, & ! intent(out): derivative in latent heat of canopy evaporation w.r.t. canopy air temperature (W m-2 K-1) - dLatHeatCanopyEvap_dTCanopy, & ! intent(out): derivative in latent heat of canopy evaporation w.r.t. canopy temperature (W m-2 K-1) - dLatHeatCanopyEvap_dTGround, & ! intent(out): derivative in latent heat of canopy evaporation w.r.t. ground temperature (W m-2 K-1) - ! output: liquid flux derivatives (ground evap) - dLatHeatGroundEvap_dCanLiq, & ! intent(out): derivative in latent heat of ground evaporation w.r.t. canopy liquid water content (J kg-1 s-1) - dLatHeatGroundEvap_dTCanair, & ! intent(out): derivative in latent heat of ground evaporation w.r.t. canopy air temperature - dLatHeatGroundEvap_dTCanopy, & ! intent(out): derivative in latent heat of ground evaporation w.r.t. canopy temperature - dLatHeatGroundEvap_dTGround, & ! intent(out): derivative in latent heat of ground evaporation w.r.t. ground temperature - ! output: cross derivatives - dTurbFluxCanair_dCanLiq, & ! intent(out): derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - dTurbFluxCanopy_dCanLiq, & ! intent(out): derivative in net canopy turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - dTurbFluxGround_dCanLiq, & ! intent(out): derivative in net ground turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - ! output: error control - err,cmessage ) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if - - !write(*,'(a,f25.15)') 'scalarSenHeatTotal = ', scalarSenHeatTotal - !write(*,'(a,f25.15)') 'scalarSenHeatCanopy = ', scalarSenHeatCanopy - !write(*,'(a,f25.15)') 'scalarLatHeatCanopyEvap = ', scalarLatHeatCanopyEvap - !write(*,'(a,f25.15)') 'scalarLatHeatCanopyTrans = ', scalarLatHeatCanopyTrans - - !print*, 'scalarSenHeatGround = ', scalarSenHeatGround - !print*, 'scalarLatHeatGround = ', scalarLatHeatGround - - !notUsed_scalarCanopyStabilityCorrection ! stability correction for the canopy (-) - !notUsed_scalarGroundStabilityCorrection ! stability correction for the ground surface (-) - !notUsed_EddyDiffusCanopyTop ! eddy diffusivity for heat at the top of the canopy (m2 s-1) - !notUsed_FrictionVelocity ! friction velocity (m s-1) - !notUsed_WindspdCanopyTop ! windspeed at the top of the canopy (m s-1) - !notUsed_WindspdCanopyBottom ! windspeed at the height of the bottom of the canopy (m s-1) - !trialLeafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) - !trialGroundResistance ! below canopy aerodynamic resistance (s m-1) - !trialCanopyResistance ! above canopy aerodynamic resistance (s m-1) - - ! save perturbed fluxes - if(ix_fDerivMeth == numerical)then - select case(itry) ! (select type of perturbation) - case(unperturbed) - try0 = turbFluxGround - exit - case(perturbStateCanair) - turbFluxCanair_dStateCanair = turbFluxCanair ! turbulent exchange from the canopy air space to the atmosphere (W m-2) - turbFluxCanopy_dStateCanair = turbFluxCanopy ! total turbulent heat fluxes from the canopy to the canopy air space (W m-2) - turbFluxGround_dStateCanair = turbFluxGround ! total turbulent heat fluxes from the ground to the canopy air space (W m-2) - latHeatCanEvap_dStateCanair = scalarLatHeatCanopyEvap ! perturbed value for the latent heat associated with canopy evaporation (W m-2) - case(perturbStateCanopy) - turbFluxCanair_dStateCanopy = turbFluxCanair ! turbulent exchange from the canopy air space to the atmosphere (W m-2) - turbFluxCanopy_dStateCanopy = turbFluxCanopy ! total turbulent heat fluxes from the canopy to the canopy air space (W m-2) - turbFluxGround_dStateCanopy = turbFluxGround ! total turbulent heat fluxes from the ground to the canopy air space (W m-2) - latHeatCanEvap_dStateCanopy = scalarLatHeatCanopyEvap ! perturbed value for the latent heat associated with canopy evaporation (W m-2) - case(perturbStateGround) - try1 = turbFluxGround - turbFluxCanair_dStateGround = turbFluxCanair ! turbulent exchange from the canopy air space to the atmosphere (W m-2) - turbFluxCanopy_dStateGround = turbFluxCanopy ! total turbulent heat fluxes from the canopy to the canopy air space (W m-2) - turbFluxGround_dStateGround = turbFluxGround ! total turbulent heat fluxes from the ground to the canopy air space (W m-2) - latHeatCanEvap_dStateGround = scalarLatHeatCanopyEvap ! perturbed value for the latent heat associated with canopy evaporation (W m-2) - case(perturbStateCanLiq) - turbFluxCanair_dStateCanliq = turbFluxCanair ! turbulent exchange from the canopy air space to the atmosphere (W m-2) - turbFluxCanopy_dStateCanLiq = turbFluxCanopy ! total turbulent heat fluxes from the canopy to the canopy air space (W m-2) - turbFluxGround_dStateCanLiq = turbFluxGround ! total turbulent heat fluxes from the ground to the canopy air space (W m-2) - latHeatCanEvap_dStateCanliq = scalarLatHeatCanopyEvap ! perturbed value for the latent heat associated with canopy evaporation (W m-2) - case default; err=10; message=trim(message)//"unknown perturbation"; return - end select ! (type of perturbation) - end if ! (if numerical) - - end do ! (looping through different flux perturbations) - - ! test derivative - !if(ix_fDerivMeth == numerical) print*, 'try0, try1 = ', try0, try1 - !if(ix_fDerivMeth == numerical) print*, 'derivative = ', (ix_fDerivMeth == numerical), (try1 - try0)/dx - !if(ix_fDerivMeth == analytical) print*, 'derivative = ', (ix_fDerivMeth == numerical), dTurbFluxGround_dTGround - !pause - - ! compute numerical derivatives - if(ix_fDerivMeth == numerical)then - ! derivatives w.r.t. canopy air temperature - dTurbFluxCanair_dTCanair = (turbFluxCanair_dStateCanair - turbFluxCanair) / dx ! derivative in net canopy air space fluxes w.r.t. canopy air temperature (W m-2 K-1) - dTurbFluxCanopy_dTCanair = (turbFluxCanopy_dStateCanair - turbFluxCanopy) / dx ! derivative in net canopy turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) - dTurbFluxGround_dTCanair = (turbFluxGround_dStateCanair - turbFluxGround) / dx ! derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) - dLatHeatCanopyEvap_dTCanair = (latHeatCanEvap_dStateCanair - scalarLatHeatCanopyEvap) / dx ! derivative in latent heat of canopy evaporation w.r.t. canopy air temperature (W m-2 K-1) - ! derivatives w.r.t. canopy temperature - dTurbFluxCanair_dTCanopy = (turbFluxCanair_dStateCanopy - turbFluxCanair) / dx ! derivative in net canopy air space fluxes w.r.t. canopy temperature (W m-2 K-1) - dTurbFluxCanopy_dTCanopy = (turbFluxCanopy_dStateCanopy - turbFluxCanopy) / dx ! derivative in net canopy turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) - dTurbFluxGround_dTCanopy = (turbFluxGround_dStateCanopy - turbFluxGround) / dx ! derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) - dLatHeatCanopyEvap_dTCanopy = (latHeatCanEvap_dStateCanopy - scalarLatHeatCanopyEvap) / dx ! derivative in latent heat of canopy evaporation w.r.t. canopy temperature (W m-2 K-1) - ! derivatives w.r.t. ground temperature - dTurbFluxCanair_dTGround = (turbFluxCanair_dStateGround - turbFluxCanair) / dx ! derivative in net canopy air space fluxes w.r.t. ground temperature (W m-2 K-1) - dTurbFluxCanopy_dTGround = (turbFluxCanopy_dStateGround - turbFluxCanopy) / dx ! derivative in net canopy turbulent fluxes w.r.t. ground temperature (W m-2 K-1) - dTurbFluxGround_dTGround = (turbFluxGround_dStateGround - turbFluxGround) / dx ! derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) - dLatHeatCanopyEvap_dTGround = (latHeatCanEvap_dStateGround - scalarLatHeatCanopyEvap) / dx ! derivative in latent heat of canopy evaporation w.r.t. ground temperature (W m-2 K-1) - ! derivatives w.r.t. canopy liquid water content - dTurbFluxCanair_dCanLiq = (turbFluxCanair_dStateCanliq - turbFluxCanair) / dx ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - dTurbFluxCanopy_dCanLiq = (turbFluxCanopy_dStateCanLiq - turbFluxCanopy) / dx ! derivative in net canopy turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - dTurbFluxGround_dCanLiq = (turbFluxGround_dStateCanLiq - turbFluxGround) / dx ! derivative in net ground turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - dLatHeatCanopyEvap_dCanLiq = (latHeatCanEvap_dStateCanliq - scalarLatHeatCanopyEvap) / dx ! derivative in latent heat of canopy evaporation w.r.t. canopy liquid water content (J kg-1 s-1) - end if - !if(heightCanopyBottom < scalarSnowDepth+z0Ground) pause 'bottom of the canopy is covered' - - ! test - !print*, (ix_fDerivMeth == numerical) - !print*, 'dTurbFluxCanair_dTCanair = ', dTurbFluxCanair_dTCanair - !print*, 'dTurbFluxCanair_dTCanopy = ', dTurbFluxCanair_dTCanopy - !print*, 'dTurbFluxCanair_dTGround = ', dTurbFluxCanair_dTGround - !print*, 'dTurbFluxCanopy_dTCanair = ', dTurbFluxCanopy_dTCanair - !print*, 'dTurbFluxCanopy_dTCanopy = ', dTurbFluxCanopy_dTCanopy - !print*, 'dTurbFluxCanopy_dTGround = ', dTurbFluxCanopy_dTGround - !print*, 'dTurbFluxGround_dTCanair = ', dTurbFluxGround_dTCanair - !print*, 'dTurbFluxGround_dTCanopy = ', dTurbFluxGround_dTCanopy - !print*, 'dTurbFluxGround_dTGround = ', dTurbFluxGround_dTGround - !print*, 'dLatHeatCanopyEvap_dCanLiq = ', dLatHeatCanopyEvap_dCanLiq - !print*, 'dLatHeatCanopyEvap_dTCanair = ', dLatHeatCanopyEvap_dTCanair - !print*, 'dLatHeatCanopyEvap_dTCanopy = ', dLatHeatCanopyEvap_dTCanopy - !print*, 'dLatHeatCanopyEvap_dTGround = ', dLatHeatCanopyEvap_dTGround - !print*, 'dTurbFluxCanair_dCanLiq = ', dTurbFluxCanair_dCanLiq - !print*, 'dTurbFluxCanopy_dCanLiq = ', dTurbFluxCanopy_dCanLiq - !print*, 'dTurbFluxGround_dCanLiq = ', dTurbFluxGround_dCanLiq - !print*, '*****' - !pause - - !print*, 'scalarRainfall, scalarThroughfallRain, scalarSnowfall, scalarThroughfallSnow, canopyTempTrial, scalarTwetbulb = ', & - ! scalarRainfall, scalarThroughfallRain, scalarSnowfall, scalarThroughfallSnow, canopyTempTrial, scalarTwetbulb - - ! compute the heat advected with precipitation (W m-2) - ! NOTE: fluxes are in kg m-2 s-1, so no need to use density of water/ice here - scalarCanopyAdvectiveHeatFlux = -Cp_water*(scalarRainfall - scalarThroughfallRain)*(canopyTempTrial - scalarTwetbulb) + & - (-Cp_ice)*(scalarSnowfall - scalarThroughfallSnow)*(canopyTempTrial - scalarTwetbulb) - scalarGroundAdvectiveHeatFlux = -Cp_water*scalarThroughfallRain*(groundTempTrial - scalarTwetbulb) + & - (-Cp_ice)*scalarThroughfallSnow*(groundTempTrial - scalarTwetbulb) !+ & - ! -Cp_water*scalarCanopyLiqDrainage *(groundTempTrial - canopyTempTrial) + & - ! -Cp_ice *scalarCanopySnowUnloading*(groundTempTrial - canopyTempTrial) - !print*, 'scalarRainfall, scalarThroughfallRain, scalarSnowfall, scalarThroughfallSnow = ', scalarRainfall, scalarThroughfallRain, scalarSnowfall, scalarThroughfallSnow - !print*, 'scalarCanopyAdvectiveHeatFlux, scalarGroundAdvectiveHeatFlux = ', scalarCanopyAdvectiveHeatFlux, scalarGroundAdvectiveHeatFlux - - ! compute the mass flux associated with transpiration and evaporation/sublimation (J m-2 s-1 --> kg m-2 s-1) - ! NOTE: remove water from the snow on the ground in preference to removing water from the water in soil pores - !print*, 'scalarLatHeatCanopyTrans = ', scalarLatHeatCanopyTrans - !print*, 'scalarLatHeatGround = ', scalarLatHeatGround - ! (canopy transpiration/sublimation) - if(scalarLatHeatSubVapCanopy > LH_vap+verySmall)then ! sublimation - scalarCanopyEvaporation = 0._rkind - scalarCanopySublimation = scalarLatHeatCanopyEvap/LH_sub - if(scalarLatHeatCanopyTrans > 0._rkind)then ! flux directed towards the veg - scalarCanopySublimation = scalarCanopySublimation + scalarLatHeatCanopyTrans/LH_sub ! frost - scalarCanopyTranspiration = 0._rkind - else - scalarCanopyTranspiration = scalarLatHeatCanopyTrans/LH_vap ! transpiration is always vapor + rawWetFractionDeriv = 0._rkind end if - ! (canopy transpiration/evaporation) - else ! evaporation - scalarCanopyEvaporation = scalarLatHeatCanopyEvap/LH_vap - scalarCanopySublimation = 0._rkind - if(scalarLatHeatCanopyTrans > 0._rkind)then ! flux directed towards the veg - scalarCanopyEvaporation = scalarCanopyEvaporation + scalarLatHeatCanopyTrans/LH_vap - scalarCanopyTranspiration = 0._rkind - else - scalarCanopyTranspiration = scalarLatHeatCanopyTrans/LH_vap - end if - end if - ! (ground evaporation/sublimation) - if(scalarLatHeatSubVapGround > LH_vap+verySmall)then ! sublimation - ! NOTE: this should only occur when we have formed snow layers, so check - if(nSnow == 0)then; err=20; message=trim(message)//'only expect snow sublimation when we have formed some snow layers'; return; end if - scalarGroundEvaporation = 0._rkind ! ground evaporation is zero once the snowpack has formed - scalarSnowSublimation = scalarLatHeatGround/LH_sub - else - ! NOTE: this should only occur when we have no snow layers, so check - if(nSnow > 0)then; err=20; message=trim(message)//'only expect ground evaporation when there are no snow layers'; return; end if - scalarGroundEvaporation = scalarLatHeatGround/LH_vap - scalarSnowSublimation = 0._rkind ! no sublimation from snow if no snow layers have formed - end if - !print*, 'scalarSnowSublimation, scalarLatHeatGround = ', scalarSnowSublimation, scalarLatHeatGround - - !print*, 'canopyWetFraction, scalarCanopyEvaporation = ', canopyWetFraction, scalarCanopyEvaporation - - ! ******************************************************************************************************************************************************************* - ! ******************************************************************************************************************************************************************* - ! ***** AND STITCH EVERYTHING TOGETHER ***************************************************************************************************************************** - ! ******************************************************************************************************************************************************************* - ! ******************************************************************************************************************************************************************* - - ! compute derived fluxes - scalarTotalET = scalarGroundEvaporation + scalarCanopyEvaporation + scalarCanopyTranspiration - scalarNetRadiation = scalarCanopyAbsorbedSolar + scalarLWNetCanopy + scalarGroundAbsorbedSolar + scalarLWNetGround - - ! compute net fluxes at the canopy and ground surface - canairNetFlux = turbFluxCanair - canopyNetFlux = scalarCanopyAbsorbedSolar + scalarLWNetCanopy + turbFluxCanopy + scalarCanopyAdvectiveHeatFlux - groundNetFlux = scalarGroundAbsorbedSolar + scalarLWNetGround + turbFluxGround + scalarGroundAdvectiveHeatFlux - !write(*,'(a,1x,10(e17.10,1x))') 'canopyNetFlux, groundNetFlux, scalarLWNetCanopy, turbFluxCanopy, turbFluxGround, scalarLWNetGround, scalarCanopyAdvectiveHeatFlux = ', & - ! canopyNetFlux, groundNetFlux, scalarLWNetCanopy, turbFluxCanopy, turbFluxGround, scalarLWNetGround, scalarCanopyAdvectiveHeatFlux - !write(*,'(a,1x,10(e20.14,1x))') 'groundNetFlux, scalarGroundAbsorbedSolar, scalarLWNetGround, turbFluxGround, scalarGroundAdvectiveHeatFlux = ', & - ! groundNetFlux, scalarGroundAbsorbedSolar, scalarLWNetGround, turbFluxGround, scalarGroundAdvectiveHeatFlux - - ! compute the energy derivatives - dCanairNetFlux_dCanairTemp = dTurbFluxCanair_dTCanair - dCanairNetFlux_dCanopyTemp = dTurbFluxCanair_dTCanopy - dCanairNetFlux_dGroundTemp = dTurbFluxCanair_dTGround - dCanopyNetFlux_dCanairTemp = dTurbFluxCanopy_dTCanair - dCanopyNetFlux_dCanopyTemp = dLWNetCanopy_dTCanopy + dTurbFluxCanopy_dTCanopy - Cp_water*(scalarRainfall - scalarThroughfallRain) - Cp_ice*(scalarSnowfall - scalarThroughfallSnow) - dCanopyNetFlux_dGroundTemp = dLWNetCanopy_dTGround + dTurbFluxCanopy_dTGround - dGroundNetFlux_dCanairTemp = dTurbFluxGround_dTCanair - dGroundNetFlux_dCanopyTemp = dLWNetGround_dTCanopy + dTurbFluxGround_dTCanopy - dGroundNetFlux_dGroundTemp = dLWNetGround_dTGround + dTurbFluxGround_dTGround - Cp_water*scalarThroughfallRain - Cp_ice*scalarThroughfallSnow - - ! check if evaporation or sublimation - if(scalarLatHeatSubVapCanopy < LH_vap+verySmall)then ! evaporation - - ! compute the liquid water derivarives - dCanopyEvaporation_dCanLiq = dLatHeatCanopyEvap_dCanLiq/LH_vap ! (s-1) - dCanopyEvaporation_dTCanair = dLatHeatCanopyEvap_dTCanair/LH_vap ! (kg m-2 s-1 K-1) - dCanopyEvaporation_dTCanopy = dLatHeatCanopyEvap_dTCanopy/LH_vap ! (kg m-2 s-1 K-1) - dCanopyEvaporation_dTGround = dLatHeatCanopyEvap_dTGround/LH_vap ! (kg m-2 s-1 K-1) - - ! sublimation - else - dCanopyEvaporation_dCanLiq = 0._rkind ! (s-1) - dCanopyEvaporation_dTCanair = 0._rkind ! (kg m-2 s-1 K-1) - dCanopyEvaporation_dTCanopy = 0._rkind ! (kg m-2 s-1 K-1) - dCanopyEvaporation_dTGround = 0._rkind ! (kg m-2 s-1 K-1) - end if - - ! compute the liquid water derivarives (ground evap) - dGroundEvaporation_dCanLiq = dLatHeatGroundEvap_dCanLiq/LH_vap ! (s-1) - dGroundEvaporation_dTCanair = dLatHeatGroundEvap_dTCanair/LH_vap ! (kg m-2 s-1 K-1) - dGroundEvaporation_dTCanopy = dLatHeatGroundEvap_dTCanopy/LH_vap ! (kg m-2 s-1 K-1) - dGroundEvaporation_dTGround = dLatHeatGroundEvap_dTGround/LH_vap ! (kg m-2 s-1 K-1) - - ! compute the cross derivative terms (only related to turbulent fluxes; specifically canopy evaporation and transpiration) - dCanopyNetFlux_dCanLiq = dTurbFluxCanopy_dCanLiq ! derivative in net canopy fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - dGroundNetFlux_dCanLiq = dTurbFluxGround_dCanLiq ! derivative in net ground fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - - !print*, (ix_fDerivMeth == numerical) - !print*, 'dGroundNetFlux_dCanairTemp = ', dGroundNetFlux_dCanairTemp - !print*, 'dCanopyNetFlux_dCanopyTemp = ', dCanopyNetFlux_dCanopyTemp - !print*, 'dGroundNetFlux_dCanopyTemp = ', dGroundNetFlux_dCanopyTemp - !print*, 'dCanopyNetFlux_dGroundTemp = ', dCanopyNetFlux_dGroundTemp - !print*, 'dGroundNetFlux_dGroundTemp = ', dGroundNetFlux_dGroundTemp - !print*, 'dLWNetCanopy_dTGround = ', dLWNetCanopy_dTGround - !print*, 'dTurbFluxCanopy_dTGround = ', dTurbFluxCanopy_dTGround - !pause - - ! * check - case default; err=10; message=trim(message)//'unable to identify upper boundary condition for thermodynamics'; return - - ! end case statement - end select ! upper boundary condition for thermodynamics - - ! return liquid fluxes (needed for coupling) - returnCanopyTranspiration = scalarCanopyTranspiration ! canopy transpiration (kg m-2 s-1) - returnCanopyEvaporation = scalarCanopyEvaporation ! canopy evaporation/condensation (kg m-2 s-1) - returnGroundEvaporation = scalarGroundEvaporation ! ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) - - ! end associations - end associate - - - end subroutine vegNrgFlux - - - ! ******************************************************************************************************* - ! public subroutine wettedFrac: compute wetted fraction of the canopy - ! ******************************************************************************************************* - subroutine wettedFrac(& - ! input - deriv, & ! flag to denote if derivative is desired - derNum, & ! flag to denote that numerical derivatives are required (otherwise, analytical derivatives are calculated) - frozen, & ! flag to denote if the canopy is frozen - dLiq_dT, & ! derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) - fracLiq, & ! fraction of liquid water on the canopy (-) - canopyLiq, & ! canopy liquid water (kg m-2) - canopyIce, & ! canopy ice (kg m-2) - canopyLiqMax, & ! maximum canopy liquid water (kg m-2) - canopyIceMax, & ! maximum canopy ice content (kg m-2) - canopyWettingFactor, & ! maximum wetted fraction of the canopy (-) - canopyWettingExp, & ! exponent in canopy wetting function (-) - ! output - canopyWetFraction, & ! canopy wetted fraction (-) - dCanopyWetFraction_dWat,& ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) - dCanopyWetFraction_dT, & ! derivative in wetted fraction w.r.t. canopy temperature (K-1) - err,message) ! error control - implicit none - ! input - logical(lgt),intent(in) :: deriv ! flag to denote if derivative is desired - logical(lgt),intent(in) :: derNum ! flag to denote that numerical derivatives are required (otherwise, analytical derivatives are calculated) - logical(lgt),intent(in) :: frozen ! flag to denote if the canopy is frozen - real(rkind),intent(in) :: dLiq_dT ! derivative in canopy liquid w.r.t. canopy temperature (kg m-2 K-1) - real(rkind),intent(in) :: fracLiq ! fraction of liquid water on the canopy (-) - real(rkind),intent(in) :: canopyLiq ! canopy liquid water (kg m-2) - real(rkind),intent(in) :: canopyIce ! canopy ice (kg m-2) - real(rkind),intent(in) :: canopyLiqMax ! maximum canopy liquid water (kg m-2) - real(rkind),intent(in) :: canopyIceMax ! maximum canopy ice content (kg m-2) - real(rkind),intent(in) :: canopyWettingFactor ! maximum wetted fraction of the canopy (-) - real(rkind),intent(in) :: canopyWettingExp ! exponent in canopy wetting function (-) - ! output - real(rkind),intent(out) :: canopyWetFraction ! canopy wetted fraction (-) - real(rkind),intent(out) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) - real(rkind),intent(out) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) - ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! local variables - logical(lgt),parameter :: smoothing=.true. ! flag to denote that smoothing is required - real(rkind) :: canopyWetFractionPert ! canopy wetted fraction after state perturbations (-) - real(rkind) :: canopyWetFractionDeriv ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) - ! ----------------------------------------------------------------------------------------------------------------------------------------------- - ! initialize error control - err=0; message='wettedFrac/' - - ! compute case where the canopy is frozen - if(frozen)then - ! compute fraction of liquid water on the canopy - call wetFraction((deriv .and. .not.derNum),smoothing,canopyIce,canopyIceMax,canopyWettingFactor,canopyWettingExp,canopyWetFraction,canopyWetFractionDeriv) - ! compute numerical derivative, if derivative is desired - if(deriv.and.derNum)then - call wetFraction((deriv .and. .not.derNum),smoothing,canopyIce+dx,canopyIceMax,canopyWettingFactor,canopyWettingExp,canopyWetFractionPert,canopyWetFractionDeriv) - canopyWetFractionDeriv = (canopyWetFractionPert - canopyWetFraction)/dx - end if - ! scale derivative by the fraction of water - ! NOTE: dIce/dWat = (1._rkind - fracLiq), hence dWet/dWat = dIce/dWat . dWet/dLiq - dCanopyWetFraction_dWat = canopyWetFractionDeriv*(1._rkind - fracLiq) - dCanopyWetFraction_dT = -canopyWetFractionDeriv*dLiq_dT ! NOTE: dIce/dT = -dLiq/dT - return - end if - - ! compute fraction of liquid water on the canopy - ! NOTE: if(.not.deriv) canopyWetFractionDeriv = 0._rkind - call wetFraction((deriv .and. .not.derNum),smoothing,canopyLiq,canopyLiqMax,canopyWettingFactor,canopyWettingExp,canopyWetFraction,canopyWetFractionDeriv) - - ! compute numerical derivative - if(deriv.and.derNum)then - call wetFraction((deriv .and. .not.derNum),smoothing,canopyLiq+dx,canopyLiqMax,canopyWettingFactor,canopyWettingExp,canopyWetFractionPert,canopyWetFractionDeriv) - canopyWetFractionDeriv = (canopyWetFractionPert - canopyWetFraction)/dx - end if - - ! scale derivative by the fraction of water - ! NOTE: dLiq/dWat = fracLiq, hence dWet/dWat = dLiq/dWat . dWet/dLiq - dCanopyWetFraction_dWat = canopyWetFractionDeriv*fracLiq - dCanopyWetFraction_dT = canopyWetFractionDeriv*dLiq_dT - - ! test - !write(*,'(a,1x,2(L1,1x),10(f20.10,1x))') 'deriv, derNum, canopyWetFraction, canopyWetFractionDeriv = ', deriv, derNum, canopyWetFraction, canopyWetFractionDeriv - !if(deriv) pause 'testing canopy wet fraction' - - end subroutine wettedFrac - - - ! ******************************************************************************************************* - ! private subroutine wetFraction: compute fraction of canopy covered with liquid water - ! ******************************************************************************************************* - subroutine wetFraction(derDesire,smoothing,canopyLiq,canopyMax,canopyWettingFactor,canopyWettingExp,canopyWetFraction,canopyWetFractionDeriv) - implicit none - ! dummy variables - logical(lgt),intent(in) :: derDesire ! flag to denote if analytical derivatives are desired - logical(lgt),intent(in) :: smoothing ! flag to denote if smoothing is required - real(rkind),intent(in) :: canopyLiq ! liquid water content (kg m-2) - real(rkind),intent(in) :: canopyMax ! liquid water content (kg m-2) - real(rkind),intent(in) :: canopyWettingFactor ! maximum wetted fraction of the canopy (-) - real(rkind),intent(in) :: canopyWettingExp ! exponent in canopy wetting function (-) - - real(rkind),intent(out) :: canopyWetFraction ! canopy wetted fraction (-) - real(rkind),intent(out) :: canopyWetFractionDeriv ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) - ! local variables - real(rkind) :: relativeCanopyWater ! water stored on vegetation canopy, expressed as a fraction of maximum storage (-) - real(rkind) :: rawCanopyWetFraction ! initial value of the canopy wet fraction (before smoothing) - real(rkind) :: rawWetFractionDeriv ! derivative in canopy wet fraction w.r.t. storage (kg-1 m2) - real(rkind) :: smoothFunc ! smoothing function used to improve numerical stability at times with limited water storage (-) - real(rkind) :: smoothFuncDeriv ! derivative in the smoothing function w.r.t.canopy storage (kg-1 m2) - real(rkind) :: verySmall=epsilon(1._rkind) ! a very small number - ! -------------------------------------------------------------------------------------------------------------- - - ! compute relative canopy water - relativeCanopyWater = canopyLiq/canopyMax - !write(*,'(a,1x,e20.10,1x,2(f20.10,1x))') 'relativeCanopyWater, canopyLiq, canopyMax = ', relativeCanopyWater, canopyLiq, canopyMax - - ! compute an initial value of the canopy wet fraction - ! - canopy below value where canopy is 100% wet - if(relativeCanopyWater < 1._rkind)then - rawCanopyWetFraction = canopyWettingFactor*(relativeCanopyWater**canopyWettingExp) - if(derDesire .and. relativeCanopyWater>verySmall)then - rawWetFractionDeriv = (canopyWettingFactor*canopyWettingExp/canopyMax)*relativeCanopyWater**(canopyWettingExp - 1._rkind) else - rawWetFractionDeriv = 0._rkind + rawCanopyWetFraction = canopyWettingFactor + rawWetFractionDeriv = 0._rkind end if - - ! - canopy is at capacity (canopyWettingFactor) - else - rawCanopyWetFraction = canopyWettingFactor - rawWetFractionDeriv = 0._rkind - end if - - ! smooth canopy wetted fraction - if(smoothing)then - call logisticSmoother(derDesire,canopyLiq,smoothFunc,smoothFuncDeriv) - canopyWetFraction = rawCanopyWetFraction*smoothFunc ! logistic smoother - else - canopyWetFraction = rawCanopyWetFraction - canopyWetFractionDeriv = rawWetFractionDeriv - end if - - ! compute derivative (product rule) - if(derDesire .and. smoothing)then ! NOTE: raw derivative is used if not smoothing - canopyWetFractionDeriv = rawWetFractionDeriv*smoothFunc + rawCanopyWetFraction*smoothFuncDeriv - else - canopyWetFractionDeriv = 0._rkind - end if - - end subroutine wetFraction - - - ! ******************************************************************************************************* - ! private subroutine logisticSmoother: compute the smoothing function - ! ******************************************************************************************************* - subroutine logisticSmoother(derDesire,canopyLiq,smoothFunc,smoothFuncDeriv) - implicit none - ! dummy variables - logical(lgt),intent(in) :: derDesire ! flag to denote if analytical derivatives are desired - real(rkind),intent(in) :: canopyLiq ! liquid water content (kg m-2) - real(rkind),intent(out) :: smoothFunc ! smoothing function (-) - real(rkind),intent(out) :: smoothFuncDeriv ! derivative in smoothing function (kg-1 m-2) - ! local variables - real(rkind) :: xArg ! argument used in the smoothing function (-) - real(rkind) :: expX ! exp(-xArg) -- used multiple times - real(rkind),parameter :: smoothThresh=0.01_rkind ! mid-point of the smoothing function (kg m-2) - real(rkind),parameter :: smoothScale=0.001_rkind ! scaling factor for the smoothing function (kg m-2) - real(rkind),parameter :: xLimit=50._rkind ! don't compute exponents for > xLimit - ! -------------------------------------------------------------------------------------------------------------- - ! compute argument in the smoothing function - xArg = (canopyLiq - smoothThresh)/smoothScale - - ! only compute smoothing function for small exponents - if(xArg > -xLimit .and. xArg < xLimit)then ! avoid huge exponents - expX = exp(-xarg) ! (also used in the derivative) - smoothFunc = 1._rkind / (1._rkind + expX) ! (logistic smoother) - if(derDesire)then - smoothFuncDeriv = expX / (smoothScale * (1._rkind + expX)**2._rkind) ! (derivative in the smoothing function) + canopyWetFraction = rawCanopyWetFraction + + ! compute derivative + if (derDesire) then + if (smoothing) then + canopyWetFractionDeriv = rawWetFractionDeriv * smoothThetaDeriv + else ! raw derivative is used if not smoothing + canopyWetFractionDeriv = rawWetFractionDeriv + end if else - smoothFuncDeriv = 0._rkind + canopyWetFractionDeriv = 0._rkind end if - ! outside limits: special case of smooth exponents - else - if(xArg < 0._rkind)then; smoothFunc = 0._rkind ! xArg < -xLimit - else; smoothFunc = 1._rkind ! xArg > xLimit +end subroutine wetFraction + +! ******************************************************************************************************* +! private subroutine thetaSmoother: compute the smoothed canopy liquid water content as in Kavetski and Kuczera (2007) +! ******************************************************************************************************* +subroutine thetaSmoother(derDesire,canopyLiq,smoothTheta,smoothThetaDeriv) + implicit none + ! dummy variables + logical(lgt),intent(in) :: derDesire ! flag to denote if analytical derivatives are desired + real(rkind),intent(in) :: canopyLiq ! liquid water content (kg m-2) + real(rkind),intent(out) :: smoothTheta ! smoothed function of water(-) + real(rkind),intent(out) :: smoothThetaDeriv ! derivative in smoothed function (kg-1 m-2) + ! local variables + real(rkind) :: xArg ! argument used in the smoothing function (-) + real(rkind) :: expX ! exponential term used in the smoothing function (-) + real(rkind),parameter :: smoothThresh=0.01_rkind ! midpoint of smoothing function, move the discontiunity a bit away from 0 (kg m-2) + real(rkind),parameter :: smoothScale=0.0001_rkind ! width of smoothing function (kg m-2) + logical(lgt),parameter :: use_logistic=.true. ! flag to denote if using logistic smoother if true, quadratic smoother if false + ! -------------------------------------------------------------------------------------------------------------- + ! compute argument in the smoothing function + xArg = (canopyLiq - smoothThresh)/smoothScale + + if (use_logistic) then + expX = exp(-xArg) ! also used in the derivative + smoothTheta = smoothScale * (xArg + log((1._rkind + expX))) ! logistic smoother + if (derDesire) then + smoothThetaDeriv = 1._rkind/(1._rkind + expX) ! derivative in the smoothing function + else + smoothThetaDeriv = 0._rkind + end if + else ! use quadratic smoother instead + smoothTheta = 0.5_rkind * smoothScale * (xArg + sqrt((1._rkind + xArg**2_i4b))) ! quadratic smoother + if (derDesire) then + smoothThetaDeriv = 0.5_rkind * (1._rkind + xArg/sqrt((1._rkind + xArg**2_i4b))) ! derivative in the smoothing function + else + smoothThetaDeriv = 0._rkind + end if end if - smoothFuncDeriv = 0._rkind - end if ! check for huge exponents - - end subroutine logisticSmoother - ! -------------------------------------------------------------------------------------------------------------- - - - ! ******************************************************************************************************* - ! private subroutine longwaveBal: compute longwave radiation balance at the canopy and ground surface - ! ******************************************************************************************************* - subroutine longwaveBal(& - ! input: model control - ixDerivMethod, & ! intent(in): choice of method used to compute derivative (analytical or numerical) - computeVegFlux, & ! intent(in): flag to compute fluxes over vegetation - ! input: canopy and ground temperature - canopyTemp, & ! intent(in): canopy temperature (K) - groundTemp, & ! intent(in): ground temperature (K) - ! input: canopy and ground emissivity - emc, & ! intent(in): canopy emissivity (-) - emg, & ! intent(in): ground emissivity (-) - ! input: forcing - LWRadUbound, & ! intent(in): downwelling longwave radiation at the upper boundary (W m-2) - ! output: sources - LWRadCanopy, & ! intent(out): longwave radiation emitted from the canopy (W m-2) - LWRadGround, & ! intent(out): longwave radiation emitted at the ground surface (W m-2) - ! output: individual fluxes - LWRadUbound2Canopy, & ! intent(out): downward atmospheric longwave radiation absorbed by the canopy (W m-2) - LWRadUbound2Ground, & ! intent(out): downward atmospheric longwave radiation absorbed by the ground (W m-2) - LWRadUbound2Ubound, & ! intent(out): atmospheric radiation reflected by the ground and lost thru upper boundary (W m-2) - LWRadCanopy2Ubound, & ! intent(out): longwave radiation emitted from canopy lost thru upper boundary (W m-2) - LWRadCanopy2Ground, & ! intent(out): longwave radiation emitted from canopy absorbed by the ground (W m-2) - LWRadCanopy2Canopy, & ! intent(out): canopy longwave reflected from ground and absorbed by the canopy (W m-2) - LWRadGround2Ubound, & ! intent(out): longwave radiation emitted from ground lost thru upper boundary (W m-2) - LWRadGround2Canopy, & ! intent(out): longwave radiation emitted from ground and absorbed by the canopy (W m-2) - ! output: net fluxes - LWNetCanopy, & ! intent(out): net longwave radiation at the canopy (W m-2) - LWNetGround, & ! intent(out): net longwave radiation at the ground surface (W m-2) - LWNetUbound, & ! intent(out): net longwave radiation at the upper boundary (W m-2) - ! output: flux derivatives - dLWNetCanopy_dTCanopy, & ! intent(out): derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) - dLWNetGround_dTGround, & ! intent(out): derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) - dLWNetCanopy_dTGround, & ! intent(out): derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) - dLWNetGround_dTCanopy, & ! intent(out): derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) - ! output: error control - err,message ) ! intent(out): error control - ! ----------------------------------------------------------------------------------------------------------------------------------------------- - implicit none - ! input: model control - integer(i4b),intent(in) :: ixDerivMethod ! choice of method used to compute derivative (analytical or numerical) - logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation - ! input: canopy and ground temperature - real(rkind),intent(in) :: canopyTemp ! canopy temperature (K) - real(rkind),intent(in) :: groundTemp ! ground temperature (K) - ! input: canopy and ground emissivity - real(rkind),intent(in) :: emc ! canopy emissivity (-) - real(rkind),intent(in) :: emg ! ground emissivity (-) - ! input: forcing - real(rkind),intent(in) :: LWRadUbound ! downwelling longwave radiation at the upper boundary (W m-2) - ! output: sources - real(rkind),intent(out) :: LWRadCanopy ! longwave radiation emitted from the canopy (W m-2) - real(rkind),intent(out) :: LWRadGround ! longwave radiation emitted at the ground surface (W m-2) - ! output: individual fluxes - real(rkind),intent(out) :: LWRadUbound2Canopy ! downward atmospheric longwave radiation absorbed by the canopy (W m-2) - real(rkind),intent(out) :: LWRadUbound2Ground ! downward atmospheric longwave radiation absorbed by the ground (W m-2) - real(rkind),intent(out) :: LWRadUbound2Ubound ! atmospheric radiation reflected by the ground and lost thru upper boundary (W m-2) - real(rkind),intent(out) :: LWRadCanopy2Ubound ! longwave radiation emitted from canopy lost thru upper boundary (W m-2) - real(rkind),intent(out) :: LWRadCanopy2Ground ! longwave radiation emitted from canopy absorbed by the ground (W m-2) - real(rkind),intent(out) :: LWRadCanopy2Canopy ! canopy longwave reflected from ground and absorbed by the canopy (W m-2) - real(rkind),intent(out) :: LWRadGround2Ubound ! longwave radiation emitted from ground lost thru upper boundary (W m-2) - real(rkind),intent(out) :: LWRadGround2Canopy ! longwave radiation emitted from ground and absorbed by the canopy (W m-2) - ! output: net fluxes - real(rkind),intent(out) :: LWNetCanopy ! net longwave radiation at the canopy (W m-2) - real(rkind),intent(out) :: LWNetGround ! net longwave radiation at the ground surface (W m-2) - real(rkind),intent(out) :: LWNetUbound ! net longwave radiation at the upper boundary (W m-2) - ! output: flux derivatives - real(rkind),intent(out) :: dLWNetCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) - real(rkind),intent(out) :: dLWNetGround_dTGround ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) - real(rkind),intent(out) :: dLWNetCanopy_dTGround ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) - real(rkind),intent(out) :: dLWNetGround_dTCanopy ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) - ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! ----------------------------------------------------------------------------------------------------------------------------------------------- - ! local variables - integer(i4b),parameter :: unperturbed=1 ! named variable to identify the case of unperturbed state variables - integer(i4b),parameter :: perturbStateCanopy=2 ! named variable to identify the case where we perturb the canopy temperature - integer(i4b),parameter :: perturbStateGround=3 ! named variable to identify the case where we perturb the ground temperature - integer(i4b) :: itry ! index of flux evaluation - integer(i4b) :: nFlux ! number of flux evaluations - real(rkind) :: TCan ! value of canopy temperature used in flux calculations (may be perturbed) - real(rkind) :: TGnd ! value of ground temperature used in flux calculations (may be perturbed) - real(rkind) :: fluxBalance ! check energy closure (W m-2) - real(rkind),parameter :: fluxTolerance=1.e-10_rkind ! tolerance for energy closure (W m-2) - real(rkind) :: dLWRadCanopy_dTCanopy ! derivative in emitted radiation at the canopy w.r.t. canopy temperature - real(rkind) :: dLWRadGround_dTGround ! derivative in emitted radiation at the ground w.r.t. ground temperature - real(rkind) :: LWNetCanopy_dStateCanopy ! net lw canopy flux after perturbation in canopy temperature - real(rkind) :: LWNetGround_dStateCanopy ! net lw ground flux after perturbation in canopy temperature - real(rkind) :: LWNetCanopy_dStateGround ! net lw canopy flux after perturbation in ground temperature - real(rkind) :: LWNetGround_dStateGround ! net lw ground flux after perturbation in ground temperature - ! ----------------------------------------------------------------------------------------------------------------------------------------------- - ! initialize error control - err=0; message='longwaveBal/' - - ! check the need to compute numerical derivatives - if(ixDerivMethod==numerical)then - nFlux=3 ! compute the derivatives using one-sided finite differences - else - nFlux=1 ! compute analytical derivatives - end if - - ! either one or multiple flux calls, depending on if using analytical or numerical derivatives - do itry=nFlux,1,-1 ! (work backwards to ensure all computed fluxes come from the un-perturbed case) - - !print*, 'perturbation: ', (itry==unperturbed), (itry==perturbStateCanopy), (itry==perturbStateGround) - - ! ------------------------------------------------------------------------------------- - ! state perturbations for numerical deriavtives with one-sided finite differences - ! note: no perturbations performed using analytical derivatives (nFlux=1) - ! ------------------------------------------------------------------------------------- - - ! identify the type of perturbation - select case(itry) - - ! un-perturbed case - case(unperturbed) - TCan = canopyTemp - TGnd = groundTemp - - ! perturb canopy temperature - case(perturbStateCanopy) - TCan = canopyTemp + dx - TGnd = groundTemp - - ! perturb ground temperature - case(perturbStateGround) - TCan = canopyTemp - TGnd = groundTemp + dx - - ! check for an unknown perturbation - case default; err=10; message=trim(message)//"unknown perturbation"; return - - end select ! (type of perturbation) - - ! ------------------------------------------------------------------------------------- - ! calculation block (unperturbed fluxes returned [computed last]) - ! ------------------------------------------------------------------------------------- - ! NOTE: emc should be set to zero when not computing canopy fluxes +end subroutine thetaSmoother + +! ******************************************************************************************************* +! private subroutine longwaveBal: compute longwave radiation balance at the canopy and ground surface +! ******************************************************************************************************* +subroutine longwaveBal(& + ! input: model control + computeVegFlux, & ! intent(in): flag to compute fluxes over vegetation + checkLWBalance, & ! intent(in): flag to check longwave balance + ! input: canopy and ground temperature + canopyTemp, & ! intent(in): canopy temperature (K) + groundTemp, & ! intent(in): ground temperature (K) + ! input: canopy and ground emissivity + emc, & ! intent(in): canopy emissivity (-) + emg, & ! intent(in): ground emissivity (-) + ! input: forcing + LWRadUbound, & ! intent(in): downwelling longwave radiation at the upper boundary (W m-2) + ! output: sources + LWRadCanopy, & ! intent(out): longwave radiation emitted from the canopy (W m-2) + LWRadGround, & ! intent(out): longwave radiation emitted at the ground surface (W m-2) + ! output: individual fluxes + LWRadUbound2Canopy, & ! intent(out): downward atmospheric longwave radiation absorbed by the canopy (W m-2) + LWRadUbound2Ground, & ! intent(out): downward atmospheric longwave radiation absorbed by the ground (W m-2) + LWRadUbound2Ubound, & ! intent(out): atmospheric radiation reflected by the ground and lost thru upper boundary (W m-2) + LWRadCanopy2Ubound, & ! intent(out): longwave radiation emitted from canopy lost thru upper boundary (W m-2) + LWRadCanopy2Ground, & ! intent(out): longwave radiation emitted from canopy absorbed by the ground (W m-2) + LWRadCanopy2Canopy, & ! intent(out): canopy longwave reflected from ground and absorbed by the canopy (W m-2) + LWRadGround2Ubound, & ! intent(out): longwave radiation emitted from ground lost thru upper boundary (W m-2) + LWRadGround2Canopy, & ! intent(out): longwave radiation emitted from ground and absorbed by the canopy (W m-2) + ! output: net fluxes + LWNetCanopy, & ! intent(out): net longwave radiation at the canopy (W m-2) + LWNetGround, & ! intent(out): net longwave radiation at the ground surface (W m-2) + LWNetUbound, & ! intent(out): net longwave radiation at the upper boundary (W m-2) + ! output: flux derivatives + dLWNetCanopy_dTCanopy, & ! intent(out): derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) + dLWNetGround_dTGround, & ! intent(out): derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) + dLWNetCanopy_dTGround, & ! intent(out): derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) + dLWNetGround_dTCanopy, & ! intent(out): derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) + ! output: error control + err,message ) ! intent(out): error control + ! ----------------------------------------------------------------------------------------------------------------------------------------------- + implicit none + ! input: model control + logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if computing fluxes over vegetation + logical(lgt),intent(in) :: checkLWBalance ! flag to check longwave balance + ! input: canopy and ground temperature + real(rkind),intent(in) :: canopyTemp ! canopy temperature (K) + real(rkind),intent(in) :: groundTemp ! ground temperature (K) + ! input: canopy and ground emissivity + real(rkind),intent(in) :: emc ! canopy emissivity (-) + real(rkind),intent(in) :: emg ! ground emissivity (-) + ! input: forcing + real(rkind),intent(in) :: LWRadUbound ! downwelling longwave radiation at the upper boundary (W m-2) + ! output: sources + real(rkind),intent(out) :: LWRadCanopy ! longwave radiation emitted from the canopy (W m-2) + real(rkind),intent(out) :: LWRadGround ! longwave radiation emitted at the ground surface (W m-2) + ! output: individual fluxes + real(rkind),intent(out) :: LWRadUbound2Canopy ! downward atmospheric longwave radiation absorbed by the canopy (W m-2) + real(rkind),intent(out) :: LWRadUbound2Ground ! downward atmospheric longwave radiation absorbed by the ground (W m-2) + real(rkind),intent(out) :: LWRadUbound2Ubound ! atmospheric radiation reflected by the ground and lost thru upper boundary (W m-2) + real(rkind),intent(out) :: LWRadCanopy2Ubound ! longwave radiation emitted from canopy lost thru upper boundary (W m-2) + real(rkind),intent(out) :: LWRadCanopy2Ground ! longwave radiation emitted from canopy absorbed by the ground (W m-2) + real(rkind),intent(out) :: LWRadCanopy2Canopy ! canopy longwave reflected from ground and absorbed by the canopy (W m-2) + real(rkind),intent(out) :: LWRadGround2Ubound ! longwave radiation emitted from ground lost thru upper boundary (W m-2) + real(rkind),intent(out) :: LWRadGround2Canopy ! longwave radiation emitted from ground and absorbed by the canopy (W m-2) + ! output: net fluxes + real(rkind),intent(out) :: LWNetCanopy ! net longwave radiation at the canopy (W m-2) + real(rkind),intent(out) :: LWNetGround ! net longwave radiation at the ground surface (W m-2) + real(rkind),intent(out) :: LWNetUbound ! net longwave radiation at the upper boundary (W m-2) + ! output: flux derivatives + real(rkind),intent(out) :: dLWNetCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) + real(rkind),intent(out) :: dLWNetGround_dTGround ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) + real(rkind),intent(out) :: dLWNetCanopy_dTGround ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) + real(rkind),intent(out) :: dLWNetGround_dTCanopy ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! ----------------------------------------------------------------------------------------------------------------------------------------------- + ! local variables + real(rkind) :: fluxBalance ! check energy closure (W m-2) + real(rkind),parameter :: fluxTolerance=1.e-10_rkind ! tolerance for energy closure (W m-2) + real(rkind) :: dLWRadCanopy_dTCanopy ! derivative in emitted radiation at the canopy w.r.t. canopy temperature + real(rkind) :: dLWRadGround_dTGround ! derivative in emitted radiation at the ground w.r.t. ground temperature + ! ----------------------------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message='longwaveBal/' + ! compute longwave fluxes from canopy and the ground - if(computeVegFlux)then - LWRadCanopy = emc*sb*TCan**4._rkind ! longwave radiation emitted from the canopy (W m-2) + ! NOTE: emc should be set to zero when not computing canopy fluxes + if (computeVegFlux) then + LWRadCanopy = emc*sb*canopyTemp**4_i4b ! longwave radiation emitted from the canopy (W m-2) else - LWRadCanopy = 0._rkind + LWRadCanopy = 0._rkind end if - LWRadGround = emg*sb*TGnd**4._rkind ! longwave radiation emitted at the ground surface (W m-2) + LWRadGround = emg*sb*groundTemp**4_i4b ! longwave radiation emitted at the ground surface (W m-2) + ! cap function to prevent blowing up + if (canopyTemp<0._rkind) LWRadCanopy = 0._rkind + if (groundTemp<0._rkind) LWRadGround = 0._rkind ! compute fluxes originating from the atmosphere - LWRadUbound2Canopy = (emc + (1._rkind - emc)*(1._rkind - emg)*emc)*LWRadUbound ! downward atmospheric longwave radiation absorbed by the canopy (W m-2) - LWRadUbound2Ground = (1._rkind - emc)*emg*LWRadUbound ! downward atmospheric longwave radiation absorbed by the ground (W m-2) + LWRadUbound2Canopy = (emc + (1._rkind - emc)*(1._rkind - emg)*emc)*LWRadUbound ! downward atmospheric longwave radiation absorbed by the canopy (W m-2) + LWRadUbound2Ground = (1._rkind - emc)*emg*LWRadUbound ! downward atmospheric longwave radiation absorbed by the ground (W m-2) LWRadUbound2Ubound = (1._rkind - emc)*(1._rkind - emg)*(1._rkind - emc)*LWRadUbound ! atmospheric radiation reflected by the ground and lost thru upper boundary (W m-2) - ! compute fluxes originating from the canopy LWRadCanopy2Ubound = (1._rkind + (1._rkind - emc)*(1._rkind - emg))*LWRadCanopy ! longwave radiation emitted from canopy lost thru upper boundary (W m-2) - LWRadCanopy2Ground = emg*LWRadCanopy ! longwave radiation emitted from canopy absorbed by the ground (W m-2) - LWRadCanopy2Canopy = emc*(1._rkind - emg)*LWRadCanopy ! canopy longwave reflected from ground and absorbed by the canopy (W m-2) - + LWRadCanopy2Ground = emg*LWRadCanopy ! longwave radiation emitted from canopy absorbed by the ground (W m-2) + LWRadCanopy2Canopy = emc*(1._rkind - emg)*LWRadCanopy ! canopy longwave reflected from ground and absorbed by the canopy (W m-2) ! compute fluxes originating from the ground surface - LWRadGround2Ubound = (1._rkind - emc)*LWRadGround ! longwave radiation emitted from ground lost thru upper boundary (W m-2) - LWRadGround2Canopy = emc*LWRadGround ! longwave radiation emitted from ground and absorbed by the canopy (W m-2) - + LWRadGround2Ubound = (1._rkind - emc)*LWRadGround ! longwave radiation emitted from ground lost thru upper boundary (W m-2) + LWRadGround2Canopy = emc*LWRadGround ! longwave radiation emitted from ground and absorbed by the canopy (W m-2) ! compute net longwave radiation (W m-2) LWNetCanopy = LWRadUbound2Canopy + LWRadGround2Canopy + LWRadCanopy2Canopy - 2._rkind*LWRadCanopy ! canopy - LWNetGround = LWRadUbound2Ground + LWRadCanopy2Ground - LWRadGround ! ground surface - LWNetUbound = LWRadUbound - LWRadUbound2Ubound - LWRadCanopy2Ubound - LWRadGround2Ubound ! upper boundary - - !print*, 'LWRadCanopy = ', LWRadCanopy - !print*, 'LWRadGround = ', LWRadGround - - !print*, 'LWNetCanopy = ', LWNetCanopy - !print*, 'LWNetGround = ', LWNetGround - !print*, 'LWNetUbound = ', LWNetUbound + LWNetGround = LWRadUbound2Ground + LWRadCanopy2Ground - LWRadGround ! ground surface + LWNetUbound = LWRadUbound - LWRadUbound2Ubound - LWRadCanopy2Ubound - LWRadGround2Ubound ! upper boundary ! check the flux balance fluxBalance = LWNetUbound - (LWNetCanopy + LWNetGround) - if(abs(fluxBalance) > fluxTolerance)then - print*, 'fluxBalance = ', fluxBalance - print*, 'emg, emc = ', emg, emc - print*, 'TCan, TGnd = ', TCan, TGnd - print*, 'LWRadUbound = ', LWRadUbound - print*, 'LWRadCanopy = ', LWRadCanopy - print*, 'LWRadGround = ', LWRadGround - print*, 'LWRadUbound2Canopy = ', LWRadUbound2Canopy - print*, 'LWRadUbound2Ground = ', LWRadUbound2Ground - print*, 'LWRadUbound2Ubound = ', LWRadUbound2Ubound - print*, 'LWRadCanopy2Ubound = ', LWRadCanopy2Ubound - print*, 'LWRadCanopy2Ground = ', LWRadCanopy2Ground - print*, 'LWRadCanopy2Canopy = ', LWRadCanopy2Canopy - print*, 'LWRadGround2Ubound = ', LWRadGround2Ubound - print*, 'LWRadGround2Canopy = ', LWRadGround2Canopy - print*, 'LWNetCanopy = ', LWNetCanopy - print*, 'LWNetGround = ', LWNetGround - print*, 'LWNetUbound = ', LWNetUbound - message=trim(message)//'flux imbalance' - err=20; return + if (abs(fluxBalance) > fluxTolerance .and. checkLWBalance) then + print*, 'fluxBalance = ', fluxBalance + print*, 'emg, emc = ', emg, emc + print*, 'canopyTemp, groundTemp = ', canopyTemp, groundTemp + print*, 'LWRadUbound = ', LWRadUbound + print*, 'LWRadCanopy = ', LWRadCanopy + print*, 'LWRadGround = ', LWRadGround + print*, 'LWRadUbound2Canopy = ', LWRadUbound2Canopy + print*, 'LWRadUbound2Ground = ', LWRadUbound2Ground + print*, 'LWRadUbound2Ubound = ', LWRadUbound2Ubound + print*, 'LWRadCanopy2Ubound = ', LWRadCanopy2Ubound + print*, 'LWRadCanopy2Ground = ', LWRadCanopy2Ground + print*, 'LWRadCanopy2Canopy = ', LWRadCanopy2Canopy + print*, 'LWRadGround2Ubound = ', LWRadGround2Ubound + print*, 'LWRadGround2Canopy = ', LWRadGround2Canopy + print*, 'LWNetCanopy = ', LWNetCanopy + print*, 'LWNetGround = ', LWNetGround + print*, 'LWNetUbound = ', LWNetUbound + message=trim(message)//'flux imbalance' + err=20; return end if - ! -------------------------------------------------------------------------------------- - ! save perturbed fluxes to calculate numerical derivatives (one-sided finite difference) - ! -------------------------------------------------------------------------------------- - if(ixDerivMethod==numerical)then - select case(itry) ! (select type of perturbation) - case(unperturbed); exit - case(perturbStateCanopy) - LWNetCanopy_dStateCanopy = LWNetCanopy - LWNetGround_dStateCanopy = LWNetGround - case(perturbStateGround) - LWNetCanopy_dStateGround = LWNetCanopy - LWNetGround_dStateGround = LWNetGround - case default; err=10; message=trim(message)//"unknown perturbation"; return - end select ! (type of perturbation) - end if ! (if numerical) - - end do ! looping through different perturbations - - ! ------------------------------------------------------------------------------------- - ! compute derivatives - ! ------------------------------------------------------------------------------------- - select case(ixDerivMethod) - - ! ***** analytical derivatives - case(analytical) - ! compute initial derivatives - dLWRadCanopy_dTCanopy = 4._rkind*emc*sb*TCan**3._rkind - dLWRadGround_dTGround = 4._rkind*emg*sb*TGnd**3._rkind - ! compute analytical derivatives - dLWNetCanopy_dTCanopy = (emc*(1._rkind - emg) - 2._rkind)*dLWRadCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) - dLWNetGround_dTGround = -dLWRadGround_dTGround ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) - dLWNetCanopy_dTGround = emc*dLWRadGround_dTGround ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) - dLWNetGround_dTCanopy = emg*dLWRadCanopy_dTCanopy ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) - - ! ***** numerical derivatives - case(numerical) - ! compute numerical derivatives (one-sided finite differences) - dLWNetCanopy_dTCanopy = (LWNetCanopy_dStateCanopy - LWNetCanopy)/dx ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) - dLWNetGround_dTGround = (LWNetGround_dStateGround - LWNetGround)/dx ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) - dLWNetCanopy_dTGround = (LWNetCanopy_dStateGround - LWNetCanopy)/dx ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) - dLWNetGround_dTCanopy = (LWNetGround_dStateCanopy - LWNetGround)/dx ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) - - ! ***** error check - case default; err=10; message=trim(message)//"unknown method to calculate derivatives"; return - - end select ! (type of method to calculate derivatives) - - end subroutine longwaveBal - - - ! ******************************************************************************************************* - ! private subroutine aeroResist: compute aerodynamic resistances - ! ******************************************************************************************************* - subroutine aeroResist(& - ! input: model control - computeVegFlux, & ! intent(in): logical flag to compute vegetation fluxes (.false. if veg buried by snow) - derivDesired, & ! intent(in): flag to indicate if analytical derivatives are desired - ixVegTraits, & ! intent(in): choice of parameterization for vegetation roughness length and displacement height - ixWindProfile, & ! intent(in): choice of canopy wind profile - ixStability, & ! intent(in): choice of stability function - ! input: above-canopy forcing data - mHeight, & ! intent(in): measurement height (m) - airtemp, & ! intent(in): air temperature at some height above the surface (K) - windspd, & ! intent(in): wind speed at some height above the surface (m s-1) - ! input: temperature (canopy, ground, canopy air space) - canairTemp, & ! intent(in): temperature of the canopy air space (K) - groundTemp, & ! intent(in): ground temperature (K) - ! input: diagnostic variables - exposedVAI, & ! intent(in): exposed vegetation area index -- leaf plus stem (m2 m-2) - snowDepth, & ! intent(in): snow depth (m) - ! input: parameters - z0Ground, & ! intent(in): roughness length of the ground (below canopy or non-vegetated surface [snow]) (m) - z0CanopyParam, & ! intent(in): roughness length of the canopy (m) - zpdFraction, & ! intent(in): zero plane displacement / canopy height (-) - critRichNumber, & ! intent(in): critical value for the bulk Richardson number where turbulence ceases (-) - Louis79_bparam, & ! intent(in): parameter in Louis (1979) stability function - Mahrt87_eScale, & ! intent(in): exponential scaling factor in the Mahrt (1987) stability function - windReductionParam, & ! intent(in): canopy wind reduction parameter (-) - leafExchangeCoeff, & ! intent(in): turbulent exchange coeff between canopy surface and canopy air ( m s-(1/2) ) - leafDimension, & ! intent(in): characteristic leaf dimension (m) - heightCanopyTop, & ! intent(in): height at the top of the vegetation canopy (m) - heightCanopyBottom, & ! intent(in): height at the bottom of the vegetation canopy (m) - ! output: stability corrections - RiBulkCanopy, & ! intent(out): bulk Richardson number for the canopy (-) - RiBulkGround, & ! intent(out): bulk Richardson number for the ground surface (-) - canopyStabilityCorrection, & ! intent(out): stability correction for the canopy (-) - groundStabilityCorrection, & ! intent(out): stability correction for the ground surface (-) - ! output: scalar resistances - z0Canopy, & ! intent(out): roughness length of the canopy (m) - windReductionFactor, & ! intent(out): canopy wind reduction factor (-) - zeroPlaneDisplacement, & ! intent(out): zero plane displacement (m) - eddyDiffusCanopyTop, & ! intent(out): eddy diffusivity for heat at the top of the canopy (m2 s-1) - frictionVelocity, & ! intent(out): friction velocity (m s-1) - windspdCanopyTop, & ! intent(out): windspeed at the top of the canopy (m s-1) - windspdCanopyBottom, & ! intent(out): windspeed at the height of the bottom of the canopy (m s-1) - leafResistance, & ! intent(out): mean leaf boundary layer resistance per unit leaf area (s m-1) - groundResistance, & ! intent(out): below canopy aerodynamic resistance (s m-1) - canopyResistance, & ! intent(out): above canopy aerodynamic resistance (s m-1) - ! output: derivatives in scalar resistances - dGroundResistance_dTGround, & ! intent(out): derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) - dGroundResistance_dTCanopy, & ! intent(out): derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) - dGroundResistance_dTCanair, & ! intent(out): derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) - dCanopyResistance_dTCanopy, & ! intent(out): derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - dCanopyResistance_dTCanair, & ! intent(out): derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) - ! output: error control - err,message ) ! intent(out): error control - ! ----------------------------------------------------------------------------------------------------------------------------------------- - ! compute aerodynamic resistances - ! Refs: Choudhury and Monteith (4-layer model for heat budget of homogenous surfaces; QJRMS, 1988) - ! Niu and Yang (Canopy effects on snow processes; JGR, 2004) - ! Mahat et al. (Below-canopy turbulence in a snowmelt model, WRR, 2012) - implicit none - ! input: model control - logical(lgt),intent(in) :: computeVegFlux ! logical flag to compute vegetation fluxes (.false. if veg buried by snow) - logical(lgt),intent(in) :: derivDesired ! logical flag to indicate if analytical derivatives are desired - integer(i4b),intent(in) :: ixVegTraits ! choice of parameterization for vegetation roughness length and displacement height - integer(i4b),intent(in) :: ixWindProfile ! choice of canopy wind profile - integer(i4b),intent(in) :: ixStability ! choice of stability function - ! input: above-canopy forcing data - real(rkind),intent(in) :: mHeight ! measurement height (m) - real(rkind),intent(in) :: airtemp ! air temperature at some height above the surface (K) - real(rkind),intent(in) :: windspd ! wind speed at some height above the surface (m s-1) - ! input: temperature (canopy, ground, canopy air space) - real(rkind),intent(in) :: canairTemp ! temperature of the canopy air space (K) - real(rkind),intent(in) :: groundTemp ! ground temperature (K) - ! input: diagnostic variables - real(rkind),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf plus stem (m2 m-2) - real(rkind),intent(in) :: snowDepth ! snow depth (m) - ! input: parameters - real(rkind),intent(in) :: z0Ground ! roughness length of the ground (below canopy or non-vegetated surface [snow]) (m) - real(rkind),intent(in) :: z0CanopyParam ! roughness length of the canopy (m) - real(rkind),intent(in) :: zpdFraction ! zero plane displacement / canopy height (-) - real(rkind),intent(in) :: critRichNumber ! critical value for the bulk Richardson number where turbulence ceases (-) - real(rkind),intent(in) :: Louis79_bparam ! parameter in Louis (1979) stability function - real(rkind),intent(in) :: Mahrt87_eScale ! exponential scaling factor in the Mahrt (1987) stability function - real(rkind),intent(in) :: windReductionParam ! canopy wind reduction parameter (-) - real(rkind),intent(in) :: leafExchangeCoeff ! turbulent exchange coeff between canopy surface and canopy air ( m s-(1/2) ) - real(rkind),intent(in) :: leafDimension ! characteristic leaf dimension (m) - real(rkind),intent(in) :: heightCanopyTop ! height at the top of the vegetation canopy (m) - real(rkind),intent(in) :: heightCanopyBottom ! height at the bottom of the vegetation canopy (m) - ! output: stability corrections - real(rkind),intent(out) :: RiBulkCanopy ! bulk Richardson number for the canopy (-) - real(rkind),intent(out) :: RiBulkGround ! bulk Richardson number for the ground surface (-) - real(rkind),intent(out) :: canopyStabilityCorrection ! stability correction for the canopy (-) - real(rkind),intent(out) :: groundStabilityCorrection ! stability correction for the ground surface (-) - ! output: scalar resistances - real(rkind),intent(out) :: z0Canopy ! roughness length of the vegetation canopy (m) - real(rkind),intent(out) :: windReductionFactor ! canopy wind reduction factor (-) - real(rkind),intent(out) :: zeroPlaneDisplacement ! zero plane displacement (m) - real(rkind),intent(out) :: eddyDiffusCanopyTop ! eddy diffusivity for heat at the top of the canopy (m2 s-1) - real(rkind),intent(out) :: frictionVelocity ! friction velocity (m s-1) - real(rkind),intent(out) :: windspdCanopyTop ! windspeed at the top of the canopy (m s-1) - real(rkind),intent(out) :: windspdCanopyBottom ! windspeed at the height of the bottom of the canopy (m s-1) - real(rkind),intent(out) :: leafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) - real(rkind),intent(out) :: groundResistance ! below canopy aerodynamic resistance (s m-1) - real(rkind),intent(out) :: canopyResistance ! above canopy aerodynamic resistance (s m-1) - ! output: derivatives in scalar resistances - real(rkind),intent(out) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) - real(rkind),intent(out) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) - real(rkind),intent(out) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) - real(rkind),intent(out) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - real(rkind),intent(out) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) - ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! ----------------------------------------------------------------------------------------------------------------------------------------- - ! local variables: general - character(LEN=256) :: cmessage ! error message of downwind routine - ! local variables: vegetation roughness and dispalcement height - real(rkind),parameter :: oneThird=1._rkind/3._rkind ! 1/3 - real(rkind),parameter :: twoThirds=2._rkind/3._rkind ! 2/3 - real(rkind),parameter :: C_r = 0.3 ! roughness element drag coefficient (-) from Raupach (BLM, 1994) - real(rkind),parameter :: C_s = 0.003_rkind ! substrate surface drag coefficient (-) from Raupach (BLM, 1994) - real(rkind),parameter :: approxDragCoef_max = 0.3_rkind ! maximum value of the approximate drag coefficient (-) from Raupach (BLM, 1994) - real(rkind),parameter :: psi_h = 0.193_rkind ! roughness sub-layer influence function (-) from Raupach (BLM, 1994) - real(rkind),parameter :: c_d1 = 7.5_rkind ! scaling parameter used to define displacement height (-) from Raupach (BLM, 1994) - real(rkind),parameter :: cd_CM = 0.2_rkind ! mean drag coefficient for individual leaves (-) from Choudhury and Monteith (QJRMS, 1988) - real(rkind) :: funcLAI ! temporary variable to calculate zero plane displacement for the canopy - real(rkind) :: fracCanopyHeight ! zero plane displacement expressed as a fraction of canopy height - real(rkind) :: approxDragCoef ! approximate drag coefficient used in the computation of canopy roughness length (-) - ! local variables: resistance - real(rkind) :: canopyExNeut ! surface-atmosphere exchange coefficient under neutral conditions (-) - real(rkind) :: groundExNeut ! surface-atmosphere exchange coefficient under neutral conditions (-) - real(rkind) :: sfc2AtmExchangeCoeff_canopy ! surface-atmosphere exchange coefficient after stability corrections (-) - real(rkind) :: groundResistanceNeutral ! ground resistance under neutral conditions (s m-1) - real(rkind) :: windConvFactor_fv ! factor to convert friction velocity to wind speed at top of canopy (-) - real(rkind) :: windConvFactor ! factor to convert wind speed at top of canopy to wind speed at a given height in the canopy (-) - real(rkind) :: referenceHeight ! z0Canopy+zeroPlaneDisplacement (m) - real(rkind) :: windspdRefHeight ! windspeed at the reference height (m/s) - real(rkind) :: heightAboveGround ! height above the snow surface (m) - real(rkind) :: heightCanopyTopAboveSnow ! height at the top of the vegetation canopy relative to snowpack (m) - real(rkind) :: heightCanopyBottomAboveSnow ! height at the bottom of the vegetation canopy relative to snowpack (m) - real(rkind),parameter :: xTolerance=0.1_rkind ! tolerance to handle the transition from exponential to log-below canopy - ! local variables: derivatives - real(rkind) :: dFV_dT ! derivative in friction velocity w.r.t. canopy air temperature - real(rkind) :: dED_dT ! derivative in eddy diffusivity at the top of the canopy w.r.t. canopy air temperature - real(rkind) :: dGR_dT ! derivative in neutral ground resistance w.r.t. canopy air temperature - real(rkind) :: tmp1,tmp2 ! temporary variables used in calculation of ground resistance - real(rkind) :: dCanopyStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number for the canopy (-) - real(rkind) :: dGroundStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number for the ground surface (-) - real(rkind) :: dCanopyStabilityCorrection_dAirTemp ! (not used) derivative in stability correction w.r.t. air temperature (K-1) - real(rkind) :: dGroundStabilityCorrection_dAirTemp ! (not used) derivative in stability correction w.r.t. air temperature (K-1) - real(rkind) :: dCanopyStabilityCorrection_dCasTemp ! derivative in canopy stability correction w.r.t. canopy air space temperature (K-1) - real(rkind) :: dGroundStabilityCorrection_dCasTemp ! derivative in ground stability correction w.r.t. canopy air space temperature (K-1) - real(rkind) :: dGroundStabilityCorrection_dSfcTemp ! derivative in ground stability correction w.r.t. surface temperature (K-1) - real(rkind) :: singleLeafConductance ! leaf boundary layer conductance (m s-1) - real(rkind) :: canopyLeafConductance ! leaf boundary layer conductance -- scaled up to the canopy (m s-1) - real(rkind) :: leaf2CanopyScaleFactor ! factor to scale from the leaf to the canopy [m s-(1/2)] - ! ----------------------------------------------------------------------------------------------------------------------------------------- - ! initialize error control - err=0; message='aeroResist/' - - ! check that measurement height is above the top of the canopy - if(mHeight < heightCanopyTop)then - err=20; message=trim(message)//'measurement height is below the top of the canopy'; return - end if - - ! ----------------------------------------------------------------------------------------------------------------------------------------- - ! * compute vegetation poperties (could be done at the same time as phenology.. does not have to be in the flux routine!) - if(computeVegFlux) then ! (if vegetation is exposed) - - ! ***** identify zero plane displacement, roughness length, and surface temperature for the canopy (m) - ! First, calculate new coordinate system above snow - use these to scale wind profiles and resistances - ! NOTE: the new coordinate system makes zeroPlaneDisplacement and z0Canopy consistent - heightCanopyTopAboveSnow = heightCanopyTop - snowDepth - heightCanopyBottomAboveSnow = max(heightCanopyBottom - snowDepth, 0.0_rkind) - select case(ixVegTraits) - - ! Raupach (BLM 1994) "Simplified expressions..." - case(Raupach_BLM1994) - ! (compute zero-plane displacement) - funcLAI = sqrt(c_d1*exposedVAI) - fracCanopyHeight = -(1._rkind - exp(-funcLAI))/funcLAI + 1._rkind - zeroPlaneDisplacement = fracCanopyHeight*(heightCanopyTopAboveSnow-heightCanopyBottomAboveSnow)+heightCanopyBottomAboveSnow - ! (coupute roughness length of the veg canopy) - approxDragCoef = min( sqrt(C_s + C_r*exposedVAI/2._rkind), approxDragCoef_max) - z0Canopy = (1._rkind - fracCanopyHeight) * exp(-vkc*approxDragCoef - psi_h) * (heightCanopyTopAboveSnow-heightCanopyBottomAboveSnow) - - ! Choudhury and Monteith (QJRMS 1988) "A four layer model for the heat budget..." - case(CM_QJRMS1988) - funcLAI = cd_CM*exposedVAI - zeroPlaneDisplacement = 1.1_rkind*heightCanopyTopAboveSnow*log(1._rkind + funcLAI**0.25_rkind) - if(funcLAI < 0.2_rkind)then - z0Canopy = z0Ground + 0.3_rkind*heightCanopyTopAboveSnow*funcLAI**0.5_rkind - else - z0Canopy = 0.3_rkind*heightCanopyTopAboveSnow*(1._rkind - zeroPlaneDisplacement/heightCanopyTopAboveSnow) - end if - - ! constant parameters dependent on the vegetation type - case(vegTypeTable) - zeroPlaneDisplacement = zpdFraction*heightCanopyTopAboveSnow ! zero-plane displacement (m) - z0Canopy = z0CanopyParam ! roughness length of the veg canopy (m) - - ! check - case default - err=10; message=trim(message)//"unknown parameterization for vegetation roughness length and displacement height"; return + ! ------------------------------------------------------------------------------------- + ! compute derivatives + ! ------------------------------------------------------------------------------------- + ! compute initial derivatives + dLWRadCanopy_dTCanopy = 4._rkind*emc*sb*canopyTemp**3_i4b + dLWRadGround_dTGround = 4._rkind*emg*sb*groundTemp**3_i4b + ! cap function to prevent blowing up + if (canopyTemp<0) dLWRadCanopy_dTCanopy = 0._rkind + if (groundTemp<0) dLWRadGround_dTGround = 0._rkind + + ! compute analytical derivatives + dLWNetCanopy_dTCanopy = (emc*(1._rkind - emg) - 2._rkind)*dLWRadCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) + dLWNetGround_dTGround = -dLWRadGround_dTGround ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) + dLWNetCanopy_dTGround = emc*dLWRadGround_dTGround ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) + dLWNetGround_dTCanopy = emg*dLWRadCanopy_dTCanopy ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) + +end subroutine longwaveBal + +! ******************************************************************************************************* +! private subroutine aeroResist: compute aerodynamic resistances +! ******************************************************************************************************* +subroutine aeroResist(& + ! input: model control + computeVegFlux, & ! intent(in): logical flag to compute vegetation fluxes (.false. if veg buried by snow) + ixVegTraits, & ! intent(in): choice of parameterization for vegetation roughness length and displacement height + ixWindProfile, & ! intent(in): choice of canopy wind profile + ixStability, & ! intent(in): choice of stability function + ! input: above-canopy forcing data + mHeight, & ! intent(in): measurement height (m) + airtemp, & ! intent(in): air temperature at measurement height (K) + windspd, & ! intent(in): wind speed at measurement height (m s-1) + ! input: temperature (canopy, ground, canopy air space) + canairTemp, & ! intent(in): temperature of the canopy air space (K) + groundTemp, & ! intent(in): ground temperature (K) + ! input: diagnostic variables + exposedVAI, & ! intent(in): exposed vegetation area index -- leaf plus stem (m2 m-2) + snowDepth, & ! intent(in): snow depth (m) + ! input: parameters + z0Ground, & ! intent(in): roughness length of the ground (below canopy or non-vegetated surface [snow]) (m) + z0CanopyParam, & ! intent(in): roughness length of the canopy (m) + zpdFraction, & ! intent(in): zero plane displacement / canopy height (-) + critRichNumber, & ! intent(in): critical value for the bulk Richardson number where turbulence ceases (-) + Louis79_bparam, & ! intent(in): parameter in Louis (1979) stability function + Mahrt87_eScale, & ! intent(in): exponential scaling factor in the Mahrt (1987) stability function + windReductionParam, & ! intent(in): canopy wind reduction parameter (-) + leafExchangeCoeff, & ! intent(in): turbulent exchange coeff between canopy surface and canopy air ( m s-(1/2) ) + leafDimension, & ! intent(in): characteristic leaf dimension (m) + heightCanopyTop, & ! intent(in): height at the top of the vegetation canopy (m) + heightCanopyBottom, & ! intent(in): height at the bottom of the vegetation canopy (m) + ! output: stability corrections + RiBulkCanopy, & ! intent(out): bulk Richardson number for the canopy (-) + RiBulkGround, & ! intent(out): bulk Richardson number for the ground surface (-) + canopyStabilityCorrection, & ! intent(out): stability correction for the canopy (-) + groundStabilityCorrection, & ! intent(out): stability correction for the ground surface (-) + ! output: scalar resistances + z0Canopy, & ! intent(out): roughness length of the canopy (m) + windReductionFactor, & ! intent(out): canopy wind reduction factor (-) + zeroPlaneDisplacement, & ! intent(out): zero plane displacement (m) + eddyDiffusCanopyTop, & ! intent(out): eddy diffusivity for heat at the top of the canopy (m2 s-1) + frictionVelocity, & ! intent(out): friction velocity (m s-1) + windspdCanopyTop, & ! intent(out): windspeed at the top of the canopy (m s-1) + windspdCanopyBottom, & ! intent(out): windspeed at the height of the bottom of the canopy (m s-1) + leafResistance, & ! intent(out): mean leaf boundary layer resistance per unit leaf area (s m-1) + groundResistance, & ! intent(out): below canopy aerodynamic resistance (s m-1) + canopyResistance, & ! intent(out): above canopy aerodynamic resistance (s m-1) + ! output: derivatives in scalar resistances + dGroundResistance_dTGround, & ! intent(out): derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) + dGroundResistance_dTCanopy, & ! intent(out): derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + dGroundResistance_dTCanair, & ! intent(out): derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) + dCanopyResistance_dTCanopy, & ! intent(out): derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + dCanopyResistance_dTCanair, & ! intent(out): derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) + ! output: error control + err,message ) ! intent(out): error control + ! ----------------------------------------------------------------------------------------------------------------------------------------- + ! compute aerodynamic resistances + ! Refs: Choudhury and Monteith (4-layer model for heat budget of homogenous surfaces; QJRMS, 1988) + ! Niu and Yang (Canopy effects on snow processes; JGR, 2004) + ! Mahat et al. (Below-canopy turbulence in a snowmelt model, WRR, 2012) + implicit none + ! input: model control + logical(lgt),intent(in) :: computeVegFlux ! logical flag to compute vegetation fluxes (.false. if veg buried by snow) + integer(i4b),intent(in) :: ixVegTraits ! choice of parameterization for vegetation roughness length and displacement height + integer(i4b),intent(in) :: ixWindProfile ! choice of canopy wind profile + integer(i4b),intent(in) :: ixStability ! choice of stability function + ! input: above-canopy forcing data + real(rkind),intent(in) :: mHeight ! measurement height (m) + real(rkind),intent(in) :: airtemp ! air temperature at measurement height (K) + real(rkind),intent(in) :: windspd ! wind speed at measurement height (m s-1) + ! input: temperature (canopy, ground, canopy air space) + real(rkind),intent(in) :: canairTemp ! temperature of the canopy air space (K) + real(rkind),intent(in) :: groundTemp ! ground temperature (K) + ! input: diagnostic variables + real(rkind),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf plus stem (m2 m-2) + real(rkind),intent(in) :: snowDepth ! snow depth (m) + ! input: parameters + real(rkind),intent(in) :: z0Ground ! roughness length of the ground (below canopy or non-vegetated surface [snow]) (m) + real(rkind),intent(in) :: z0CanopyParam ! roughness length of the canopy (m) + real(rkind),intent(in) :: zpdFraction ! zero plane displacement / canopy height (-) + real(rkind),intent(in) :: critRichNumber ! critical value for the bulk Richardson number where turbulence ceases (-) + real(rkind),intent(in) :: Louis79_bparam ! parameter in Louis (1979) stability function + real(rkind),intent(in) :: Mahrt87_eScale ! exponential scaling factor in the Mahrt (1987) stability function + real(rkind),intent(in) :: windReductionParam ! canopy wind reduction parameter (-) + real(rkind),intent(in) :: leafExchangeCoeff ! turbulent exchange coeff between canopy surface and canopy air ( m s-(1/2) ) + real(rkind),intent(in) :: leafDimension ! characteristic leaf dimension (m) + real(rkind),intent(in) :: heightCanopyTop ! height at the top of the vegetation canopy (m) + real(rkind),intent(in) :: heightCanopyBottom ! height at the bottom of the vegetation canopy (m) + ! output: stability corrections + real(rkind),intent(out) :: RiBulkCanopy ! bulk Richardson number for the canopy (-) + real(rkind),intent(out) :: RiBulkGround ! bulk Richardson number for the ground surface (-) + real(rkind),intent(out) :: canopyStabilityCorrection ! stability correction for the canopy (-) + real(rkind),intent(out) :: groundStabilityCorrection ! stability correction for the ground surface (-) + ! output: scalar resistances + real(rkind),intent(out) :: z0Canopy ! roughness length of the vegetation canopy (m) + real(rkind),intent(out) :: windReductionFactor ! canopy wind reduction factor (-) + real(rkind),intent(out) :: zeroPlaneDisplacement ! zero plane displacement (m) + real(rkind),intent(out) :: eddyDiffusCanopyTop ! eddy diffusivity for heat at the top of the canopy (m2 s-1) + real(rkind),intent(out) :: frictionVelocity ! friction velocity (m s-1) + real(rkind),intent(out) :: windspdCanopyTop ! windspeed at the top of the canopy (m s-1) + real(rkind),intent(out) :: windspdCanopyBottom ! windspeed at the height of the bottom of the canopy (m s-1) + real(rkind),intent(out) :: leafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) + real(rkind),intent(out) :: groundResistance ! below canopy aerodynamic resistance (s m-1) + real(rkind),intent(out) :: canopyResistance ! above canopy aerodynamic resistance (s m-1) + ! output: derivatives in scalar resistances + real(rkind),intent(out) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) + real(rkind),intent(out) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + real(rkind),intent(out) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) + real(rkind),intent(out) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + real(rkind),intent(out) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! ----------------------------------------------------------------------------------------------------------------------------------------- + ! local variables: general + character(LEN=256) :: cmessage ! error message of downwind routine + ! local variables: vegetation roughness and dispalcement height + real(rkind),parameter :: oneThird=1._rkind/3._rkind ! 1/3 + real(rkind),parameter :: twoThirds=2._rkind/3._rkind ! 2/3 + real(rkind),parameter :: C_r = 0.3_rkind ! roughness element drag coefficient (-) from Raupach (BLM, 1994) + real(rkind),parameter :: C_s = 0.003_rkind ! substrate surface drag coefficient (-) from Raupach (BLM, 1994) + real(rkind),parameter :: approxDragCoef_max = 0.3_rkind ! maximum value of the approximate drag coefficient (-) from Raupach (BLM, 1994) + real(rkind),parameter :: psi_h = 0.193_rkind ! roughness sub-layer influence function (-) from Raupach (BLM, 1994) + real(rkind),parameter :: c_d1 = 7.5_rkind ! scaling parameter used to define displacement height (-) from Raupach (BLM, 1994) + real(rkind),parameter :: cd_CM = 0.2_rkind ! mean drag coefficient for individual leaves (-) from Choudhury and Monteith (QJRMS, 1988) + real(rkind) :: funcLAI ! temporary variable to calculate zero plane displacement for the canopy + real(rkind) :: fracCanopyHeight ! zero plane displacement expressed as a fraction of canopy height + real(rkind) :: zpdScaleCanopy ! scale for zero plane displacement for the canopy (m) + real(rkind) :: approxDragCoef ! approximate drag coefficient used in the computation of canopy roughness length (-) + ! local variables: resistance + real(rkind) :: canopyExNeut ! surface-atmosphere exchange coefficient under neutral conditions (-) + real(rkind) :: groundExNeut ! surface-atmosphere exchange coefficient under neutral conditions (-) + real(rkind) :: sfc2AtmExchangeCoeff_canopy ! surface-atmosphere exchange coefficient after stability corrections (-) + real(rkind) :: groundResistanceNeutral ! ground resistance under neutral conditions (s m-1) + real(rkind) :: windConvFactor_fv ! factor to convert friction velocity to wind speed at top of canopy (-) + real(rkind) :: windConvFactor ! factor to convert wind speed at top of canopy to wind speed at a given height in the canopy (-) + real(rkind) :: referenceHeight ! z0Canopy+zeroPlaneDisplacement (m) + real(rkind) :: windspdRefHeight ! windspeed at the reference height (m/s) + real(rkind) :: heightAboveGround ! height above the snow surface (m) + real(rkind) :: heightCanopyTopAboveSnow ! height at the top of the vegetation canopy relative to snowpack (m) + real(rkind) :: heightCanopyBottomAboveSnow ! height at the bottom of the vegetation canopy relative to snowpack (m) + real(rkind) :: minExpLogHgt ! minimum height above ground for logarithmic wind profile (m) + ! local variables: derivatives + real(rkind) :: dFV_dT ! derivative in friction velocity w.r.t. canopy air temperature + real(rkind) :: dED_dT ! derivative in eddy diffusivity at the top of the canopy w.r.t. canopy air temperature + real(rkind) :: dGR_dT ! derivative in neutral ground resistance w.r.t. canopy air temperature + real(rkind) :: tmp1,tmp2 ! temporary variables used in calculation of ground resistance + real(rkind) :: dCanopyStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number for the canopy (-) + real(rkind) :: dGroundStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number for the ground surface (-) + real(rkind) :: dCanopyStabilityCorrection_dAirTemp ! (not used) derivative in stability correction w.r.t. air temperature (K-1) + real(rkind) :: dGroundStabilityCorrection_dAirTemp ! (not used) derivative in stability correction w.r.t. air temperature (K-1) + real(rkind) :: dCanopyStabilityCorrection_dCasTemp ! derivative in canopy stability correction w.r.t. canopy air space temperature (K-1) + real(rkind) :: dGroundStabilityCorrection_dCasTemp ! derivative in ground stability correction w.r.t. canopy air space temperature (K-1) + real(rkind) :: dGroundStabilityCorrection_dSfcTemp ! derivative in ground stability correction w.r.t. surface temperature (K-1) + real(rkind) :: singleLeafConductance ! leaf boundary layer conductance (m s-1) + real(rkind) :: canopyLeafConductance ! leaf boundary layer conductance -- scaled up to the canopy (m s-1) + real(rkind) :: leaf2CanopyScaleFactor ! factor to scale from the leaf to the canopy [m s-(1/2)] + ! ----------------------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message='aeroResist/' - end select ! vegetation traits (z0, zpd) + ! check that measurement height is above the top of the canopy + if (mHeight < heightCanopyTop) then + err=20; message=trim(message)//'measurement height is below the top of the canopy'; return + end if - ! check zero plane displacement - if(zeroPlaneDisplacement < heightCanopyBottomAboveSnow)then - write(*,'(a,1x,10(f12.5,1x))') 'heightCanopyTop, snowDepth, heightCanopyTopAboveSnow, heightCanopyBottomAboveSnow, exposedVAI = ', & - heightCanopyTop, snowDepth, heightCanopyTopAboveSnow, heightCanopyBottomAboveSnow, exposedVAI - message=trim(message)//'zero plane displacement is below the canopy bottom' - err=20; return - endif + ! ----------------------------------------------------------------------------------------------------------------------------------------- + ! * compute vegetation poperties (NOTE: could be done at the same time as phenology, does not have to be in the flux routine!) + if (computeVegFlux) then ! if vegetation is exposed + ! ***** identify zero plane displacement, roughness length, and surface temperature for the canopy (m) + ! First, calculate new coordinate system above snow - use these to scale wind profiles and resistances + ! NOTE: the new coordinate system makes zeroPlaneDisplacement and z0Canopy consistent + heightCanopyTopAboveSnow = heightCanopyTop - snowDepth + ! Ensure that heightCanopyBottomAboveSnow >= z0Ground + minExpLogHgt + minExpLogHgt = minExpLogHgtFac*sqrt(heightCanopyTop) ! minimum height above ground for logarithmic wind profile (m) + heightCanopyBottomAboveSnow = max(heightCanopyBottom - snowDepth, z0Ground + minExpLogHgt) + ! compute zero-plane displacement and roughness length of the vegetation canopy + select case(ixVegTraits) + ! Raupach (BLM 1994) "Simplified expressions..." + case(Raupach_BLM1994) + funcLAI = sqrt(c_d1*exposedVAI) + fracCanopyHeight = -(1._rkind - exp(-funcLAI))/funcLAI + 1._rkind + zeroPlaneDisplacement = fracCanopyHeight*(heightCanopyTopAboveSnow-heightCanopyBottomAboveSnow)+heightCanopyBottomAboveSnow + approxDragCoef = min( sqrt(C_s + C_r*exposedVAI/2._rkind), approxDragCoef_max) + z0Canopy = (1._rkind - fracCanopyHeight) * exp(-vkc*approxDragCoef - psi_h) * (heightCanopyTopAboveSnow-heightCanopyBottomAboveSnow) + ! Choudhury and Monteith (QJRMS 1988) "A four layer model for the heat budget..." + case(CM_QJRMS1988) + funcLAI = cd_CM*exposedVAI + zpdScaleCanopy = 1.1_rkind*(heightCanopyTopAboveSnow - heightCanopyBottomAboveSnow)*log(1._rkind + sqrt(sqrt(funcLAI))) + zeroPlaneDisplacement = heightCanopyBottomAboveSnow + zpdScaleCanopy + if (funcLAI < 0.2_rkind) then + z0Canopy = z0Ground + 0.3_rkind*heightCanopyTopAboveSnow*sqrt(funcLAI) + else + z0Canopy = 0.3_rkind*heightCanopyTopAboveSnow*(1._rkind - zeroPlaneDisplacement/heightCanopyTopAboveSnow) + end if + ! constant parameters dependent on the vegetation type + case(vegTypeTable) + zeroPlaneDisplacement = zpdFraction*(heightCanopyTopAboveSnow-heightCanopyBottomAboveSnow)+heightCanopyBottomAboveSnow + z0Canopy = z0CanopyParam + ! check + case default + err=10; message=trim(message)//"unknown parameterization for vegetation roughness length and displacement height"; return + end select ! vegetation traits (z0, zpd) + + ! check zero plane displacement, should not happen but leaving it here incase something is really wrong with the params + if (zeroPlaneDisplacement < heightCanopyBottomAboveSnow) then + write(*,'(a,1x,5(f12.5,1x))') 'heightCanopyTop, snowDepth, heightCanopyTopAboveSnow, heightCanopyBottomAboveSnow, exposedVAI = ', & + heightCanopyTop, snowDepth, heightCanopyTopAboveSnow, heightCanopyBottomAboveSnow, exposedVAI + message=trim(message)//'zero plane displacement is below the canopy bottom' + err=20; return + end if - ! check measurement height - if(mHeight < zeroPlaneDisplacement)then; err=20; message=trim(message)//'measurement height is below the displacement height'; return; end if - if(mHeight < z0Canopy)then; err=20; message=trim(message)//'measurement height is below the roughness length'; return; end if + ! check measurement height + if (mHeight < zeroPlaneDisplacement+z0Canopy) then; err=20; message=trim(message)//'measurement height is below the displacement height'; return; end if + + ! ----------------------------------------------------------------------------------------------------------------------------------------- + ! ----------------------------------------------------------------------------------------------------------------------------------------- + ! * compute resistance for the case where the canopy is exposed + ! compute windspeed at the top of the canopy above snow depth (m s-1) + ! NOTE: stability corrections cancel out + windConvFactor_fv = log((heightCanopyTopAboveSnow - zeroPlaneDisplacement)/z0Canopy) / log((mHeight - snowDepth - zeroPlaneDisplacement)/z0Canopy) + windspdCanopyTop = windspd*windConvFactor_fv + + ! compute the windspeed reduction from the canopy to the reference height (m s-1) + ! Refs: Norman et al. (Ag. Forest Met., 1995) -- citing Goudriaan (1977 manuscript "crop micrometeorology: a simulation study", Wageningen). + windReductionFactor = windReductionParam * exposedVAI**twoThirds * (heightCanopyTopAboveSnow - heightCanopyBottomAboveSnow)**oneThird / leafDimension**oneThird + + ! compute windspeed at the referenceHeight + referenceHeight = z0Canopy+zeroPlaneDisplacement + windConvFactor = exp(-windReductionFactor*(1._rkind - (referenceHeight/heightCanopyTopAboveSnow))) + windspdRefHeight = windspdCanopyTop*windConvFactor + if(heightCanopyTopAboveSnow < referenceHeight)then; err=20; message=trim(message)//'canopy top height above snow < reference height'; return; end if + + ! compute windspeed at the bottom of the canopy relative to the snow depth (m s-1) + windConvFactor = exp(-windReductionFactor*(1._rkind - (heightCanopyBottomAboveSnow/heightCanopyTopAboveSnow))) + windspdCanopyBottom = windspdCanopyTop*windConvFactor + + ! compute the stability correction for resistance from canopy air space to air above the canopy (-) + call aStability(& + ! input + ixStability, & ! input: choice of stability function + ! input: forcing data, diagnostic and state variables + mHeight - referenceHeight, & ! input: height difference from measurement height to canopy air space (m) + airTemp, & ! input: air temperature above the canopy (measurement height) (K) + canairTemp, & ! input: temperature of the canopy air space (reference height) (K) + windspd - windspdRefHeight, & ! input: wind speed difference from measurement height to reference height (m s-1) + ! input: stability parameters + critRichNumber, & ! input: critical value for the bulk Richardson number where turbulence ceases (-) + Louis79_bparam, & ! input: parameter in Louis (1979) stability function + Mahrt87_eScale, & ! input: exponential scaling factor in the Mahrt (1987) stability function + ! output + RiBulkCanopy, & ! output: bulk Richardson number (-) + canopyStabilityCorrection, & ! output: stability correction for turbulent heat fluxes (-) + dCanopyStabilityCorrection_dRich, & ! output: derivative in stability correction w.r.t. Richardson number for the canopy (-) + dCanopyStabilityCorrection_dAirTemp, & ! output: (not used) derivative in stability correction w.r.t. air temperature (K-1) + dCanopyStabilityCorrection_dCasTemp, & ! output: derivative in stability correction w.r.t. canopy air space temperature (K-1) + err, cmessage ) ! output: error control + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if + + ! compute turbulent exchange coefficient (-) + canopyExNeut = (vkc**2_i4b) / ( log((mHeight - zeroPlaneDisplacement)/z0Canopy))**2_i4b ! coefficient under conditions of neutral stability + sfc2AtmExchangeCoeff_canopy = canopyExNeut*canopyStabilityCorrection ! after stability corrections + + ! compute the friction velocity (m s-1) + frictionVelocity = windspd * sqrt(sfc2AtmExchangeCoeff_canopy) + + ! compute the above-canopy resistance (s m-1) + canopyResistance = 1._rkind/(sfc2AtmExchangeCoeff_canopy*windspd) + if (canopyResistance < 0._rkind) then; err=20; message=trim(message)//'canopy resistance < 0'; return; end if + + ! compute the leaf boundary layer resistance (s m-1) + singleLeafConductance = leafExchangeCoeff*sqrt(windspdCanopyTop/leafDimension) + leaf2CanopyScaleFactor = (2._rkind/windReductionFactor) * (1._rkind - exp(-windReductionFactor/2._rkind)) ! factor to scale from the leaf to the canopy + canopyLeafConductance = singleLeafConductance*leaf2CanopyScaleFactor + leafResistance = 1._rkind/(canopyLeafConductance) + if (leafResistance < 0._rkind) then; err=20; message=trim(message)//'leaf resistance < 0'; return; end if + + ! compute eddy diffusivity for heat at the top of the canopy (m2 s-1) + ! Note: use of friction velocity here includes stability adjustments + ! Note: max used to avoid dividing by zero + eddyDiffusCanopyTop = max(vkc*FrictionVelocity*(heightCanopyTopAboveSnow - zeroPlaneDisplacement), mpe) + + ! compute the resistance between the surface and canopy air UNDER NEUTRAL CONDITIONS (s m-1) + ! case 1: assume exponential profile extends from the snow depth plus surface roughness length to the displacement height plus vegetation roughness + if (ixWindProfile==exponential) then + ! compute the neutral ground resistance + tmp1 = exp(-windReductionFactor* z0Ground/heightCanopyTopAboveSnow) + tmp2 = exp(-windReductionFactor* referenceHeight/heightCanopyTopAboveSnow) + groundResistanceNeutral = ( heightCanopyTopAboveSnow*exp(windReductionFactor) / (windReductionFactor*eddyDiffusCanopyTop) ) * (tmp1 - tmp2) ! s m-1 + ! check that (tmp1 - tmp2) is positive + if(z0Ground > referenceHeight)then; err=20; message=trim(message)//'ground roughness length > reference height'; return; end if + + ! case 2: logarithmic profile from snow depth plus roughness height to bottom of the canopy + ! NOTE: heightCanopyBottomAboveSnow>z0Ground+minExpLogHgt + else + ! compute the neutral ground resistance + ! first, component between heightCanopyBottomAboveSnow and referenceHeight + tmp1 = exp(-windReductionFactor* heightCanopyBottomAboveSnow/heightCanopyTopAboveSnow) + tmp2 = exp(-windReductionFactor* referenceHeight/heightCanopyTopAboveSnow) + groundResistanceNeutral = ( heightCanopyTopAboveSnow*exp(windReductionFactor) / (windReductionFactor*eddyDiffusCanopyTop) ) * (tmp1 - tmp2) + ! add log-below-canopy component + groundResistanceNeutral = groundResistanceNeutral + (1._rkind/(max(0.1_rkind,windspdCanopyBottom)*vkc**2_i4b))*(log(heightCanopyBottomAboveSnow/z0Ground))**2_i4b + endif ! switch between exponential profile and log-below-canopy + + ! compute the stability correction for resistance from the ground to the canopy air space (-) + call aStability(& + ! input + ixStability, & ! input: choice of stability function + ! input: forcing data, diagnostic and state variables + referenceHeight, & ! input: height difference from reference height to the ground (m) + canairTemp, & ! input: temperature of the canopy air space (reference temp) (K) + groundTemp, & ! input: temperature of the ground surface (K) + max(0.1_rkind,windspdRefHeight), & ! input: wind speed difference from reference height to ground (m s-1) + ! input: stability parameters + critRichNumber, & ! input: critical value for the bulk Richardson number where turbulence ceases (-) + Louis79_bparam, & ! input: parameter in Louis (1979) stability function + Mahrt87_eScale, & ! input: exponential scaling factor in the Mahrt (1987) stability function + ! output + RiBulkGround, & ! output: bulk Richardson number (-) + groundStabilityCorrection, & ! output: stability correction for turbulent heat fluxes (-) + dGroundStabilityCorrection_dRich, & ! output: derivative in stability correction w.r.t. Richardson number for the canopy (-) + dGroundStabilityCorrection_dCasTemp, & ! output: derivative in stability correction w.r.t. canopy air space temperature (K-1) + dGroundStabilityCorrection_dSfcTemp, & ! output: derivative in stability correction w.r.t. surface temperature (K-1) + err, cmessage ) ! output: error control + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if + + ! compute the ground resistance + groundResistance = groundResistanceNeutral / groundStabilityCorrection + if (groundResistance < 0._rkind) then; err=20; message=trim(message)//'ground resistance < 0 [vegetation is present]'; return; end if ! ----------------------------------------------------------------------------------------------------------------------------------------- ! ----------------------------------------------------------------------------------------------------------------------------------------- - ! * compute resistance for the case where the canopy is exposed - ! compute the stability correction for resistance from canopy air space to air above the canopy (-) - call aStability(& - ! input - derivDesired, & ! input: logical flag to compute analytical derivatives - ixStability, & ! input: choice of stability function - ! input: forcing data, diagnostic and state variables - mHeight, & ! input: measurement height (m) - airTemp, & ! input: air temperature above the canopy (K) - canairTemp, & ! input: temperature of the canopy air space (K) - windspd, & ! input: wind speed above the canopy (m s-1) - ! input: stability parameters - critRichNumber, & ! input: critical value for the bulk Richardson number where turbulence ceases (-) - Louis79_bparam, & ! input: parameter in Louis (1979) stability function - Mahrt87_eScale, & ! input: exponential scaling factor in the Mahrt (1987) stability function - ! output - RiBulkCanopy, & ! output: bulk Richardson number (-) - canopyStabilityCorrection, & ! output: stability correction for turbulent heat fluxes (-) - dCanopyStabilityCorrection_dRich, & ! output: derivative in stability correction w.r.t. Richardson number for the canopy (-) - dCanopyStabilityCorrection_dAirTemp, & ! output: (not used) derivative in stability correction w.r.t. air temperature (K-1) - dCanopyStabilityCorrection_dCasTemp, & ! output: derivative in stability correction w.r.t. canopy air space temperature (K-1) - err, cmessage ) ! output: error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if - - ! compute turbulent exchange coefficient (-) - canopyExNeut = (vkc**2._rkind) / ( log((mHeight - zeroPlaneDisplacement)/z0Canopy))**2._rkind ! coefficient under conditions of neutral stability - sfc2AtmExchangeCoeff_canopy = canopyExNeut*canopyStabilityCorrection ! after stability corrections - - ! compute the friction velocity (m s-1) - frictionVelocity = windspd * sqrt(sfc2AtmExchangeCoeff_canopy) - - ! compute the above-canopy resistance (s m-1) - canopyResistance = 1._rkind/(sfc2AtmExchangeCoeff_canopy*windspd) - if(canopyResistance < 0._rkind)then; err=20; message=trim(message)//'canopy resistance < 0'; return; end if - - ! compute windspeed at the top of the canopy above snow depth (m s-1) - ! NOTE: stability corrections cancel out - windConvFactor_fv = log((heightCanopyTopAboveSnow - zeroPlaneDisplacement)/z0Canopy) / log((mHeight - snowDepth - zeroPlaneDisplacement)/z0Canopy) - windspdCanopyTop = windspd*windConvFactor_fv - - ! compute the windspeed reduction - ! Refs: Norman et al. (Ag. Forest Met., 1995) -- citing Goudriaan (1977 manuscript "crop micrometeorology: a simulation study", Wageningen). - windReductionFactor = windReductionParam * exposedVAI**twoThirds * (heightCanopyTopAboveSnow - heightCanopyBottomAboveSnow)**oneThird / leafDimension**oneThird - - ! compute windspeed at the height z0Canopy+zeroPlaneDisplacement (m s-1) - referenceHeight = z0Canopy+zeroPlaneDisplacement - windConvFactor = exp(-windReductionFactor*(1._rkind - (referenceHeight/heightCanopyTopAboveSnow))) - windspdRefHeight = windspdCanopyTop*windConvFactor - - ! compute windspeed at the bottom of the canopy relative to the snow depth (m s-1) - windConvFactor = exp(-windReductionFactor*(1._rkind - (heightCanopyBottomAboveSnow/heightCanopyTopAboveSnow))) - windspdCanopyBottom = windspdCanopyTop*windConvFactor - - ! compute the leaf boundary layer resistance (s m-1) - singleLeafConductance = leafExchangeCoeff*sqrt(windspdCanopyTop/leafDimension) - leaf2CanopyScaleFactor = (2._rkind/windReductionFactor) * (1._rkind - exp(-windReductionFactor/2._rkind)) ! factor to scale from the leaf to the canopy - canopyLeafConductance = singleLeafConductance*leaf2CanopyScaleFactor - leafResistance = 1._rkind/(canopyLeafConductance) - if(leafResistance < 0._rkind)then; err=20; message=trim(message)//'leaf resistance < 0'; return; end if - - ! compute eddy diffusivity for heat at the top of the canopy (m2 s-1) - ! Note: use of friction velocity here includes stability adjustments - ! Note: max used to avoid dividing by zero - eddyDiffusCanopyTop = max(vkc*FrictionVelocity*(heightCanopyTopAboveSnow - zeroPlaneDisplacement), mpe) - - ! compute the resistance between the surface and canopy air UNDER NEUTRAL CONDITIONS (s m-1) - - ! case 1: assume exponential profile extends from the snow depth plus surface roughness length to the displacement height plus vegetation roughness - if(ixWindProfile==exponential .or. heightCanopyBottomAboveSnowz0Ground+xTolerance + ! * compute resistance for the case without a canopy (bare ground, or canopy completely buried with snow) else + ! no canopy, so set huge resistances (not used) + canopyResistance = 1.e12_rkind ! not used: huge resistance, so conductance is essentially zero + leafResistance = 1.e12_rkind ! not used: huge resistance, so conductance is essentially zero + + ! check that measurement height above the ground surface is above the roughness length + if (mHeight < snowDepth+z0Ground) then; err=20; message=trim(message)//'measurement height < snow depth + roughness length'; return; end if + + ! compute the resistance between the surface and canopy air UNDER NEUTRAL CONDITIONS (s m-1) + groundExNeut = (vkc**2_i4b) / ( log((mHeight - snowDepth)/z0Ground)**2_i4b) ! turbulent transfer coefficient under conditions of neutral stability (-) + groundResistanceNeutral = 1._rkind / (groundExNeut*windspd) + + ! define height above the snow surface + heightAboveGround = mHeight - snowDepth + + ! check that measurement height above the ground surface is above the roughness length + if (heightAboveGround < z0Ground) then + write(*,'(a,1x,4(f12.5,1x))') 'z0Ground, mHeight, snowDepth, heightAboveGround = ', & + z0Ground, mHeight, snowDepth, heightAboveGround + message=trim(message)//'height above ground < roughness length [likely due to snow accumulation]' + err=20; return + end if - ! compute the neutral ground resistance - ! (first, component between heightCanopyBottomAboveSnow and z0Canopy+zeroPlaneDisplacement) - tmp1 = exp(-windReductionFactor* heightCanopyBottomAboveSnow/heightCanopyTopAboveSnow) - tmp2 = exp(-windReductionFactor*(z0Canopy+zeroPlaneDisplacement)/heightCanopyTopAboveSnow) - groundResistanceNeutral = ( heightCanopyTopAboveSnow*exp(windReductionFactor) / (windReductionFactor*eddyDiffusCanopyTop) ) * (tmp1 - tmp2) - ! (add log-below-canopy component) - groundResistanceNeutral = groundResistanceNeutral + (1._rkind/(max(0.1_rkind,windspdCanopyBottom)*vkc**2._rkind))*(log(heightCanopyBottomAboveSnow/z0Ground))**2._rkind - - endif ! switch between exponential profile and log-below-canopy - - ! compute the stability correction for resistance from the ground to the canopy air space (-) - ! NOTE: here we are interested in the windspeed at height z0Canopy+zeroPlaneDisplacement - call aStability(& - ! input - derivDesired, & ! input: logical flag to compute analytical derivatives - ixStability, & ! input: choice of stability function - ! input: forcing data, diagnostic and state variables - referenceHeight, & ! input: height of the canopy air space temperature/wind (m) - canairTemp, & ! input: temperature of the canopy air space (K) - groundTemp, & ! input: temperature of the ground surface (K) - max(0.1_rkind,windspdRefHeight), & ! input: wind speed at height z0Canopy+zeroPlaneDisplacement (m s-1) - ! input: stability parameters - critRichNumber, & ! input: critical value for the bulk Richardson number where turbulence ceases (-) - Louis79_bparam, & ! input: parameter in Louis (1979) stability function - Mahrt87_eScale, & ! input: exponential scaling factor in the Mahrt (1987) stability function - ! output - RiBulkGround, & ! output: bulk Richardson number (-) - groundStabilityCorrection, & ! output: stability correction for turbulent heat fluxes (-) - dGroundStabilityCorrection_dRich, & ! output: derivative in stability correction w.r.t. Richardson number for the canopy (-) - dGroundStabilityCorrection_dCasTemp, & ! output: derivative in stability correction w.r.t. canopy air space temperature (K-1) - dGroundStabilityCorrection_dSfcTemp, & ! output: derivative in stability correction w.r.t. surface temperature (K-1) - err, cmessage ) ! output: error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if - - ! compute the ground resistance - groundResistance = groundResistanceNeutral / groundStabilityCorrection - if(groundResistance < 0._rkind)then; err=20; message=trim(message)//'ground resistance < 0 [vegetation is present]'; return; end if - - ! ----------------------------------------------------------------------------------------------------------------------------------------- - ! ----------------------------------------------------------------------------------------------------------------------------------------- - ! * compute resistance for the case without a canopy (bare ground, or canopy completely buried with snow) - else - - ! no canopy, so set huge resistances (not used) - canopyResistance = 1.e12_rkind ! not used: huge resistance, so conductance is essentially zero - leafResistance = 1.e12_rkind ! not used: huge resistance, so conductance is essentially zero - - ! check that measurement height above the ground surface is above the roughness length - if(mHeight < snowDepth+z0Ground)then; err=20; message=trim(message)//'measurement height < snow depth + roughness length'; return; end if - - ! compute the resistance between the surface and canopy air UNDER NEUTRAL CONDITIONS (s m-1) - groundExNeut = (vkc**2._rkind) / ( log((mHeight - snowDepth)/z0Ground)**2._rkind) ! turbulent transfer coefficient under conditions of neutral stability (-) - groundResistanceNeutral = 1._rkind / (groundExNeut*windspd) - - ! define height above the snow surface - heightAboveGround = mHeight - snowDepth - - ! check that measurement height above the ground surface is above the roughness length - if(heightAboveGround < z0Ground)then - print*, 'z0Ground = ', z0Ground - print*, 'mHeight = ', mHeight - print*, 'snowDepth = ', snowDepth - print*, 'heightAboveGround = ', heightAboveGround - message=trim(message)//'height above ground < roughness length [likely due to snow accumulation]' - err=20; return + ! compute ground stability correction + call aStability(& + ! input + ixStability, & ! input: choice of stability function + ! input: forcing data, diagnostic and state variables + heightAboveGround, & ! input: height difference from measurement height to surface -- "surface" is either snow or ground (m) + airtemp, & ! input: temperature at measurement height (K) + groundTemp, & ! input: trial value of surface temperature -- "surface" is either snow or ground (K) + windspd, & ! input: wind speed difference from measurement height to surface -- "surface" is either snow or ground (m s-1) + ! input: stability parameters + critRichNumber, & ! input: critical value for the bulk Richardson number where turbulence ceases (-) + Louis79_bparam, & ! input: parameter in Louis (1979) stability function + Mahrt87_eScale, & ! input: exponential scaling factor in the Mahrt (1987) stability function + ! output + RiBulkGround, & ! output: bulk Richardson number (-) + groundStabilityCorrection, & ! output: stability correction for turbulent heat fluxes (-) + dGroundStabilityCorrection_dRich, & ! output: derivative in stability correction w.r.t. Richardson number for the ground surface (-) + dGroundStabilityCorrection_dAirTemp, & ! output: (not used) derivative in stability correction w.r.t. air temperature (K-1) + dGroundStabilityCorrection_dSfcTemp, & ! output: derivative in stability correction w.r.t. surface temperature (K-1) + err, cmessage ) ! output: error control + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if + + ! compute the ground resistance (after stability corrections) + groundResistance = groundResistanceNeutral/groundStabilityCorrection + if (groundResistance < 0._rkind) then; err=20; message=trim(message)//'ground resistance < 0 [no vegetation]'; return; end if + + ! set all canopy variables to missing (no canopy!) + z0Canopy = realMissing ! roughness length of the vegetation canopy (m) + RiBulkCanopy = realMissing ! bulk Richardson number for the canopy (-) + windReductionFactor = realMissing ! canopy wind reduction factor (-) + zeroPlaneDisplacement = realMissing ! zero plane displacement (m) + canopyStabilityCorrection = realMissing ! stability correction for the canopy (-) + eddyDiffusCanopyTop = realMissing ! eddy diffusivity for heat at the top of the canopy (m2 s-1) + frictionVelocity = realMissing ! friction velocity (m s-1) + windspdCanopyTop = realMissing ! windspeed at the top of the canopy (m s-1) + windspdCanopyBottom = realMissing ! windspeed at the height of the bottom of the canopy (m s-1) + end if ! end if no canopy + + ! derivatives for the vegetation canopy + if (computeVegFlux) then ! if vegetation is exposed + ! ***** compute derivatives w.r.t. canopy temperature + ! NOTE: derivatives are zero because using canopy air space temperature + dCanopyResistance_dTCanopy = 0._rkind ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + dGroundResistance_dTCanopy = 0._rkind ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + ! ***** compute derivatives w.r.t. ground temperature (s m-1 K-1) + dGroundResistance_dTGround = -(groundResistanceNeutral*dGroundStabilityCorrection_dSfcTemp)/(groundStabilityCorrection**2_i4b) + ! ***** compute derivatives w.r.t. temperature of the canopy air space (s m-1 K-1) + ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) + dCanopyResistance_dTCanair = -dCanopyStabilityCorrection_dCasTemp/(windspd*canopyExNeut*canopyStabilityCorrection**2_i4b) + ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) + ! compute derivative in NEUTRAL ground resistance w.r.t. canopy air temperature (s m-1 K-1) + dFV_dT = windspd*canopyExNeut*dCanopyStabilityCorrection_dCasTemp/(sqrt(sfc2AtmExchangeCoeff_canopy)*2._rkind) ! d(frictionVelocity)/d(canopy air temperature) + dED_dT = dFV_dT*vkc*(heightCanopyTopAboveSnow - zeroPlaneDisplacement) ! d(eddyDiffusCanopyTop)d(canopy air temperature) + dGR_dT = -dED_dT*(tmp1 - tmp2)*heightCanopyTopAboveSnow*exp(windReductionFactor) / (windReductionFactor*eddyDiffusCanopyTop**2_i4b) ! d(groundResistanceNeutral)/d(canopy air temperature) + ! stitch everything together -- product rule + dGroundResistance_dTCanair = dGR_dT/groundStabilityCorrection - groundResistanceNeutral*dGroundStabilityCorrection_dCasTemp/(groundStabilityCorrection**2_i4b) + ! ***** compute resistances for non-vegetated surfaces (e.g., snow) + else + ! set canopy derivatives to zero (non-vegetated, remember) + dCanopyResistance_dTCanopy = 0._rkind + dGroundResistance_dTCanopy = 0._rkind + ! compute derivatives for ground resistance + dGroundResistance_dTGround = -dGroundStabilityCorrection_dSfcTemp/(windspd*groundExNeut*groundStabilityCorrection**2_i4b) + end if ! end switch between vegetated and non-vegetated surfaces + +end subroutine aeroResist + +! ******************************************************************************************************* +! private subroutine soilResist: compute soil moisture factor controlling stomatal resistance +! ******************************************************************************************************* +subroutine soilResist(& + ! input (model decisions) + ixSoilResist, & ! intent(in): choice of function for the soil moisture control on stomatal resistance + ixGroundwater, & ! intent(in): choice of groundwater representation + ! input (state variables) + mLayerMatricHead, & ! intent(in): matric head in each layer (m) + mLayerVolFracLiq, & ! intent(in): volumetric fraction of liquid water in each layer + scalarAquiferStorage, & ! intent(in): aquifer storage (m) + ! input (diagnostic variables) + mLayerRootDensity, & ! intent(in): root density in each layer (-) + scalarAquiferRootFrac, & ! intent(in): fraction of roots below the lowest unsaturated layer (-) + ! input (parameters) + plantWiltPsi, & ! intent(in): matric head at wilting point (m) + soilStressParam, & ! intent(in): parameter in the exponential soil stress function (-) + critSoilWilting, & ! intent(in): critical vol. liq. water content when plants are wilting (-) + critSoilTranspire, & ! intent(in): critical vol. liq. water content when transpiration is limited (-) + critAquiferTranspire, & ! intent(in): critical aquifer storage value when transpiration is limited (m) + ! output + wAvgTranspireLimitFac, & ! intent(out): weighted average of the transpiration limiting factor (-) + mLayerTranspireLimitFac, & ! intent(out): transpiration limiting factor in each layer (-) + aquiferTranspireLimitFac, & ! intent(out): transpiration limiting factor for the aquifer (-) + err,message) ! intent(out): error control + ! ----------------------------------------------------------------------------------------------------------------------------------------- + USE mDecisions_module, only: NoahType,CLM_Type,SiB_Type ! options for the choice of function for the soil moisture control on stomatal resistance + USE mDecisions_module, only: bigBucket ! named variable that defines the "bigBucket" groundwater parameterization + implicit none + ! input (model decisions) + integer(i4b),intent(in) :: ixSoilResist ! choice of function for the soil moisture control on stomatal resistance + integer(i4b),intent(in) :: ixGroundwater ! choice of groundwater representation + ! input (variables) + real(rkind),intent(in) :: mLayerMatricHead(:) ! matric head in each layer (m) + real(rkind),intent(in) :: mLayerVolFracLiq(:) ! volumetric fraction of liquid water in each layer (-) + real(rkind),intent(in) :: scalarAquiferStorage ! aquifer storage (m) + ! input (diagnostic variables) + real(rkind),intent(in) :: mLayerRootDensity(:) ! root density in each layer (-) + real(rkind),intent(in) :: scalarAquiferRootFrac ! fraction of roots below the lowest unsaturated layer (-) + ! input (parameters) + real(rkind),intent(in) :: plantWiltPsi ! matric head at wilting point (m) + real(rkind),intent(in) :: soilStressParam ! parameter in the exponential soil stress function (-) + real(rkind),intent(in) :: critSoilWilting ! critical vol. liq. water content when plants are wilting (-) + real(rkind),intent(in) :: critSoilTranspire ! critical vol. liq. water content when transpiration is limited (-) + real(rkind),intent(in) :: critAquiferTranspire ! critical aquifer storage value when transpiration is limited (m) + ! output + real(rkind),intent(out) :: wAvgTranspireLimitFac ! intent(out): weighted average of the transpiration limiting factor (-) + real(rkind),intent(out) :: mLayerTranspireLimitFac(:) ! intent(out): transpiration limiting factor in each layer (-) + real(rkind),intent(out) :: aquiferTranspireLimitFac ! intent(out): transpiration limiting factor for the aquifer (-) + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! local variables + real(rkind) :: gx ! stress function for the soil layers + real(rkind),parameter :: eps=epsilon(gx) ! machine precision for gx + integer(i4b) :: iLayer ! index of soil layer + ! initialize error control + err=0; message='soilResist/' + + ! ** compute the factor limiting transpiration for each soil layer (-) + wAvgTranspireLimitFac = 0._rkind ! initialize the weighted average + do iLayer=1,size(mLayerMatricHead) + ! compute the soil stress function + select case(ixSoilResist) + case(NoahType) ! thresholded linear function of volumetric liquid water content + gx = (mLayerVolFracLiq(iLayer) - critSoilWilting) / (critSoilTranspire - critSoilWilting) + case(CLM_Type) ! thresholded linear function of matric head + if (mLayerMatricHead(iLayer) > plantWiltPsi) then + gx = 1._rkind - mLayerMatricHead(iLayer)/plantWiltPsi + else + gx = 0._rkind + end if + case(SiB_Type) ! exponential of the log of matric head + if (mLayerMatricHead(iLayer) < 0._rkind) then ! unsaturated + gx = 1._rkind - exp( -soilStressParam * ( log(plantWiltPsi/mLayerMatricHead(iLayer)) ) ) + else ! saturated + gx = 1._rkind + end if + case default ! check identified the option + err=20; message=trim(message)//'cannot identify option for soil resistance'; return + end select + ! save the factor for the given layer (ensure between zero and one) + mLayerTranspireLimitFac(iLayer) = min( max(eps,gx), 1._rkind) + ! compute the weighted average (weighted by root density) + wAvgTranspireLimitFac = wAvgTranspireLimitFac + mLayerTranspireLimitFac(iLayer)*mLayerRootDensity(iLayer) + end do ! end looping through soil layers + + ! ** compute the factor limiting evaporation in the aquifer + if (scalarAquiferRootFrac > eps) then + ! check that aquifer root fraction is allowed + if (ixGroundwater /= bigBucket) then + message=trim(message)//'aquifer evaporation only allowed for the big groundwater bucket -- increase the soil depth to account for roots' + err=20; return + end if + ! compute the factor limiting evaporation for the aquifer + aquiferTranspireLimitFac = min(scalarAquiferStorage/critAquiferTranspire, 1._rkind) + else ! if there are roots in the aquifer + aquiferTranspireLimitFac = 0._rkind end if - ! compute ground stability correction - call aStability(& - ! input - derivDesired, & ! input: logical flag to compute analytical derivatives - ixStability, & ! input: choice of stability function - ! input: forcing data, diagnostic and state variables - heightAboveGround, & ! input: measurement height above the ground surface (m) - airtemp, & ! input: temperature above the ground surface (K) - groundTemp, & ! input: trial value of surface temperature -- "surface" is either canopy or ground (K) - windspd, & ! input: wind speed above the ground surface (m s-1) - ! input: stability parameters - critRichNumber, & ! input: critical value for the bulk Richardson number where turbulence ceases (-) - Louis79_bparam, & ! input: parameter in Louis (1979) stability function - Mahrt87_eScale, & ! input: exponential scaling factor in the Mahrt (1987) stability function - ! output - RiBulkGround, & ! output: bulk Richardson number (-) - groundStabilityCorrection, & ! output: stability correction for turbulent heat fluxes (-) - dGroundStabilityCorrection_dRich, & ! output: derivative in stability correction w.r.t. Richardson number for the ground surface (-) - dGroundStabilityCorrection_dAirTemp, & ! output: (not used) derivative in stability correction w.r.t. air temperature (K-1) - dGroundStabilityCorrection_dSfcTemp, & ! output: derivative in stability correction w.r.t. surface temperature (K-1) - err, cmessage ) ! output: error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if - - ! compute the ground resistance (after stability corrections) - groundResistance = groundResistanceNeutral/groundStabilityCorrection - if(groundResistance < 0._rkind)then; err=20; message=trim(message)//'ground resistance < 0 [no vegetation]'; return; end if - - ! set all canopy variables to missing (no canopy!) - z0Canopy = missingValue ! roughness length of the vegetation canopy (m) - RiBulkCanopy = missingValue ! bulk Richardson number for the canopy (-) - windReductionFactor = missingValue ! canopy wind reduction factor (-) - zeroPlaneDisplacement = missingValue ! zero plane displacement (m) - canopyStabilityCorrection = missingValue ! stability correction for the canopy (-) - eddyDiffusCanopyTop = missingValue ! eddy diffusivity for heat at the top of the canopy (m2 s-1) - frictionVelocity = missingValue ! friction velocity (m s-1) - windspdCanopyTop = missingValue ! windspeed at the top of the canopy (m s-1) - windspdCanopyBottom = missingValue ! windspeed at the height of the bottom of the canopy (m s-1) - - end if ! (if no canopy) - - ! ----------------------------------------------------------------------------------------------------------------------------------------- - ! ----------------------------------------------------------------------------------------------------------------------------------------- - ! ----------------------------------------------------------------------------------------------------------------------------------------- - ! ----------------------------------------------------------------------------------------------------------------------------------------- - ! * compute derivatives - if(derivDesired)then ! if analytical derivatives are desired + ! compute the weighted average (weighted by root density) + wAvgTranspireLimitFac = wAvgTranspireLimitFac + aquiferTranspireLimitFac*scalarAquiferRootFrac + +end subroutine soilResist + +! ******************************************************************************** +! private subroutine turbFluxes: compute turbulent heat fluxes +! ******************************************************************************** +subroutine turbFluxes(& + ! input: model control + computeVegFlux, & ! intent(in): logical flag to compute vegetation fluxes (.false. if veg buried by snow) + ! input: above-canopy forcing data + airtemp, & ! intent(in): air temperature of the air above the vegetation canopy (K) + airpres, & ! intent(in): air pressure of the air above the vegetation canopy (Pa) + VPair, & ! intent(in): vapor pressure of the air above the vegetation canopy (Pa) + ! input: latent heat of sublimation/vaporization + latHeatSubVapCanopy, & ! intent(in): latent heat of sublimation/vaporization for the vegetation canopy (J kg-1) + latHeatSubVapGround, & ! intent(in): latent heat of sublimation/vaporization for the ground surface (J kg-1) + ! input: canopy and ground temperature + canairTemp, & ! intent(in): temperature of the canopy air space (K) + canopyTemp, & ! intent(in): canopy temperature (K) + groundTemp, & ! intent(in): ground temperature (K) + satVP_CanopyTemp, & ! intent(in): saturation vapor pressure at the temperature of the veg canopy (Pa) + satVP_GroundTemp, & ! intent(in): saturation vapor pressure at the temperature of the ground (Pa) + dSVPCanopy_dCanopyTemp, & ! intent(in): derivative in canopy saturation vapor pressure w.r.t. canopy temperature (Pa K-1) + dSVPGround_dGroundTemp, & ! intent(in): derivative in ground saturation vapor pressure w.r.t. ground temperature (Pa K-1) + ! input: diagnostic variables + exposedVAI, & ! intent(in): exposed vegetation area index -- leaf plus stem (m2 m-2) + canopyWetFraction, & ! intent(in): fraction of canopy that is wet [0-1] + dCanopyWetFraction_dWat, & ! intent(in): derivative in the canopy wetted fraction w.r.t. total water content (kg-1 m-2) + dCanopyWetFraction_dT, & ! intent(in): derivative in wetted fraction w.r.t. canopy temperature (K-1) + canopySunlitLAI, & ! intent(in): sunlit leaf area (-) + canopyShadedLAI, & ! intent(in): shaded leaf area (-) + soilRelHumidity, & ! intent(in): relative humidity in the soil pores [0-1] + soilResistance, & ! intent(in): resistance from the soil (s m-1) + leafResistance, & ! intent(in): mean leaf boundary layer resistance per unit leaf area (s m-1) + groundResistance, & ! intent(in): below canopy aerodynamic resistance (s m-1) + canopyResistance, & ! intent(in): above canopy aerodynamic resistance (s m-1) + stomResistSunlit, & ! intent(in): stomatal resistance for sunlit leaves (s m-1) + stomResistShaded, & ! intent(in): stomatal resistance for shaded leaves (s m-1) + ! input: derivatives in scalar resistances + dGroundResistance_dTGround, & ! intent(in): derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) + dGroundResistance_dTCanopy, & ! intent(in): derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + dGroundResistance_dTCanair, & ! intent(in): derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) + dCanopyResistance_dTCanopy, & ! intent(in): derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + dCanopyResistance_dTCanair, & ! intent(in): derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) + ! output: conductances (used to check derivative calculations) + leafConductance, & ! intent(out): leaf conductance (m s-1) + canopyConductance, & ! intent(out): canopy conductance (m s-1) + groundConductanceSH, & ! intent(out): ground conductance for sensible heat (m s-1) + groundConductanceLH, & ! intent(out): ground conductance for latent heat -- includes soil resistance (m s-1) + evapConductance, & ! intent(out): conductance for evaporation (m s-1) + transConductance, & ! intent(out): conductance for transpiration (m s-1) + totalConductanceSH, & ! intent(out): total conductance for sensible heat (m s-1) + totalConductanceLH, & ! intent(out): total conductance for latent heat (m s-1) + ! output: canopy air space variables + VP_CanopyAir, & ! intent(out): vapor pressure of the canopy air space (Pa) + ! output: fluxes from the vegetation canopy + senHeatCanopy, & ! intent(out): sensible heat flux from the canopy to the canopy air space (W m-2) + latHeatCanopyEvap, & ! intent(out): latent heat flux associated with evaporation from the canopy to the canopy air space (W m-2) + latHeatCanopyTrans, & ! intent(out): latent heat flux associated with transpiration from the canopy to the canopy air space (W m-2) + ! output: fluxes from non-vegetated surfaces (ground surface below vegetation, bare ground, or snow covered vegetation) + senHeatGround, & ! intent(out): sensible heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) + latHeatGround, & ! intent(out): latent heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) + ! output: total heat fluxes to the atmosphere + senHeatTotal, & ! intent(out): total sensible heat flux to the atmosphere (W m-2) + latHeatTotal, & ! intent(out): total latent heat flux to the atmosphere (W m-2) + ! output: net fluxes + turbFluxCanair, & ! intent(out): net turbulent heat fluxes at the canopy air space (W m-2) + turbFluxCanopy, & ! intent(out): net turbulent heat fluxes at the canopy (W m-2) + turbFluxGround, & ! intent(out): net turbulent heat fluxes at the ground surface (W m-2) + ! output: flux derivatives + dTurbFluxCanair_dTCanair, & ! intent(out): derivative in net canopy air space fluxes w.r.t. canopy air temperature (W m-2 K-1) + dTurbFluxCanair_dTCanopy, & ! intent(out): derivative in net canopy air space fluxes w.r.t. canopy temperature (W m-2 K-1) + dTurbFluxCanair_dTGround, & ! intent(out): derivative in net canopy air space fluxes w.r.t. ground temperature (W m-2 K-1) + dTurbFluxCanopy_dTCanair, & ! intent(out): derivative in net canopy turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) + dTurbFluxCanopy_dTCanopy, & ! intent(out): derivative in net canopy turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) + dTurbFluxCanopy_dTGround, & ! intent(out): derivative in net canopy turbulent fluxes w.r.t. ground temperature (W m-2 K-1) + dTurbFluxGround_dTCanair, & ! intent(out): derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) + dTurbFluxGround_dTCanopy, & ! intent(out): derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) + dTurbFluxGround_dTGround, & ! intent(out): derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) + ! output: liquid flux derivatives (canopy evap) + dLatHeatCanopyEvap_dCanWat, & ! intent(out): derivative in latent heat of canopy evaporation w.r.t. canopy total water content (J kg-1 s-1) + dLatHeatCanopyEvap_dTCanair, & ! intent(out): derivative in latent heat of canopy evaporation w.r.t. canopy air temperature (W m-2 K-1) + dLatHeatCanopyEvap_dTCanopy, & ! intent(out): derivative in latent heat of canopy evaporation w.r.t. canopy temperature (W m-2 K-1) + dLatHeatCanopyEvap_dTGround, & ! intent(out): derivative in latent heat of canopy evaporation w.r.t. ground temperature (W m-2 K-1) + ! output: liquid flux derivatives (ground evap) + dLatHeatGroundEvap_dCanWat, & ! intent(out): derivative in latent heat of ground evaporation w.r.t. canopy total water content (J kg-1 s-1) + dLatHeatGroundEvap_dTCanair, & ! intent(out): derivative in latent heat of ground evaporation w.r.t. canopy air temperature + dLatHeatGroundEvap_dTCanopy, & ! intent(out): derivative in latent heat of ground evaporation w.r.t. canopy temperature + dLatHeatGroundEvap_dTGround, & ! intent(out): derivative in latent heat of ground evaporation w.r.t. ground temperature + ! output: latent heat flux derivatives (canopy trans) + dLatHeatCanopyTrans_dCanWat, & ! intent(out): derivative in the latent heat of canopy transpiration w.r.t. canopy total water (J kg-1 s-1) + dLatHeatCanopyTrans_dTCanair, & ! intent(out): derivative in the latent heat of canopy transpiration w.r.t. canopy air temperature + dLatHeatCanopyTrans_dTCanopy, & ! intent(out): derivative in the latent heat of canopy transpiration w.r.t. canopy temperature + dLatHeatCanopyTrans_dTGround, & ! intent(out): derivative in the latent heat of canopy transpiration w.r.t. ground temperature + ! output: cross derivatives + dTurbFluxCanair_dCanWat, & ! intent(out): derivative in net canopy air space fluxes w.r.t. canopy total water content (J kg-1 s-1) + dTurbFluxCanopy_dCanWat, & ! intent(out): derivative in net canopy turbulent fluxes w.r.t. canopy total water content (J kg-1 s-1) + dTurbFluxGround_dCanWat, & ! intent(out): derivative in net ground turbulent fluxes w.r.t. canopy total water content (J kg-1 s-1) + ! output: error control + err,message ) ! intent(out): error control + ! ----------------------------------------------------------------------------------------------------------------------------------------- + implicit none + ! input: model control + logical(lgt),intent(in) :: computeVegFlux ! logical flag to compute vegetation fluxes (.false. if veg buried by snow) + ! input: above-canopy forcing data + real(rkind),intent(in) :: airtemp ! air temperature of the air above the vegetation canopy (K) + real(rkind),intent(in) :: airpres ! air pressure of the air above the vegetation canopy (Pa) + real(rkind),intent(in) :: VPair ! vapor pressure of the air above the vegetation canopy (Pa) + ! input: latent heat of sublimation/vaporization + real(rkind),intent(in) :: latHeatSubVapCanopy ! latent heat of sublimation/vaporization for the vegetation canopy (J kg-1) + real(rkind),intent(in) :: latHeatSubVapGround ! latent heat of sublimation/vaporization for the ground surface (J kg-1) + ! input: canopy and ground temperature + real(rkind),intent(in) :: canairTemp ! temperature of the canopy air space (K) + real(rkind),intent(in) :: canopyTemp ! canopy temperature (K) + real(rkind),intent(in) :: groundTemp ! ground temperature (K) + real(rkind),intent(in) :: satVP_CanopyTemp ! saturation vapor pressure at the temperature of the veg canopy (Pa) + real(rkind),intent(in) :: satVP_GroundTemp ! saturation vapor pressure at the temperature of the ground (Pa) + real(rkind),intent(in) :: dSVPCanopy_dCanopyTemp ! derivative in canopy saturation vapor pressure w.r.t. canopy temperature (Pa K-1) + real(rkind),intent(in) :: dSVPGround_dGroundTemp ! derivative in ground saturation vapor pressure w.r.t. ground temperature (Pa K-1) + ! input: diagnostic variables + real(rkind),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf plus stem (m2 m-2) + real(rkind),intent(in) :: canopyWetFraction ! fraction of canopy that is wet [0-1] + real(rkind),intent(in) :: dCanopyWetFraction_dWat ! derivative in the canopy wetted fraction w.r.t. liquid water content (kg-1 m-2) + real(rkind),intent(in) :: dCanopyWetFraction_dT ! derivative in the canopy wetted fraction w.r.t. canopy temperature (K-1) + real(rkind),intent(in) :: canopySunlitLAI ! sunlit leaf area (-) + real(rkind),intent(in) :: canopyShadedLAI ! shaded leaf area (-) + real(rkind),intent(in) :: soilRelHumidity ! relative humidity in the soil pores [0-1] + real(rkind),intent(in) :: soilResistance ! resistance from the soil (s m-1) + real(rkind),intent(in) :: leafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) + real(rkind),intent(in) :: groundResistance ! below canopy aerodynamic resistance (s m-1) + real(rkind),intent(in) :: canopyResistance ! above canopy aerodynamic resistance (s m-1) + real(rkind),intent(in) :: stomResistSunlit ! stomatal resistance for sunlit leaves (s m-1) + real(rkind),intent(in) :: stomResistShaded ! stomatal resistance for shaded leaves (s m-1) + ! input: derivatives in scalar resistances + real(rkind),intent(in) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) + real(rkind),intent(in) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) + real(rkind),intent(in) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) + real(rkind),intent(in) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) + real(rkind),intent(in) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) + ! --------------------------------------------------------------------------------------------------------------------------------------------------------------- + ! output: conductances -- used to test derivatives + real(rkind),intent(out) :: leafConductance ! leaf conductance (m s-1) + real(rkind),intent(out) :: canopyConductance ! canopy conductance (m s-1) + real(rkind),intent(out) :: groundConductanceSH ! ground conductance for sensible heat (m s-1) + real(rkind),intent(out) :: groundConductanceLH ! ground conductance for latent heat -- includes soil resistance (m s-1) + real(rkind),intent(out) :: evapConductance ! conductance for evaporation (m s-1) + real(rkind),intent(out) :: transConductance ! conductance for transpiration (m s-1) + real(rkind),intent(out) :: totalConductanceSH ! total conductance for sensible heat (m s-1) + real(rkind),intent(out) :: totalConductanceLH ! total conductance for latent heat (m s-1) + ! output: canopy air space variables + real(rkind),intent(out) :: VP_CanopyAir ! vapor pressure of the canopy air space (Pa) + ! output: fluxes from the vegetation canopy + real(rkind),intent(out) :: senHeatCanopy ! sensible heat flux from the canopy to the canopy air space (W m-2) + real(rkind),intent(out) :: latHeatCanopyEvap ! latent heat flux associated with evaporation from the canopy to the canopy air space (W m-2) + real(rkind),intent(out) :: latHeatCanopyTrans ! latent heat flux associated with transpiration from the canopy to the canopy air space (W m-2) + ! output: fluxes from non-vegetated surfaces (ground surface below vegetation, bare ground, or snow covered vegetation) + real(rkind),intent(out) :: senHeatGround ! sensible heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) + real(rkind),intent(out) :: latHeatGround ! latent heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) + ! output: total heat fluxes to the atmosphere + real(rkind),intent(out) :: senHeatTotal ! total sensible heat flux to the atmosphere (W m-2) + real(rkind),intent(out) :: latHeatTotal ! total latent heat flux to the atmosphere (W m-2) + ! output: net fluxes + real(rkind),intent(out) :: turbFluxCanair ! net turbulent heat fluxes at the canopy air space (W m-2) + real(rkind),intent(out) :: turbFluxCanopy ! net turbulent heat fluxes at the canopy (W m-2) + real(rkind),intent(out) :: turbFluxGround ! net turbulent heat fluxes at the ground surface (W m-2) + ! output: energy flux derivatives + real(rkind),intent(out) :: dTurbFluxCanair_dTCanair ! derivative in net canopy air space fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(rkind),intent(out) :: dTurbFluxCanair_dTCanopy ! derivative in net canopy air space fluxes w.r.t. canopy temperature (W m-2 K-1) + real(rkind),intent(out) :: dTurbFluxCanair_dTGround ! derivative in net canopy air space fluxes w.r.t. ground temperature (W m-2 K-1) + real(rkind),intent(out) :: dTurbFluxCanopy_dTCanair ! derivative in net canopy turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(rkind),intent(out) :: dTurbFluxCanopy_dTCanopy ! derivative in net canopy turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) + real(rkind),intent(out) :: dTurbFluxCanopy_dTGround ! derivative in net canopy turbulent fluxes w.r.t. ground temperature (W m-2 K-1) + real(rkind),intent(out) :: dTurbFluxGround_dTCanair ! derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) + real(rkind),intent(out) :: dTurbFluxGround_dTCanopy ! derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) + real(rkind),intent(out) :: dTurbFluxGround_dTGround ! derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) + ! output: liquid flux derivatives (canopy evap) + real(rkind),intent(out) :: dLatHeatCanopyEvap_dCanWat ! derivative in latent heat of canopy evaporation w.r.t. canopy total water content (W kg-1) + real(rkind),intent(out) :: dLatHeatCanopyEvap_dTCanair ! derivative in latent heat of canopy evaporation w.r.t. canopy air temperature (W m-2 K-1) + real(rkind),intent(out) :: dLatHeatCanopyEvap_dTCanopy ! derivative in latent heat of canopy evaporation w.r.t. canopy temperature (W m-2 K-1) + real(rkind),intent(out) :: dLatHeatCanopyEvap_dTGround ! derivative in latent heat of canopy evaporation w.r.t. ground temperature (W m-2 K-1) + ! output: liquid flux derivatives (ground evap) + real(rkind),intent(out) :: dLatHeatGroundEvap_dCanWat ! derivative in latent heat of ground evaporation w.r.t. canopy total water content (J kg-1 s-1) + real(rkind),intent(out) :: dLatHeatGroundEvap_dTCanair ! derivative in latent heat of ground evaporation w.r.t. canopy air temperature (W m-2 K-1) + real(rkind),intent(out) :: dLatHeatGroundEvap_dTCanopy ! derivative in latent heat of ground evaporation w.r.t. canopy temperature (W m-2 K-1) + real(rkind),intent(out) :: dLatHeatGroundEvap_dTGround ! derivative in latent heat of ground evaporation w.r.t. ground temperature (W m-2 K-1) + ! output: latent heat flux derivatives (canopy trans) + real(rkind) :: dLatHeatCanopyTrans_dCanWat ! derivative in the latent heat of canopy transpiration w.r.t. canopy total water (J kg-1 s-1) + real(rkind) :: dLatHeatCanopyTrans_dTCanair ! derivative in the latent heat of canopy transpiration w.r.t. canopy air temperature + real(rkind) :: dLatHeatCanopyTrans_dTCanopy ! derivative in the latent heat of canopy transpiration w.r.t. canopy temperature + real(rkind) :: dLatHeatCanopyTrans_dTGround ! derivative in the latent heat of canopy transpiration flux w.r.t. ground temperature + ! output: cross derivatives + real(rkind),intent(out) :: dTurbFluxCanair_dCanWat ! derivative in net canopy air space fluxes w.r.t. canopy total water content (J kg-1 s-1) + real(rkind),intent(out) :: dTurbFluxCanopy_dCanWat ! derivative in net canopy turbulent fluxes w.r.t. canopy total water content (J kg-1 s-1) + real(rkind),intent(out) :: dTurbFluxGround_dCanWat ! derivative in net ground turbulent fluxes w.r.t. canopy total water content (J kg-1 s-1) + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! ----------------------------------------------------------------------------------------------------------------------------------------- + ! local variables -- general + real(rkind) :: fPart1,fPart2 ! different parts of a function + real(rkind) :: dPart0,dPart1,dPart2 ! derivatives for different parts of a function + ! local variables -- "constants" + real(rkind) :: volHeatCapacityAir ! volumetric heat capacity of air (J m-3) + real(rkind) :: latentHeatConstant ! latent heat constant (kg m-3 K-1) + ! local variables -- derivatives for energy conductances + real(rkind) :: dEvapCond_dCanopyTemp ! derivative in evap conductance w.r.t. canopy temperature + real(rkind) :: dTransCond_dCanopyTemp ! derivative in trans conductance w.r.t. canopy temperature + real(rkind) :: dCanopyCond_dCanairTemp ! derivative in canopy conductance w.r.t. canopy air temperature + real(rkind) :: dCanopyCond_dCanopyTemp ! derivative in canopy conductance w.r.t. canopy temperature + real(rkind) :: dGroundCondSH_dCanairTemp ! derivative in ground conductance of sensible heat w.r.t. canopy air temperature + real(rkind) :: dGroundCondSH_dCanopyTemp ! derivative in ground conductance of sensible heat w.r.t. canopy temperature + real(rkind) :: dGroundCondSH_dGroundTemp ! derivative in ground conductance of sensible heat w.r.t. ground temperature + ! local variables -- derivatives for mass conductances + real(rkind) :: dGroundCondLH_dCanairTemp ! derivative in ground conductance w.r.t. canopy air temperature + real(rkind) :: dGroundCondLH_dCanopyTemp ! derivative in ground conductance w.r.t. canopy temperature + real(rkind) :: dGroundCondLH_dGroundTemp ! derivative in ground conductance w.r.t. ground temperature + ! local variables -- derivatives for the canopy air space variables + real(rkind) :: fPart_VP ! part of the function for vapor pressure of the canopy air space + real(rkind) :: leafConductanceTr ! leaf conductance for transpiration (m s-1) + real(rkind) :: dVPCanopyAir_dTCanair ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the canopy air space + real(rkind) :: dVPCanopyAir_dTCanopy ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the canopy + real(rkind) :: dVPCanopyAir_dTGround ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the ground + real(rkind) :: dVPCanopyAir_dWetFrac ! derivative of vapor pressure in the canopy air space w.r.t. wetted fraction of the canopy + real(rkind) :: dVPCanopyAir_dCanWat ! derivative of vapor pressure in the canopy air space w.r.t. canopy total water content + ! local variables -- sensible heat flux derivatives + real(rkind) :: dSenHeatTotal_dTCanair ! derivative in the total sensible heat flux w.r.t. canopy air temperature + real(rkind) :: dSenHeatTotal_dTCanopy ! derivative in the total sensible heat flux w.r.t. canopy air temperature + real(rkind) :: dSenHeatTotal_dTGround ! derivative in the total sensible heat flux w.r.t. ground temperature + real(rkind) :: dSenHeatCanopy_dTCanair ! derivative in the canopy sensible heat flux w.r.t. canopy air temperature + real(rkind) :: dSenHeatCanopy_dTCanopy ! derivative in the canopy sensible heat flux w.r.t. canopy temperature + real(rkind) :: dSenHeatCanopy_dTGround ! derivative in the canopy sensible heat flux w.r.t. ground temperature + real(rkind) :: dSenHeatGround_dTCanair ! derivative in the ground sensible heat flux w.r.t. canopy air temperature + real(rkind) :: dSenHeatGround_dTCanopy ! derivative in the ground sensible heat flux w.r.t. canopy temperature + real(rkind) :: dSenHeatGround_dTGround ! derivative in the ground sensible heat flux w.r.t. ground temperature + ! local variables -- wetted fraction derivatives + real(rkind) :: dLatHeatCanopyEvap_dWetFrac ! derivative in the latent heat of canopy evaporation w.r.t. canopy wet fraction (W m-2) + real(rkind) :: dLatHeatCanopyTrans_dWetFrac ! derivative in the latent heat of canopy transpiration w.r.t. canopy wet fraction (W m-2) + ! ----------------------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message='turbFluxes/' - ! derivatives for the vegetation canopy - if(computeVegFlux) then ! (if vegetation is exposed) - - ! ***** compute derivatives w.r.t. canopy temperature - ! NOTE: derivatives are zero because using canopy air space temperature - dCanopyResistance_dTCanopy = 0._rkind ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - dGroundResistance_dTCanopy = 0._rkind ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) - - ! ***** compute derivatives w.r.t. ground temperature (s m-1 K-1) - dGroundResistance_dTGround = -(groundResistanceNeutral*dGroundStabilityCorrection_dSfcTemp)/(groundStabilityCorrection**2._rkind) - - ! ***** compute derivatives w.r.t. temperature of the canopy air space (s m-1 K-1) - ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) - dCanopyResistance_dTCanair = -dCanopyStabilityCorrection_dCasTemp/(windspd*canopyExNeut*canopyStabilityCorrection**2._rkind) - ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) - ! (compute derivative in NEUTRAL ground resistance w.r.t. canopy air temperature (s m-1 K-1)) - dFV_dT = windspd*canopyExNeut*dCanopyStabilityCorrection_dCasTemp/(sqrt(sfc2AtmExchangeCoeff_canopy)*2._rkind) ! d(frictionVelocity)/d(canopy air temperature) - dED_dT = dFV_dT*vkc*(heightCanopyTopAboveSnow - zeroPlaneDisplacement) ! d(eddyDiffusCanopyTop)d(canopy air temperature) - dGR_dT = -dED_dT*(tmp1 - tmp2)*heightCanopyTopAboveSnow*exp(windReductionFactor) / (windReductionFactor*eddyDiffusCanopyTop**2._rkind) ! d(groundResistanceNeutral)/d(canopy air temperature) - ! (stitch everything together -- product rule) - dGroundResistance_dTCanair = dGR_dT/groundStabilityCorrection - groundResistanceNeutral*dGroundStabilityCorrection_dCasTemp/(groundStabilityCorrection**2._rkind) - - ! ***** compute resistances for non-vegetated surfaces (e.g., snow) + ! compute constants + volHeatCapacityAir = iden_air*Cp_air ! volumetric heat capacity of air (J m-3) + latentHeatConstant = iden_air*w_ratio/airpres ! latent heat constant for (kg m-3 Pa-1) + + ! ***** + ! * compute conductances, and derivatives... + ! ****************************************** + + ! compute conductances for sensible heat (m s-1) + if (computeVegFlux) then + leafConductance = exposedVAI/leafResistance + leafConductanceTr = canopySunlitLAI/(leafResistance+stomResistSunlit) + canopyShadedLAI/(leafResistance+stomResistShaded) + canopyConductance = 1._rkind/canopyResistance else + leafConductance = 0._rkind + canopyConductance = 0._rkind + end if + groundConductanceSH = 1._rkind/groundResistance - ! set canopy derivatives to zero (non-vegetated, remember) - dCanopyResistance_dTCanopy = 0._rkind - dGroundResistance_dTCanopy = 0._rkind - - ! compute derivatives for ground resistance - dGroundResistance_dTGround = -dGroundStabilityCorrection_dSfcTemp/(windspd*groundExNeut*groundStabilityCorrection**2._rkind) - - end if ! (switch between vegetated and non-vegetated surfaces) - - ! * analytical derivatives not desired - else - dGroundResistance_dTGround = missingValue - dGroundResistance_dTCanopy = missingValue - dCanopyResistance_dTCanopy = missingValue - end if - - ! test - !print*, 'dGroundResistance_dTGround = ', dGroundResistance_dTGround - !print*, 'dGroundResistance_dTCanopy = ', dGroundResistance_dTCanopy - !print*, 'dCanopyResistance_dTCanopy = ', dCanopyResistance_dTCanopy - !pause 'in aeroResist' - - end subroutine aeroResist - - - ! ******************************************************************************************************* - ! private subroutine soilResist: compute soil moisture factor controlling stomatal resistance - ! ******************************************************************************************************* - subroutine soilResist(& - ! input (model decisions) - ixSoilResist, & ! intent(in): choice of function for the soil moisture control on stomatal resistance - ixGroundwater, & ! intent(in): choice of groundwater representation - ! input (state variables) - mLayerMatricHead, & ! intent(in): matric head in each layer (m) - mLayerVolFracLiq, & ! intent(in): volumetric fraction of liquid water in each layer - scalarAquiferStorage, & ! intent(in): aquifer storage (m) - ! input (diagnostic variables) - mLayerRootDensity, & ! intent(in): root density in each layer (-) - scalarAquiferRootFrac, & ! intent(in): fraction of roots below the lowest unsaturated layer (-) - ! input (parameters) - plantWiltPsi, & ! intent(in): matric head at wilting point (m) - soilStressParam, & ! intent(in): parameter in the exponential soil stress function (-) - critSoilWilting, & ! intent(in): critical vol. liq. water content when plants are wilting (-) - critSoilTranspire, & ! intent(in): critical vol. liq. water content when transpiration is limited (-) - critAquiferTranspire, & ! intent(in): critical aquifer storage value when transpiration is limited (m) - ! output - wAvgTranspireLimitFac, & ! intent(out): weighted average of the transpiration limiting factor (-) - mLayerTranspireLimitFac, & ! intent(out): transpiration limiting factor in each layer (-) - aquiferTranspireLimitFac, & ! intent(out): transpiration limiting factor for the aquifer (-) - err,message) ! intent(out): error control - ! ----------------------------------------------------------------------------------------------------------------------------------------- - USE mDecisions_module, only: NoahType,CLM_Type,SiB_Type ! options for the choice of function for the soil moisture control on stomatal resistance - USE mDecisions_module, only: bigBucket ! named variable that defines the "bigBucket" groundwater parameterization - implicit none - ! input (model decisions) - integer(i4b),intent(in) :: ixSoilResist ! choice of function for the soil moisture control on stomatal resistance - integer(i4b),intent(in) :: ixGroundwater ! choice of groundwater representation - ! input (variables) - real(rkind),intent(in) :: mLayerMatricHead(:) ! matric head in each layer (m) - real(rkind),intent(in) :: mLayerVolFracLiq(:) ! volumetric fraction of liquid water in each layer (-) - real(rkind),intent(in) :: scalarAquiferStorage ! aquifer storage (m) - ! input (diagnostic variables) - real(rkind),intent(in) :: mLayerRootDensity(:) ! root density in each layer (-) - real(rkind),intent(in) :: scalarAquiferRootFrac ! fraction of roots below the lowest unsaturated layer (-) - ! input (parameters) - real(rkind),intent(in) :: plantWiltPsi ! matric head at wilting point (m) - real(rkind),intent(in) :: soilStressParam ! parameter in the exponential soil stress function (-) - real(rkind),intent(in) :: critSoilWilting(:) ! critical vol. liq. water content when plants are wilting (-) - real(rkind),intent(in) :: critSoilTranspire(:) ! critical vol. liq. water content when transpiration is limited (-) - real(rkind),intent(in) :: critAquiferTranspire ! critical aquifer storage value when transpiration is limited (m) - ! output - real(rkind),intent(out) :: wAvgTranspireLimitFac ! intent(out): weighted average of the transpiration limiting factor (-) - real(rkind),intent(out) :: mLayerTranspireLimitFac(:) ! intent(out): transpiration limiting factor in each layer (-) - real(rkind),intent(out) :: aquiferTranspireLimitFac ! intent(out): transpiration limiting factor for the aquifer (-) - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! local variables - real(rkind) :: gx ! stress function for the soil layers - real(rkind),parameter :: verySmall=epsilon(gx) ! a very small number - integer(i4b) :: iLayer ! index of soil layer - ! initialize error control - err=0; message='soilResist/' - - ! ** compute the factor limiting transpiration for each soil layer (-) - wAvgTranspireLimitFac = 0._rkind ! (initialize the weighted average) - do iLayer=1,size(mLayerMatricHead) - ! compute the soil stress function - select case(ixSoilResist) - case(NoahType) ! thresholded linear function of volumetric liquid water content - gx = (mLayerVolFracLiq(iLayer) - critSoilWilting(iLayer)) / (critSoilTranspire(iLayer) - critSoilWilting(iLayer)) - case(CLM_Type) ! thresholded linear function of matric head - if(mLayerMatricHead(iLayer) > plantWiltPsi)then - gx = 1._rkind - mLayerMatricHead(iLayer)/plantWiltPsi - else - gx = 0._rkind - end if - case(SiB_Type) ! exponential of the log of matric head - if(mLayerMatricHead(iLayer) < 0._rkind)then ! (unsaturated) - gx = 1._rkind - exp( -soilStressParam * ( log(plantWiltPsi/mLayerMatricHead(iLayer)) ) ) - else ! (saturated) - gx = 1._rkind - end if - case default ! check identified the option - err=20; message=trim(message)//'cannot identify option for soil resistance'; return - end select - ! save the factor for the given layer (ensure between zero and one) - mLayerTranspireLimitFac(iLayer) = min( max(verySmall,gx), 1._rkind) - ! compute the weighted average (weighted by root density) - wAvgTranspireLimitFac = wAvgTranspireLimitFac + mLayerTranspireLimitFac(iLayer)*mLayerRootDensity(iLayer) - end do ! (looping through soil layers) - - ! ** compute the factor limiting evaporation in the aquifer - if(scalarAquiferRootFrac > verySmall)then - ! check that aquifer root fraction is allowed - if(ixGroundwater /= bigBucket)then - message=trim(message)//'aquifer evaporation only allowed for the big groundwater bucket -- increase the soil depth to account for roots' - err=20; return + ! compute total conductance for sensible heat + if(groundConductanceSH < 0._rkind) groundConductanceSH = 0._rkind ! to avoid negative conductance, will make large residual error instead of old version where failed outright + if(canopyConductance < 0._rkind) canopyConductance = 0._rkind ! to avoid negative conductance, will make large residual error instead of old version where failed outright + totalConductanceSH = leafConductance + groundConductanceSH + canopyConductance + + ! compute conductances for latent heat (m s-1) + if (computeVegFlux) then + evapConductance = canopyWetFraction*leafConductance + transConductance = (1._rkind - canopyWetFraction) * leafConductanceTr + else + evapConductance = 0._rkind + transConductance = 0._rkind end if - ! compute the factor limiting evaporation for the aquifer - aquiferTranspireLimitFac = min(scalarAquiferStorage/critAquiferTranspire, 1._rkind) - else ! (if there are roots in the aquifer) - aquiferTranspireLimitFac = 0._rkind - end if - - ! compute the weighted average (weighted by root density) - wAvgTranspireLimitFac = wAvgTranspireLimitFac + aquiferTranspireLimitFac*scalarAquiferRootFrac - - end subroutine soilResist - - - ! ******************************************************************************** - ! private subroutine turbFluxes: compute turbulent heat fluxes - ! ******************************************************************************** - subroutine turbFluxes(& - ! input: model control - computeVegFlux, & ! intent(in): logical flag to compute vegetation fluxes (.false. if veg buried by snow) - ixDerivMethod, & ! intent(in): choice of method used to compute derivative (analytical or numerical) - ! input: above-canopy forcing data - airtemp, & ! intent(in): air temperature at some height above the surface (K) - airpres, & ! intent(in): air pressure of the air above the vegetation canopy (Pa) - VPair, & ! intent(in): vapor pressure of the air above the vegetation canopy (Pa) - ! input: latent heat of sublimation/vaporization - latHeatSubVapCanopy, & ! intent(in): latent heat of sublimation/vaporization for the vegetation canopy (J kg-1) - latHeatSubVapGround, & ! intent(in): latent heat of sublimation/vaporization for the ground surface (J kg-1) - ! input: canopy and ground temperature - canairTemp, & ! intent(in): temperature of the canopy air space (K) - canopyTemp, & ! intent(in): canopy temperature (K) - groundTemp, & ! intent(in): ground temperature (K) - satVP_CanopyTemp, & ! intent(in): saturation vapor pressure at the temperature of the veg canopy (Pa) - satVP_GroundTemp, & ! intent(in): saturation vapor pressure at the temperature of the ground (Pa) - dSVPCanopy_dCanopyTemp, & ! intent(in): derivative in canopy saturation vapor pressure w.r.t. canopy temperature (Pa K-1) - dSVPGround_dGroundTemp, & ! intent(in): derivative in ground saturation vapor pressure w.r.t. ground temperature (Pa K-1) - ! input: diagnostic variables - exposedVAI, & ! intent(in): exposed vegetation area index -- leaf plus stem (m2 m-2) - canopyWetFraction, & ! intent(in): fraction of canopy that is wet [0-1] - dCanopyWetFraction_dWat, & ! intent(in): derivative in the canopy wetted fraction w.r.t. total water content (kg-1 m-2) - dCanopyWetFraction_dT, & ! intent(in): derivative in wetted fraction w.r.t. canopy temperature (K-1) - canopySunlitLAI, & ! intent(in): sunlit leaf area (-) - canopyShadedLAI, & ! intent(in): shaded leaf area (-) - soilRelHumidity, & ! intent(in): relative humidity in the soil pores [0-1] - soilResistance, & ! intent(in): resistance from the soil (s m-1) - leafResistance, & ! intent(in): mean leaf boundary layer resistance per unit leaf area (s m-1) - groundResistance, & ! intent(in): below canopy aerodynamic resistance (s m-1) - canopyResistance, & ! intent(in): above canopy aerodynamic resistance (s m-1) - stomResistSunlit, & ! intent(in): stomatal resistance for sunlit leaves (s m-1) - stomResistShaded, & ! intent(in): stomatal resistance for shaded leaves (s m-1) - ! input: derivatives in scalar resistances - dGroundResistance_dTGround, & ! intent(in): derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) - dGroundResistance_dTCanopy, & ! intent(in): derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) - dGroundResistance_dTCanair, & ! intent(in): derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) - dCanopyResistance_dTCanopy, & ! intent(in): derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - dCanopyResistance_dTCanair, & ! intent(in): derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) - ! output: conductances (used to check derivative calculations) - leafConductance, & ! intent(out): leaf conductance (m s-1) - canopyConductance, & ! intent(out): canopy conductance (m s-1) - groundConductanceSH, & ! intent(out): ground conductance for sensible heat (m s-1) - groundConductanceLH, & ! intent(out): ground conductance for latent heat -- includes soil resistance (m s-1) - evapConductance, & ! intent(out): conductance for evaporation (m s-1) - transConductance, & ! intent(out): conductance for transpiration (m s-1) - totalConductanceSH, & ! intent(out): total conductance for sensible heat (m s-1) - totalConductanceLH, & ! intent(out): total conductance for latent heat (m s-1) - ! output: canopy air space variables - VP_CanopyAir, & ! intent(out): vapor pressure of the canopy air space (Pa) - ! output: fluxes from the vegetation canopy - senHeatCanopy, & ! intent(out): sensible heat flux from the canopy to the canopy air space (W m-2) - latHeatCanopyEvap, & ! intent(out): latent heat flux associated with evaporation from the canopy to the canopy air space (W m-2) - latHeatCanopyTrans, & ! intent(out): latent heat flux associated with transpiration from the canopy to the canopy air space (W m-2) - ! output: fluxes from non-vegetated surfaces (ground surface below vegetation, bare ground, or snow covered vegetation) - senHeatGround, & ! intent(out): sensible heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) - latHeatGround, & ! intent(out): latent heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) - ! output: total heat fluxes to the atmosphere - senHeatTotal, & ! intent(out): total sensible heat flux to the atmosphere (W m-2) - latHeatTotal, & ! intent(out): total latent heat flux to the atmosphere (W m-2) - ! output: net fluxes - turbFluxCanair, & ! intent(out): net turbulent heat fluxes at the canopy air space (W m-2) - turbFluxCanopy, & ! intent(out): net turbulent heat fluxes at the canopy (W m-2) - turbFluxGround, & ! intent(out): net turbulent heat fluxes at the ground surface (W m-2) - ! output: flux derivatives - dTurbFluxCanair_dTCanair, & ! intent(out): derivative in net canopy air space fluxes w.r.t. canopy air temperature (W m-2 K-1) - dTurbFluxCanair_dTCanopy, & ! intent(out): derivative in net canopy air space fluxes w.r.t. canopy temperature (W m-2 K-1) - dTurbFluxCanair_dTGround, & ! intent(out): derivative in net canopy air space fluxes w.r.t. ground temperature (W m-2 K-1) - dTurbFluxCanopy_dTCanair, & ! intent(out): derivative in net canopy turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) - dTurbFluxCanopy_dTCanopy, & ! intent(out): derivative in net canopy turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) - dTurbFluxCanopy_dTGround, & ! intent(out): derivative in net canopy turbulent fluxes w.r.t. ground temperature (W m-2 K-1) - dTurbFluxGround_dTCanair, & ! intent(out): derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) - dTurbFluxGround_dTCanopy, & ! intent(out): derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) - dTurbFluxGround_dTGround, & ! intent(out): derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) - ! output: liquid flux derivatives (canopy evap) - dLatHeatCanopyEvap_dCanLiq, & ! intent(out): derivative in latent heat of canopy evaporation w.r.t. canopy liquid water content (J kg-1 s-1) - dLatHeatCanopyEvap_dTCanair, & ! intent(out): derivative in latent heat of canopy evaporation w.r.t. canopy air temperature (W m-2 K-1) - dLatHeatCanopyEvap_dTCanopy, & ! intent(out): derivative in latent heat of canopy evaporation w.r.t. canopy temperature (W m-2 K-1) - dLatHeatCanopyEvap_dTGround, & ! intent(out): derivative in latent heat of canopy evaporation w.r.t. ground temperature (W m-2 K-1) - ! output: liquid flux derivatives (ground evap) - dLatHeatGroundEvap_dCanLiq, & ! intent(out): derivative in latent heat of ground evaporation w.r.t. canopy liquid water content (J kg-1 s-1) - dLatHeatGroundEvap_dTCanair, & ! intent(out): derivative in latent heat of ground evaporation w.r.t. canopy air temperature - dLatHeatGroundEvap_dTCanopy, & ! intent(out): derivative in latent heat of ground evaporation w.r.t. canopy temperature - dLatHeatGroundEvap_dTGround, & ! intent(out): derivative in latent heat of ground evaporation w.r.t. ground temperature - ! output: cross derivatives - dTurbFluxCanair_dCanLiq, & ! intent(out): derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - dTurbFluxCanopy_dCanLiq, & ! intent(out): derivative in net canopy turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - dTurbFluxGround_dCanLiq, & ! intent(out): derivative in net ground turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - ! output: error control - err,message ) ! intent(out): error control - ! ----------------------------------------------------------------------------------------------------------------------------------------- - implicit none - ! input: model control - logical(lgt),intent(in) :: computeVegFlux ! logical flag to compute vegetation fluxes (.false. if veg buried by snow) - integer(i4b),intent(in) :: ixDerivMethod ! choice of method used to compute derivative (analytical or numerical) - ! input: above-canopy forcing data - real(rkind),intent(in) :: airtemp ! air temperature at some height above the surface (K) - real(rkind),intent(in) :: airpres ! air pressure of the air above the vegetation canopy (Pa) - real(rkind),intent(in) :: VPair ! vapor pressure of the air above the vegetation canopy (Pa) - ! input: latent heat of sublimation/vaporization - real(rkind),intent(in) :: latHeatSubVapCanopy ! latent heat of sublimation/vaporization for the vegetation canopy (J kg-1) - real(rkind),intent(in) :: latHeatSubVapGround ! latent heat of sublimation/vaporization for the ground surface (J kg-1) - ! input: canopy and ground temperature - real(rkind),intent(in) :: canairTemp ! temperature of the canopy air space (K) - real(rkind),intent(in) :: canopyTemp ! canopy temperature (K) - real(rkind),intent(in) :: groundTemp ! ground temperature (K) - real(rkind),intent(in) :: satVP_CanopyTemp ! saturation vapor pressure at the temperature of the veg canopy (Pa) - real(rkind),intent(in) :: satVP_GroundTemp ! saturation vapor pressure at the temperature of the ground (Pa) - real(rkind),intent(in) :: dSVPCanopy_dCanopyTemp ! derivative in canopy saturation vapor pressure w.r.t. canopy temperature (Pa K-1) - real(rkind),intent(in) :: dSVPGround_dGroundTemp ! derivative in ground saturation vapor pressure w.r.t. ground temperature (Pa K-1) - ! input: diagnostic variables - real(rkind),intent(in) :: exposedVAI ! exposed vegetation area index -- leaf plus stem (m2 m-2) - real(rkind),intent(in) :: canopyWetFraction ! fraction of canopy that is wet [0-1] - real(rkind),intent(in) :: dCanopyWetFraction_dWat ! derivative in the canopy wetted fraction w.r.t. liquid water content (kg-1 m-2) - real(rkind),intent(in) :: dCanopyWetFraction_dT ! derivative in the canopy wetted fraction w.r.t. canopy temperature (K-1) - real(rkind),intent(in) :: canopySunlitLAI ! sunlit leaf area (-) - real(rkind),intent(in) :: canopyShadedLAI ! shaded leaf area (-) - real(rkind),intent(in) :: soilRelHumidity ! relative humidity in the soil pores [0-1] - real(rkind),intent(in) :: soilResistance ! resistance from the soil (s m-1) - real(rkind),intent(in) :: leafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) - real(rkind),intent(in) :: groundResistance ! below canopy aerodynamic resistance (s m-1) - real(rkind),intent(in) :: canopyResistance ! above canopy aerodynamic resistance (s m-1) - real(rkind),intent(in) :: stomResistSunlit ! stomatal resistance for sunlit leaves (s m-1) - real(rkind),intent(in) :: stomResistShaded ! stomatal resistance for shaded leaves (s m-1) - ! input: derivatives in scalar resistances - real(rkind),intent(in) :: dGroundResistance_dTGround ! derivative in ground resistance w.r.t. ground temperature (s m-1 K-1) - real(rkind),intent(in) :: dGroundResistance_dTCanopy ! derivative in ground resistance w.r.t. canopy temperature (s m-1 K-1) - real(rkind),intent(in) :: dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) - real(rkind),intent(in) :: dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) - real(rkind),intent(in) :: dCanopyResistance_dTCanair ! derivative in canopy resistance w.r.t. canopy air temperature (s m-1 K-1) - ! --------------------------------------------------------------------------------------------------------------------------------------------------------------- - ! output: conductances -- used to test derivatives - real(rkind),intent(out) :: leafConductance ! leaf conductance (m s-1) - real(rkind),intent(out) :: canopyConductance ! canopy conductance (m s-1) - real(rkind),intent(out) :: groundConductanceSH ! ground conductance for sensible heat (m s-1) - real(rkind),intent(out) :: groundConductanceLH ! ground conductance for latent heat -- includes soil resistance (m s-1) - real(rkind),intent(out) :: evapConductance ! conductance for evaporation (m s-1) - real(rkind),intent(out) :: transConductance ! conductance for transpiration (m s-1) - real(rkind),intent(out) :: totalConductanceSH ! total conductance for sensible heat (m s-1) - real(rkind),intent(out) :: totalConductanceLH ! total conductance for latent heat (m s-1) - ! output: canopy air space variables - real(rkind),intent(out) :: VP_CanopyAir ! vapor pressure of the canopy air space (Pa) - ! output: fluxes from the vegetation canopy - real(rkind),intent(out) :: senHeatCanopy ! sensible heat flux from the canopy to the canopy air space (W m-2) - real(rkind),intent(out) :: latHeatCanopyEvap ! latent heat flux associated with evaporation from the canopy to the canopy air space (W m-2) - real(rkind),intent(out) :: latHeatCanopyTrans ! latent heat flux associated with transpiration from the canopy to the canopy air space (W m-2) - ! output: fluxes from non-vegetated surfaces (ground surface below vegetation, bare ground, or snow covered vegetation) - real(rkind),intent(out) :: senHeatGround ! sensible heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) - real(rkind),intent(out) :: latHeatGround ! latent heat flux from ground surface below vegetation, bare ground, or snow covered vegetation (W m-2) - ! output: total heat fluxes to the atmosphere - real(rkind),intent(out) :: senHeatTotal ! total sensible heat flux to the atmosphere (W m-2) - real(rkind),intent(out) :: latHeatTotal ! total latent heat flux to the atmosphere (W m-2) - ! output: net fluxes - real(rkind),intent(out) :: turbFluxCanair ! net turbulent heat fluxes at the canopy air space (W m-2) - real(rkind),intent(out) :: turbFluxCanopy ! net turbulent heat fluxes at the canopy (W m-2) - real(rkind),intent(out) :: turbFluxGround ! net turbulent heat fluxes at the ground surface (W m-2) - ! output: energy flux derivatives - real(rkind),intent(out) :: dTurbFluxCanair_dTCanair ! derivative in net canopy air space fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(rkind),intent(out) :: dTurbFluxCanair_dTCanopy ! derivative in net canopy air space fluxes w.r.t. canopy temperature (W m-2 K-1) - real(rkind),intent(out) :: dTurbFluxCanair_dTGround ! derivative in net canopy air space fluxes w.r.t. ground temperature (W m-2 K-1) - real(rkind),intent(out) :: dTurbFluxCanopy_dTCanair ! derivative in net canopy turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(rkind),intent(out) :: dTurbFluxCanopy_dTCanopy ! derivative in net canopy turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) - real(rkind),intent(out) :: dTurbFluxCanopy_dTGround ! derivative in net canopy turbulent fluxes w.r.t. ground temperature (W m-2 K-1) - real(rkind),intent(out) :: dTurbFluxGround_dTCanair ! derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) - real(rkind),intent(out) :: dTurbFluxGround_dTCanopy ! derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) - real(rkind),intent(out) :: dTurbFluxGround_dTGround ! derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) - ! output: liquid flux derivatives (canopy evap) - real(rkind),intent(out) :: dLatHeatCanopyEvap_dCanLiq ! derivative in latent heat of canopy evaporation w.r.t. canopy liquid water content (W kg-1) - real(rkind),intent(out) :: dLatHeatCanopyEvap_dTCanair ! derivative in latent heat of canopy evaporation w.r.t. canopy air temperature (W m-2 K-1) - real(rkind),intent(out) :: dLatHeatCanopyEvap_dTCanopy ! derivative in latent heat of canopy evaporation w.r.t. canopy temperature (W m-2 K-1) - real(rkind),intent(out) :: dLatHeatCanopyEvap_dTGround ! derivative in latent heat of canopy evaporation w.r.t. ground temperature (W m-2 K-1) - ! output: liquid flux derivatives (ground evap) - real(rkind),intent(out) :: dLatHeatGroundEvap_dCanLiq ! derivative in latent heat of ground evaporation w.r.t. canopy liquid water content (J kg-1 s-1) - real(rkind),intent(out) :: dLatHeatGroundEvap_dTCanair ! derivative in latent heat of ground evaporation w.r.t. canopy air temperature (W m-2 K-1) - real(rkind),intent(out) :: dLatHeatGroundEvap_dTCanopy ! derivative in latent heat of ground evaporation w.r.t. canopy temperature (W m-2 K-1) - real(rkind),intent(out) :: dLatHeatGroundEvap_dTGround ! derivative in latent heat of ground evaporation w.r.t. ground temperature (W m-2 K-1) - ! output: cross derivatives - real(rkind),intent(out) :: dTurbFluxCanair_dCanLiq ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - real(rkind),intent(out) :: dTurbFluxCanopy_dCanLiq ! derivative in net canopy turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - real(rkind),intent(out) :: dTurbFluxGround_dCanLiq ! derivative in net ground turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! ----------------------------------------------------------------------------------------------------------------------------------------- - ! local variables -- general - real(rkind) :: fpart1,fpart2 ! different parts of a function - real(rkind) :: dPart0,dpart1,dpart2 ! derivatives for different parts of a function - ! local variables -- "constants" - real(rkind) :: volHeatCapacityAir ! volumetric heat capacity of air (J m-3) - real(rkind) :: latentHeatConstant ! latent heat constant (kg m-3 K-1) - ! local variables -- derivatives for energy conductances - real(rkind) :: dEvapCond_dCanopyTemp ! derivative in evap conductance w.r.t. canopy temperature - real(rkind) :: dTransCond_dCanopyTemp ! derivative in trans conductance w.r.t. canopy temperature - real(rkind) :: dCanopyCond_dCanairTemp ! derivative in canopy conductance w.r.t. canopy air temperature - real(rkind) :: dCanopyCond_dCanopyTemp ! derivative in canopy conductance w.r.t. canopy temperature - real(rkind) :: dGroundCondSH_dCanairTemp ! derivative in ground conductance of sensible heat w.r.t. canopy air temperature - real(rkind) :: dGroundCondSH_dCanopyTemp ! derivative in ground conductance of sensible heat w.r.t. canopy temperature - real(rkind) :: dGroundCondSH_dGroundTemp ! derivative in ground conductance of sensible heat w.r.t. ground temperature - ! local variables -- derivatives for mass conductances - real(rkind) :: dGroundCondLH_dCanairTemp ! derivative in ground conductance w.r.t. canopy air temperature - real(rkind) :: dGroundCondLH_dCanopyTemp ! derivative in ground conductance w.r.t. canopy temperature - real(rkind) :: dGroundCondLH_dGroundTemp ! derivative in ground conductance w.r.t. ground temperature - ! local variables -- derivatives for the canopy air space variables - real(rkind) :: fPart_VP ! part of the function for vapor pressure of the canopy air space - real(rkind) :: leafConductanceTr ! leaf conductance for transpiration (m s-1) - real(rkind) :: dVPCanopyAir_dTCanair ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the canopy air space - real(rkind) :: dVPCanopyAir_dTCanopy ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the canopy - real(rkind) :: dVPCanopyAir_dTGround ! derivative in the vapor pressure of the canopy air space w.r.t. temperature of the ground - real(rkind) :: dVPCanopyAir_dWetFrac ! derivative of vapor pressure in the canopy air space w.r.t. wetted fraction of the canopy - real(rkind) :: dVPCanopyAir_dCanLiq ! derivative of vapor pressure in the canopy air space w.r.t. canopy liquid water content - ! local variables -- sensible heat flux derivatives - real(rkind) :: dSenHeatTotal_dTCanair ! derivative in the total sensible heat flux w.r.t. canopy air temperature - real(rkind) :: dSenHeatTotal_dTCanopy ! derivative in the total sensible heat flux w.r.t. canopy air temperature - real(rkind) :: dSenHeatTotal_dTGround ! derivative in the total sensible heat flux w.r.t. ground temperature - real(rkind) :: dSenHeatCanopy_dTCanair ! derivative in the canopy sensible heat flux w.r.t. canopy air temperature - real(rkind) :: dSenHeatCanopy_dTCanopy ! derivative in the canopy sensible heat flux w.r.t. canopy temperature - real(rkind) :: dSenHeatCanopy_dTGround ! derivative in the canopy sensible heat flux w.r.t. ground temperature - real(rkind) :: dSenHeatGround_dTCanair ! derivative in the ground sensible heat flux w.r.t. canopy air temperature - real(rkind) :: dSenHeatGround_dTCanopy ! derivative in the ground sensible heat flux w.r.t. canopy temperature - real(rkind) :: dSenHeatGround_dTGround ! derivative in the ground sensible heat flux w.r.t. ground temperature - ! local variables -- latent heat flux derivatives - real(rkind) :: dLatHeatCanopyTrans_dTCanair ! derivative in the canopy transpiration flux w.r.t. canopy air temperature - real(rkind) :: dLatHeatCanopyTrans_dTCanopy ! derivative in the canopy transpiration flux w.r.t. canopy temperature - real(rkind) :: dLatHeatCanopyTrans_dTGround ! derivative in the canopy transpiration flux w.r.t. ground temperature - ! local variables -- wetted fraction derivatives - real(rkind) :: dLatHeatCanopyEvap_dWetFrac ! derivative in the latent heat of canopy evaporation w.r.t. canopy wet fraction (W m-2) - real(rkind) :: dLatHeatCanopyTrans_dWetFrac ! derivative in the latent heat of canopy transpiration w.r.t. canopy wet fraction (W m-2) - real(rkind) :: dLatHeatCanopyTrans_dCanLiq ! derivative in the latent heat of canopy transpiration w.r.t. canopy liquid water (J kg-1 s-1) - ! ----------------------------------------------------------------------------------------------------------------------------------------- - ! initialize error control - err=0; message='turbFluxes/' - - ! compute constants - volHeatCapacityAir = iden_air*cp_air ! volumetric heat capacity of air (J m-3) - latentHeatConstant = iden_air*w_ratio/airpres ! latent heat constant for (kg m-3 Pa-1) - - ! ***** - ! * compute conductances, and derivatives... - ! ****************************************** - - ! compute conductances for sensible heat (m s-1) - if(computeVegFlux)then - leafConductance = exposedVAI/leafResistance - leafConductanceTr = canopySunlitLAI/(leafResistance+stomResistSunlit) + canopyShadedLAI/(leafResistance+stomResistShaded) - canopyConductance = 1._rkind/canopyResistance - else - leafConductance = 0._rkind - canopyConductance = 0._rkind - end if - groundConductanceSH = 1._rkind/groundResistance - - ! compute total conductance for sensible heat - totalConductanceSH = leafConductance + groundConductanceSH + canopyConductance - - ! compute conductances for latent heat (m s-1) - if(computeVegFlux)then - evapConductance = canopyWetFraction*leafConductance - transConductance = (1._rkind - canopyWetFraction) * leafConductanceTr - !write(*,'(a,10(f14.8,1x))') 'canopySunlitLAI, canopyShadedLAI, stomResistSunlit, stomResistShaded, leafResistance, canopyWetFraction = ', & - ! canopySunlitLAI, canopyShadedLAI, stomResistSunlit, stomResistShaded, leafResistance, canopyWetFraction - else - evapConductance = 0._rkind - transConductance = 0._rkind - end if - groundConductanceLH = 1._rkind/(groundResistance + soilResistance) ! NOTE: soilResistance accounts for fractional snow, and =0 when snow cover is 100% - totalConductanceLH = evapConductance + transConductance + groundConductanceLH + canopyConductance - - ! check sensible heat conductance - if(totalConductanceSH < -tinyVal .or. groundConductanceSH < -tinyVal .or. canopyConductance < -tinyVal)then - message=trim(message)//'negative conductance for sensible heat' - err=20; return - endif - - ! check latent heat conductance - if(totalConductanceLH < tinyVal .or. groundConductanceLH < -tinyVal)then - message=trim(message)//'negative conductance for latent heat' - err=20; return - endif - - ! * compute derivatives - ! NOTE: it may be more efficient to compute these derivatives when computing resistances - if(ixDerivMethod == analytical)then + groundConductanceLH = 1._rkind/(groundResistance + soilResistance) ! NOTE: soilResistance accounts for fractional snow, and =0 when snow cover is 100% + if(groundConductanceLH < 0._rkind) groundConductanceLH = 0._rkind ! to avoid negative conductance, will make large residual error instead of old version where failed outright + totalConductanceLH = evapConductance + transConductance + groundConductanceLH + canopyConductance + if(totalConductanceLH < 0._rkind) totalConductanceLH = epsilon(1._rkind) ! to avoid division by zero, will make large residual error instead of old version where failed outright ! compute derivatives in individual conductances for sensible heat w.r.t. canopy temperature (m s-1 K-1) - if(computeVegFlux)then - dEvapCond_dCanopyTemp = dCanopyWetFraction_dT*leafConductance ! derivative in evap conductance w.r.t. canopy temperature - dTransCond_dCanopyTemp = -dCanopyWetFraction_dT*leafConductanceTr ! derivative in trans conductance w.r.t. canopy temperature - dCanopyCond_dCanairTemp = -dCanopyResistance_dTCanair/canopyResistance**2._rkind ! derivative in canopy conductance w.r.t. canopy air emperature - dCanopyCond_dCanopyTemp = -dCanopyResistance_dTCanopy/canopyResistance**2._rkind ! derivative in canopy conductance w.r.t. canopy temperature - dGroundCondSH_dCanairTemp = -dGroundResistance_dTCanair/groundResistance**2._rkind ! derivative in ground conductance w.r.t. canopy air temperature - dGroundCondSH_dCanopyTemp = -dGroundResistance_dTCanopy/groundResistance**2._rkind ! derivative in ground conductance w.r.t. canopy temperature - dGroundCondSH_dGroundTemp = -dGroundResistance_dTGround/groundResistance**2._rkind ! derivative in ground conductance w.r.t. ground temperature + ! NOTE: it may be more efficient to compute these derivatives when computing resistances + if (computeVegFlux) then + dEvapCond_dCanopyTemp = dCanopyWetFraction_dT*leafConductance ! derivative in evap conductance w.r.t. canopy temperature + dTransCond_dCanopyTemp = -dCanopyWetFraction_dT*leafConductanceTr ! derivative in trans conductance w.r.t. canopy temperature + dCanopyCond_dCanairTemp = -dCanopyResistance_dTCanair/canopyResistance**2_i4b ! derivative in canopy conductance w.r.t. canopy air emperature + dCanopyCond_dCanopyTemp = -dCanopyResistance_dTCanopy/canopyResistance**2_i4b ! derivative in canopy conductance w.r.t. canopy temperature + dGroundCondSH_dCanairTemp = -dGroundResistance_dTCanair/groundResistance**2_i4b ! derivative in ground conductance w.r.t. canopy air temperature + dGroundCondSH_dCanopyTemp = -dGroundResistance_dTCanopy/groundResistance**2_i4b ! derivative in ground conductance w.r.t. canopy temperature + dGroundCondSH_dGroundTemp = -dGroundResistance_dTGround/groundResistance**2_i4b ! derivative in ground conductance w.r.t. ground temperature else - dEvapCond_dCanopyTemp = 0._rkind ! derivative in evap conductance w.r.t. canopy temperature - dTransCond_dCanopyTemp = 0._rkind ! derivative in trans conductance w.r.t. canopy temperature - dCanopyCond_dCanairTemp = 0._rkind ! derivative in canopy conductance w.r.t. canopy air emperature - dCanopyCond_dCanopyTemp = 0._rkind ! derivative in canopy conductance w.r.t. canopy temperature - dGroundCondSH_dCanairTemp = 0._rkind ! derivative in ground conductance w.r.t. canopy air temperature - dGroundCondSH_dCanopyTemp = 0._rkind ! derivative in ground conductance w.r.t. canopy temperature - dGroundCondSH_dGroundTemp = -dGroundResistance_dTGround/groundResistance**2._rkind ! derivative in ground conductance w.r.t. ground temperature + dEvapCond_dCanopyTemp = 0._rkind ! derivative in evap conductance w.r.t. canopy temperature + dTransCond_dCanopyTemp = 0._rkind ! derivative in trans conductance w.r.t. canopy temperature + dCanopyCond_dCanairTemp = 0._rkind ! derivative in canopy conductance w.r.t. canopy air emperature + dCanopyCond_dCanopyTemp = 0._rkind ! derivative in canopy conductance w.r.t. canopy temperature + dGroundCondSH_dCanairTemp = 0._rkind ! derivative in ground conductance w.r.t. canopy air temperature + dGroundCondSH_dCanopyTemp = 0._rkind ! derivative in ground conductance w.r.t. canopy temperature + dGroundCondSH_dGroundTemp = -dGroundResistance_dTGround/groundResistance**2_i4b ! derivative in ground conductance w.r.t. ground temperature + endif + if(groundConductanceSH <= 0._rkind) then + dGroundCondSH_dCanairTemp = 0._rkind + dGroundCondSH_dCanopyTemp = 0._rkind + dGroundCondSH_dGroundTemp = 0._rkind + end if + if(canopyConductance <= 0._rkind) then + dCanopyCond_dCanairTemp = 0._rkind + dCanopyCond_dCanopyTemp = 0._rkind end if ! compute derivatives in individual conductances for latent heat w.r.t. canopy temperature (m s-1 K-1) - if(computeVegFlux)then - dGroundCondLH_dCanairTemp = -dGroundResistance_dTCanair/(groundResistance+soilResistance)**2._rkind ! derivative in ground conductance w.r.t. canopy air temperature - dGroundCondLH_dCanopyTemp = -dGroundResistance_dTCanopy/(groundResistance+soilResistance)**2._rkind ! derivative in ground conductance w.r.t. canopy temperature - dGroundCondLH_dGroundTemp = -dGroundResistance_dTGround/(groundResistance+soilResistance)**2._rkind ! derivative in ground conductance w.r.t. ground temperature + if (computeVegFlux) then + dGroundCondLH_dCanairTemp = -dGroundResistance_dTCanair/(groundResistance+soilResistance)**2_i4b ! derivative in ground conductance w.r.t. canopy air temperature + dGroundCondLH_dCanopyTemp = -dGroundResistance_dTCanopy/(groundResistance+soilResistance)**2_i4b ! derivative in ground conductance w.r.t. canopy temperature + dGroundCondLH_dGroundTemp = -dGroundResistance_dTGround/(groundResistance+soilResistance)**2_i4b ! derivative in ground conductance w.r.t. ground temperature else - dGroundCondLH_dCanairTemp = 0._rkind ! derivative in ground conductance w.r.t. canopy air temperature - dGroundCondLH_dCanopyTemp = 0._rkind ! derivative in ground conductance w.r.t. canopy temperature - dGroundCondLH_dGroundTemp = -dGroundResistance_dTGround/(groundResistance+soilResistance)**2._rkind ! derivative in ground conductance w.r.t. ground temperature + dGroundCondLH_dCanairTemp = 0._rkind ! derivative in ground conductance w.r.t. canopy air temperature + dGroundCondLH_dCanopyTemp = 0._rkind ! derivative in ground conductance w.r.t. canopy temperature + dGroundCondLH_dGroundTemp = -dGroundResistance_dTGround/(groundResistance+soilResistance)**2_i4b ! derivative in ground conductance w.r.t. ground temperature + end if + if(groundConductanceLH <= 0._rkind) then + dGroundCondLH_dCanairTemp = 0._rkind + dGroundCondLH_dCanopyTemp = 0._rkind + dGroundCondLH_dGroundTemp = 0._rkind end if - end if ! (if computing analytical derivatives) - - ! ***** - ! * compute sensible and latent heat fluxes, and derivatives... - ! ************************************************************* - - ! * compute sensible and latent heat fluxes from the canopy to the canopy air space (W m-2) - if(computeVegFlux)then - - ! compute the vapor pressure in the canopy air space (Pa) - fPart_VP = canopyConductance*VPair + (evapConductance + transConductance)*satVP_CanopyTemp + groundConductanceLH*satVP_GroundTemp*soilRelHumidity - VP_CanopyAir = fPart_VP/totalConductanceLH - !write(*,'(a,10(f20.10,1x))') 'canopyConductance, evapConductance, transConductance, groundConductanceLH, soilRelHumidity = ', & - ! canopyConductance, evapConductance, transConductance, groundConductanceLH, soilRelHumidity - - ! compute sensible heat flux from the canopy air space to the atmosphere - ! NOTE: canairTemp is a state variable - senHeatTotal = -volHeatCapacityAir*canopyConductance*(canairTemp - airtemp) - !print*, 'canairTemp, airtemp, senHeatTotal = ', canairTemp, airtemp, senHeatTotal - - ! compute fluxes - senHeatCanopy = -volHeatCapacityAir*leafConductance*(canopyTemp - canairTemp) ! (positive downwards) - latHeatCanopyEvap = -latHeatSubVapCanopy*latentHeatConstant*evapConductance*(satVP_CanopyTemp - VP_CanopyAir) ! (positive downwards) - latHeatCanopyTrans = -LH_vap*latentHeatConstant*transConductance*(satVP_CanopyTemp - VP_CanopyAir) ! (positive downwards) - !write(*,'(a,10(f25.15,1x))') 'latHeatCanopyEvap, VP_CanopyAir = ', latHeatCanopyEvap, VP_CanopyAir - !write(*,'(a,10(f25.15,1x))') 'latHeatCanopyTrans, VP_CanopyAir = ', latHeatCanopyTrans, VP_CanopyAir - !write(*,'(a,10(f25.15,1x))') 'transConductance = ', transConductance - - ! check that energy for canopy evaporation does not exhaust the available water - ! NOTE: do this here, rather than enforcing solution constraints, because energy and mass solutions may be uncoupled - !if(latHeatSubVapCanopy > LH_vap+verySmall)then ! (sublimation) - ! maxFlux = -canopyIce*LH_sub/dt ! W m-2 - !else ! (evaporation) - ! maxFlux = -canopyLiquid*LH_vap/dt ! W m-2 - !end if - ! NOTE: fluxes are positive downwards - !if(latHeatCanopyEvap < maxFlux) latHeatCanopyEvap = maxFlux - !write(*,'(a,10(f20.10,1x))') 'maxFlux, latHeatCanopyEvap = ', maxFlux, latHeatCanopyEvap - - ! * no vegetation, so fluxes are zero - else - senHeatCanopy = 0._rkind - latHeatCanopyEvap = 0._rkind - latHeatCanopyTrans = 0._rkind - end if - - ! compute sensible and latent heat fluxes from the ground to the canopy air space (W m-2) - if(computeVegFlux)then - senHeatGround = -volHeatCapacityAir*groundConductanceSH*(groundTemp - canairTemp) ! (positive downwards) - latHeatGround = -latHeatSubVapGround*latentHeatConstant*groundConductanceLH*(satVP_GroundTemp*soilRelHumidity - VP_CanopyAir) ! (positive downwards) - else - senHeatGround = -volHeatCapacityAir*groundConductanceSH*(groundTemp - airtemp) ! (positive downwards) - latHeatGround = -latHeatSubVapGround*latentHeatConstant*groundConductanceLH*(satVP_GroundTemp*soilRelHumidity - VPair) ! (positive downwards) - senHeatTotal = senHeatGround - end if - !write(*,'(a,10(f25.15,1x))') 'latHeatGround = ', latHeatGround - - ! compute latent heat flux from the canopy air space to the atmosphere - ! NOTE: VP_CanopyAir is a diagnostic variable - latHeatTotal = latHeatCanopyEvap + latHeatCanopyTrans + latHeatGround - - ! * compute derivatives - if(ixDerivMethod == analytical)then + ! ***** + ! * compute sensible and latent heat fluxes, and derivatives... + ! ************************************************************* + + ! * compute sensible and latent heat fluxes from the canopy to the canopy air space (W m-2) + if (computeVegFlux) then + ! compute the vapor pressure in the canopy air space (Pa) + fPart_VP = canopyConductance*VPair + (evapConductance + transConductance)*satVP_CanopyTemp + groundConductanceLH*satVP_GroundTemp*soilRelHumidity + VP_CanopyAir = fPart_VP/totalConductanceLH + + ! compute sensible heat flux from the canopy air space to the atmosphere + ! NOTE: canairTemp is a state variable + senHeatTotal = -volHeatCapacityAir*canopyConductance*(canairTemp - airtemp) + if (canairTemp<0._rkind) senHeatTotal = volHeatCapacityAir*canopyConductance*airtemp ! cap function to prevent blowing up + + ! compute fluxes + senHeatCanopy = -volHeatCapacityAir*leafConductance*(canopyTemp - canairTemp) ! positive downwards + latHeatCanopyEvap = -latHeatSubVapCanopy*latentHeatConstant*evapConductance*(satVP_CanopyTemp - VP_CanopyAir) ! positive downwards + latHeatCanopyTrans = -LH_vap*latentHeatConstant*transConductance*(satVP_CanopyTemp - VP_CanopyAir) ! positive downwards + if (canopyTemp<0._rkind) then ! cap function to prevent blowing up + senHeatCanopy = volHeatCapacityAir*leafConductance*canairTemp + if (canairTemp<0._rkind) senHeatCanopy = 0._rkind + else if (canairTemp<0._rkind) then + senHeatCanopy = -volHeatCapacityAir*leafConductance*canopyTemp + end if + ! * no vegetation, so fluxes are zero + else + senHeatCanopy = 0._rkind + latHeatCanopyEvap = 0._rkind + latHeatCanopyTrans = 0._rkind + end if + ! compute sensible and latent heat fluxes from the ground to the canopy air space (W m-2) + if (computeVegFlux) then + senHeatGround = -volHeatCapacityAir*groundConductanceSH*(groundTemp - canairTemp) ! positive downwards + latHeatGround = -latHeatSubVapGround*latentHeatConstant*groundConductanceLH*(satVP_GroundTemp*soilRelHumidity - VP_CanopyAir) ! positive downwards + if (groundTemp<0._rkind) then ! cap function to prevent blowing up + senHeatGround = volHeatCapacityAir*groundConductanceSH*canairTemp + if (canairTemp<0._rkind) senHeatGround = 0._rkind + else if (canairTemp<0._rkind) then + senHeatGround = -volHeatCapacityAir*groundConductanceSH*groundTemp + end if + else + senHeatGround = -volHeatCapacityAir*groundConductanceSH*(groundTemp - airtemp) ! positive downwards + latHeatGround = -latHeatSubVapGround*latentHeatConstant*groundConductanceLH*(satVP_GroundTemp*soilRelHumidity - VPair) ! positive downwards + senHeatTotal = senHeatGround + if (groundTemp<0._rkind) senHeatGround = volHeatCapacityAir*groundConductanceSH*airtemp ! cap function to prevent blowing up + end if + + ! compute latent heat flux from the canopy air space to the atmosphere + ! NOTE: VP_CanopyAir is a diagnostic variable + latHeatTotal = latHeatCanopyEvap + latHeatCanopyTrans + latHeatGround + + ! * compute derivatives ! differentiate CANOPY fluxes - if(computeVegFlux)then - - ! compute derivatives of vapor pressure in the canopy air space w.r.t. all state variables - ! (derivative of vapor pressure in the canopy air space w.r.t. temperature of the canopy air space) - dPart1 = dCanopyCond_dCanairTemp*VPair + dGroundCondLH_dCanairTemp*satVP_GroundTemp*soilRelHumidity - dPart2 = -(dCanopyCond_dCanairTemp + dGroundCondLH_dCanairTemp)/(totalConductanceLH**2._rkind) - dVPCanopyAir_dTCanair = dPart1/totalConductanceLH + fPart_VP*dPart2 - ! (derivative of vapor pressure in the canopy air space w.r.t. temperature of the canopy) - dPart0 = (evapConductance + transConductance)*dSVPCanopy_dCanopyTemp + (dEvapCond_dCanopyTemp + dTransCond_dCanopyTemp)*satVP_CanopyTemp - dPart1 = dCanopyCond_dCanopyTemp*VPair + dPart0 + dGroundCondLH_dCanopyTemp*satVP_GroundTemp*soilRelHumidity - dPart2 = -(dCanopyCond_dCanopyTemp + dEvapCond_dCanopyTemp + dTransCond_dCanopyTemp + dGroundCondLH_dCanopyTemp)/(totalConductanceLH**2._rkind) - dVPCanopyAir_dTCanopy = dPart1/totalConductanceLH + fPart_VP*dPart2 - ! (derivative of vapor pressure in the canopy air space w.r.t. temperature of the ground) - dPart1 = dGroundCondLH_dGroundTemp*satVP_GroundTemp*soilRelHumidity + groundConductanceLH*dSVPGround_dGroundTemp*soilRelHumidity - dPart2 = -dGroundCondLH_dGroundTemp/(totalConductanceLH**2._rkind) - dVPCanopyAir_dTGround = dPart1/totalConductanceLH + fPart_VP*dPart2 - ! (derivative of vapor pressure in the canopy air space w.r.t. wetted fraction of the canopy) - dPart1 = (leafConductance - leafConductanceTr)*satVP_CanopyTemp - dPart2 = -(leafConductance - leafConductanceTr)/(totalConductanceLH**2._rkind) - dVPCanopyAir_dWetFrac = dPart1/totalConductanceLH + fPart_VP*dPart2 - dVPCanopyAir_dCanLiq = dVPCanopyAir_dWetFrac*dCanopyWetFraction_dWat - !write(*,'(a,5(f20.8,1x))') 'dVPCanopyAir_dTCanair, dVPCanopyAir_dTCanopy, dVPCanopyAir_dTGround, dVPCanopyAir_dWetFrac, dVPCanopyAir_dCanLiq = ', & - ! dVPCanopyAir_dTCanair, dVPCanopyAir_dTCanopy, dVPCanopyAir_dTGround, dVPCanopyAir_dWetFrac, dVPCanopyAir_dCanLiq - - ! sensible heat from the canopy to the atmosphere - dSenHeatTotal_dTCanair = -volHeatCapacityAir*canopyConductance - volHeatCapacityAir*dCanopyCond_dCanairTemp*(canairTemp - airtemp) - dSenHeatTotal_dTCanopy = -volHeatCapacityAir*dCanopyCond_dCanopyTemp*(canairTemp - airtemp) - dSenHeatTotal_dTGround = 0._rkind - !write(*,'(a,3(f20.8,1x))') 'dSenHeatTotal_dTCanair, dSenHeatTotal_dTCanopy, dSenHeatTotal_dTGround = ', & - ! dSenHeatTotal_dTCanair, dSenHeatTotal_dTCanopy, dSenHeatTotal_dTGround - - ! sensible heat from the canopy to the canopy air space - dSenHeatCanopy_dTCanair = volHeatCapacityAir*leafConductance - dSenHeatCanopy_dTCanopy = -volHeatCapacityAir*leafConductance - dSenHeatCanopy_dTGround = 0._rkind - !write(*,'(a,3(f20.8,1x))') 'dSenHeatCanopy_dTCanair, dSenHeatCanopy_dTCanopy, dSenHeatCanopy_dTGround = ', & - ! dSenHeatCanopy_dTCanair, dSenHeatCanopy_dTCanopy, dSenHeatCanopy_dTGround - - ! sensible heat from the ground to the canopy air space - dSenHeatGround_dTCanair = -volHeatCapacityAir*dGroundCondSH_dCanairTemp*(groundTemp - canairTemp) + volHeatCapacityAir*groundConductanceSH - dSenHeatGround_dTCanopy = -volHeatCapacityAir*dGroundCondSH_dCanopyTemp*(groundTemp - canairTemp) - dSenHeatGround_dTGround = -volHeatCapacityAir*dGroundCondSH_dGroundTemp*(groundTemp - canairTemp) - volHeatCapacityAir*groundConductanceSH - !write(*,'(a,3(f20.8,1x))') 'dSenHeatGround_dTCanair, dSenHeatGround_dTCanopy, dSenHeatGround_dTGround = ', & - ! dSenHeatGround_dTCanair, dSenHeatGround_dTCanopy, dSenHeatGround_dTGround - - ! latent heat associated with canopy evaporation - ! (initial calculations) - fPart1 = -latHeatSubVapCanopy*latentHeatConstant*evapConductance - dPart1 = -latHeatSubVapCanopy*latentHeatConstant*dEvapCond_dCanopyTemp - fPart2 = satVP_CanopyTemp - VP_CanopyAir - dPart2 = dSVPCanopy_dCanopyTemp - dVPCanopyAir_dTCanopy - ! (derivatives) - dLatHeatCanopyEvap_dTCanair = fPart1*(-dVPCanopyAir_dTCanair) - dLatHeatCanopyEvap_dTCanopy = fPart1*dpart2 + fPart2*dPart1 - dLatHeatCanopyEvap_dTGround = fPart1*(-dVPCanopyAir_dTGround) - !write(*,'(a,3(f20.8,1x))') 'dLatHeatCanopyEvap_dTCanair, dLatHeatCanopyEvap_dTCanopy, dLatHeatCanopyEvap_dTGround = ', & - ! dLatHeatCanopyEvap_dTCanair, dLatHeatCanopyEvap_dTCanopy, dLatHeatCanopyEvap_dTGround - - ! latent heat associated with canopy transpiration - ! (initial calculations) - fPart1 = -LH_vap*latentHeatConstant*transConductance - dPart1 = -LH_vap*latentHeatConstant*dTransCond_dCanopyTemp - ! (derivatives) - dLatHeatCanopyTrans_dTCanair = fPart1*(-dVPCanopyAir_dTCanair) - dLatHeatCanopyTrans_dTCanopy = fPart1*dPart2 + fPart2*dPart1 - dLatHeatCanopyTrans_dTGround = fPart1*(-dVPCanopyAir_dTGround) - !write(*,'(a,3(f20.8,1x))') 'dLatHeatCanopyTrans_dTCanair, dLatHeatCanopyTrans_dTCanopy, dLatHeatCanopyTrans_dTGround = ', & - ! dLatHeatCanopyTrans_dTCanair, dLatHeatCanopyTrans_dTCanopy, dLatHeatCanopyTrans_dTGround - - ! latent heat flux from the ground - fPart1 = -latHeatSubVapGround*latentHeatConstant*groundConductanceLH ! function of the first part - fPart2 = (satVP_GroundTemp*soilRelHumidity - VP_CanopyAir) ! function of the second part - dLatHeatGroundEvap_dTCanair = -latHeatSubVapGround*latentHeatConstant*dGroundCondLH_dCanairTemp*fPart2 - dVPCanopyAir_dTCanair*fPart1 - dLatHeatGroundEvap_dTCanopy = -latHeatSubVapGround*latentHeatConstant*dGroundCondLH_dCanopyTemp*fPart2 - dVPCanopyAir_dTCanopy*fPart1 - dLatHeatGroundEvap_dTGround = -latHeatSubVapGround*latentHeatConstant*dGroundCondLH_dGroundTemp*fPart2 + (dSVPGround_dGroundTemp*soilRelHumidity - dVPCanopyAir_dTGround)*fPart1 - !write(*,'(a,3(f20.8,1x))') 'dLatHeatGroundEvap_dTCanair, dLatHeatGroundEvap_dTCanopy, dLatHeatGroundEvap_dTGround = ', & - ! dLatHeatGroundEvap_dTCanair, dLatHeatGroundEvap_dTCanopy, dLatHeatGroundEvap_dTGround - - ! latent heat associated with canopy evaporation w.r.t. wetted fraction of the canopy - dPart1 = -latHeatSubVapCanopy*latentHeatConstant*leafConductance - fPart1 = dPart1*canopyWetFraction - dLatHeatCanopyEvap_dWetFrac = dPart1*(satVP_CanopyTemp - VP_CanopyAir) + fPart1*(-dVPCanopyAir_dWetFrac) - - ! latent heat associated with canopy transpiration w.r.t. wetted fraction of the canopy - dPart1 = LH_vap*latentHeatConstant*leafConductanceTr ! NOTE: positive, since (1 - wetFrac) - fPart1 = -dPart1*(1._rkind - canopyWetFraction) - dLatHeatCanopyTrans_dWetFrac = dPart1*(satVP_CanopyTemp - VP_CanopyAir) + fPart1*(-dVPCanopyAir_dWetFrac) - !print*, 'dLatHeatCanopyTrans_dWetFrac = ', dLatHeatCanopyTrans_dWetFrac - - ! latent heat associated with canopy transpiration w.r.t. canopy liquid water - dLatHeatCanopyTrans_dCanLiq = dLatHeatCanopyTrans_dWetFrac*dCanopyWetFraction_dWat ! (J s-1 kg-1) - !print*, 'dLatHeatCanopyTrans_dCanLiq = ', dLatHeatCanopyTrans_dCanLiq + if (computeVegFlux) then + ! compute derivatives of vapor pressure in the canopy air space w.r.t. all state variables + ! derivative of vapor pressure in the canopy air space w.r.t. temperature of the canopy air space + dPart1 = dCanopyCond_dCanairTemp*VPair + dGroundCondLH_dCanairTemp*satVP_GroundTemp*soilRelHumidity + dPart2 = -(dCanopyCond_dCanairTemp + dGroundCondLH_dCanairTemp)/(totalConductanceLH**2_i4b) + dVPCanopyAir_dTCanair = dPart1/totalConductanceLH + fPart_VP*dPart2 + ! derivative of vapor pressure in the canopy air space w.r.t. temperature of the canopy + dPart0 = (evapConductance + transConductance)*dSVPCanopy_dCanopyTemp + (dEvapCond_dCanopyTemp + dTransCond_dCanopyTemp)*satVP_CanopyTemp + dPart1 = dCanopyCond_dCanopyTemp*VPair + dPart0 + dGroundCondLH_dCanopyTemp*satVP_GroundTemp*soilRelHumidity + dPart2 = -(dCanopyCond_dCanopyTemp + dEvapCond_dCanopyTemp + dTransCond_dCanopyTemp + dGroundCondLH_dCanopyTemp)/(totalConductanceLH**2_i4b) + dVPCanopyAir_dTCanopy = dPart1/totalConductanceLH + fPart_VP*dPart2 + ! derivative of vapor pressure in the canopy air space w.r.t. temperature of the ground + dPart1 = dGroundCondLH_dGroundTemp*satVP_GroundTemp*soilRelHumidity + groundConductanceLH*dSVPGround_dGroundTemp*soilRelHumidity + dPart2 = -dGroundCondLH_dGroundTemp/(totalConductanceLH**2_i4b) + dVPCanopyAir_dTGround = dPart1/totalConductanceLH + fPart_VP*dPart2 + ! derivative of vapor pressure in the canopy air space w.r.t. wetted fraction of the canopy + dPart1 = (leafConductance - leafConductanceTr)*satVP_CanopyTemp + dPart2 = -(leafConductance - leafConductanceTr)/(totalConductanceLH**2_i4b) + dVPCanopyAir_dWetFrac = dPart1/totalConductanceLH + fPart_VP*dPart2 + dVPCanopyAir_dCanWat = dVPCanopyAir_dWetFrac*dCanopyWetFraction_dWat + + ! sensible heat from the canopy to the atmosphere + dSenHeatTotal_dTCanair = -volHeatCapacityAir*canopyConductance - volHeatCapacityAir*dCanopyCond_dCanairTemp*(canairTemp - airtemp) + dSenHeatTotal_dTCanopy = -volHeatCapacityAir*dCanopyCond_dCanopyTemp*(canairTemp - airtemp) + dSenHeatTotal_dTGround = 0._rkind + if (canairTemp<0._rkind) then ! cap function to prevent blowing up + dSenHeatTotal_dTCanair = volHeatCapacityAir*dCanopyCond_dCanairTemp*airtemp + dSenHeatTotal_dTCanopy = volHeatCapacityAir*dCanopyCond_dCanopyTemp*airtemp + end if + + ! sensible heat from the canopy to the canopy air space + dSenHeatCanopy_dTCanair = volHeatCapacityAir*leafConductance + dSenHeatCanopy_dTCanopy = -volHeatCapacityAir*leafConductance + dSenHeatCanopy_dTGround = 0._rkind + if (canopyTemp<0._rkind) then ! cap function to prevent blowing up + dSenHeatCanopy_dTCanopy = 0._rkind + if (canairTemp<0._rkind) dSenHeatCanopy_dTCanair = 0._rkind + else if (canairTemp<0._rkind) then + dSenHeatCanopy_dTCanair = 0._rkind + end if + + ! sensible heat from the ground to the canopy air space + dSenHeatGround_dTCanair = -volHeatCapacityAir*dGroundCondSH_dCanairTemp*(groundTemp - canairTemp) + volHeatCapacityAir*groundConductanceSH + dSenHeatGround_dTCanopy = -volHeatCapacityAir*dGroundCondSH_dCanopyTemp*(groundTemp - canairTemp) + dSenHeatGround_dTGround = -volHeatCapacityAir*dGroundCondSH_dGroundTemp*(groundTemp - canairTemp) - volHeatCapacityAir*groundConductanceSH + if (groundTemp<0._rkind) then ! cap function to prevent blowing up + dSenHeatGround_dTCanair = volHeatCapacityAir*dGroundCondSH_dCanairTemp*canairTemp + volHeatCapacityAir*groundConductanceSH + dSenHeatGround_dTCanopy = volHeatCapacityAir*dGroundCondSH_dCanopyTemp*canairTemp + dSenHeatGround_dTGround = volHeatCapacityAir*dGroundCondSH_dGroundTemp*canairTemp + if (canairTemp<0._rkind) then + dSenHeatGround_dTCanair = 0._rkind + dSenHeatGround_dTCanopy = 0._rkind + dSenHeatGround_dTGround = 0._rkind + endif + else if (canairTemp<0._rkind) then + dSenHeatGround_dTCanair = -volHeatCapacityAir*dGroundCondSH_dCanairTemp*groundTemp + dSenHeatGround_dTCanopy = -volHeatCapacityAir*dGroundCondSH_dCanopyTemp*groundTemp + dSenHeatGround_dTGround = -volHeatCapacityAir*dGroundCondSH_dGroundTemp*groundTemp - volHeatCapacityAir*groundConductanceSH + end if + ! latent heat associated with canopy evaporation + ! initial calculations + fPart1 = -latHeatSubVapCanopy*latentHeatConstant*evapConductance + dPart1 = -latHeatSubVapCanopy*latentHeatConstant*dEvapCond_dCanopyTemp + fPart2 = satVP_CanopyTemp - VP_CanopyAir + dPart2 = dSVPCanopy_dCanopyTemp - dVPCanopyAir_dTCanopy + ! derivatives + dLatHeatCanopyEvap_dTCanair = fPart1*(-dVPCanopyAir_dTCanair) + dLatHeatCanopyEvap_dTCanopy = fPart1*dpart2 + fPart2*dPart1 + dLatHeatCanopyEvap_dTGround = fPart1*(-dVPCanopyAir_dTGround) + + ! latent heat associated with canopy transpiration + ! initial calculations + fPart1 = -LH_vap*latentHeatConstant*transConductance + dPart1 = -LH_vap*latentHeatConstant*dTransCond_dCanopyTemp + ! derivatives + dLatHeatCanopyTrans_dTCanair = fPart1*(-dVPCanopyAir_dTCanair) + dLatHeatCanopyTrans_dTCanopy = fPart1*dPart2 + fPart2*dPart1 + dLatHeatCanopyTrans_dTGround = fPart1*(-dVPCanopyAir_dTGround) + + ! latent heat flux from the ground + fPart1 = -latHeatSubVapGround*latentHeatConstant*groundConductanceLH ! function of the first part + fPart2 = (satVP_GroundTemp*soilRelHumidity - VP_CanopyAir) ! function of the second part + dLatHeatGroundEvap_dTCanair = -latHeatSubVapGround*latentHeatConstant*dGroundCondLH_dCanairTemp*fPart2 - dVPCanopyAir_dTCanair*fPart1 + dLatHeatGroundEvap_dTCanopy = -latHeatSubVapGround*latentHeatConstant*dGroundCondLH_dCanopyTemp*fPart2 - dVPCanopyAir_dTCanopy*fPart1 + dLatHeatGroundEvap_dTGround = -latHeatSubVapGround*latentHeatConstant*dGroundCondLH_dGroundTemp*fPart2 + (dSVPGround_dGroundTemp*soilRelHumidity - dVPCanopyAir_dTGround)*fPart1 + + ! latent heat associated with canopy evaporation w.r.t. wetted fraction of the canopy + dPart1 = -latHeatSubVapCanopy*latentHeatConstant*leafConductance + fPart1 = dPart1*canopyWetFraction + dLatHeatCanopyEvap_dWetFrac = dPart1*(satVP_CanopyTemp - VP_CanopyAir) + fPart1*(-dVPCanopyAir_dWetFrac) + + ! latent heat associated with canopy transpiration w.r.t. wetted fraction of the canopy + dPart1 = LH_vap*latentHeatConstant*leafConductanceTr ! NOTE: positive, since (1 - wetFrac) + fPart1 = -dPart1*(1._rkind - canopyWetFraction) + dLatHeatCanopyTrans_dWetFrac = dPart1*(satVP_CanopyTemp - VP_CanopyAir) + fPart1*(-dVPCanopyAir_dWetFrac) + + ! latent heat associated with canopy transpiration w.r.t. canopy total water + dLatHeatCanopyTrans_dCanWat = dLatHeatCanopyTrans_dWetFrac*dCanopyWetFraction_dWat ! (J s-1 kg-1) else ! canopy is undefined + ! set derivatives for canopy fluxes to zero (no canopy, so fluxes are undefined) + dSenHeatTotal_dTCanair = 0._rkind + dSenHeatTotal_dTCanopy = 0._rkind + dSenHeatTotal_dTGround = 0._rkind + dSenHeatCanopy_dTCanair = 0._rkind + dSenHeatCanopy_dTCanopy = 0._rkind + dSenHeatCanopy_dTGround = 0._rkind + dLatHeatCanopyEvap_dTCanair = 0._rkind + dLatHeatCanopyEvap_dTCanopy = 0._rkind + dLatHeatCanopyEvap_dTGround = 0._rkind + dLatHeatCanopyTrans_dTCanair = 0._rkind + dLatHeatCanopyTrans_dTCanopy = 0._rkind + dLatHeatCanopyTrans_dTGround = 0._rkind + + ! set derivatives for wetted area and canopy transpiration to zero (no canopy, so fluxes are undefined) + dLatHeatCanopyEvap_dWetFrac = 0._rkind + dLatHeatCanopyEvap_dCanWat = 0._rkind + dLatHeatCanopyTrans_dCanWat = 0._rkind + dVPCanopyAir_dCanWat = 0._rkind + + ! set derivatives for ground fluxes w.r.t canopy temperature to zero (no canopy, so fluxes are undefined) + dSenHeatGround_dTCanair = 0._rkind + dSenHeatGround_dTCanopy = 0._rkind + dLatHeatGroundEvap_dTCanair = 0._rkind + dLatHeatGroundEvap_dTCanopy = 0._rkind + + ! compute derivatives for the ground fluxes w.r.t. ground temperature + dSenHeatGround_dTGround = (-volHeatCapacityAir*dGroundCondSH_dGroundTemp)*(groundTemp - airtemp) + & ! d(ground sensible heat flux)/d(ground temp) + (-volHeatCapacityAir*groundConductanceSH) + dLatHeatGroundEvap_dTGround = (-latHeatSubVapGround*latentHeatConstant*dGroundCondLH_dGroundTemp)*(satVP_GroundTemp*soilRelHumidity - VPair) + & ! d(ground latent heat flux)/d(ground temp) + (-latHeatSubVapGround*latentHeatConstant*groundConductanceLH)*dSVPGround_dGroundTemp*soilRelHumidity + end if ! end if canopy is defined - ! set derivatives for canopy fluxes to zero (no canopy, so fluxes are undefined) - dSenHeatTotal_dTCanair = 0._rkind - dSenHeatTotal_dTCanopy = 0._rkind - dSenHeatTotal_dTGround = 0._rkind - dSenHeatCanopy_dTCanair = 0._rkind - dSenHeatCanopy_dTCanopy = 0._rkind - dSenHeatCanopy_dTGround = 0._rkind - dLatHeatCanopyEvap_dTCanair = 0._rkind - dLatHeatCanopyEvap_dTCanopy = 0._rkind - dLatHeatCanopyEvap_dTGround = 0._rkind - dLatHeatCanopyTrans_dTCanair = 0._rkind - dLatHeatCanopyTrans_dTCanopy = 0._rkind - dLatHeatCanopyTrans_dTGround = 0._rkind - - ! set derivatives for wetted area and canopy transpiration to zero (no canopy, so fluxes are undefined) - dLatHeatCanopyEvap_dWetFrac = 0._rkind - dLatHeatCanopyEvap_dCanLiq = 0._rkind - dLatHeatCanopyTrans_dCanLiq = 0._rkind - dVPCanopyAir_dCanLiq = 0._rkind - - ! set derivatives for ground fluxes w.r.t canopy temperature to zero (no canopy, so fluxes are undefined) - dSenHeatGround_dTCanair = 0._rkind - dSenHeatGround_dTCanopy = 0._rkind - dLatHeatGroundEvap_dTCanair = 0._rkind - dLatHeatGroundEvap_dTCanopy = 0._rkind - - ! compute derivatives for the ground fluxes w.r.t. ground temperature - dSenHeatGround_dTGround = (-volHeatCapacityAir*dGroundCondSH_dGroundTemp)*(groundTemp - airtemp) + & ! d(ground sensible heat flux)/d(ground temp) - (-volHeatCapacityAir*groundConductanceSH) - dLatHeatGroundEvap_dTGround = (-latHeatSubVapGround*latentHeatConstant*dGroundCondLH_dGroundTemp)*(satVP_GroundTemp*soilRelHumidity - VPair) + & ! d(ground latent heat flux)/d(ground temp) - (-latHeatSubVapGround*latentHeatConstant*groundConductanceLH)*dSVPGround_dGroundTemp*soilRelHumidity - - !print*, 'dGroundCondLH_dGroundTemp = ', dGroundCondLH_dGroundTemp - - end if ! (if canopy is defined) - - end if ! (if computing analytical derivatives) - - - ! ***** - ! * compute net turbulent fluxes, and derivatives... - ! ************************************************** - - ! compute net fluxes - turbFluxCanair = senHeatTotal - senHeatCanopy - senHeatGround ! net turbulent flux at the canopy air space (W m-2) - turbFluxCanopy = senHeatCanopy + latHeatCanopyEvap + latHeatCanopyTrans ! net turbulent flux at the canopy (W m-2) - turbFluxGround = senHeatGround + latHeatGround ! net turbulent flux at the ground surface (W m-2) - !write(*,'(a,1x,3(f20.10,1x))') 'senHeatCanopy, latHeatCanopyEvap, latHeatCanopyTrans = ', senHeatCanopy, latHeatCanopyEvap, latHeatCanopyTrans + ! ***** + ! * compute net turbulent fluxes, and derivatives... + ! ************************************************** + + ! compute net fluxes + turbFluxCanair = senHeatTotal - senHeatCanopy - senHeatGround ! net turbulent flux at the canopy air space (W m-2) + turbFluxCanopy = senHeatCanopy + latHeatCanopyEvap + latHeatCanopyTrans ! net turbulent flux at the canopy (W m-2) + turbFluxGround = senHeatGround + latHeatGround ! net turbulent flux at the ground surface (W m-2) ! * compute derivatives - if(ixDerivMethod == analytical)then - ! (energy derivatives) + ! energy derivatives dTurbFluxCanair_dTCanair = dSenHeatTotal_dTCanair - dSenHeatCanopy_dTCanair - dSenHeatGround_dTCanair ! derivative in net canopy air space fluxes w.r.t. canopy air temperature (W m-2 K-1) dTurbFluxCanair_dTCanopy = dSenHeatTotal_dTCanopy - dSenHeatCanopy_dTCanopy - dSenHeatGround_dTCanopy ! derivative in net canopy air space fluxes w.r.t. canopy temperature (W m-2 K-1) dTurbFluxCanair_dTGround = dSenHeatTotal_dTGround - dSenHeatCanopy_dTGround - dSenHeatGround_dTGround ! derivative in net canopy air space fluxes w.r.t. ground temperature (W m-2 K-1) @@ -3065,224 +2401,182 @@ subroutine turbFluxes(& dTurbFluxGround_dTCanair = dSenHeatGround_dTCanair + dLatHeatGroundEvap_dTCanair ! derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) dTurbFluxGround_dTCanopy = dSenHeatGround_dTCanopy + dLatHeatGroundEvap_dTCanopy ! derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) dTurbFluxGround_dTGround = dSenHeatGround_dTGround + dLatHeatGroundEvap_dTGround ! derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) - ! (liquid water derivatives) - dLatHeatCanopyEvap_dCanLiq = dLatHeatCanopyEvap_dWetFrac*dCanopyWetFraction_dWat ! derivative in latent heat of canopy evaporation w.r.t. canopy liquid water (W kg-1) - dLatHeatGroundEvap_dCanLiq = latHeatSubVapGround*latentHeatConstant*groundConductanceLH*dVPCanopyAir_dCanLiq ! derivative in latent heat of ground evaporation w.r.t. canopy liquid water (J kg-1 s-1) - ! (cross deriavtives) - dTurbFluxCanair_dCanLiq = 0._rkind ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - dTurbFluxCanopy_dCanLiq = dLatHeatCanopyEvap_dCanLiq + dLatHeatCanopyTrans_dCanLiq ! derivative in net canopy turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - dTurbFluxGround_dCanLiq = dLatHeatGroundEvap_dCanLiq ! derivative in net ground turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - else ! (just make sure we return something) - ! (energy derivatives) - dTurbFluxCanair_dTCanair = 0._rkind - dTurbFluxCanair_dTCanopy = 0._rkind - dTurbFluxCanair_dTGround = 0._rkind - dTurbFluxCanopy_dTCanair = 0._rkind - dTurbFluxCanopy_dTCanopy = 0._rkind - dTurbFluxCanopy_dTGround = 0._rkind - dTurbFluxGround_dTCanair = 0._rkind - dTurbFluxGround_dTCanopy = 0._rkind - dTurbFluxGround_dTGround = 0._rkind - ! (liquid water derivatives) - dLatHeatCanopyEvap_dCanLiq = 0._rkind - dLatHeatGroundEvap_dCanLiq = 0._rkind - ! (cross deriavtives) - dTurbFluxCanair_dCanLiq = 0._rkind - dTurbFluxCanopy_dCanLiq = 0._rkind - dTurbFluxGround_dCanLiq = 0._rkind - end if - - end subroutine turbFluxes - - - ! ******************************************************************************************************* - ! private subroutine aStability: compute stability corrections for turbulent heat fluxes (-) - ! ******************************************************************************************************* - subroutine aStability(& - ! input: control - computeDerivative, & ! input: logical flag to compute analytical derivatives - ixStability, & ! input: choice of stability function - ! input: forcing data, diagnostic and state variables - mHeight, & ! input: measurement height (m) - airTemp, & ! input: air temperature (K) - sfcTemp, & ! input: surface temperature (K) - windspd, & ! input: wind speed (m s-1) - ! input: stability parameters - critRichNumber, & ! input: critical value for the bulk Richardson number where turbulence ceases (-) - Louis79_bparam, & ! input: parameter in Louis (1979) stability function - Mahrt87_eScale, & ! input: exponential scaling factor in the Mahrt (1987) stability function - ! output - RiBulk, & ! output: bulk Richardson number (-) - stabilityCorrection, & ! output: stability correction for turbulent heat fluxes (-) - dStabilityCorrection_dRich, & ! output: derivative in stability correction w.r.t. Richardson number (-) - dStabilityCorrection_dAirTemp, & ! output: derivative in stability correction w.r.t. temperature (K-1) - dStabilityCorrection_dSfcTemp, & ! output: derivative in stability correction w.r.t. temperature (K-1) - err, message ) ! output: error control - implicit none - ! input: control - logical(lgt),intent(in) :: computeDerivative ! flag to compute the derivative - integer(i4b),intent(in) :: ixStability ! choice of stability function - ! input: forcing data, diagnostic and state variables - real(rkind),intent(in) :: mHeight ! measurement height (m) - real(rkind),intent(in) :: airtemp ! air temperature (K) - real(rkind),intent(in) :: sfcTemp ! surface temperature (K) - real(rkind),intent(in) :: windspd ! wind speed (m s-1) - ! input: stability parameters - real(rkind),intent(in) :: critRichNumber ! critical value for the bulk Richardson number where turbulence ceases (-) - real(rkind),intent(in) :: Louis79_bparam ! parameter in Louis (1979) stability function - real(rkind),intent(in) :: Mahrt87_eScale ! exponential scaling factor in the Mahrt (1987) stability function - ! output - real(rkind),intent(out) :: RiBulk ! bulk Richardson number (-) - real(rkind),intent(out) :: stabilityCorrection ! stability correction for turbulent heat fluxes (-) - real(rkind),intent(out) :: dStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number (-) - real(rkind),intent(out) :: dStabilityCorrection_dAirTemp ! derivative in stability correction w.r.t. air temperature (K-1) - real(rkind),intent(out) :: dStabilityCorrection_dSfcTemp ! derivative in stability correction w.r.t. surface temperature (K-1) - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! local - real(rkind), parameter :: verySmall=1.e-10_rkind ! a very small number (avoid stability of zero) - real(rkind) :: dRiBulk_dAirTemp ! derivative in the bulk Richardson number w.r.t. air temperature (K-1) - real(rkind) :: dRiBulk_dSfcTemp ! derivative in the bulk Richardson number w.r.t. surface temperature (K-1) - real(rkind) :: bPrime ! scaled "b" parameter for stability calculations in Louis (1979) - ! ----------------------------------------------------------------------------------------------------------------------------------------- - ! initialize error control - err=0; message='aStability/' - - ! compute the bulk Richardson number (-) - call bulkRichardson(& - ! input - airTemp, & ! input: air temperature (K) - sfcTemp, & ! input: surface temperature (K) - windspd, & ! input: wind speed (m s-1) - mHeight, & ! input: measurement height (m) - computeDerivative, & ! input: flag to compute the derivative - ! output - RiBulk, & ! output: bulk Richardson number (-) - dRiBulk_dAirTemp, & ! output: derivative in the bulk Richardson number w.r.t. air temperature (K-1) - dRiBulk_dSfcTemp, & ! output: derivative in the bulk Richardson number w.r.t. surface temperature (K-1) - err,message) ! output: error control - - ! set derivative to one if not computing it - if(.not.computeDerivative)then - dStabilityCorrection_dRich = 1._rkind - dStabilityCorrection_dAirTemp = 1._rkind - dStabilityCorrection_dSfcTemp = 1._rkind - end if - - ! ***** process unstable cases - if(RiBulk<0._rkind)then - ! compute surface-atmosphere exchange coefficient (-) - stabilityCorrection = (1._rkind - 16._rkind*RiBulk)**0.5_rkind - ! compute derivative in surface-atmosphere exchange coefficient w.r.t. temperature (K-1) - if(computeDerivative)then - dStabilityCorrection_dRich = (-16._rkind) * 0.5_rkind*(1._rkind - 16._rkind*RiBulk)**(-0.5_rkind) - dStabilityCorrection_dAirTemp = dRiBulk_dAirTemp * dStabilityCorrection_dRich - dStabilityCorrection_dSfcTemp = dRiBulk_dSfcTemp * dStabilityCorrection_dRich + ! liquid water derivatives + dLatHeatCanopyEvap_dCanWat = dLatHeatCanopyEvap_dWetFrac*dCanopyWetFraction_dWat ! derivative in latent heat of canopy evaporation w.r.t. canopy total water (W kg-1) + dLatHeatGroundEvap_dCanWat = latHeatSubVapGround*latentHeatConstant*groundConductanceLH*dVPCanopyAir_dCanWat ! derivative in latent heat of ground evaporation w.r.t. canopy total water (J kg-1 s-1) + ! cross derivatives + dTurbFluxCanair_dCanWat = 0._rkind ! derivative in net canopy air space fluxes w.r.t. canopy total water content (J kg-1 s-1) + dTurbFluxCanopy_dCanWat = dLatHeatCanopyEvap_dCanWat + dLatHeatCanopyTrans_dCanWat ! derivative in net canopy turbulent fluxes w.r.t. canopy total water content (J kg-1 s-1) + dTurbFluxGround_dCanWat = dLatHeatGroundEvap_dCanWat ! derivative in net ground turbulent fluxes w.r.t. canopy total water content (J kg-1 s-1) + +end subroutine turbFluxes + +! ******************************************************************************************************* +! private subroutine aStability: compute stability corrections for turbulent heat fluxes (-) +! ******************************************************************************************************* +subroutine aStability(& + ! input: control + ixStability, & ! input: choice of stability function + ! input: forcing data, diagnostic and state variables + hgt_diff, & ! input: height difference from air to surface (m) + airTemp, & ! input: air temperature (K) + sfcTemp, & ! input: surface temperature (K) + windspd_diff, & ! input: wind speed difference air to surface (m s-1) + ! input: stability parameters + critRichNumber, & ! input: critical value for the bulk Richardson number where turbulence ceases (-) + Louis79_bparam, & ! input: parameter in Louis (1979) stability function + Mahrt87_eScale, & ! input: exponential scaling factor in the Mahrt (1987) stability function + ! output + RiBulk, & ! output: bulk Richardson number (-) + stabilityCorrection, & ! output: stability correction for turbulent heat fluxes (-) + dStabilityCorrection_dRich, & ! output: derivative in stability correction w.r.t. Richardson number (-) + dStabilityCorrection_dAirTemp, & ! output: derivative in stability correction w.r.t. temperature (K-1) + dStabilityCorrection_dSfcTemp, & ! output: derivative in stability correction w.r.t. temperature (K-1) + err, message ) ! output: error control + implicit none + ! input: control + integer(i4b),intent(in) :: ixStability ! choice of stability function + ! input: forcing data, diagnostic and state variables + real(rkind),intent(in) :: hgt_diff ! height difference from air to surface (m) + real(rkind),intent(in) :: airtemp ! air temperature (K) + real(rkind),intent(in) :: sfcTemp ! surface temperature (K) + real(rkind),intent(in) :: windspd_diff ! wind speed difference air to surface (m s-1) + ! input: stability parameters + real(rkind),intent(in) :: critRichNumber ! critical value for the bulk Richardson number where turbulence ceases (-) + real(rkind),intent(in) :: Louis79_bparam ! parameter in Louis (1979) stability function + real(rkind),intent(in) :: Mahrt87_eScale ! exponential scaling factor in the Mahrt (1987) stability function + ! output + real(rkind),intent(out) :: RiBulk ! bulk Richardson number (-) + real(rkind),intent(out) :: stabilityCorrection ! stability correction for turbulent heat fluxes (-) + real(rkind),intent(out) :: dStabilityCorrection_dRich ! derivative in stability correction w.r.t. Richardson number (-) + real(rkind),intent(out) :: dStabilityCorrection_dAirTemp ! derivative in stability correction w.r.t. air temperature (K-1) + real(rkind),intent(out) :: dStabilityCorrection_dSfcTemp ! derivative in stability correction w.r.t. surface temperature (K-1) + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! local + real(rkind), parameter :: stabilityTol=1.e-10_rkind ! tolerance for stability correction (to avoid division by zero) + real(rkind) :: dRiBulk_dAirTemp ! derivative in the bulk Richardson number w.r.t. air temperature (K-1) + real(rkind) :: dRiBulk_dSfcTemp ! derivative in the bulk Richardson number w.r.t. surface temperature (K-1) + real(rkind) :: bPrime ! scaled "b" parameter for stability calculations in Louis (1979) + ! ----------------------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message='aStability/' + + ! compute the bulk Richardson number (-) + call bulkRichardson(& + ! input + airTemp, & ! input: air temperature (K) + sfcTemp, & ! input: surface temperature (K) + windspd_diff, & ! input: wind speed difference air to surface (m s-1) + hgt_diff, & ! input: height difference from air to surface (m) + ! output + RiBulk, & ! output: bulk Richardson number (-) + dRiBulk_dAirTemp, & ! output: derivative in the bulk Richardson number w.r.t. air temperature (K-1) + dRiBulk_dSfcTemp, & ! output: derivative in the bulk Richardson number w.r.t. surface temperature (K-1) + err,message) ! output: error control + + ! compute surface-atmosphere exchange coefficient (-) and its derivatives + ! ***** process unstable cases, Anderson 1976 and Oke 1978 + if (RiBulk<0._rkind) then + stabilityCorrection = (1._rkind - 16._rkind*RiBulk)**(0.75_rkind) + dStabilityCorrection_dRich = -12._rkind*(1._rkind - 16._rkind*RiBulk)**(-0.25_rkind) + dStabilityCorrection_dAirTemp = dRiBulk_dAirTemp * dStabilityCorrection_dRich + dStabilityCorrection_dSfcTemp = dRiBulk_dSfcTemp * dStabilityCorrection_dRich + return end if - return - end if - - ! ***** process stable cases - select case(ixStability) - - ! ("standard" stability correction, a la Anderson 1976) - case(standard) - ! compute surface-atmosphere exchange coefficient (-) - if(RiBulk < critRichNumber) stabilityCorrection = (1._rkind - 5._rkind*RiBulk)**2._rkind - if(RiBulk >= critRichNumber) stabilityCorrection = verySmall - ! compute derivative in surface-atmosphere exchange coefficient w.r.t. temperature (K-1) - if(computeDerivative)then - if(RiBulk < critRichNumber) dStabilityCorrection_dRich = (-5._rkind) * 2._rkind*(1._rkind - 5._rkind*RiBulk) - if(RiBulk >= critRichNumber) dStabilityCorrection_dRich = verySmall - end if - - ! (Louis 1979) - case(louisInversePower) - ! scale the "b" parameter for stable conditions - bprime = Louis79_bparam/2._rkind - ! compute surface-atmosphere exchange coefficient (-) - stabilityCorrection = 1._rkind / ( (1._rkind + bprime*RiBulk)**2._rkind ) - if(stabilityCorrection < epsilon(stabilityCorrection)) stabilityCorrection = epsilon(stabilityCorrection) - ! compute derivative in surface-atmosphere exchange coefficient w.r.t. temperature (K-1) - if(computeDerivative)then - dStabilityCorrection_dRich = bprime * (-2._rkind)*(1._rkind + bprime*RiBulk)**(-3._rkind) - end if - - ! (Mahrt 1987) - case(mahrtExponential) - ! compute surface-atmosphere exchange coefficient (-) - stabilityCorrection = exp(-Mahrt87_eScale * RiBulk) - if(stabilityCorrection < epsilon(stabilityCorrection)) stabilityCorrection = epsilon(stabilityCorrection) - ! compute derivative in surface-atmosphere exchange coefficient w.r.t. temperature (K-1) - if(computeDerivative)then - dStabilityCorrection_dRich = (-Mahrt87_eScale) * exp(-Mahrt87_eScale * RiBulk) - end if - - ! (return error if the stability correction method is not found) - case default - err=10; message=trim(message)//"optionNotFound[stability correction]"; return - - end select - - ! get the stability correction with respect to air temperature and surface temperature - ! NOTE: air temperature is used for canopy air temperature, which is a model state variable - if(computeDerivative)then - dStabilityCorrection_dAirTemp = dRiBulk_dAirTemp * dStabilityCorrection_dRich - dStabilityCorrection_dSfcTemp = dRiBulk_dSfcTemp * dStabilityCorrection_dRich - end if - end subroutine aStability + ! ***** process stable cases + select case(ixStability) + ! "standard" stability correction, Anderson 1976 and Oke 1978 + case(standard) + if(RiBulk < critRichNumber)then + stabilityCorrection = (1._rkind - 5._rkind*RiBulk)**2_i4b + dStabilityCorrection_dRich = -10._rkind*(1._rkind - 5._rkind*RiBulk) + else + stabilityCorrection = stabilityTol + dStabilityCorrection_dRich = 0._rkind + end if + ! Louis 1979 + case(louisInversePower) + bprime = Louis79_bparam/2._rkind ! scale the "b" parameter for stable conditions + stabilityCorrection = (1._rkind + bprime*RiBulk)**(-2_i4b) + if(stabilityCorrection >= epsilon(stabilityCorrection))then + dStabilityCorrection_dRich = -2._rkind*bprime*(1._rkind + bprime*RiBulk)**(-3_i4b) + else + stabilityCorrection = epsilon(stabilityCorrection) + dStabilityCorrection_dRich = 0._rkind + end if - ! ******************************************************************************************************* - ! private subroutine bulkRichardson: compute bulk Richardson number - ! ******************************************************************************************************* - subroutine bulkRichardson(& - ! input - airTemp, & ! input: air temperature (K) - sfcTemp, & ! input: surface temperature (K) - windspd, & ! input: wind speed (m s-1) - mHeight, & ! input: measurement height (m) - computeDerivative, & ! input: flag to compute the derivative + ! Mahrt 1987 + case(mahrtExponential) + stabilityCorrection = exp(-Mahrt87_eScale*RiBulk) + if(stabilityCorrection >= epsilon(stabilityCorrection))then + dStabilityCorrection_dRich = -Mahrt87_eScale * exp(-Mahrt87_eScale*RiBulk) + else + stabilityCorrection = epsilon(stabilityCorrection) + dStabilityCorrection_dRich = 0._rkind + end if + + case default + err=10; message=trim(message)//"optionNotFound[stability correction]"; return + end select + dStabilityCorrection_dAirTemp = dRiBulk_dAirTemp * dStabilityCorrection_dRich + dStabilityCorrection_dSfcTemp = dRiBulk_dSfcTemp * dStabilityCorrection_dRich + +end subroutine aStability + +! ******************************************************************************************************* +! private subroutine bulkRichardson: compute bulk Richardson number +! ******************************************************************************************************* +subroutine bulkRichardson(& + ! input + airTemp, & ! input: air temperature (K) + sfcTemp, & ! input: surface temperature (K) + windspd_diff, & ! input: wind speed difference air to surface (m s-1) + hgt_diff, & ! input: height difference from air to surface (m) ! output - RiBulk, & ! output: bulk Richardson number (-) - dRiBulk_dAirTemp, & ! output: derivative in the bulk Richardson number w.r.t. air temperature (K-1) - dRiBulk_dSfcTemp, & ! output: derivative in the bulk Richardson number w.r.t. surface temperature (K-1) - err,message) ! output: error control - implicit none - ! input - real(rkind),intent(in) :: airtemp ! air temperature (K) - real(rkind),intent(in) :: sfcTemp ! surface temperature (K) - real(rkind),intent(in) :: windspd ! wind speed (m s-1) - real(rkind),intent(in) :: mHeight ! measurement height (m) - logical(lgt),intent(in) :: computeDerivative ! flag to compute the derivative - ! output - real(rkind),intent(inout) :: RiBulk ! bulk Richardson number (-) - real(rkind),intent(out) :: dRiBulk_dAirTemp ! derivative in the bulk Richardson number w.r.t. air temperature (K-1) - real(rkind),intent(out) :: dRiBulk_dSfcTemp ! derivative in the bulk Richardson number w.r.t. surface temperature (K-1) - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! local variables - real(rkind) :: T_grad ! gradient in temperature between the atmosphere and surface (K) - real(rkind) :: T_mean ! mean of the atmosphere and surface temperature (K) - real(rkind) :: RiMult ! dimensionless scaling factor (-) - ! initialize error control - err=0; message='bulkRichardson/' - ! compute local variables - T_grad = airtemp - sfcTemp - T_mean = 0.5_rkind*(airtemp + sfcTemp) - RiMult = (gravity*mHeight)/(windspd*windspd) - ! compute the Richardson number - RiBulk = (T_grad/T_mean) * RiMult - ! compute the derivative in the Richardson number - if(computeDerivative)then - dRiBulk_dAirTemp = RiMult/T_mean - RiMult*T_grad/(0.5_rkind*((airtemp + sfcTemp)**2._rkind)) - dRiBulk_dSfcTemp = -RiMult/T_mean - RiMult*T_grad/(0.5_rkind*((airtemp + sfcTemp)**2._rkind)) - else - dRiBulk_dAirTemp = 1._rkind - dRiBulk_dSfcTemp = 1._rkind - end if - end subroutine bulkRichardson + RiBulk, & ! output: bulk Richardson number (-) + dRiBulk_dAirTemp, & ! output: derivative in the bulk Richardson number w.r.t. air temperature (K-1) + dRiBulk_dSfcTemp, & ! output: derivative in the bulk Richardson number w.r.t. surface temperature (K-1) + err,message) ! output: error control +implicit none +! input +real(rkind),intent(in) :: airtemp ! air temperature (K) +real(rkind),intent(in) :: sfcTemp ! surface temperature (K) +real(rkind),intent(in) :: windspd_diff ! wind speed difference air to surface (m s-1) +real(rkind),intent(in) :: hgt_diff ! height difference from air to surface (m) +! output +real(rkind),intent(inout) :: RiBulk ! bulk Richardson number (-) +real(rkind),intent(out) :: dRiBulk_dAirTemp ! derivative in the bulk Richardson number w.r.t. air temperature (K-1) +real(rkind),intent(out) :: dRiBulk_dSfcTemp ! derivative in the bulk Richardson number w.r.t. surface temperature (K-1) +integer(i4b),intent(out) :: err ! error code +character(*),intent(out) :: message ! error message +! local variables +real(rkind) :: T_grad ! gradient in temperature between the atmosphere and surface (K) +real(rkind) :: T_mean ! mean of the atmosphere and surface temperature (K) +real(rkind) :: RiMult ! dimensionless scaling factor (-) + ! initialize error control + err=0; message='bulkRichardson/' + ! compute local variables + T_grad = airtemp - sfcTemp + T_mean = 0.5_rkind*(airtemp + sfcTemp) + if (sfcTemp < 0._rkind) then ! cap function to prevent blowing up + T_grad = airtemp + T_mean = 0.5_rkind*airtemp + endif + RiMult = gravity*hgt_diff / windspd_diff**2_i4b + ! compute the Richardson number + RiBulk = (T_grad/T_mean) * RiMult + ! compute the derivative in the Richardson number + dRiBulk_dAirTemp = RiMult/T_mean - RiMult*T_grad / (0.5_rkind*((airtemp + sfcTemp)**2_i4b)) + dRiBulk_dSfcTemp = -RiMult/T_mean - RiMult*T_grad / (0.5_rkind*((airtemp + sfcTemp)**2_i4b)) + ! cap function to prevent blowing up + if (sfcTemp < 0._rkind) then + dRiBulk_dAirTemp = 0._rkind + dRiBulk_dSfcTemp = 0._rkind + endif +end subroutine bulkRichardson end module vegNrgFlux_module diff --git a/build/source/engine/vegPhenlgy.f90 b/build/source/engine/vegPhenlgy.f90 old mode 100755 new mode 100644 index 194463a78..5a187c075 --- a/build/source/engine/vegPhenlgy.f90 +++ b/build/source/engine/vegPhenlgy.f90 @@ -24,15 +24,17 @@ module vegPhenlgy_module USE nrtype ! global variables -USE globalData,only:urbanVegCategory ! vegetation category for urban areas -USE globalData,only:fracJulday ! fractional julian days since the start of year -USE globalData,only:yearLength ! number of days in the current year +USE globalData,only:& + realMissing, & ! missing value for real numbers + urbanVegCategory, & ! vegetation category for urban areas + minExpLogHgtFac ! factor for minimum height of transition from the exponential to the logarithmic wind profile + ! provide access to the derived types to define the data structures USE data_types,only:& var_i, & ! data vector (i4b) - var_d, & ! data vector (dp) - var_dlength, & ! data vector with variable length dimension (dp) + var_d, & ! data vector (rkind) + var_dlength, & ! data vector with variable length dimension (rkind) model_options ! defines the model decisions ! named variables defining elements in the data structures @@ -57,9 +59,6 @@ module vegPhenlgy_module implicit none private public::vegPhenlgy -! algorithmic parameters -real(rkind),parameter :: valueMissing=-9999._rkind ! missing value, used when diagnostic or state variables are undefined -real(rkind),parameter :: verySmall=1.e-6_rkind ! used as an additive constant to check if substantial difference among real numbers contains @@ -67,75 +66,88 @@ module vegPhenlgy_module ! public subroutine vegPhenlgy: compute vegetation phenology ! ************************************************************************************************ subroutine vegPhenlgy(& - ! input/output: data structures + ! model control + nSnow, & ! intent(in): number of snow layers model_decisions, & ! intent(in): model decisions + fracJulDay, & ! intent(in): fractional julian days since the start of year + yearLength, & ! intent(in): number of days in the current year + ! input/output: data structures type_data, & ! intent(in): type of vegetation and soil attr_data, & ! intent(in): spatial attributes mpar_data, & ! intent(in): model parameters - prog_data, & ! intent(in): prognostic variables for a local HRU + prog_data, & ! intent(inout): prognostic variables for a local HRU diag_data, & ! intent(inout): diagnostic variables for a local HRU ! output computeVegFlux, & ! intent(out): flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) canopyDepth, & ! intent(out): canopy depth (m) exposedVAI, & ! intent(out): exposed vegetation area index (LAI + SAI) err,message) ! intent(out): error control + ! ------------------------------------------------------------------------------------------------- ! modules USE NOAHMP_ROUTINES,only:phenology ! determine vegetation phenology implicit none ! ------------------------------------------------------------------------------------------------- ! input/output + integer(i4b),intent(in) :: nSnow ! number of snow layers type(model_options),intent(in) :: model_decisions(:) ! model decisions + real(rkind),intent(in) :: fracJulDay ! fractional julian days since the start of year + integer(i4b),intent(in) :: yearLength ! number of days in the current year type(var_i),intent(in) :: type_data ! type of vegetation and soil type(var_d),intent(in) :: attr_data ! spatial attributes type(var_dlength),intent(in) :: mpar_data ! model parameters - type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU + type(var_dlength),intent(inout) :: prog_data ! prognostic variables for a local HRU type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU ! output logical(lgt),intent(out) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) - real(rkind),intent(out) :: canopyDepth ! canopy depth (m) - real(rkind),intent(out) :: exposedVAI ! exposed vegetation area index (LAI + SAI) + real(rkind),intent(out) :: canopyDepth ! canopy depth (m) + real(rkind),intent(out) :: exposedVAI ! exposed vegetation area index (LAI + SAI) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ------------------------------------------------------------------------------------------------- ! local - real(rkind) :: notUsed_heightCanopyTop ! height of the top of the canopy layer (m) - real(rkind) :: heightAboveSnow ! height top of canopy is above the snow surface (m) + real(rkind) :: z0Ground ! roughness length of the ground (ground below the canopy or non-vegetated surface) (m) + real(rkind) :: notUsed_heightCanopyTop ! height of the top of the canopy layer (m) + real(rkind) :: heightAboveSnow ! height top of canopy is above the snow surface (m) + real(rkind) :: minExpLogHgt ! minimum height above ground for logarithmic wind profile (m) + ! initialize error control err=0; message="vegPhenlgy/" ! ---------------------------------------------------------------------------------------------------------------------------------- ! associate variables in the data structure associate(& - ! input: model decisions ix_bcUpprTdyn => model_decisions(iLookDECISIONS%bcUpprTdyn)%iDecision, & ! intent(in): [i4b] choice of upper boundary condition for thermodynamics ix_bcUpprSoiH => model_decisions(iLookDECISIONS%bcUpprSoiH)%iDecision, & ! intent(in): [i4b] index of method used for the upper boundary condition for soil hydrology - ! local attributes vegTypeIndex => type_data%var(iLookTYPE%vegTypeIndex), & ! intent(in): [i4b] vegetation type index latitude => attr_data%var(iLookATTR%latitude), & ! intent(in): [dp] latitude - ! model state variables scalarSnowDepth => prog_data%var(iLookPROG%scalarSnowDepth)%dat(1), & ! intent(in): [dp] snow depth on the ground surface (m) scalarCanopyTemp => prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1), & ! intent(in): [dp] temperature of the vegetation canopy at the start of the sub-step (K) - + scalarCanopyLiq => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1), & ! intent(inout): [dp] liquid water in the vegetation canopy at the start of the sub-step ! diagnostic variables and parameters (input) - heightCanopyTop => mpar_data%var(iLookPARAM%heightCanopyTop)%dat(1), & ! intent(in): [dp] height of the top of the canopy layer (m) - heightCanopyBottom => mpar_data%var(iLookPARAM%heightCanopyBottom)%dat(1), & ! intent(in): [dp] height of the bottom of the canopy layer (m) - scalarRootZoneTemp => diag_data%var(iLookDIAG%scalarRootZoneTemp)%dat(1), & ! intent(in): [dp] root zone temperature (K) - + z0Snow => mpar_data%var(iLookPARAM%z0Snow)%dat(1), & ! intent(in): [dp] roughness length of snow (m) + z0Soil => mpar_data%var(iLookPARAM%z0Soil)%dat(1), & ! intent(in): [dp] roughness length of soil (m) + heightCanopyTop => mpar_data%var(iLookPARAM%heightCanopyTop)%dat(1), & ! intent(in): [dp] height of the top of the canopy layer (m) + heightCanopyBottom => mpar_data%var(iLookPARAM%heightCanopyBottom)%dat(1), & ! intent(in): [dp] height of the bottom of the canopy layer (m) ! diagnostic variables and parameters (input/output) scalarLAI => diag_data%var(iLookDIAG%scalarLAI)%dat(1), & ! intent(inout): [dp] one-sided leaf area index (m2 m-2) scalarSAI => diag_data%var(iLookDIAG%scalarSAI)%dat(1), & ! intent(inout): [dp] one-sided stem area index (m2 m-2) - ! diagnostic variables and parameters (output) scalarExposedLAI => diag_data%var(iLookDIAG%scalarExposedLAI)%dat(1), & ! intent(out): [dp] exposed leaf area index after burial by snow (m2 m-2) scalarExposedSAI => diag_data%var(iLookDIAG%scalarExposedSAI)%dat(1), & ! intent(out): [dp] exposed stem area index after burial by snow (m2 m-2) - scalarGrowingSeasonIndex => diag_data%var(iLookDIAG%scalarGrowingSeasonIndex)%dat(1) & ! intent(out): [dp] growing season index (0=off, 1=on) + scalarGrowingSeasonIndex => diag_data%var(iLookDIAG%scalarGrowingSeasonIndex)%dat(1), & ! intent(out): [dp] growing season index (0=off, 1=on) + scalarGroundSnowFraction => diag_data%var(iLookDIAG%scalarGroundSnowFraction)%dat(1) & ! intent(out): [dp] fraction of ground covered with snow (-) ) ! associate variables in data structure ! ---------------------------------------------------------------------------------------------------------------------------------- - + if (nSnow > 0) then ! case when there is snow on the ground (EXCLUDE "snow without a layer" -- in this case, evaporate from the soil) + scalarGroundSnowFraction = 1._rkind + else ! case when the ground is less than a layer of snow (e.g., bare soil or snow without a layer) + scalarGroundSnowFraction = 0._rkind + end if ! (there is snow enough for a layer on the ground) + ! check if we have isolated the snow-soil domain (used in test cases) if(ix_bcUpprTdyn == prescribedTemp .or. ix_bcUpprTdyn == zeroFlux .or. ix_bcUpprSoiH == prescribedHead)then @@ -143,14 +155,14 @@ subroutine vegPhenlgy(& computeVegFlux = .false. ! set vegetation phenology variables to missing - scalarLAI = valueMissing ! one-sided leaf area index (m2 m-2) - scalarSAI = valueMissing ! one-sided stem area index (m2 m-2) - scalarExposedLAI = valueMissing ! exposed leaf area index after burial by snow (m2 m-2) - scalarExposedSAI = valueMissing ! exposed stem area index after burial by snow (m2 m-2) - scalarGrowingSeasonIndex = valueMissing ! growing season index (0=off, 1=on) - exposedVAI = valueMissing ! exposed vegetation area index (m2 m-2) - canopyDepth = valueMissing ! canopy depth (m) - heightAboveSnow = valueMissing ! height top of canopy is above the snow surface (m) + scalarLAI = realMissing ! one-sided leaf area index (m2 m-2) + scalarSAI = realMissing ! one-sided stem area index (m2 m-2) + scalarExposedLAI = realMissing ! exposed leaf area index after burial by snow (m2 m-2) + scalarExposedSAI = realMissing ! exposed stem area index after burial by snow (m2 m-2) + scalarGrowingSeasonIndex = realMissing ! growing season index (0=off, 1=on) + exposedVAI = realMissing ! exposed vegetation area index (m2 m-2) + canopyDepth = realMissing ! canopy depth (m) + heightAboveSnow = realMissing ! height top of canopy is above the snow surface (m) ! compute vegetation phenology (checks for complete burial of vegetation) else @@ -165,10 +177,9 @@ subroutine vegPhenlgy(& scalarCanopyTemp, & ! intent(in): temperature of the vegetation canopy at the start of the sub-step (K) latitude, & ! intent(in): latitude yearLength, & ! intent(in): number of days in the current year - fracJulday, & ! intent(in): fractional julian days since the start of year + fracJulDay, & ! intent(in): fractional julian days since the start of year scalarLAI, & ! intent(inout): one-sided leaf area index (m2 m-2) scalarSAI, & ! intent(inout): one-sided stem area index (m2 m-2) - scalarRootZoneTemp, & ! intent(in): root zone temperature (K) ! output notUsed_heightCanopyTop, & ! intent(out): height of the top of the canopy layer (m) scalarExposedLAI, & ! intent(out): exposed leaf area index after burial by snow (m2 m-2) @@ -180,10 +191,12 @@ subroutine vegPhenlgy(& canopyDepth = heightCanopyTop - heightCanopyBottom ! canopy depth (m) heightAboveSnow = heightCanopyTop - scalarSnowDepth ! height top of canopy is above the snow surface (m) + ! compute the roughness length of the ground (ground below the canopy or non-vegetated surface) + z0Ground = z0Soil*(1._rkind - scalarGroundSnowFraction) + z0Snow*scalarGroundSnowFraction ! roughness length (m) + ! determine if need to include vegetation in the energy flux routines - computeVegFlux = (exposedVAI > 0.05_rkind .and. heightAboveSnow > 0.05_rkind) - !write(*,'(a,1x,i2,1x,L1,1x,10(f12.5,1x))') 'vegTypeIndex, computeVegFlux, heightCanopyTop, heightAboveSnow, scalarSnowDepth = ', & - ! vegTypeIndex, computeVegFlux, heightCanopyTop, heightAboveSnow, scalarSnowDepth + minExpLogHgt = minExpLogHgtFac*sqrt(heightCanopyTop) ! minimum height above ground for logarithmic wind profile (m) + computeVegFlux = (exposedVAI > 0.05_rkind .and. heightAboveSnow > z0Ground + minExpLogHgt) end if ! (check if the snow-soil column is isolated) diff --git a/build/source/engine/vegSWavRad.f90 b/build/source/engine/vegSWavRad.f90 old mode 100755 new mode 100644 index 45357f36b..23848dd31 --- a/build/source/engine/vegSWavRad.f90 +++ b/build/source/engine/vegSWavRad.f90 @@ -23,10 +23,10 @@ module vegSWavRad_module ! data types USE nrtype USE data_types,only:var_i ! x%var(:) (i4b) -USE data_types,only:var_dlength ! x%var(:)%dat (dp) +USE data_types,only:var_dlength ! x%var(:)%dat (rkind) ! physical constants -USE multiconst,only:Tfreeze ! temperature at freezing (K) +USE multiconst,only:Tfreeze ! temperature at freezing (K) ! named variables for structure elements USE var_lookup,only:iLookTYPE,iLookPROG,iLookDIAG,iLookFLUX @@ -34,6 +34,8 @@ module vegSWavRad_module ! model decisions USE globalData,only:model_decisions ! model decision structure USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure +USE globalData,only:nSpecBand ! number of spectral bands +USE globalData,only:verySmall ! a very small number used as an additive constant to check if substantial difference among real numbers ! look-up values for the choice of canopy shortwave radiation method USE mDecisions_module,only: & @@ -48,20 +50,11 @@ module vegSWavRad_module implicit none private public::vegSWavRad -! dimensions -integer(i4b),parameter :: nBands=2 ! number of spectral bands for shortwave radiation ! named variables integer(i4b),parameter :: ist = 1 ! Surface type: IST=1 => soil; IST=2 => lake integer(i4b),parameter :: isc = 4 ! Soil color type -integer(i4b),parameter :: ice = 0 ! Surface type: ICE=0 => soil; ICE=1 => sea-ice -! spatial indices -integer(i4b),parameter :: iLoc = 1 ! i-location -integer(i4b),parameter :: jLoc = 1 ! j-location ! algorithmic parameters -real(rkind),parameter :: missingValue=-9999._rkind ! missing value, used when diagnostic or state variables are undefined -real(rkind),parameter :: verySmall=1.e-6_rkind ! used as an additive constant to check if substantial difference among real numbers -real(rkind),parameter :: mpe=1.e-6_rkind ! prevents overflow error if division by zero -real(rkind),parameter :: dx=1.e-6_rkind ! finite difference increment +real(rkind),parameter :: mpe=1.e-6_rkind ! prevents overflow error if division by zero, from NOAH mpe value contains @@ -84,20 +77,19 @@ subroutine vegSWavRad(& implicit none ! dummy variables real(rkind),intent(in) :: dt ! time step (s) -- only used in Noah-MP radiation, to compute albedo - integer(i4b),intent(in) :: nSnow ! number of snow layers - integer(i4b),intent(in) :: nSoil ! number of soil layers - integer(i4b),intent(in) :: nLayers ! total number of layers - logical(lgt),intent(in) :: computeVegFlux ! logical flag to compute vegetation fluxes (.false. if veg buried by snow) - type(var_i),intent(in) :: type_data ! classification of veg, soil etc. for a local HRU - type(var_dlength),intent(inout) :: prog_data ! model prognostic variables for a local HRU - type(var_dlength),intent(inout) :: diag_data ! model diagnostic variables for a local HRU - type(var_dlength),intent(inout) :: flux_data ! model flux variables - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + integer(i4b),intent(in) :: nSnow ! number of snow layers + integer(i4b),intent(in) :: nSoil ! number of soil layers + integer(i4b),intent(in) :: nLayers ! total number of layers + logical(lgt),intent(in) :: computeVegFlux ! logical flag to compute vegetation fluxes (.false. if veg buried by snow) + type(var_i),intent(in) :: type_data ! classification of veg, soil etc. for a local HRU + type(var_dlength),intent(inout) :: prog_data ! model prognostic variables for a local HRU + type(var_dlength),intent(inout) :: diag_data ! model diagnostic variables for a local HRU + type(var_dlength),intent(inout) :: flux_data ! model flux variables + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message ! local variables - character(LEN=256) :: cmessage ! error message of downwind routine + character(LEN=256) :: cmessage ! error message of downwind routine real(rkind) :: snowmassPlusNewsnow ! sum of snow mass and new snowfall (kg m-2 [mm]) - real(rkind) :: scalarGroundSnowFraction ! snow cover fraction on the ground surface (-) real(rkind),parameter :: scalarVegFraction=1._rkind ! vegetation fraction (=1 forces no canopy gaps and open areas in radiation routine) real(rkind) :: scalarTotalReflectedSolar ! total reflected solar radiation (W m-2) real(rkind) :: scalarTotalAbsorbedSolar ! total absorbed solar radiation (W m-2) @@ -109,65 +101,54 @@ subroutine vegSWavRad(& ! make association between local variables and the information in the data structures associate(& ! input: control - vegTypeIndex => type_data%var(iLookTYPE%vegTypeIndex), & ! intent(in): vegetation type index - ix_canopySrad => model_decisions(iLookDECISIONS%canopySrad)%iDecision, & ! intent(in): index defining method for canopy shortwave radiation + vegTypeIndex => type_data%var(iLookTYPE%vegTypeIndex), & ! intent(in): vegetation type index + ix_canopySrad => model_decisions(iLookDECISIONS%canopySrad)%iDecision, & ! intent(in): index defining method for canopy shortwave radiation ! input: forcing at the upper boundary - scalarSnowfall => flux_data%var(iLookFLUX%scalarSnowfall)%dat(1), & ! intent(in): computed snowfall rate (kg m-2 s-1) - spectralIncomingDirect => flux_data%var(iLookFLUX%spectralIncomingDirect)%dat(1:nBands), & ! intent(in): incoming direct solar radiation in each wave band (w m-2) - spectralIncomingDiffuse => flux_data%var(iLookFLUX%spectralIncomingDiffuse)%dat(1:nBands), & ! intent(in): incoming diffuse solar radiation in each wave band (w m-2) + scalarSnowfall => flux_data%var(iLookFLUX%scalarSnowfall)%dat(1), & ! intent(in): computed snowfall rate (kg m-2 s-1) + spectralIncomingDirect => flux_data%var(iLookFLUX%spectralIncomingDirect)%dat(1:nSpecBand), & ! intent(in): incoming direct solar radiation in each wave band (w m-2) + spectralIncomingDiffuse => flux_data%var(iLookFLUX%spectralIncomingDiffuse)%dat(1:nSpecBand), & ! intent(in): incoming diffuse solar radiation in each wave band (w m-2) ! input: snow states - scalarSWE => prog_data%var(iLookPROG%scalarSWE)%dat(1), & ! intent(in): snow water equivalent on the ground (kg m-2) - scalarSnowDepth => prog_data%var(iLookPROG%scalarSnowDepth)%dat(1), & ! intent(in): snow depth on the ground surface (m) - mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat(nSnow+1:nLayers), & ! intent(in): volumetric fraction of liquid water in each soil layer (-) - spectralSnowAlbedoDiffuse => prog_data%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(1:nBands), & ! intent(in): diffuse albedo of snow in each spectral band (-) - scalarSnowAlbedo => prog_data%var(iLookPROG%scalarSnowAlbedo)%dat(1), & ! intent(inout): snow albedo (-) + scalarSWE => prog_data%var(iLookPROG%scalarSWE)%dat(1), & ! intent(in): snow water equivalent on the ground (kg m-2) + mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat(nSnow+1:nLayers), & ! intent(in): volumetric fraction of liquid water in each soil layer (-) + spectralSnowAlbedoDiffuse => prog_data%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(1:nSpecBand), & ! intent(in): diffuse albedo of snow in each spectral band (-) + scalarSnowAlbedo => prog_data%var(iLookPROG%scalarSnowAlbedo)%dat(1), & ! intent(inout): snow albedo (-) + scalarGroundSnowFraction => diag_data%var(iLookDIAG%scalarGroundSnowFraction)%dat(1), & ! intent(in): fraction of ground covered with snow (-) ! input: ground and canopy temperature - scalarGroundTemp => prog_data%var(iLookPROG%mLayerTemp)%dat(1), & ! intent(in): ground temperature (K) - scalarCanopyTemp => prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1), & ! intent(in): vegetation temperature (K) + scalarGroundTemp => prog_data%var(iLookPROG%mLayerTemp)%dat(1), & ! intent(in): ground temperature (K) + scalarCanopyTemp => prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1), & ! intent(in): vegetation temperature (K) ! input: surface characteristix - scalarSnowAge => diag_data%var(iLookDIAG%scalarSnowAge)%dat(1), & ! intent(inout): non-dimensional snow age (-) - scalarCosZenith => diag_data%var(iLookDIAG%scalarCosZenith)%dat(1), & ! intent(in): cosine of the solar zenith angle (0-1) - spectralSnowAlbedoDirect => diag_data%var(iLookDIAG%spectralSnowAlbedoDirect)%dat(1:nBands), & ! intent(in): direct albedo of snow in each spectral band (-) + scalarSnowAge => diag_data%var(iLookDIAG%scalarSnowAge)%dat(1), & ! intent(inout): non-dimensional snow age (-) + scalarCosZenith => diag_data%var(iLookDIAG%scalarCosZenith)%dat(1), & ! intent(in): cosine of the solar zenith angle (0-1) + spectralSnowAlbedoDirect => diag_data%var(iLookDIAG%spectralSnowAlbedoDirect)%dat(1:nSpecBand), & ! intent(in): direct albedo of snow in each spectral band (-) ! input: vegetation characteristix - scalarExposedLAI => diag_data%var(iLookDIAG%scalarExposedLAI)%dat(1), & ! intent(in): exposed leaf area index after burial by snow (m2 m-2) - scalarExposedSAI => diag_data%var(iLookDIAG%scalarExposedSAI)%dat(1), & ! intent(in): exposed stem area index after burial by snow (m2 m-2) - scalarCanopyWetFraction => diag_data%var(iLookDIAG%scalarCanopyWetFraction)%dat(1), & ! intent(in): canopy wetted fraction (-) + scalarExposedLAI => diag_data%var(iLookDIAG%scalarExposedLAI)%dat(1), & ! intent(in): exposed leaf area index after burial by snow (m2 m-2) + scalarExposedSAI => diag_data%var(iLookDIAG%scalarExposedSAI)%dat(1), & ! intent(in): exposed stem area index after burial by snow (m2 m-2) + scalarCanopyWetFraction => diag_data%var(iLookDIAG%scalarCanopyWetFraction)%dat(1), & ! intent(in): canopy wetted fraction (-) ! output: canopy properties - scalarCanopySunlitFraction => diag_data%var(iLookDIAG%scalarCanopySunlitFraction)%dat(1), & ! intent(out): sunlit fraction of canopy (-) - scalarCanopySunlitLAI => diag_data%var(iLookDIAG%scalarCanopySunlitLAI)%dat(1), & ! intent(out): sunlit leaf area (-) - scalarCanopyShadedLAI => diag_data%var(iLookDIAG%scalarCanopyShadedLAI)%dat(1), & ! intent(out): shaded leaf area (-) - spectralAlbGndDirect => diag_data%var(iLookDIAG%spectralAlbGndDirect)%dat, & ! intent(out): direct albedo of underlying surface (1:nBands) (-) - spectralAlbGndDiffuse => diag_data%var(iLookDIAG%spectralAlbGndDiffuse)%dat, & ! intent(out): diffuse albedo of underlying surface (1:nBands) (-) - scalarGroundAlbedo => diag_data%var(iLookDIAG%scalarGroundAlbedo)%dat(1), & ! intent(out): albedo of the ground surface (-) + scalarCanopySunlitFraction => diag_data%var(iLookDIAG%scalarCanopySunlitFraction)%dat(1), & ! intent(out): sunlit fraction of canopy (-) + scalarCanopySunlitLAI => diag_data%var(iLookDIAG%scalarCanopySunlitLAI)%dat(1), & ! intent(out): sunlit leaf area (-) + scalarCanopyShadedLAI => diag_data%var(iLookDIAG%scalarCanopyShadedLAI)%dat(1), & ! intent(out): shaded leaf area (-) + spectralAlbGndDirect => diag_data%var(iLookDIAG%spectralAlbGndDirect)%dat, & ! intent(out): direct albedo of underlying surface (1:nSpecBand) (-) + spectralAlbGndDiffuse => diag_data%var(iLookDIAG%spectralAlbGndDiffuse)%dat, & ! intent(out): diffuse albedo of underlying surface (1:nSpecBand) (-) + scalarGroundAlbedo => diag_data%var(iLookDIAG%scalarGroundAlbedo)%dat(1), & ! intent(out): albedo of the ground surface (-) ! output: canopy sw radiation fluxes - scalarCanopySunlitPAR => flux_data%var(iLookFLUX%scalarCanopySunlitPAR)%dat(1), & ! intent(out): average absorbed par for sunlit leaves (w m-2) - scalarCanopyShadedPAR => flux_data%var(iLookFLUX%scalarCanopyShadedPAR)%dat(1), & ! intent(out): average absorbed par for shaded leaves (w m-2) - spectralBelowCanopyDirect => flux_data%var(iLookFLUX%spectralBelowCanopyDirect)%dat, & ! intent(out): downward direct flux below veg layer for each spectral band W m-2) - spectralBelowCanopyDiffuse => flux_data%var(iLookFLUX%spectralBelowCanopyDiffuse)%dat, & ! intent(out): downward diffuse flux below veg layer for each spectral band (W m-2) - scalarBelowCanopySolar => flux_data%var(iLookFLUX%scalarBelowCanopySolar)%dat(1), & ! intent(out): solar radiation transmitted below the canopy (W m-2) - scalarCanopyAbsorbedSolar => flux_data%var(iLookFLUX%scalarCanopyAbsorbedSolar)%dat(1), & ! intent(out): solar radiation absorbed by canopy (W m-2) - scalarGroundAbsorbedSolar => flux_data%var(iLookFLUX%scalarGroundAbsorbedSolar)%dat(1) & ! intent(out): solar radiation absorbed by ground (W m-2) + scalarCanopySunlitPAR => flux_data%var(iLookFLUX%scalarCanopySunlitPAR)%dat(1), & ! intent(out): average absorbed par for sunlit leaves (w m-2) + scalarCanopyShadedPAR => flux_data%var(iLookFLUX%scalarCanopyShadedPAR)%dat(1), & ! intent(out): average absorbed par for shaded leaves (w m-2) + spectralBelowCanopyDirect => flux_data%var(iLookFLUX%spectralBelowCanopyDirect)%dat, & ! intent(out): downward direct flux below veg layer for each spectral band W m-2) + spectralBelowCanopyDiffuse => flux_data%var(iLookFLUX%spectralBelowCanopyDiffuse)%dat, & ! intent(out): downward diffuse flux below veg layer for each spectral band (W m-2) + scalarBelowCanopySolar => flux_data%var(iLookFLUX%scalarBelowCanopySolar)%dat(1), & ! intent(out): solar radiation transmitted below the canopy (W m-2) + scalarCanopyAbsorbedSolar => flux_data%var(iLookFLUX%scalarCanopyAbsorbedSolar)%dat(1), & ! intent(out): solar radiation absorbed by canopy (W m-2) + scalarGroundAbsorbedSolar => flux_data%var(iLookFLUX%scalarGroundAbsorbedSolar)%dat(1) & ! intent(out): solar radiation absorbed by ground (W m-2) ) ! associating local variables with the information in the data structures ! ------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='vegSWavRad/' - ! * preliminaries... - ! ------------------ - ! compute the sum of snow mass and new snowfall (kg m-2 [mm]) snowmassPlusNewsnow = scalarSWE + scalarSnowfall*dt - ! compute the ground snow fraction - if(nSnow > 0)then - scalarGroundSnowFraction = 1._rkind - else - scalarGroundSnowFraction = 0._rkind - end if ! (if there is snow on the ground) - ! * compute radiation fluxes... ! ----------------------------- - select case(ix_canopySrad) ! ***** unchanged Noah-MP routine @@ -175,42 +156,40 @@ subroutine vegSWavRad(& call radiation(& ! input - vegTypeIndex, & ! intent(in): vegetation type index - ist, isc, ice, & ! intent(in): indices to define surface type, soil color, and ice type (constant) - nSoil, & ! intent(in): number of soil layers - scalarSWE, & ! intent(in): snow water equivalent (kg m-2) - snowmassPlusNewsnow, & ! intent(in): sum of snow mass and new snowfall (kg m-2 [mm]) - dt, & ! intent(in): time step (s) - scalarCosZenith, & ! intent(in): cosine of the solar zenith angle (0-1) - scalarSnowDepth*1000._rkind, & ! intent(in): snow depth on the ground surface (mm) - scalarGroundTemp, & ! intent(in): ground temperature (K) - scalarCanopyTemp, & ! intent(in): canopy temperature (K) - scalarGroundSnowFraction, & ! intent(in): snow cover fraction (0-1) - scalarSnowfall, & ! intent(in): snowfall (kg m-2 s-1 [mm/s]) - scalarCanopyWetFraction, & ! intent(in): fraction of canopy that is wet - scalarExposedLAI, & ! intent(in): exposed leaf area index after burial by snow (m2 m-2) - scalarExposedSAI, & ! intent(in): exposed stem area index after burial by snow (m2 m-2) - mLayerVolFracLiq(1:nSoil), & ! intent(in): volumetric fraction of liquid water in each soil layer (-) - spectralIncomingDirect(1:nBands), & ! intent(in): incoming direct solar radiation in each wave band (w m-2) - spectralIncomingDiffuse(1:nBands), & ! intent(in): incoming diffuse solar radiation in each wave band (w m-2) - scalarVegFraction, & ! intent(in): vegetation fraction (=1 forces no canopy gaps and open areas in radiation routine) - iLoc, jLoc, & ! intent(in): spatial location indices + vegTypeIndex, & ! intent(in): vegetation type index + ist, isc, & ! intent(in): indices to define surface type and soil color (constants) + nSoil, & ! intent(in): number of soil layers + scalarSWE, & ! intent(in): snow water equivalent (kg m-2) + snowmassPlusNewsnow, & ! intent(in): sum of snow mass and new snowfall (kg m-2 [mm]) + dt, & ! intent(in): time step (s) + scalarCosZenith, & ! intent(in): cosine of the solar zenith angle (0-1) + scalarGroundTemp, & ! intent(in): ground temperature (K) + scalarCanopyTemp, & ! intent(in): canopy temperature (K) + scalarGroundSnowFraction, & ! intent(in): snow cover fraction (0-1) + scalarSnowfall, & ! intent(in): snowfall (kg m-2 s-1 [mm/s]) + scalarCanopyWetFraction, & ! intent(in): fraction of canopy that is wet + scalarExposedLAI, & ! intent(in): exposed leaf area index after burial by snow (m2 m-2) + scalarExposedSAI, & ! intent(in): exposed stem area index after burial by snow (m2 m-2) + mLayerVolFracLiq(1:nSoil), & ! intent(in): volumetric fraction of liquid water in each soil layer (-) + spectralIncomingDirect(1:nSpecBand), & ! intent(in): incoming direct solar radiation in each wave band (w m-2) + spectralIncomingDiffuse(1:nSpecBand), & ! intent(in): incoming diffuse solar radiation in each wave band (w m-2) + scalarVegFraction, & ! intent(in): vegetation fraction (=1 forces no canopy gaps and open areas in radiation routine) ! output - scalarSnowAlbedo, & ! intent(inout): snow albedo (-) - scalarSnowAge, & ! intent(inout): non-dimensional snow age (-) - scalarCanopySunlitFraction, & ! intent(out): sunlit fraction of canopy (-) - scalarCanopySunlitLAI, & ! intent(out): sunlit leaf area (-) - scalarCanopyShadedLAI, & ! intent(out): shaded leaf area (-) - scalarCanopySunlitPAR, & ! intent(out): average absorbed par for sunlit leaves (w m-2) - scalarCanopyShadedPAR, & ! intent(out): average absorbed par for shaded leaves (w m-2) - scalarCanopyAbsorbedSolar, & ! intent(out): solar radiation absorbed by canopy (W m-2) - scalarGroundAbsorbedSolar, & ! intent(out): solar radiation absorbed by ground (W m-2) - scalarTotalReflectedSolar, & ! intent(out): total reflected solar radiation (W m-2) - scalarTotalAbsorbedSolar, & ! intent(out): total absorbed solar radiation (W m-2) - scalarCanopyReflectedSolar, & ! intent(out): solar radiation reflected from the canopy (W m-2) - scalarGroundReflectedSolar, & ! intent(out): solar radiation reflected from the ground (W m-2) - scalarBetweenCanopyGapFraction, & ! intent(out): between canopy gap fraction for beam (-) - scalarWithinCanopyGapFraction ) ! intent(out): within canopy gap fraction for beam (-) + scalarSnowAlbedo, & ! intent(inout): snow albedo (-) + scalarSnowAge, & ! intent(inout): non-dimensional snow age (-) + scalarCanopySunlitFraction, & ! intent(out): sunlit fraction of canopy (-) + scalarCanopySunlitLAI, & ! intent(out): sunlit leaf area (-) + scalarCanopyShadedLAI, & ! intent(out): shaded leaf area (-) + scalarCanopySunlitPAR, & ! intent(out): average absorbed par for sunlit leaves (w m-2) + scalarCanopyShadedPAR, & ! intent(out): average absorbed par for shaded leaves (w m-2) + scalarCanopyAbsorbedSolar, & ! intent(out): solar radiation absorbed by canopy (W m-2) + scalarGroundAbsorbedSolar, & ! intent(out): solar radiation absorbed by ground (W m-2) + scalarTotalReflectedSolar, & ! intent(out): total reflected solar radiation (W m-2) + scalarTotalAbsorbedSolar, & ! intent(out): total absorbed solar radiation (W m-2) + scalarCanopyReflectedSolar, & ! intent(out): solar radiation reflected from the canopy (W m-2) + scalarGroundReflectedSolar, & ! intent(out): solar radiation reflected from the ground (W m-2) + scalarBetweenCanopyGapFraction, & ! intent(out): between canopy gap fraction for beam (-) + scalarWithinCanopyGapFraction ) ! intent(out): within canopy gap fraction for beam (-) ! **** all other options case(CLM_2stream,UEB_2stream,NL_scatter,BeersLaw) @@ -223,10 +202,10 @@ subroutine vegSWavRad(& ix_canopySrad, & ! intent(in): index of method used for transmission of shortwave rad through the canopy ! input: model variables scalarCosZenith, & ! intent(in): cosine of direct zenith angle (0-1) - spectralIncomingDirect(1:nBands), & ! intent(in): incoming direct solar radiation in each wave band (w m-2) - spectralIncomingDiffuse(1:nBands), & ! intent(in): incoming diffuse solar radiation in each wave band (w m-2) - spectralSnowAlbedoDirect(1:nBands), & ! intent(in): direct albedo of snow in each spectral band (-) - spectralSnowAlbedoDiffuse(1:nBands), & ! intent(in): diffuse albedo of snow in each spectral band (-) + spectralIncomingDirect(1:nSpecBand), & ! intent(in): incoming direct solar radiation in each wave band (w m-2) + spectralIncomingDiffuse(1:nSpecBand), & ! intent(in): incoming diffuse solar radiation in each wave band (w m-2) + spectralSnowAlbedoDirect(1:nSpecBand), & ! intent(in): direct albedo of snow in each spectral band (-) + spectralSnowAlbedoDiffuse(1:nSpecBand), & ! intent(in): diffuse albedo of snow in each spectral band (-) scalarExposedLAI, & ! intent(in): exposed leaf area index after burial by snow (m2 m-2) scalarExposedSAI, & ! intent(in): exposed stem area index after burial by snow (m2 m-2) scalarVegFraction, & ! intent(in): vegetation fraction (=1 forces no canopy gaps and open areas in radiation routine) @@ -238,8 +217,8 @@ subroutine vegSWavRad(& spectralBelowCanopyDirect, & ! intent(out): downward direct flux below veg layer for each spectral band W m-2) spectralBelowCanopyDiffuse, & ! intent(out): downward diffuse flux below veg layer for each spectral band (W m-2) scalarBelowCanopySolar, & ! intent(out): solar radiation transmitted below the canopy (W m-2) - spectralAlbGndDirect, & ! intent(out): direct albedo of underlying surface (1:nBands) (-) - spectralAlbGndDiffuse, & ! intent(out): diffuse albedo of underlying surface (1:nBands) (-) + spectralAlbGndDirect, & ! intent(out): direct albedo of underlying surface (1:nSpecBand) (-) + spectralAlbGndDiffuse, & ! intent(out): diffuse albedo of underlying surface (1:nSpecBand) (-) scalarGroundAlbedo, & ! intent(out): albedo of the ground surface (-) scalarCanopyAbsorbedSolar, & ! intent(out): solar radiation absorbed by the vegetation canopy (W m-2) scalarGroundAbsorbedSolar, & ! intent(out): solar radiation absorbed by the ground (W m-2) @@ -288,8 +267,8 @@ subroutine canopy_SW(& spectralBelowCanopyDirect, & ! intent(out): downward direct flux below veg layer (W m-2) spectralBelowCanopyDiffuse, & ! intent(out): downward diffuse flux below veg layer (W m-2) scalarBelowCanopySolar, & ! intent(out): radiation transmitted below the canopy (W m-2) - spectralAlbGndDirect, & ! intent(out): direct albedo of underlying surface (1:nBands) (-) - spectralAlbGndDiffuse, & ! intent(out): diffuse albedo of underlying surface (1:nBands) (-) + spectralAlbGndDirect, & ! intent(out): direct albedo of underlying surface (1:nSpecBand) (-) + spectralAlbGndDiffuse, & ! intent(out): diffuse albedo of underlying surface (1:nSpecBand) (-) scalarGroundAlbedo, & ! intent(out): albedo of the ground surface (-) scalarCanopyAbsorbedSolar, & ! intent(out): radiation absorbed by the vegetation canopy (W m-2) scalarGroundAbsorbedSolar, & ! intent(out): radiation absorbed by the ground (W m-2) @@ -307,10 +286,10 @@ subroutine canopy_SW(& USE NOAHMP_VEG_PARAMETERS, only: RHOS,RHOL ! Noah-MP: stem and leaf reflectance for each wave band USE NOAHMP_VEG_PARAMETERS, only: TAUS,TAUL ! Noah-MP: stem and leaf transmittance for each wave band ! input - integer(i4b),intent(in) :: vegTypeIndex ! vegetation type index - integer(i4b),intent(in) :: isc ! soil color index - logical(lgt),intent(in) :: computeVegFlux ! logical flag to compute vegetation fluxes (.false. if veg buried by snow) - integer(i4b),intent(in) :: ix_canopySrad ! choice of canopy shortwave radiation method + integer(i4b),intent(in) :: vegTypeIndex ! vegetation type index + integer(i4b),intent(in) :: isc ! soil color index + logical(lgt),intent(in) :: computeVegFlux ! logical flag to compute vegetation fluxes (.false. if veg buried by snow) + integer(i4b),intent(in) :: ix_canopySrad ! choice of canopy shortwave radiation method real(rkind),intent(in) :: scalarCosZenith ! cosine of the solar zenith angle (0-1) real(rkind),intent(in) :: spectralIncomingDirect(:) ! incoming direct solar radiation in each wave band (w m-2) real(rkind),intent(in) :: spectralIncomingDiffuse(:) ! incoming diffuse solar radiation in each wave band (w m-2) @@ -327,8 +306,8 @@ subroutine canopy_SW(& real(rkind),intent(out) :: spectralBelowCanopyDirect(:) ! downward direct flux below veg layer (W m-2) real(rkind),intent(out) :: spectralBelowCanopyDiffuse(:) ! downward diffuse flux below veg layer (W m-2) real(rkind),intent(out) :: scalarBelowCanopySolar ! radiation transmitted below the canopy (W m-2) - real(rkind),intent(out) :: spectralAlbGndDirect(:) ! direct albedo of underlying surface (1:nBands) (-) - real(rkind),intent(out) :: spectralAlbGndDiffuse(:) ! diffuse albedo of underlying surface (1:nBands) (-) + real(rkind),intent(out) :: spectralAlbGndDirect(:) ! direct albedo of underlying surface (1:nSpecBand) (-) + real(rkind),intent(out) :: spectralAlbGndDiffuse(:) ! diffuse albedo of underlying surface (1:nSpecBand) (-) real(rkind),intent(out) :: scalarGroundAlbedo ! albedo of the ground surface (-) real(rkind),intent(out) :: scalarCanopyAbsorbedSolar ! radiation absorbed by the vegetation canopy (W m-2) real(rkind),intent(out) :: scalarGroundAbsorbedSolar ! radiation absorbed by the ground (W m-2) @@ -337,30 +316,30 @@ subroutine canopy_SW(& real(rkind),intent(out) :: scalarCanopyShadedLAI ! shaded leaf area (-) real(rkind),intent(out) :: scalarCanopySunlitPAR ! average absorbed par for sunlit leaves (w m-2) real(rkind),intent(out) :: scalarCanopyShadedPAR ! average absorbed par for shaded leaves (w m-2) - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------------------------------------------------------------------- ! local variables ! ----------------------------------------------------------------------------------------------------------------------------------------------------------------- ! general - integer(i4b),parameter :: ixVisible=1 ! index of the visible wave band - integer(i4b),parameter :: ixNearIR=2 ! index of the near infra-red wave band - integer(i4b) :: iBand ! index of wave band - integer(i4b) :: ic ! 0=unit incoming direct; 1=unit incoming diffuse - character(LEN=256) :: cmessage ! error message of downwind routine + integer(i4b),parameter :: ixVisible=1 ! index of the visible wave band + integer(i4b),parameter :: ixNearIR=2 ! index of the near infra-red wave band + integer(i4b) :: iBand ! index of wave band + integer(i4b) :: ic ! 0=unit incoming direct; 1=unit incoming diffuse + character(LEN=256) :: cmessage ! error message of downwind routine ! variables used in Nijssen-Lettenmaier method - real(rkind),parameter :: multScatExp=0.81_rkind ! multiple scattering exponent (-) - real(rkind),parameter :: bulkCanopyAlbedo=0.25_rkind ! bulk canopy albedo (-), smaller than actual canopy albedo because of shading in the canopy - real(rkind),dimension(1:nBands) :: spectralIncomingSolar ! total incoming solar radiation in each spectral band (W m-2) - real(rkind),dimension(1:nBands) :: spectralGroundAbsorbedDirect ! total direct radiation absorbed at the ground surface (W m-2) - real(rkind),dimension(1:nBands) :: spectralGroundAbsorbedDiffuse ! total diffuse radiation absorbed at the ground surface (W m-2) + real(rkind),parameter :: multScatExp=0.81_rkind ! multiple scattering exponent (-) + real(rkind),parameter :: bulkCanopyAlbedo=0.25_rkind ! bulk canopy albedo (-), smaller than actual canopy albedo because of shading in the canopy + real(rkind),dimension(1:nSpecBand) :: spectralIncomingSolar ! total incoming solar radiation in each spectral band (W m-2) + real(rkind),dimension(1:nSpecBand) :: spectralGroundAbsorbedDirect ! total direct radiation absorbed at the ground surface (W m-2) + real(rkind),dimension(1:nSpecBand) :: spectralGroundAbsorbedDiffuse ! total diffuse radiation absorbed at the ground surface (W m-2) real(rkind) :: Fdirect ! fraction of direct radiation (-) real(rkind) :: tauInitial ! transmission in the absence of scattering and multiple reflections (-) real(rkind) :: tauTotal ! transmission due to scattering and multiple reflections (-) ! variables used in Mahat-Tarboton method - real(rkind),parameter :: Frad_vis=0.5_rkind ! fraction of radiation in the visible wave band (-) - real(rkind),parameter :: gProjParam=0.5_rkind ! projected leaf and stem area in the solar direction (-) - real(rkind),parameter :: bScatParam=0.5_rkind ! back scatter parameter (-) + real(rkind),parameter :: Frad_vis=0.5_rkind ! fraction of radiation in the visible wave band (-) + real(rkind),parameter :: gProjParam=0.5_rkind ! projected leaf and stem area in the solar direction (-) + real(rkind),parameter :: bScatParam=0.5_rkind ! back scatter parameter (-) real(rkind) :: transCoef ! transmission coefficient (-) real(rkind) :: transCoefPrime ! "k-prime" coefficient (-) real(rkind) :: groundAlbedoDirect ! direct ground albedo (-) @@ -381,30 +360,30 @@ subroutine canopy_SW(& real(rkind) :: tauDiffuse ! total transmission of diffuse radiation (-) real(rkind) :: fractionRefDirect ! fraction of direct radiaiton lost to space (-) real(rkind) :: fractionRefDiffuse ! fraction of diffuse radiaiton lost to space (-) - real(rkind),dimension(1:nBands) :: spectralBelowCanopySolar ! total below-canopy radiation for each wave band (W m-2) - real(rkind),dimension(1:nBands) :: spectralTotalReflectedSolar ! total reflected radiaion for each wave band (W m-2) - real(rkind),dimension(1:nBands) :: spectralGroundAbsorbedSolar ! radiation absorbed by the ground in each wave band (W m-2) - real(rkind),dimension(1:nBands) :: spectralCanopyAbsorbedSolar ! radiation absorbed by the canopy in each wave band (W m-2) + real(rkind),dimension(1:nSpecBand) :: spectralBelowCanopySolar ! total below-canopy radiation for each wave band (W m-2) + real(rkind),dimension(1:nSpecBand) :: spectralTotalReflectedSolar ! total reflected radiaion for each wave band (W m-2) + real(rkind),dimension(1:nSpecBand) :: spectralGroundAbsorbedSolar ! radiation absorbed by the ground in each wave band (W m-2) + real(rkind),dimension(1:nSpecBand) :: spectralCanopyAbsorbedSolar ! radiation absorbed by the canopy in each wave band (W m-2) ! vegetation properties used in 2-stream real(rkind) :: scalarExposedVAI ! one-sided leaf+stem area index (m2/m2) real(rkind) :: weightLeaf ! fraction of exposed VAI that is leaf real(rkind) :: weightStem ! fraction of exposed VAI that is stem - real(rkind),dimension(1:nBands) :: spectralVegReflc ! leaf+stem reflectance (1:nbands) - real(rkind),dimension(1:nBands) :: spectralVegTrans ! leaf+stem transmittance (1:nBands) + real(rkind),dimension(1:nSpecBand) :: spectralVegReflc ! leaf+stem reflectance (1:nSpecBand) + real(rkind),dimension(1:nSpecBand) :: spectralVegTrans ! leaf+stem transmittance (1:nSpecBand) ! output from two-stream -- direct-beam - real(rkind),dimension(1:nBands) :: spectralCanopyAbsorbedDirect ! flux abs by veg layer (per unit incoming flux), (1:nBands) - real(rkind),dimension(1:nBands) :: spectralTotalReflectedDirect ! flux refl above veg layer (per unit incoming flux), (1:nBands) - real(rkind),dimension(1:nBands) :: spectralDirectBelowCanopyDirect ! down dir flux below veg layer (per unit in flux), (1:nBands) - real(rkind),dimension(1:nBands) :: spectralDiffuseBelowCanopyDirect ! down dif flux below veg layer (per unit in flux), (1:nBands) - real(rkind),dimension(1:nBands) :: spectralCanopyReflectedDirect ! flux reflected by veg layer (per unit incoming flux), (1:nBands) - real(rkind),dimension(1:nBands) :: spectralGroundReflectedDirect ! flux reflected by ground (per unit incoming flux), (1:nBands) + real(rkind),dimension(1:nSpecBand) :: spectralCanopyAbsorbedDirect ! flux abs by veg layer (per unit incoming flux), (1:nSpecBand) + real(rkind),dimension(1:nSpecBand) :: spectralTotalReflectedDirect ! flux refl above veg layer (per unit incoming flux), (1:nSpecBand) + real(rkind),dimension(1:nSpecBand) :: spectralDirectBelowCanopyDirect ! down dir flux below veg layer (per unit in flux), (1:nSpecBand) + real(rkind),dimension(1:nSpecBand) :: spectralDiffuseBelowCanopyDirect ! down dif flux below veg layer (per unit in flux), (1:nSpecBand) + real(rkind),dimension(1:nSpecBand) :: spectralCanopyReflectedDirect ! flux reflected by veg layer (per unit incoming flux), (1:nSpecBand) + real(rkind),dimension(1:nSpecBand) :: spectralGroundReflectedDirect ! flux reflected by ground (per unit incoming flux), (1:nSpecBand) ! output from two-stream -- diffuse - real(rkind),dimension(1:nBands) :: spectralCanopyAbsorbedDiffuse ! flux abs by veg layer (per unit incoming flux), (1:nBands) - real(rkind),dimension(1:nBands) :: spectralTotalReflectedDiffuse ! flux refl above veg layer (per unit incoming flux), (1:nBands) - real(rkind),dimension(1:nBands) :: spectralDirectBelowCanopyDiffuse ! down dir flux below veg layer (per unit in flux), (1:nBands) - real(rkind),dimension(1:nBands) :: spectralDiffuseBelowCanopyDiffuse ! down dif flux below veg layer (per unit in flux), (1:nBands) - real(rkind),dimension(1:nBands) :: spectralCanopyReflectedDiffuse ! flux reflected by veg layer (per unit incoming flux), (1:nBands) - real(rkind),dimension(1:nBands) :: spectralGroundReflectedDiffuse ! flux reflected by ground (per unit incoming flux), (1:nBands) + real(rkind),dimension(1:nSpecBand) :: spectralCanopyAbsorbedDiffuse ! flux abs by veg layer (per unit incoming flux), (1:nSpecBand) + real(rkind),dimension(1:nSpecBand) :: spectralTotalReflectedDiffuse ! flux refl above veg layer (per unit incoming flux), (1:nSpecBand) + real(rkind),dimension(1:nSpecBand) :: spectralDirectBelowCanopyDiffuse ! down dir flux below veg layer (per unit in flux), (1:nSpecBand) + real(rkind),dimension(1:nSpecBand) :: spectralDiffuseBelowCanopyDiffuse ! down dif flux below veg layer (per unit in flux), (1:nSpecBand) + real(rkind),dimension(1:nSpecBand) :: spectralCanopyReflectedDiffuse ! flux reflected by veg layer (per unit incoming flux), (1:nSpecBand) + real(rkind),dimension(1:nSpecBand) :: spectralGroundReflectedDiffuse ! flux reflected by ground (per unit incoming flux), (1:nSpecBand) ! output from two-stream -- scalar variables real(rkind) :: scalarGproj ! projected leaf+stem area in solar direction real(rkind) :: scalarBetweenCanopyGapFraction ! between canopy gap fraction for beam (-) @@ -447,7 +426,7 @@ subroutine canopy_SW(& scalarCanopySunlitPAR = 0._rkind ! average absorbed par for sunlit leaves (w m-2) scalarCanopyShadedPAR = 0._rkind ! average absorbed par for shaded leaves (w m-2) ! compute below-canopy radiation - do iBand=1,nBands + do iBand=1,nSpecBand ! (set below-canopy radiation to incoming radiation) if(scalarCosZenith > tiny(scalarCosZenith))then spectralBelowCanopyDirect(iBand) = spectralIncomingDirect(iBand) @@ -487,14 +466,13 @@ subroutine canopy_SW(& ! compute transmission of direct radiation according to Beer's Law (-) tauTotal = exp(-transCoef*scalarExposedVAI) - !print*, 'tauTotal = ', tauTotal ! compute ground albedo (-) groundAlbedoDirect = Frad_vis*spectralAlbGndDirect(ixVisible) + (1._rkind - Frad_vis)*spectralAlbGndDirect(ixNearIR) groundAlbedoDiffuse = Frad_vis*spectralAlbGndDiffuse(ixVisible) + (1._rkind - Frad_vis)*spectralAlbGndDiffuse(ixNearIR) ! compute radiation in each spectral band (W m-2) - do iBand=1,nBands + do iBand=1,nSpecBand ! compute total incoming solar radiation spectralIncomingSolar(iBand) = spectralIncomingDirect(iBand) + spectralIncomingDiffuse(iBand) @@ -587,14 +565,14 @@ subroutine canopy_SW(& ! compute transmission of diffuse radiation (-) vFactor = scalarGproj*scalarExposedVAI expi = expInt(vFactor) - taudFinite = (1._rkind - vFactor)*exp(-vFactor) + (vFactor**2._rkind)*expi + taudFinite = (1._rkind - vFactor)*exp(-vFactor) + (vFactor**2_i4b)*expi ! compute ground albedo (-) groundAlbedoDirect = Frad_vis*spectralAlbGndDirect(ixVisible) + (1._rkind - Frad_vis)*spectralAlbGndDirect(ixNearIR) groundAlbedoDiffuse = Frad_vis*spectralAlbGndDiffuse(ixVisible) + (1._rkind - Frad_vis)*spectralAlbGndDiffuse(ixNearIR) ! compute radiation in each spectral band (W m-2) - do iBand=1,nBands + do iBand=1,nSpecBand ! compute total incoming solar radiation spectralIncomingSolar(iBand) = spectralIncomingDirect(iBand) + spectralIncomingDiffuse(iBand) @@ -690,19 +668,19 @@ subroutine canopy_SW(& betaInfinite = (1._rkind - transCoefPrime)/(1._rkind + transCoefPrime) ! compute transmission for a finite canopy (-) - tauFinite = tauInfinite*(1._rkind - betaInfinite**2._rkind)/(1._rkind - (betaInfinite**2._rkind)*tauInfinite**2._rkind) + tauFinite = tauInfinite*(1._rkind - betaInfinite**2_i4b)/(1._rkind - (betaInfinite**2_i4b)*tauInfinite**2_i4b) ! compute reflectance for a finite canopy (-) - betaFinite = betaInfinite*(1._rkind - tauInfinite**2._rkind) / (1._rkind - (betaInfinite**2._rkind)*(tauInfinite**2._rkind)) + betaFinite = betaInfinite*(1._rkind - tauInfinite**2_i4b) / (1._rkind - (betaInfinite**2_i4b)*(tauInfinite**2_i4b)) ! compute transmission of diffuse radiation (-) vFactor = transCoefPrime*scalarGproj*scalarExposedVAI expi = expInt(vFactor) - taudInfinite = (1._rkind - vFactor)*exp(-vFactor) + (vFactor**2._rkind)*expi - taudFinite = taudInfinite*(1._rkind - betaInfinite**2._rkind)/(1._rkind - (betaInfinite**2._rkind)*taudInfinite**2._rkind) + taudInfinite = (1._rkind - vFactor)*exp(-vFactor) + (vFactor**2_i4b)*expi + taudFinite = taudInfinite*(1._rkind - betaInfinite**2_i4b)/(1._rkind - (betaInfinite**2_i4b)*taudInfinite**2_i4b) ! compute reflectance of diffuse radiation (-) - betadFinite = betaInfinite*(1._rkind - taudInfinite**2._rkind) / (1._rkind - (betaInfinite**2._rkind)*(taudInfinite**2._rkind)) + betadFinite = betaInfinite*(1._rkind - taudInfinite**2_i4b) / (1._rkind - (betaInfinite**2_i4b)*(taudInfinite**2_i4b)) ! compute total transmission of direct and diffuse radiation, accounting for multiple reflections (-) refMult = 1._rkind / (1._rkind - groundAlbedoDiffuse*betadFinite*(1._rkind - taudFinite) ) @@ -716,7 +694,7 @@ subroutine canopy_SW(& fractionRefDiffuse = ( (1._rkind - groundAlbedoDiffuse)*betadFinite + groundAlbedoDiffuse*taudFinite*taudFinite) * refMult ! compute radiation in each spectral band (W m-2) - do iBand=1,nBands + do iBand=1,nSpecBand ! compute below-canopy radiation (W m-2) spectralBelowCanopyDirect(iBand) = spectralIncomingDirect(iBand)*tauFinite*refMult ! direct radiation from current wave band @@ -766,13 +744,13 @@ subroutine canopy_SW(& ! weight reflectance and transmittance by exposed leaf and stem area index weightLeaf = scalarExposedLAI / scalarExposedVAI weightStem = scalarExposedSAI / scalarExposedVAI - do iBand = 1,nBands ! loop through spectral bands + do iBand = 1,nSpecBand ! loop through spectral bands spectralVegReflc(iBand) = RHOL(vegTypeIndex,iBand)*weightLeaf + RHOS(vegTypeIndex,iBand)*weightStem spectralVegTrans(iBand) = TAUL(vegTypeIndex,iBand)*weightLeaf + TAUS(vegTypeIndex,iBand)*weightStem end do ! loop through wave bands - do iBand=1,nBands + do iBand=1,nSpecBand ic = 0 ! two-stream approximation for direct-beam radiation (from CLM/Noah-MP) @@ -785,21 +763,19 @@ subroutine canopy_SW(& scalarExposedVAI, & ! intent(in): one-sided leaf+stem area index (m2/m2) scalarCanopyWetFraction, & ! intent(in): fraction of lai, sai that is wetted (-) scalarCanopyTempTrial, & ! intent(in): surface temperature (k) - spectralAlbGndDirect, & ! intent(in): direct albedo of underlying surface (1:nBands) (-) - spectralAlbGndDiffuse, & ! intent(in): diffuse albedo of underlying surface (1:nBands) (-) - spectralVegReflc, & ! intent(in): leaf+stem reflectance (1:nbands) - spectralVegTrans, & ! intent(in): leaf+stem transmittance (1:nBands) + spectralAlbGndDirect, & ! intent(in): direct albedo of underlying surface (1:nSpecBand) (-) + spectralAlbGndDiffuse, & ! intent(in): diffuse albedo of underlying surface (1:nSpecBand) (-) + spectralVegReflc, & ! intent(in): leaf+stem reflectance (1:nSpecBand) + spectralVegTrans, & ! intent(in): leaf+stem transmittance (1:nSpecBand) scalarVegFraction, & ! intent(in): vegetation fraction (=1 forces no canopy gaps and open areas in radiation routine) - ist, & ! intent(in): surface type - iLoc,jLoc, & ! intent(in): grid indices ! output - spectralCanopyAbsorbedDirect, & ! intent(out): flux abs by veg layer (per unit incoming flux), (1:nBands) - spectralTotalReflectedDirect, & ! intent(out): flux refl above veg layer (per unit incoming flux), (1:nBands) - spectralDirectBelowCanopyDirect, & ! intent(out): down dir flux below veg layer (per unit in flux), (1:nBands) - spectralDiffuseBelowCanopyDirect, & ! intent(out): down dif flux below veg layer (per unit in flux), (1:nBands) + spectralCanopyAbsorbedDirect, & ! intent(out): flux abs by veg layer (per unit incoming flux), (1:nSpecBand) + spectralTotalReflectedDirect, & ! intent(out): flux refl above veg layer (per unit incoming flux), (1:nSpecBand) + spectralDirectBelowCanopyDirect, & ! intent(out): down dir flux below veg layer (per unit in flux), (1:nSpecBand) + spectralDiffuseBelowCanopyDirect, & ! intent(out): down dif flux below veg layer (per unit in flux), (1:nSpecBand) scalarGproj, & ! intent(out): projected leaf+stem area in solar direction - spectralCanopyReflectedDirect, & ! intent(out): flux reflected by veg layer (per unit incoming flux), (1:nBands) - spectralGroundReflectedDirect, & ! intent(out): flux reflected by ground (per unit incoming flux), (1:nBands) + spectralCanopyReflectedDirect, & ! intent(out): flux reflected by veg layer (per unit incoming flux), (1:nSpecBand) + spectralGroundReflectedDirect, & ! intent(out): flux reflected by ground (per unit incoming flux), (1:nSpecBand) ! input-output scalarBetweenCanopyGapFraction, & ! intent(inout): between canopy gap fraction for beam (-) scalarWithinCanopyGapFraction ) ! intent(inout): within canopy gap fraction for beam (-) @@ -815,21 +791,19 @@ subroutine canopy_SW(& scalarExposedVAI, & ! intent(in): one-sided leaf+stem area index (m2/m2) scalarCanopyWetFraction, & ! intent(in): fraction of lai, sai that is wetted (-) scalarCanopyTempTrial, & ! intent(in): surface temperature (k) - spectralAlbGndDirect, & ! intent(in): direct albedo of underlying surface (1:nBands) (-) - spectralAlbGndDiffuse, & ! intent(in): diffuse albedo of underlying surface (1:nBands) (-) - spectralVegReflc, & ! intent(in): leaf+stem reflectance (1:nbands) - spectralVegTrans, & ! intent(in): leaf+stem transmittance (1:nBands) + spectralAlbGndDirect, & ! intent(in): direct albedo of underlying surface (1:nSpecBand) (-) + spectralAlbGndDiffuse, & ! intent(in): diffuse albedo of underlying surface (1:nSpecBand) (-) + spectralVegReflc, & ! intent(in): leaf+stem reflectance (1:nSpecBand) + spectralVegTrans, & ! intent(in): leaf+stem transmittance (1:nSpecBand) scalarVegFraction, & ! intent(in): vegetation fraction (=1 forces no canopy gaps and open areas in radiation routine) - ist, & ! intent(in): surface type - iLoc,jLoc, & ! intent(in): grid indices ! output - spectralCanopyAbsorbedDiffuse, & ! intent(out): flux abs by veg layer (per unit incoming flux), (1:nBands) - spectralTotalReflectedDiffuse, & ! intent(out): flux refl above veg layer (per unit incoming flux), (1:nBands) - spectralDirectBelowCanopyDiffuse, & ! intent(out): down dir flux below veg layer (per unit in flux), (1:nBands) - spectralDiffuseBelowCanopyDiffuse, & ! intent(out): down dif flux below veg layer (per unit in flux), (1:nBands) + spectralCanopyAbsorbedDiffuse, & ! intent(out): flux abs by veg layer (per unit incoming flux), (1:nSpecBand) + spectralTotalReflectedDiffuse, & ! intent(out): flux refl above veg layer (per unit incoming flux), (1:nSpecBand) + spectralDirectBelowCanopyDiffuse, & ! intent(out): down dir flux below veg layer (per unit in flux), (1:nSpecBand) + spectralDiffuseBelowCanopyDiffuse, & ! intent(out): down dif flux below veg layer (per unit in flux), (1:nSpecBand) scalarGproj, & ! intent(out): projected leaf+stem area in solar direction - spectralCanopyReflectedDiffuse, & ! intent(out): flux reflected by veg layer (per unit incoming flux), (1:nBands) - spectralGroundReflectedDiffuse, & ! intent(out): flux reflected by ground (per unit incoming flux), (1:nBands) + spectralCanopyReflectedDiffuse, & ! intent(out): flux reflected by veg layer (per unit incoming flux), (1:nSpecBand) + spectralGroundReflectedDiffuse, & ! intent(out): flux reflected by ground (per unit incoming flux), (1:nSpecBand) ! input-output scalarBetweenCanopyGapFraction, & ! intent(inout): between canopy gap fraction for beam (-) scalarWithinCanopyGapFraction ) ! intent(inout): within canopy gap fraction for beam (-) @@ -893,10 +867,6 @@ subroutine canopy_SW(& scalarCanopySunlitPAR = 0._rkind scalarCanopyShadedPAR = (visibleAbsDirect + visibleAbsDiffuse) * fractionLAI / max(scalarCanopyShadedLAI, mpe) end if - !print*, 'scalarCanopySunlitLAI, fractionLAI, visibleAbsDirect, visibleAbsDiffuse, scalarCanopySunlitPAR = ', & - ! scalarCanopySunlitLAI, fractionLAI, visibleAbsDirect, visibleAbsDiffuse, scalarCanopySunlitPAR - - end subroutine canopy_SW @@ -920,31 +890,31 @@ subroutine gndAlbedo(& USE NOAHMP_RAD_PARAMETERS, only: ALBSAT,ALBDRY ! Noah-MP: saturated and dry soil albedos for each wave band ! -------------------------------------------------------------------------------------------------------------------------------------- ! input: model control - integer(i4b),intent(in) :: isc ! index of soil color - real(rkind),intent(in) :: scalarGroundSnowFraction ! fraction of ground that is snow covered (-) - real(rkind),intent(in) :: scalarVolFracLiqUpper ! volumetric liquid water content in upper-most soil layer (-) - real(rkind),intent(in) :: spectralSnowAlbedoDirect(:) ! direct albedo of snow in each spectral band (-) - real(rkind),intent(in) :: spectralSnowAlbedoDiffuse(:) ! diffuse albedo of snow in each spectral band (-) + integer(i4b),intent(in) :: isc ! index of soil color + real(rkind),intent(in) :: scalarGroundSnowFraction ! fraction of ground that is snow covered (-) + real(rkind),intent(in) :: scalarVolFracLiqUpper ! volumetric liquid water content in upper-most soil layer (-) + real(rkind),intent(in) :: spectralSnowAlbedoDirect(:) ! direct albedo of snow in each spectral band (-) + real(rkind),intent(in) :: spectralSnowAlbedoDiffuse(:) ! diffuse albedo of snow in each spectral band (-) ! output - real(rkind),intent(out) :: spectralAlbGndDirect(:) ! direct albedo of underlying surface (-) - real(rkind),intent(out) :: spectralAlbGndDiffuse(:) ! diffuse albedo of underlying surface (-) - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + real(rkind),intent(out) :: spectralAlbGndDirect(:) ! direct albedo of underlying surface (-) + real(rkind),intent(out) :: spectralAlbGndDiffuse(:) ! diffuse albedo of underlying surface (-) + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message ! local variables - integer(i4b) :: iBand ! index of spectral band - real(rkind) :: xInc ! soil water correction factor for soil albedo - real(rkind),dimension(1:nBands) :: spectralSoilAlbedo ! soil albedo in each spectral band + integer(i4b) :: iBand ! index of spectral band + real(rkind) :: xInc ! soil water correction factor for soil albedo + real(rkind),dimension(1:nSpecBand) :: spectralSoilAlbedo ! soil albedo in each spectral band ! initialize error control err=0; message='gndAlbedo/' ! compute soil albedo - do iBand=1,nBands ! loop through spectral bands + do iBand=1,nSpecBand ! loop through spectral bands xInc = max(0.11_rkind - 0.40_rkind*scalarVolFracLiqUpper, 0._rkind) spectralSoilAlbedo(iBand) = min(ALBSAT(isc,iBand)+xInc,ALBDRY(isc,iBand)) end do ! (looping through spectral bands) ! compute surface albedo (weighted combination of snow and soil) - do iBand=1,nBands + do iBand=1,nSpecBand spectralAlbGndDirect(iBand) = (1._rkind - scalarGroundSnowFraction)*spectralSoilAlbedo(iBand) + scalarGroundSnowFraction*spectralSnowAlbedoDirect(iBand) spectralAlbGndDiffuse(iBand) = (1._rkind - scalarGroundSnowFraction)*spectralSoilAlbedo(iBand) + scalarGroundSnowFraction*spectralSnowAlbedoDiffuse(iBand) end do ! (looping through spectral bands) diff --git a/build/source/engine/volicePack.f90 b/build/source/engine/volicePack.f90 old mode 100755 new mode 100644 index 71adf8ede..310f9e84b --- a/build/source/engine/volicePack.f90 +++ b/build/source/engine/volicePack.f90 @@ -25,9 +25,9 @@ module volicePack_module ! derived types to define the data structures USE data_types,only:& - var_d, & ! data vector (dp) + var_d, & ! data vector (rkind) var_ilength, & ! data vector with variable length dimension (i4b) - var_dlength, & ! data vector with variable length dimension (dp) + var_dlength, & ! data vector with variable length dimension (rkind) model_options ! defines the model decisions ! named variables for snow and soil @@ -39,11 +39,6 @@ module volicePack_module ! physical constants USE multiconst,only:& - Tfreeze, & ! freezing point (K) - LH_fus, & ! latent heat of fusion (J kg-1) - LH_vap, & ! latent heat of vaporization (J kg-1) - LH_sub, & ! latent heat of sublimation (J kg-1) - iden_air, & ! intrinsic density of air (kg m-3) iden_ice, & ! intrinsic density of ice (kg m-3) iden_water ! intrinsic density of water (kg m-3) @@ -97,19 +92,21 @@ subroutine volicePack(& ! initialize error control err=0; message='volicePack/' - ! divide snow layers if too thick - call layerDivide(& - ! input/output: model data structures - model_decisions, & ! intent(in): model decisions - mpar_data, & ! intent(in): model parameters - indx_data, & ! intent(inout): type of each layer - prog_data, & ! intent(inout): model prognostic variables for a local HRU - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - flux_data, & ! intent(inout): model fluxes for a local HRU - ! output - divideLayer, & ! intent(out): flag to denote that layers were modified - err,cmessage) ! intent(out): error control - if(err/=0)then; err=65; message=trim(message)//trim(cmessage); return; end if + ! divide snow layers if too thick, don't do it if need to merge + if (.not.tooMuchMelt)then + call layerDivide(& + ! input/output: model data structures + model_decisions, & ! intent(in): model decisions + mpar_data, & ! intent(in): model parameters + indx_data, & ! intent(inout): type of each layer + prog_data, & ! intent(inout): model prognostic variables for a local HRU + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + flux_data, & ! intent(inout): model fluxes for a local HRU + ! output + divideLayer, & ! intent(out): flag to denote that layers were modified + err,cmessage) ! intent(out): error control + if(err/=0)then; err=65; message=trim(message)//trim(cmessage); return; end if + endif ! merge snow layers if they are too thin call layerMerge(& @@ -153,10 +150,10 @@ subroutine newsnwfall(& ! input/output: state variables scalarSWE, & ! SWE (kg m-2) scalarSnowDepth, & ! total snow depth (m) - surfaceLayerTemp, & ! temperature of each layer (K) - surfaceLayerDepth, & ! depth of each layer (m) - surfaceLayerVolFracIce, & ! volumetric fraction of ice in each layer (-) - surfaceLayerVolFracLiq, & ! volumetric fraction of liquid water in each layer (-) + surfaceLayerTemp, & ! temperature of surface layer (K) + surfaceLayerDepth, & ! depth of surface layer (m) + surfaceLayerVolFracIce, & ! volumetric fraction of ice in surface layer (-) + surfaceLayerVolFracLiq, & ! volumetric fraction of liquid water in surface layer (-) ! output: error control err,message ) ! error control ! computational modules @@ -165,7 +162,7 @@ subroutine newsnwfall(& implicit none ! input: model control real(rkind),intent(in) :: dt ! time step (seconds) - logical(lgt),intent(in) :: snowLayers ! logical flag if snow layers exist + logical(lgt),intent(in) :: snowLayers ! logical flag if snow layers exist real(rkind),intent(in) :: fc_param ! freeezing curve parameter for snow (K-1) ! input: diagnostic scalar variables real(rkind),intent(in) :: scalarSnowfallTemp ! computed temperature of fresh snow (K) @@ -175,13 +172,13 @@ subroutine newsnwfall(& ! input/output: state variables real(rkind),intent(inout) :: scalarSWE ! SWE (kg m-2) real(rkind),intent(inout) :: scalarSnowDepth ! total snow depth (m) - real(rkind),intent(inout) :: surfaceLayerTemp ! temperature of each layer (K) + real(rkind),intent(inout) :: surfaceLayerTemp ! temperature of surface layer (K) real(rkind),intent(inout) :: surfaceLayerDepth ! depth of each layer (m) - real(rkind),intent(inout) :: surfaceLayerVolFracIce ! volumetric fraction of ice in each layer (-) - real(rkind),intent(inout) :: surfaceLayerVolFracLiq ! volumetric fraction of liquid water in each layer (-) + real(rkind),intent(inout) :: surfaceLayerVolFracIce ! volumetric fraction of ice in surface layer (-) + real(rkind),intent(inout) :: surfaceLayerVolFracLiq ! volumetric fraction of liquid water in surface layer (-) ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message ! define local variables real(rkind) :: newSnowfall ! new snowfall -- throughfall and unloading (kg m-2 s-1) real(rkind) :: newSnowDepth ! new snow depth (m) @@ -194,7 +191,7 @@ subroutine newsnwfall(& real(rkind) :: tempSWE0 ! temporary SWE before snowfall, used to check mass balance (kg m-2) real(rkind) :: tempSWE1 ! temporary SWE after snowfall, used to check mass balance (kg m-2) real(rkind) :: xMassBalance ! mass balance check (kg m-2) - real(rkind),parameter :: verySmall=1.e-8_rkind ! a very small number -- used to check mass balance + real(rkind),parameter :: massBalTol=1.e-8_rkind ! tolerance for mass balance check (kg m-2) ! initialize error control err=0; message="newsnwfall/" @@ -223,9 +220,6 @@ subroutine newsnwfall(& totalMassIceSurfLayer = iden_ice*surfaceLayerVolFracIce*surfaceLayerDepth + newSnowfall*dt ! get the total snow depth totalDepthSurfLayer = surfaceLayerDepth + newSnowDepth - !write(*,'(a,1x,10(f20.10,1x))') 'scalarSnowfallTemp, surfaceLayerTemp, newSnowDepth, surfaceLayerDepth, tempSWE0, totalMassIceSurfLayer/totalDepthSurfLayer = ', & - ! scalarSnowfallTemp, surfaceLayerTemp, newSnowDepth, surfaceLayerDepth, tempSWE0, totalMassIceSurfLayer/totalDepthSurfLayer - ! compute the new temperature surfaceLayerTemp = (surfaceLayerTemp*surfaceLayerDepth + scalarSnowfallTemp*newSnowDepth) / totalDepthSurfLayer ! compute new SWE for the upper layer (kg m-2) @@ -243,7 +237,7 @@ subroutine newsnwfall(& ! check SWE xMassBalance = tempSWE1 - (tempSWE0 + newSnowfall*dt) - if (abs(xMassBalance) > verySmall)then + if (abs(xMassBalance) > massBalTol)then write(*,'(a,1x,f20.10)') 'SWE mass balance = ', xMassBalance message=trim(message)//'mass balance problem' err=20; return diff --git a/build/source/hookup/ascii_util.f90 b/build/source/hookup/ascii_util.f90 old mode 100755 new mode 100644 index da8a3ea5b..b28768526 --- a/build/source/hookup/ascii_util.f90 +++ b/build/source/hookup/ascii_util.f90 @@ -77,22 +77,22 @@ subroutine split_line(inline,words,err,message) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! declare local variables - integer(i4b),parameter :: cLen=8192 - character(len=cLen) :: temp ! temporary line of characters - integer(i4b) :: iword ! loop through words - integer(i4b),parameter :: maxWords=1000 ! maximum number of words in a line - integer(i4b) :: i1 ! index at the start of a given word - character(len=256) :: cword ! the current word - integer(i4b) :: nWords ! number of words in the character string + integer(i4b),parameter :: cLen=8192 + character(len=cLen) :: temp ! temporary line of characters + integer(i4b) :: iword ! loop through words + integer(i4b),parameter :: maxWords=1000 ! maximum number of words in a line + integer(i4b) :: i1 ! index at the start of a given word + character(len=256) :: cword ! the current word + integer(i4b) :: nWords ! number of words in the character string ! define pointers for linked list type node - character(len=256) :: chardat - integer(i4b) :: ix - type(node),pointer :: next=>null() + character(len=256) :: chardat + integer(i4b) :: ix + type(node),pointer :: next=>null() end type node - type(node),pointer :: list=>null() - type(node),pointer :: current=>null() - type(node),pointer :: previous=>null() + type(node),pointer :: list=>null() + type(node),pointer :: current=>null() + type(node),pointer :: previous=>null() ! start procedure here err=0; message='split_line/' temp=inline ! initialize string of characters @@ -131,60 +131,70 @@ end subroutine split_line ! ********************************************************************************************************* ! public subroutine get_vlines: get valid lines of data from file and store as a vector of charater strings ! ********************************************************************************************************* - subroutine get_vlines(unt,vlines,err,message) - ! do not know how many valid lines, so use linked lists - implicit none - ! declare dummy arguments - integer(i4b),intent(in) :: unt ! file unit - character(len=linewidth),intent(out),allocatable :: vlines(:) ! vector of character strings - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! declare local variables - integer(i4b) :: iline ! loop through lines in the file - integer(i4b),parameter :: maxLines=1000000 ! maximum number of valid lines in a file - character(len=2048) :: temp ! character data or a given line - integer(i4b) :: icount ! counter for the valid lines - integer(i4b) :: iend ! index to indicate end of the file - ! define pointers for linked list - type node - character(len=2048) :: chardat - integer(i4b) :: ix - type(node),pointer :: next=>null() - end type node - type(node),pointer :: list=>null() - type(node),pointer :: current=>null() - type(node),pointer :: previous=>null() - ! start procedure here - err=0; message='get_vlines/' - ! ***** get the valid lines of data from the file and store in linked lists ***** - icount=0 ! initialize the counter for the valid lines - do iline=1,maxLines - read(unt,'(a)',iostat=iend)temp; if(iend/=0)exit ! read line of data - if (temp(1:1)=='!' .or. temp == '')cycle ! skip comment and empty lines - icount = icount+1 - ! add the variable to the linked list - if(.not.associated(list))then - allocate(list,previous,current); list=node(temp,icount,null()) - current=>list - else - allocate(current%next) - current%next=node(temp,icount,null()) - current=>current%next - end if - if (iline==maxLines)then; err=20; message=trim(message)//"exceedMaxLines"; return; end if - end do ! looping through the lines in the file (exit clause above will kick in) - ! ***** allocate space for the valid lines ***** - allocate(vlines(icount),stat=err) - if(err/=0)then; err=30; message=trim(message)//"problemAllocateVlines"; return; end if - ! ***** save the list in a vector, and deallocate space as we go... ***** - current=>list - do while(associated(current)) - vlines(current%ix) = current%chardat - previous=>current; current=>current%next - deallocate(previous) - end do - if(associated(list)) nullify(list) - end subroutine get_vlines +subroutine get_vlines(unt,vlines,err,message) + ! do not know how many valid lines, so use linked lists + implicit none + ! declare dummy arguments + integer(i4b),intent(in) :: unt ! file unit + character(len=linewidth),intent(out),allocatable :: vlines(:) ! vector of character strings + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! declare local variables + integer(i4b) :: iline ! loop through lines in the file + integer(i4b),parameter :: maxLines=1000000 ! maximum number of valid lines in a file + character(len=2048) :: temp ! character data or a given line + integer(i4b) :: icount ! counter for the valid lines + integer(i4b) :: iend ! index to indicate end of the file + character(len=2048),dimension(:),allocatable :: tempArray + ! define pointers for linked list + type node + character(len=2048) :: chardat + integer(i4b) :: ix + type(node),pointer :: next=>null() + end type node + ! type(node),pointer :: list=>null() + ! type(node),pointer :: current=>null() + ! type(node),pointer :: previous=>null() + ! start procedure here + err=0; message='get_vlines/' + allocate(tempArray(1000)) + ! ***** get the valid lines of data from the file and store in linked lists ***** + icount=0 ! initialize the counter for the valid lines + do iline=1,maxLines + read(unt,'(a)',iostat=iend)temp; if(iend/=0)exit ! read line of data + if (temp(1:1)=='!' .or. temp == '')cycle ! skip comment and empty lines + icount = icount+1 + ! add the variable to the linked list + ! if(.not.associated(list))then + ! allocate(list) + ! allocate(current) + ! allocate(previous) + ! list=node(temp,icount,null()) + ! current=>list + ! else + ! allocate(current%next) + ! current%next=node(temp,icount,null()) + ! current=>current%next + ! end if + tempArray(icount) = temp + if (iline==maxLines)then; err=20; message=trim(message)//"exceedMaxLines"; return; end if + end do ! looping through the lines in the file (exit clause above will kick in) + ! ***** allocate space for the valid lines ***** + allocate(vlines(icount),stat=err) + if(err/=0)then; err=30; message=trim(message)//"problemAllocateVlines"; return; end if + ! ***** save the list in a vector, and deallocate space as we go... ***** + do iline=1, icount + vlines(iline) = tempArray(iline) + end do + ! current=>list + ! do while(associated(current)) + ! ! vlines(current%ix) = current%chardat + ! previous=>current; current=>current%next + ! deallocate(previous) + ! end do + ! if(associated(list)) nullify(list) + deallocate(tempArray) +end subroutine get_vlines end module ascii_util_module diff --git a/build/source/hookup/summaFileManager.f90 b/build/source/hookup/summaFileManager.f90 old mode 100755 new mode 100644 index 3170a12d4..afb27405b --- a/build/source/hookup/summaFileManager.f90 +++ b/build/source/hookup/summaFileManager.f90 @@ -56,100 +56,101 @@ MODULE summaFileManager contains - ! ************************************************************************************************** - ! public subroutine summa_SetTimesDirsAndFiles: Sets times, directories and filenames for summa run - ! ************************************************************************************************** - subroutine summa_SetTimesDirsAndFiles(summaFileManagerIn,err,message) - ! Purpose: Sets run times, directories and filenames for summa. - ! --- - USE ascii_util_module,only:file_open ! function to open file - USE ascii_util_module,only:linewidth ! max character number for one line - USE ascii_util_module,only:get_vlines ! function to get a vector of non-comment lines +! ************************************************************************************************** +! public subroutine summa_SetTimesDirsAndFiles: Sets times, directories and filenames for summa run +! ************************************************************************************************** +subroutine summa_SetTimesDirsAndFiles(summaFileManagerIn,err,message) + ! Purpose: Sets run times, directories and filenames for summa. + ! --- + USE ascii_util_module,only:file_open ! function to open file + USE ascii_util_module,only:linewidth ! max character number for one line + USE ascii_util_module,only:get_vlines ! function to get a vector of non-comment lines - implicit none + implicit none - ! input/output vars - character(*),intent(in) :: summaFileManagerIn - integer(i4b),intent(out) :: err - character(*),intent(out) :: message - ! local vars - character(*),parameter :: summaFileManagerHeader='SUMMA_FILE_MANAGER_V3.0.0' - integer(i4b),parameter :: runinfo_fileunit=67 ! file unit for run time information - character(len=8) :: cdate - character(len=10) :: ctime - character(len=256) :: cmessage ! error message for downwind routine - integer(i4b) :: unt ! file unit (free unit output from file_open) - character(LEN=linewidth),allocatable :: charline(:) ! vector of character strings - integer(i4b) :: iControl, nControl ! number of model info - character(len=summaPathLen) :: varEntry ! name of model info - character(len=32) :: option ! option for model info + ! input/output vars + character(*),intent(in) :: summaFileManagerIn + integer(i4b),intent(out) :: err + character(*),intent(out) :: message + ! local vars + character(*),parameter :: summaFileManagerHeader='SUMMA_FILE_MANAGER_V3.0.0' + integer(i4b),parameter :: runinfo_fileunit=67 ! file unit for run time information + character(len=8) :: cdate + character(len=10) :: ctime + character(len=256) :: cmessage ! error message for downwind routine + integer(i4b) :: unt ! file unit (free unit output from file_open) + character(LEN=linewidth),allocatable :: charline(:) ! vector of character strings + integer(i4b) :: iControl, nControl ! number of model info + character(len=summaPathLen) :: varEntry ! name of model info + character(len=32) :: option ! option for model info - err=0; message="summa_SetTimesDirsAndFiles/" + err=0; message="summa_SetTimesDirsAndFiles/" - ! read information from model control file, and populate model control structure - ! populates global control information structure + ! read information from model control file, and populate model control structure + ! populates global control information structure - ! open file, read non-comment lines, close file - call file_open(trim(summaFileManagerIn),unt,err,cmessage) - if(err/=0) then; message=trim(message)//trim(cmessage)//"/Failed to open control file [''"//trim(summaFileManagerIn)//"']"; err=-10; return; end if - call get_vlines(unt,charline,err,cmessage) ! 'charline' is a list of strings from non-comment lines - if(err/=0) then; message=trim(message)//trim(cmessage)//"/Control file read issue in get_vlines()"; return; end if - close(unt) + ! open file, read non-comment lines, close file + call file_open(trim(summaFileManagerIn),unt,err,cmessage) + if(err/=0) then; message=trim(message)//trim(cmessage)//"/Failed to open control file [''"//trim(summaFileManagerIn)//"']"; err=-10; return; end if + call get_vlines(unt,charline,err,cmessage) ! 'charline' is a list of strings from non-comment lines + if(err/=0) then; message=trim(message)//trim(cmessage)//"/Control file read issue in get_vlines()"; return; end if + close(unt) - ! get the number of model control file entries - nControl = size(charline) + ! get the number of model control file entries + nControl = size(charline) - ! populate the model control info structure - do iControl=1,nControl - ! extract name of decision and the decision selected - read(charline(iControl),*,iostat=err) option, varEntry - if (err/=0) then; err=30; message=trim(message)//"error reading charline array"; return; end if - ! get the index of the control file entry in the data structure - write(*,'(i4,1x,a)') iControl, trim(option)//': '//trim(varEntry) + ! populate the model control info structure + do iControl=1,nControl + ! extract name of decision and the decision selected + read(charline(iControl),*,iostat=err) option, varEntry + if (err/=0) then; err=30; message=trim(message)//"error reading charline array"; return; end if + ! get the index of the control file entry in the data structure +#ifndef NGEN_ACTIVE + write(*,'(i4,1x,a)') iControl, trim(option)//': '//trim(varEntry) +#endif + ! assign entries from control file to module public variables; add checking as needed + select case(trim(option)) + case('controlVersion' ); + CONTROL_VRS = trim(varEntry); + if(trim(varEntry)/=trim(summaFileManagerHeader)) then + message=trim(message)//"unknown control file version in '"//trim(summaFileManagerIn)//" looking for "//trim(summaFileManagerHeader) + err=20 + return + end if + case('simStartTime' ); SIM_START_TM = trim(varEntry) ! start simulation time + case('simEndTime' ); SIM_END_TM = trim(varEntry) ! end simulation time + case('tmZoneInfo' ); NC_TIME_ZONE = trim(varEntry) ! time zone info + case('settingsPath' ); SETTINGS_PATH = trim(varEntry) ! settings directory + case('forcingPath' ); FORCING_PATH = trim(varEntry) ! input forcing directory + case('outputPath' ); OUTPUT_PATH = trim(varEntry) ! output directory + case('statePath' ); STATE_PATH = trim(varEntry) ! state file input/output directory + case('decisionsFile' ); M_DECISIONS = trim(varEntry) ! model decisions file + case('outputControlFile' ); OUTPUT_CONTROL = trim(varEntry) ! output control file + case('globalHruParamFile' ); LOCALPARAM_INFO = trim(varEntry) ! default/global hru-level param file + case('globalGruParamFile' ); BASINPARAM_INFO = trim(varEntry) ! default/global gru-level param file + case('attributeFile' ); LOCAL_ATTRIBUTES = trim(varEntry) ! attribute file + case('trialParamFile' ); PARAMETER_TRIAL = trim(varEntry) ! trial parameters file (hru and/or gru) + case('vegTableFile' ); VEGPARM = trim(varEntry) ! vegetation parameter table + case('soilTableFile' ); SOILPARM = trim(varEntry) ! soil parameter table + case('generalTableFile' ); GENPARM = trim(varEntry) ! general parameter table + case('noahmpTableFile' ); MPTABLE = trim(varEntry) ! noah mp parameter table + case('forcingListFile' ); FORCING_FILELIST = trim(varEntry) ! file listing forcing filenames + case('initConditionFile' ); MODEL_INITCOND = trim(varEntry) ! initial conditions file (cold State) + case('outFilePrefix' ); OUTPUT_PREFIX = trim(varEntry) ! filename root for output files + ! get to here if cannot find the variable + case default + err=10; message=trim(message)//"unknown control file option: "//trim(option); return + end select + end do - ! assign entries from control file to module public variables; add checking as needed - select case(trim(option)) - case('controlVersion' ); - CONTROL_VRS = trim(varEntry); - if(trim(varEntry)/=trim(summaFileManagerHeader)) then - message=trim(message)//"unknown control file version in '"//trim(summaFileManagerIn)//" looking for "//trim(summaFileManagerHeader) - err=20 - return - end if - case('simStartTime' ); SIM_START_TM = trim(varEntry) ! start simulation time - case('simEndTime' ); SIM_END_TM = trim(varEntry) ! end simulation time - case('tmZoneInfo' ); NC_TIME_ZONE = trim(varEntry) ! time zone info - case('settingsPath' ); SETTINGS_PATH = trim(varEntry) ! settings directory - case('forcingPath' ); FORCING_PATH = trim(varEntry) ! input forcing directory - case('outputPath' ); OUTPUT_PATH = trim(varEntry) ! output directory - case('statePath' ); STATE_PATH = trim(varEntry) ! state file input/output directory - case('decisionsFile' ); M_DECISIONS = trim(varEntry) ! model decisions file - case('outputControlFile' ); OUTPUT_CONTROL = trim(varEntry) ! output control file - case('globalHruParamFile' ); LOCALPARAM_INFO = trim(varEntry) ! default/global hru-level param file - case('globalGruParamFile' ); BASINPARAM_INFO = trim(varEntry) ! default/global gru-level param file - case('attributeFile' ); LOCAL_ATTRIBUTES = trim(varEntry) ! attribute file - case('trialParamFile' ); PARAMETER_TRIAL = trim(varEntry) ! trial parameters file (hru and/or gru) - case('vegTableFile' ); VEGPARM = trim(varEntry) ! vegetation parameter table - case('soilTableFile' ); SOILPARM = trim(varEntry) ! soil parameter table - case('generalTableFile' ); GENPARM = trim(varEntry) ! general parameter table - case('noahmpTableFile' ); MPTABLE = trim(varEntry) ! noah mp parameter table - case('forcingListFile' ); FORCING_FILELIST = trim(varEntry) ! file listing forcing filenames - case('initConditionFile' ); MODEL_INITCOND = trim(varEntry) ! initial conditions file (cold State) - case('outFilePrefix' ); OUTPUT_PREFIX = trim(varEntry) ! filename root for output files - ! get to here if cannot find the variable - case default - err=10; message=trim(message)//"unknown control file option: "//trim(option); return - end select - end do + ! before embarking on a run, check that the output directory is writable; write system date and time to a log file there + open(runinfo_fileunit,file=trim(OUTPUT_PATH)//"runinfo.txt",iostat=err) + if(err/=0)then; err=10; message=trim(message)//"cannot write to output directory '"//trim(OUTPUT_PATH)//"'"; return; end if + call date_and_time(cdate,ctime) + write(runinfo_fileunit,*) 'Run start time on system: ccyy='//cdate(1:4)//' - mm='//cdate(5:6)//' - dd='//cdate(7:8), & + ' - hh='//ctime(1:2)//' - mi='//ctime(3:4)//' - ss='//ctime(5:10) + close(runinfo_fileunit) - ! before embarking on a run, check that the output directory is writable; write system date and time to a log file there - open(runinfo_fileunit,file=trim(OUTPUT_PATH)//"runinfo.txt",iostat=err) - if(err/=0)then; err=10; message=trim(message)//"cannot write to output directory '"//trim(OUTPUT_PATH)//"'"; return; end if - call date_and_time(cdate,ctime) - write(runinfo_fileunit,*) 'Run start time on system: ccyy='//cdate(1:4)//' - mm='//cdate(5:6)//' - dd='//cdate(7:8), & - ' - hh='//ctime(1:2)//' - mi='//ctime(3:4)//' - ss='//ctime(5:10) - close(runinfo_fileunit) - - end subroutine summa_SetTimesDirsAndFiles +end subroutine summa_SetTimesDirsAndFiles END MODULE summaFileManager diff --git a/build/source/lapack/Makefile b/build/source/lapack/Makefile deleted file mode 100755 index 2d59c7114..000000000 --- a/build/source/lapack/Makefile +++ /dev/null @@ -1,74 +0,0 @@ -#======================================================================== -# PART 0: Define directory paths -#======================================================================== - -# Define core directory below which everything resides. This is the -# parent directory of the 'build' directory -F_MASTER = /home/mclark/summa - -# Core directory that contains source code -F_KORE_DIR = $(F_MASTER)/build/source - -# Location of the compiled modules -MOD_PATH = $(F_MASTER)/build/source/lapack - -# Define the directory for the executables -EXE_PATH = $(F_MASTER)/build/source/lapack - -#======================================================================== -# PART 1: Assemble all of the sub-routines -#======================================================================== - -# Define directories -NUMREC_DIR = $(F_KORE_DIR)/numrec -LAPACK_DIR = $(F_KORE_DIR)/lapack - -# -# Numerical Recipes utilities -SUMMA_NRUTIL= \ - nrtype.f90 -NRUTIL = $(patsubst %, $(NUMREC_DIR)/%, $(SUMMA_NRUTIL)) - -# numerical recipes routines -SUMMA_NUMREC= \ - luSolv_numrec.f90 -NUMREC = $(patsubst %, $(LAPACK_DIR)/%, $(SUMMA_NUMREC)) - -# ... stitch together all programs -LUTEST = $(NRUTIL) $(NUMREC) - -#======================================================================== -# PART 2: Define the libraries, driver programs, and executables -#======================================================================== - -# Define the Fortran Compiler -FC = ifort - -# Define the lapack library -LAPK_PATH = /usr -LIBLAPACK = -L$(LAPK_PATH)/lib -llapack - -DRIVER = test_lusolve.f90 - -# Define the executable -DRIVER__EX = test_lusolve.exe - - -#======================================================================== -# PART 3: Compile the puppy -#======================================================================== - -# Define flags -FLAGS = -debug -warn all -check all -FR -O0 -auto -WB -traceback -g -fltconsistency -fpe0 - -all: compile link clean - -compile: - $(FC) $(FLAGS) -c $(LUTEST) $(DRIVER) - -link: - $(FC) *.o $(LIBLAPACK) -o $(DRIVER__EX) - -clean: - rm -f *.o - rm -f *.mod diff --git a/build/source/lapack/README b/build/source/lapack/README deleted file mode 100755 index c7fe5ddb9..000000000 --- a/build/source/lapack/README +++ /dev/null @@ -1 +0,0 @@ -Used to test the lapack routines diff --git a/build/source/netcdf/def_output.f90 b/build/source/netcdf/def_output.f90 old mode 100755 new mode 100644 index c56a5a6b5..264642261 --- a/build/source/netcdf/def_output.f90 +++ b/build/source/netcdf/def_output.f90 @@ -30,6 +30,7 @@ module def_output_module implicit none private public :: def_output +public :: write_hru_info ! define dimension names character(len=32),parameter :: gru_DimName = 'gru' ! dimension name for the GRUs @@ -153,23 +154,24 @@ subroutine def_output(summaVersion,buildTime,gitBranch,gitHash,nGRU,nHRU,nSoil,i ! define variables do iStruct = 1,size(structInfo) select case (trim(structInfo(iStruct)%structName)) - case('attr' ); call def_variab(ncid(iFreq),iFreq,needHRU, noTime,attr_meta, outputPrecision, err,cmessage) ! local attributes HRU - case('type' ); call def_variab(ncid(iFreq),iFreq,needHRU, noTime,type_meta, nf90_int, err,cmessage) ! local classification - case('mpar' ); call def_variab(ncid(iFreq),iFreq,needHRU, noTime,mpar_meta, outputPrecision, err,cmessage) ! model parameters - case('bpar' ); call def_variab(ncid(iFreq),iFreq,needGRU, noTime,bpar_meta, outputPrecision, err,cmessage) ! basin-average param - case('indx' ); call def_variab(ncid(iFreq),iFreq,needHRU,needTime,indx_meta, nf90_int, err,cmessage) ! model variables - case('deriv'); call def_variab(ncid(iFreq),iFreq,needHRU,needTime,deriv_meta,outputPrecision, err,cmessage) ! model derivatives - case('time' ); call def_variab(ncid(iFreq),iFreq, noHRU,needTime,time_meta, nf90_int, err,cmessage) ! model derivatives - case('forc' ); call def_variab(ncid(iFreq),iFreq,needHRU,needTime,forc_meta, outputPrecision, err,cmessage) ! model forcing data - case('prog' ); call def_variab(ncid(iFreq),iFreq,needHRU,needTime,prog_meta, outputPrecision, err,cmessage) ! model prognostics - case('diag' ); call def_variab(ncid(iFreq),iFreq,needHRU,needTime,diag_meta, outputPrecision, err,cmessage) ! model diagnostic variables - case('flux' ); call def_variab(ncid(iFreq),iFreq,needHRU,needTime,flux_meta, outputPrecision, err,cmessage) ! model fluxes - case('bvar' ); call def_variab(ncid(iFreq),iFreq,needGRU,needTime,bvar_meta, outputPrecision, err,cmessage) ! basin-average variables - case('id' ); cycle ! ids -- see write_hru_info() + case('attr' ); call def_variab(ncid(iFreq),iFreq,needHRU, noTime,attr_meta, outputPrecision, err,cmessage) ! local attributes HRU + case('type' ); call def_variab(ncid(iFreq),iFreq,needHRU, noTime,type_meta, nf90_int, err,cmessage) ! local classification + case('mpar' ); call def_variab(ncid(iFreq),iFreq,needHRU, noTime,mpar_meta, outputPrecision, err,cmessage) ! model parameters + case('bpar' ); call def_variab(ncid(iFreq),iFreq,needGRU, noTime,bpar_meta, outputPrecision, err,cmessage) ! basin-average param + case('indx' ); call def_variab(ncid(iFreq),iFreq,needHRU,needTime,indx_meta, nf90_int, err,cmessage) ! model variables + case('deriv' ); call def_variab(ncid(iFreq),iFreq,needHRU,needTime,deriv_meta,outputPrecision, err,cmessage) ! model derivatives + case('time' ); call def_variab(ncid(iFreq),iFreq, noHRU,needTime,time_meta, nf90_int, err,cmessage) ! model derivatives + case('forc' ); call def_variab(ncid(iFreq),iFreq,needHRU,needTime,forc_meta, outputPrecision, err,cmessage) ! model forcing data + case('prog' ); call def_variab(ncid(iFreq),iFreq,needHRU,needTime,prog_meta, outputPrecision, err,cmessage) ! model prognostics + case('diag' ); call def_variab(ncid(iFreq),iFreq,needHRU,needTime,diag_meta, outputPrecision, err,cmessage) ! model diagnostic variables + case('flux' ); call def_variab(ncid(iFreq),iFreq,needHRU,needTime,flux_meta, outputPrecision, err,cmessage) ! model fluxes + case('bvar' ); call def_variab(ncid(iFreq),iFreq,needGRU,needTime,bvar_meta, outputPrecision, err,cmessage) ! basin-average variables + case('id' ); cycle ! ids -- see write_hru_info() + case('lookup'); cycle ! ids -- see write_hru_info() case default; err=20; message=trim(message)//'unable to identify lookup structure'; end select ! error handling - if(err/=0)then;err=20;message=trim(message)//trim(cmessage)//'[structure = '//trim(structInfo(iStruct)%structName);return;end if + if(err/=0)then;err=20;message=trim(message)//'[structure = '//trim(structInfo(iStruct)%structName);return;end if end do ! iStruct ! write HRU dimension and ID for each output file @@ -220,8 +222,8 @@ subroutine ini_create(nGRU,nHRU,nSoil,infile,ncid,err,message) message='iCreate[create]'; call netcdf_err(err,message); if (err/=0) return ! create dimensions - err = nf90_def_dim(ncid, trim( gru_DimName), nGRU, gru_DimID); message='iCreate[GRU]'; call netcdf_err(err,message); if (err/=0) return - err = nf90_def_dim(ncid, trim( hru_DimName), nHRU, hru_DimID); message='iCreate[HRU]'; call netcdf_err(err,message); if (err/=0) return + err = nf90_def_dim(ncid, trim( gru_DimName), nGRU, gru_DimID); message='iCreate[gru]'; call netcdf_err(err,message); if (err/=0) return + err = nf90_def_dim(ncid, trim( hru_DimName), nHRU, hru_DimID); message='iCreate[hru]'; call netcdf_err(err,message); if (err/=0) return err = nf90_def_dim(ncid, trim(timestep_DimName), nf90_unlimited, timestep_DimID); message='iCreate[time]'; call netcdf_err(err,message); if (err/=0) return err = nf90_def_dim(ncid, trim( depth_DimName), nSoil, depth_DimID); message='iCreate[depth]'; call netcdf_err(err,message); if (err/=0) return err = nf90_def_dim(ncid, trim( scalar_DimName), scalarLength, scalar_DimID); message='iCreate[scalar]'; call netcdf_err(err,message); if (err/=0) return @@ -268,12 +270,12 @@ end subroutine put_attrib subroutine def_variab(ncid,iFreq,spatialDesire,timeDesire,metaData,ivtype,err,message) USE var_lookup,only:iLookvarType ! look up structure for variable typed USE data_types,only:var_info ! derived type for metaData - USE var_lookup,only:iLookStat ! index into stats structure + USE var_lookup,only:iLookSTAT ! index into stats structure USE var_lookup,only:maxVarFreq ! # of available output frequencies USE get_ixName_module,only:get_varTypeName ! to access type strings for error messages USE get_ixname_module,only:get_statName ! statistics names for variable defs in output file - USE globalData,only:nHRUrun - USE globalData,only:nGRUrun + USE globalData,only:nHRUrun ! number of HRUs in the current run + USE globalData,only:nGRUrun ! number of GRUs in the current run implicit none ! input integer(i4b) ,intent(in) :: ncid ! netcdf file id @@ -365,7 +367,7 @@ subroutine def_variab(ncid,iFreq,spatialDesire,timeDesire,metaData,ivtype,err,me iStat = metaData(iVar)%statIndex(iFreq) ! create full variable name (append statistics info) - if(iStat==iLookStat%inst)then + if(iStat==iLookSTAT%inst)then catName = trim(metaData(iVar)%varName) else catName = trim(metaData(iVar)%varName)//'_'//trim(get_statName(iStat)) @@ -385,7 +387,7 @@ subroutine def_variab(ncid,iFreq,spatialDesire,timeDesire,metaData,ivtype,err,me ! modify units for the summation catName = trim(metaData(iVar)%varunit) - if (iStat==iLookStat%totl) then + if (iStat==iLookSTAT%totl) then ! make sure that the units of this variable allow for integration if ((index(catName,'s-1')<=0).and.(index(catName,'s-2')<=0).and.(index(catName,'W m-2')<=0)) then @@ -422,7 +424,7 @@ subroutine def_variab(ncid,iFreq,spatialDesire,timeDesire,metaData,ivtype,err,me end subroutine def_variab ! ********************************************************************************************************** - ! internal subroutine write_hru_info: write HRU dimension and IDs + ! public subroutine write_hru_info: write HRU dimension and IDs ! ********************************************************************************************************** subroutine write_hru_info(ncid, err, message) use globalData,only:gru_struc ! gru-hru mapping structures @@ -435,9 +437,9 @@ subroutine write_hru_info(ncid, err, message) integer(i4b) :: iHRU ! local HRU index integer(i4b) :: iGRU ! GRU index integer(i4b) :: hruVarID ! hru varID in netcdf file - integer(i4b) :: gruVarID ! hru varID in netcdf file - integer(i4b) :: hruIdVarID ! hruId varID in netcdf file - integer(i4b) :: gruIdVarID ! gruId varID in netcdf file + integer(i4b) :: gruVarID ! gru varID in netcdf file + integer(i4b) :: hruIdVarID ! hruId varID in netcdf file, non-sequential HRU ID + integer(i4b) :: gruIdVarID ! gruId varID in netcdf file, non-sequential GRU ID ! initialize error control err=0; message='write_hru_info/' @@ -446,22 +448,22 @@ subroutine write_hru_info(ncid, err, message) err = nf90_redef(ncid); call netcdf_err(err, message); if (err/=nf90_NoErr) return ! define HRU var - err = nf90_def_var(ncid, trim(hru_DimName), nf90_int64, hru_DimID, hruVarID, deflate_level=outputCompressionLevel); if (err/=nf90_NoErr) then; message=trim(message)//'nf90_define_hruVar' ; call netcdf_err(err,message); return; end if + err = nf90_def_var(ncid, trim(hru_DimName), nf90_int, (/hru_DimID/), hruVarID, deflate_level=outputCompressionLevel); if (err/=nf90_NoErr) then; message=trim(message)//'nf90_define_hruVar' ; call netcdf_err(err,message); return; end if err = nf90_put_att(ncid, hruVarID, 'long_name', 'hruId in the input file'); if (err/=nf90_NoErr) then; message=trim(message)//'write_hruVar_longname'; call netcdf_err(err,message); return; end if err = nf90_put_att(ncid, hruVarID, 'units', '-' ); if (err/=nf90_NoErr) then; message=trim(message)//'write_hruVar_unit'; call netcdf_err(err,message); return; end if ! define GRU var - err = nf90_def_var(ncid, trim(gru_DimName), nf90_int64, gru_DimID, gruVarID, deflate_level=outputCompressionLevel); if (err/=nf90_NoErr) then; message=trim(message)//'nf90_define_gruVar' ; call netcdf_err(err,message); return; end if + err = nf90_def_var(ncid, trim(gru_DimName), nf90_int, (/gru_DimID/), gruVarID, deflate_level=outputCompressionLevel); if (err/=nf90_NoErr) then; message=trim(message)//'nf90_define_gruVar' ; call netcdf_err(err,message); return; end if err = nf90_put_att(ncid, gruVarID, 'long_name', 'gruId in the input file'); if (err/=nf90_NoErr) then; message=trim(message)//'write_gruVar_longname'; call netcdf_err(err,message); return; end if err = nf90_put_att(ncid, gruVarID, 'units', '-' ); if (err/=nf90_NoErr) then; message=trim(message)//'write_gruVar_unit'; call netcdf_err(err,message); return; end if ! define hruId var - err = nf90_def_var(ncid, 'hruId', nf90_int64, hru_DimID, hruIdVarID, deflate_level=outputCompressionLevel); if (err/=nf90_NoErr) then; message=trim(message)//'nf90_define_hruIdVar' ; call netcdf_err(err,message); return; end if + err = nf90_def_var(ncid, 'hruId', nf90_int64, (/hru_DimID/), hruIdVarID, deflate_level=outputCompressionLevel); if (err/=nf90_NoErr) then; message=trim(message)//'nf90_define_hruIdVar' ; call netcdf_err(err,message); return; end if err = nf90_put_att(ncid, hruIdVarID, 'long_name', 'ID defining the hydrologic response unit'); if (err/=nf90_NoErr) then; message=trim(message)//'write_hruIdVar_longname'; call netcdf_err(err,message); return; end if err = nf90_put_att(ncid, hruIdVarID, 'units', '-' ); if (err/=nf90_NoErr) then; message=trim(message)//'write_hruIdVar_unit'; call netcdf_err(err,message); return; end if ! define gruId var - err = nf90_def_var(ncid, 'gruId', nf90_int64, gru_DimID, gruIdVarID, deflate_level=outputCompressionLevel); if (err/=nf90_NoErr) then; message=trim(message)//'nf90_define_gruIdVar' ; call netcdf_err(err,message); return; end if + err = nf90_def_var(ncid, 'gruId', nf90_int64, (/gru_DimID/), gruIdVarID, deflate_level=outputCompressionLevel); if (err/=nf90_NoErr) then; message=trim(message)//'nf90_define_gruIdVar' ; call netcdf_err(err,message); return; end if err = nf90_put_att(ncid, gruIdVarID, 'long_name', 'ID defining the grouped (basin) response unit'); if (err/=nf90_NoErr) then; message=trim(message)//'write_gruIdVar_longname'; call netcdf_err(err,message); return; end if err = nf90_put_att(ncid, gruIdVarID, 'units', '-' ); if (err/=nf90_NoErr) then; message=trim(message)//'write_gruIdVar_unit'; call netcdf_err(err,message); return; end if @@ -472,14 +474,14 @@ subroutine write_hru_info(ncid, err, message) do iGRU = 1, size(gru_struc) ! GRU info - err = nf90_put_var(ncid, gruVarID, gru_struc(iGRU)%gru_id, start=(/iGRU/)) + err = nf90_put_var(ncid, gruVarID, gru_struc(iGRU)%gru_nc, start=(/iGRU/)) if (err/=nf90_NoErr) then; message=trim(message)//'nf90_write_gruVar'; call netcdf_err(err,message); return; end if err = nf90_put_var(ncid, gruIdVarID, gru_struc(iGRU)%gru_id, start=(/iGRU/)) if (err/=nf90_NoErr) then; message=trim(message)//'nf90_write_gruIdVar'; call netcdf_err(err,message); return; end if ! HRU info do iHRU = 1, gru_struc(iGRU)%hruCount - err = nf90_put_var(ncid, hruVarID, gru_struc(iGRU)%hruInfo(iHRU)%hru_id, start=(/gru_struc(iGRU)%hruInfo(iHRU)%hru_ix/)) + err = nf90_put_var(ncid, hruVarID, gru_struc(iGRU)%hruInfo(iHRU)%hru_nc, start=(/gru_struc(iGRU)%hruInfo(iHRU)%hru_ix/)) if (err/=nf90_NoErr) then; message=trim(message)//'nf90_write_hruVar'; call netcdf_err(err,message); return; end if err = nf90_put_var(ncid, hruIdVarID, gru_struc(iGRU)%hruInfo(iHRU)%hru_id, start=(/gru_struc(iGRU)%hruInfo(iHRU)%hru_ix/)) if (err/=nf90_NoErr) then; message=trim(message)//'nf90_write_hruIdVar'; call netcdf_err(err,message); return; end if diff --git a/build/source/netcdf/modelwrite.f90 b/build/source/netcdf/modelwrite.f90 old mode 100755 new mode 100644 index d66e0df02..b59f9fb3a --- a/build/source/netcdf/modelwrite.f90 +++ b/build/source/netcdf/modelwrite.f90 @@ -33,9 +33,6 @@ module modelwrite_module ! provide access to global data USE globalData,only:gru_struc ! gru->hru mapping structure -! netcdf deflate level -USE globalData,only: outputCompressionLevel - ! provide access to the derived types to define the data structures USE data_types,only:& ! final data vectors @@ -43,7 +40,7 @@ module modelwrite_module ilength, & ! var%dat ! no spatial dimension var_i, & ! x%var(:) (i4b) - var_i8, & ! x%var(:) integer(8) + var_i8, & ! x%var(:) (i8b) var_d, & ! x%var(:) (dp) var_ilength, & ! x%var(:)%dat (i4b) var_dlength, & ! x%var(:)%dat (dp) @@ -57,7 +54,7 @@ module modelwrite_module gru_doubleVec, & ! x%gru(:)%var(:)%dat (dp) ! gru+hru dimension gru_hru_int, & ! x%gru(:)%hru(:)%var(:) (i4b) - gru_hru_int8, & ! x%gru(:)%hru(:)%var(:) integer(8) + gru_hru_int8, & ! x%gru(:)%hru(:)%var(:) (i8b) gru_hru_double, & ! x%gru(:)%hru(:)%var(:) (dp) gru_hru_intVec, & ! x%gru(:)%hru(:)%var(:)%dat (i4b) gru_hru_doubleVec ! x%gru(:)%hru(:)%var(:)%dat (dp) @@ -86,8 +83,8 @@ module modelwrite_module subroutine writeParm(ispatial,struct,meta,err,message) USE globalData,only:ncid ! netcdf file ids USE data_types,only:var_info ! metadata info - USE var_lookup,only:iLookStat ! index in statistics vector - USE var_lookup,only:iLookFreq ! index in vector of model output frequencies + USE var_lookup,only:iLookSTAT ! index in statistics vector + USE var_lookup,only:iLookFREQ ! index in vector of model output frequencies implicit none ! declare input variables @@ -115,13 +112,13 @@ subroutine writeParm(ispatial,struct,meta,err,message) if (iSpatial/=integerMissing) then select type (struct) class is (var_i) - err = nf90_put_var(ncid(iLookFreq%timestep),meta(iVar)%ncVarID(iLookFreq%timestep),(/struct%var(iVar)/),start=(/iSpatial/),count=(/1/)) + err = nf90_put_var(ncid(iLookFREQ%timestep),meta(iVar)%ncVarID(iLookFREQ%timestep),(/struct%var(iVar)/),start=(/iSpatial/),count=(/1/)) class is (var_i8) - err = nf90_put_var(ncid(iLookFreq%timestep),meta(iVar)%ncVarID(iLookFreq%timestep),(/struct%var(iVar)/),start=(/iSpatial/),count=(/1/)) + err = nf90_put_var(ncid(iLookFREQ%timestep),meta(iVar)%ncVarID(iLookFREQ%timestep),(/struct%var(iVar)/),start=(/iSpatial/),count=(/1/)) class is (var_d) - err = nf90_put_var(ncid(iLookFreq%timestep),meta(iVar)%ncVarID(iLookFreq%timestep),(/struct%var(iVar)/),start=(/iSpatial/),count=(/1/)) + err = nf90_put_var(ncid(iLookFREQ%timestep),meta(iVar)%ncVarID(iLookFREQ%timestep),(/struct%var(iVar)/),start=(/iSpatial/),count=(/1/)) class is (var_dlength) - err = nf90_put_var(ncid(iLookFreq%timestep),meta(iVar)%ncVarID(iLookFreq%timestep),(/struct%var(iVar)%dat/),start=(/iSpatial,1/),count=(/1,size(struct%var(iVar)%dat)/)) + err = nf90_put_var(ncid(iLookFREQ%timestep),meta(iVar)%ncVarID(iLookFREQ%timestep),(/struct%var(iVar)%dat/),start=(/iSpatial,1/),count=(/1,size(struct%var(iVar)%dat)/)) class default; err=20; message=trim(message)//'unknown variable type (with HRU)'; return end select call netcdf_err(err,message); if (err/=0) return @@ -130,9 +127,9 @@ subroutine writeParm(ispatial,struct,meta,err,message) else select type (struct) class is (var_d) - err = nf90_put_var(ncid(iLookFreq%timestep),meta(iVar)%ncVarID(iLookFreq%timestep),(/struct%var(iVar)/),start=(/1/),count=(/1/)) + err = nf90_put_var(ncid(iLookFREQ%timestep),meta(iVar)%ncVarID(iLookFREQ%timestep),(/struct%var(iVar)/),start=(/1/),count=(/1/)) class is (var_i8) - err = nf90_put_var(ncid(iLookFreq%timestep),meta(iVar)%ncVarID(iLookFreq%timestep),(/struct%var(iVar)/),start=(/1/),count=(/1/)) + err = nf90_put_var(ncid(iLookFREQ%timestep),meta(iVar)%ncVarID(iLookFREQ%timestep),(/struct%var(iVar)/),start=(/1/),count=(/1/)) class default; err=20; message=trim(message)//'unknown variable type (no HRU)'; return end select end if @@ -151,8 +148,8 @@ subroutine writeData(finalizeStats,outputTimestep,nHRUrun,maxLayers,meta,stat,da USE data_types,only:var_info ! metadata type USE var_lookup,only:maxVarStat ! index into stats structure USE var_lookup,only:iLookVarType ! index into type structure - USE var_lookup,only:iLookIndex ! index into index structure - USE var_lookup,only:iLookStat ! index into stat structure + USE var_lookup,only:iLookINDEX ! index into index structure + USE var_lookup,only:iLookSTAT ! index into stat structure USE globalData,only:outFreq,ncid ! output file information USE get_ixName_module,only:get_varTypeName ! to access type strings for error messages USE get_ixName_module,only:get_statName ! to access type strings for error messages @@ -259,9 +256,9 @@ subroutine writeData(finalizeStats,outputTimestep,nHRUrun,maxLayers,meta,stat,da do iHRU=1,gru_struc(iGRU)%hruCount ! get the model layers - nSoil = indx%gru(iGRU)%hru(iHRU)%var(iLookIndex%nSoil)%dat(1) - nSnow = indx%gru(iGRU)%hru(iHRU)%var(iLookIndex%nSnow)%dat(1) - nLayers = indx%gru(iGRU)%hru(iHRU)%var(iLookIndex%nLayers)%dat(1) + nSoil = indx%gru(iGRU)%hru(iHRU)%var(iLookINDEX%nSoil)%dat(1) + nSnow = indx%gru(iGRU)%hru(iHRU)%var(iLookINDEX%nSnow)%dat(1) + nLayers = indx%gru(iGRU)%hru(iHRU)%var(iLookINDEX%nLayers)%dat(1) ! get the length of each data vector select case (meta(iVar)%varType) @@ -392,7 +389,7 @@ end subroutine writeBasin subroutine writeTime(finalizeStats,outputTimestep,meta,dat,err,message) USE data_types,only:var_info ! metadata type USE globalData,only:ncid ! output file IDs - USE var_lookup,only:iLookStat ! index into stat structure + USE var_lookup,only:iLookSTAT ! index into stat structure implicit none ! declare dummy variables @@ -419,7 +416,7 @@ subroutine writeTime(finalizeStats,outputTimestep,meta,dat,err,message) do iVar = 1,size(meta) ! check instantaneous - if (meta(iVar)%statIndex(iFreq)/=iLookStat%inst) cycle + if (meta(iVar)%statIndex(iFreq)/=iLookSTAT%inst) cycle ! get variable id in file err = nf90_inq_varid(ncid(iFreq),trim(meta(iVar)%varName),ncVarID) @@ -467,6 +464,7 @@ subroutine writeRestart(filename, & ! intent(in): name of restart file USE netcdf_util_module,only:nc_file_close ! close netcdf file USE netcdf_util_module,only:nc_file_open ! open netcdf file USE globalData,only:nTimeDelay ! number of timesteps in the time delay histogram + USE def_output_module,only: write_hru_info ! write HRU information to netcdf file implicit none ! -------------------------------------------------------------------------------------------------------- @@ -493,7 +491,6 @@ subroutine writeRestart(filename, & ! intent(in): name of restart file integer(i4b),allocatable :: ncVarID(:) ! netcdf variable id integer(i4b) :: ncSnowID ! index variable id integer(i4b) :: ncSoilID ! index variable id - integer(i4b) :: nSoil ! number of soil layers integer(i4b) :: nSnow ! number of snow layers integer(i4b) :: maxSnow ! maximum number of snow layers @@ -502,7 +499,6 @@ subroutine writeRestart(filename, & ! intent(in): name of restart file integer(i4b),parameter :: nSpectral=2 ! number of spectal bands integer(i4b),parameter :: nScalar=1 ! size of a scalar integer(i4b) :: nProgVars ! number of prognostic variables written to state file - integer(i4b) :: hruDimID ! variable dimension ID integer(i4b) :: gruDimID ! variable dimension ID integer(i4b) :: tdhDimID ! variable dimension ID @@ -514,7 +510,6 @@ subroutine writeRestart(filename, & ! intent(in): name of restart file integer(i4b) :: ifcSnowDimID ! variable dimension ID integer(i4b) :: ifcSoilDimID ! variable dimension ID integer(i4b) :: ifcTotoDimID ! variable dimension ID - character(len=32),parameter :: hruDimName ='hru' ! dimension name for HRUs character(len=32),parameter :: gruDimName ='gru' ! dimension name for GRUs character(len=32),parameter :: tdhDimName ='tdh' ! dimension name for time-delay basin variables @@ -526,7 +521,6 @@ subroutine writeRestart(filename, & ! intent(in): name of restart file character(len=32),parameter :: ifcSnowDimName='ifcSnow' ! dimension name for snow-only layers character(len=32),parameter :: ifcSoilDimName='ifcSoil' ! dimension name for soil-only layers character(len=32),parameter :: ifcTotoDimName='ifcToto' ! dimension name for layered variables - integer(i4b) :: cHRU ! count of HRUs integer(i4b) :: iHRU ! index of HRUs integer(i4b) :: iGRU ! index of GRUs @@ -549,12 +543,12 @@ subroutine writeRestart(filename, & ! intent(in): name of restart file maxSnow = maxSnowLayers ! create file - err = nf90_create(trim(filename),nf90_classic_model,ncid) + err = nf90_create(trim(filename),NF90_NETCDF4,ncid) message='iCreate[create]'; call netcdf_err(err,message); if(err/=0)return ! define dimensions - err = nf90_def_dim(ncid,trim(hruDimName) ,nHRU , hruDimID); message='iCreate[hru]' ; call netcdf_err(err,message); if(err/=0)return err = nf90_def_dim(ncid,trim(gruDimName) ,nGRU , gruDimID); message='iCreate[gru]' ; call netcdf_err(err,message); if(err/=0)return + err = nf90_def_dim(ncid,trim(hruDimName) ,nHRU , hruDimID); message='iCreate[hru]' ; call netcdf_err(err,message); if(err/=0)return err = nf90_def_dim(ncid,trim(tdhDimName) ,nTimeDelay , tdhDimID); message='iCreate[tdh]' ; call netcdf_err(err,message); if(err/=0)return err = nf90_def_dim(ncid,trim(scalDimName) ,nScalar , scalDimID); message='iCreate[scalar]' ; call netcdf_err(err,message); if(err/=0)return err = nf90_def_dim(ncid,trim(specDimName) ,nSpectral , specDimID); message='iCreate[spectral]'; call netcdf_err(err,message); if(err/=0)return @@ -605,14 +599,14 @@ subroutine writeRestart(filename, & ! intent(in): name of restart file err = nf90_put_att(ncid,ncVarID(nProgVars+1),'units' ,trim(bvar_meta(iLookBVAR%routingRunoffFuture)%varunit)); call netcdf_err(err,message) ! define index variables - snow - err = nf90_def_var(ncid,trim(indx_meta(iLookIndex%nSnow)%varName),nf90_int,(/hruDimID/),ncSnowID); call netcdf_err(err,message) - err = nf90_put_att(ncid,ncSnowID,'long_name',trim(indx_meta(iLookIndex%nSnow)%vardesc)); call netcdf_err(err,message) - err = nf90_put_att(ncid,ncSnowID,'units' ,trim(indx_meta(iLookIndex%nSnow)%varunit)); call netcdf_err(err,message) + err = nf90_def_var(ncid,trim(indx_meta(iLookINDEX%nSnow)%varName),nf90_int,(/hruDimID/),ncSnowID); call netcdf_err(err,message) + err = nf90_put_att(ncid,ncSnowID,'long_name',trim(indx_meta(iLookINDEX%nSnow)%vardesc)); call netcdf_err(err,message) + err = nf90_put_att(ncid,ncSnowID,'units' ,trim(indx_meta(iLookINDEX%nSnow)%varunit)); call netcdf_err(err,message) ! define index variables - soil - err = nf90_def_var(ncid,trim(indx_meta(iLookIndex%nSoil)%varName),nf90_int,(/hruDimID/),ncSoilID); call netcdf_err(err,message) - err = nf90_put_att(ncid,ncSoilID,'long_name',trim(indx_meta(iLookIndex%nSoil)%vardesc)); call netcdf_err(err,message) - err = nf90_put_att(ncid,ncSoilID,'units' ,trim(indx_meta(iLookIndex%nSoil)%varunit)); call netcdf_err(err,message) + err = nf90_def_var(ncid,trim(indx_meta(iLookINDEX%nSoil)%varName),nf90_int,(/hruDimID/),ncSoilID); call netcdf_err(err,message) + err = nf90_put_att(ncid,ncSoilID,'long_name',trim(indx_meta(iLookINDEX%nSoil)%vardesc)); call netcdf_err(err,message) + err = nf90_put_att(ncid,ncSoilID,'units' ,trim(indx_meta(iLookINDEX%nSoil)%varunit)); call netcdf_err(err,message) ! end definition phase err = nf90_enddef(ncid); call netcdf_err(err,message); if (err/=0) return @@ -673,8 +667,8 @@ subroutine writeRestart(filename, & ! intent(in): name of restart file end do ! iVar loop ! write index variables - err=nf90_put_var(ncid,ncSnowID,(/indx_data%gru(iGRU)%hru(iHRU)%var(iLookIndex%nSnow)%dat/),start=(/cHRU/),count=(/1/)) - err=nf90_put_var(ncid,ncSoilID,(/indx_data%gru(iGRU)%hru(iHRU)%var(iLookIndex%nSoil)%dat/),start=(/cHRU/),count=(/1/)) + err=nf90_put_var(ncid,ncSnowID,(/indx_data%gru(iGRU)%hru(iHRU)%var(iLookINDEX%nSnow)%dat/),start=(/cHRU/),count=(/1/)) + err=nf90_put_var(ncid,ncSoilID,(/indx_data%gru(iGRU)%hru(iHRU)%var(iLookINDEX%nSoil)%dat/),start=(/cHRU/),count=(/1/)) end do ! iHRU loop @@ -683,6 +677,9 @@ subroutine writeRestart(filename, & ! intent(in): name of restart file end do ! iGRU loop + ! write HRU dimension and ID for file + call write_hru_info(ncid, err, cmessage); if(err/=0) then; message=trim(message)//trim(cmessage); return; end if + ! close file call nc_file_close(ncid,err,cmessage) if(err/=0)then;message=trim(message)//trim(cmessage);return;end if diff --git a/build/source/netcdf/netcdf_util.f90 b/build/source/netcdf/netcdf_util.f90 old mode 100755 new mode 100644 diff --git a/build/source/netcdf/read_icond.f90 b/build/source/netcdf/read_icond.f90 index c66b727d5..127e8849e 100644 --- a/build/source/netcdf/read_icond.f90 +++ b/build/source/netcdf/read_icond.f90 @@ -23,6 +23,9 @@ module read_icond_module USE netcdf USE globalData,only: ixHRUfile_min,ixHRUfile_max USE globalData,only: nTimeDelay ! number of hours in the time delay histogram +USE globalData,only: nSpecBand ! number of spectral bands +USE globalData,only:verySmaller ! a smaller number used as an additive constant to check if substantial difference among real numbers + implicit none private public::read_icond @@ -40,9 +43,8 @@ subroutine read_icond_nlayers(iconFile,nGRU,indx_meta,err,message) ! -------------------------------------------------------------------------------------------------------- ! modules USE nrtype - USE var_lookup,only:iLookIndex ! variable lookup structure + USE var_lookup,only:iLookINDEX ! variable lookup structure USE globalData,only:gru_struc ! gru-hru mapping structures - USE globalData,only:startGRU ! index of first gru for parallel runs USE netcdf_util_module,only:nc_file_close ! close netcdf file USE netcdf_util_module,only:nc_file_open ! close netcdf file USE netcdf_util_module,only:netcdf_err ! netcdf error handling @@ -58,18 +60,16 @@ subroutine read_icond_nlayers(iconFile,nGRU,indx_meta,err,message) type(var_info) ,intent(in) :: indx_meta(:) ! metadata integer(i4b) ,intent(out) :: err ! error code character(*) ,intent(out) :: message ! returned error message - ! locals - integer(i4b) :: ncID ! netcdf file id - integer(i4b) :: dimID ! netcdf file dimension id - integer(i4b) :: fileHRU ! number of HRUs in netcdf file - integer(i4b) :: snowID, soilID ! netcdf variable ids - integer(i4b) :: iGRU, iHRU ! loop indexes - integer(i4b) :: iHRU_local ! index of HRU in the data subset - integer(i4b) :: iHRU_global ! index of HRU in the netcdf file - integer(i4b),allocatable :: snowData(:) ! number of snow layers in all HRUs - integer(i4b),allocatable :: soilData(:) ! number of soil layers in all HRUs - character(len=256) :: cmessage ! downstream error message + integer(i4b) :: ncID ! netcdf file id + integer(i4b) :: dimID ! netcdf file dimension id + integer(i4b) :: fileHRU ! number of HRUs in netcdf file + integer(i4b) :: snowID, soilID ! netcdf variable ids + integer(i4b) :: iGRU, iHRU ! loop indexes + integer(i4b) :: iHRU_global ! index of HRU in the netcdf file + integer(i4b),allocatable :: snowData(:) ! number of snow layers in all HRUs + integer(i4b),allocatable :: soilData(:) ! number of soil layers in all HRUs + character(len=256) :: cmessage ! downstream error message ! -------------------------------------------------------------------------------------------------------- ! initialize error message @@ -91,8 +91,8 @@ subroutine read_icond_nlayers(iconFile,nGRU,indx_meta,err,message) soilData = 0 ! get netcdf ids for the variables holding number of snow and soil layers in each hru - err = nf90_inq_varid(ncid,trim(indx_meta(iLookIndex%nSnow)%varName),snowid); call netcdf_err(err,message) - err = nf90_inq_varid(ncid,trim(indx_meta(iLookIndex%nSoil)%varName),soilid); call netcdf_err(err,message) + err = nf90_inq_varid(ncid,trim(indx_meta(iLookINDEX%nSnow)%varName),snowid); call netcdf_err(err,message) + err = nf90_inq_varid(ncid,trim(indx_meta(iLookINDEX%nSoil)%varName),soilid); call netcdf_err(err,message) ! get nSnow and nSoil data (reads entire state file) err = nf90_get_var(ncid,snowid,snowData); call netcdf_err(err,message) @@ -112,18 +112,15 @@ subroutine read_icond_nlayers(iconFile,nGRU,indx_meta,err,message) do iGRU = 1,nGRU do iHRU = 1,gru_struc(iGRU)%hruCount iHRU_global = gru_struc(iGRU)%hruInfo(iHRU)%hru_nc - ! single HRU (Note: 'restartFileType' is hardwired above to multiHRU) if(restartFileType==singleHRU) then gru_struc(iGRU)%hruInfo(iHRU)%nSnow = snowData(1) gru_struc(iGRU)%hruInfo(iHRU)%nSoil = soilData(1) - ! multi HRU else gru_struc(iGRU)%hruInfo(iHRU)%nSnow = snowData(iHRU_global) gru_struc(iGRU)%hruInfo(iHRU)%nSoil = soilData(iHRU_global) endif - end do end do @@ -146,6 +143,7 @@ subroutine read_icond(iconFile, & ! intent(in): name of progData, & ! intent(inout): model prognostic variables bvarData, & ! intent(inout): model basin (GRU) variables indxData, & ! intent(inout): model indices + no_icond_enth, & ! intent(out): flag that enthalpy variables are not in the file err,message) ! intent(out): error control ! -------------------------------------------------------------------------------------------------------- ! modules @@ -159,7 +157,7 @@ subroutine read_icond(iconFile, & ! intent(in): name of USE globalData,only:bvar_meta ! metadata for basin (GRU) variables USE globalData,only:gru_struc ! gru-hru mapping structures USE globalData,only:startGRU ! index of first gru for parallel runs - USE globaldata,only:iname_soil,iname_snow ! named variables to describe the type of layer + USE globalData,only:iname_soil,iname_snow ! named variables to describe the type of layer USE netcdf_util_module,only:nc_file_open ! open netcdf file USE netcdf_util_module,only:nc_file_close ! close netcdf file USE netcdf_util_module,only:netcdf_err ! netcdf error handling @@ -172,50 +170,45 @@ subroutine read_icond(iconFile, & ! intent(in): name of USE updatState_module,only:updateSoil ! update soil states implicit none - ! -------------------------------------------------------------------------------------------------------- ! variable declarations ! dummies - character(*) ,intent(in) :: iconFile ! name of netcdf file containing the initial conditions - integer(i4b) ,intent(in) :: nGRU ! number of grouped response units in simulation domain - type(gru_hru_doubleVec),intent(in) :: mparData ! model parameters - type(gru_hru_doubleVec),intent(inout) :: progData ! model prognostic variables - type(gru_doubleVec) ,intent(inout) :: bvarData ! model basin (GRU) variables - type(gru_hru_intVec) ,intent(inout) :: indxData ! model indices - integer(i4b) ,intent(out) :: err ! error code - character(*) ,intent(out) :: message ! returned error message - + character(*) ,intent(in) :: iconFile ! name of netcdf file containing the initial conditions + integer(i4b) ,intent(in) :: nGRU ! number of grouped response units in simulation domain + type(gru_hru_doubleVec),intent(in) :: mparData ! model parameters + type(gru_hru_doubleVec),intent(inout) :: progData ! model prognostic variables + type(gru_doubleVec) ,intent(inout) :: bvarData ! model basin (GRU) variables + type(gru_hru_intVec) ,intent(inout) :: indxData ! model indices + logical ,intent(out) :: no_icond_enth ! flag that enthalpy variables are not in the file + integer(i4b) ,intent(out) :: err ! error code + character(*) ,intent(out) :: message ! returned error message ! locals - character(len=256) :: cmessage ! downstream error message - integer(i4b) :: fileHRU ! number of HRUs in file - integer(i4b) :: fileGRU ! number of GRUs in file - integer(i4b) :: iVar, i ! loop indices - integer(i4b),dimension(1) :: ndx ! intermediate array of loop indices - integer(i4b) :: iGRU ! loop index - integer(i4b) :: iHRU ! loop index - integer(i4b) :: dimID ! varible dimension ids - integer(i4b) :: ncVarID ! variable ID in netcdf file - character(256) :: dimName ! not used except as a placeholder in call to inq_dim function - integer(i4b) :: dimLen ! data dimensions - integer(i4b) :: ncID ! netcdf file ID - integer(i4b) :: ixFile ! index in file - integer(i4b) :: iHRU_local ! index of HRU in the data subset - integer(i4b) :: iHRU_global ! index of HRU in the netcdf file - real(rkind),allocatable :: varData(:,:) ! variable data storage - integer(i4b) :: nSoil, nSnow, nToto ! # layers - integer(i4b) :: nTDH ! number of points in time-delay histogram - integer(i4b) :: iLayer,jLayer ! layer indices - integer(i4b),parameter :: nBand=2 ! number of spectral bands - integer(i4b) :: nProgVars ! number of prognostic variables written to state file - - character(len=32),parameter :: scalDimName ='scalarv' ! dimension name for scalar data - character(len=32),parameter :: midSoilDimName='midSoil' ! dimension name for soil-only layers - character(len=32),parameter :: midTotoDimName='midToto' ! dimension name for layered varaiables - character(len=32),parameter :: ifcTotoDimName='ifcToto' ! dimension name for layered varaiables - character(len=32),parameter :: tdhDimName ='tdh' ! dimension name for time-delay basin variables + character(len=256) :: cmessage ! downstream error message + integer(i4b) :: fileHRU ! number of HRUs in file + integer(i4b) :: fileGRU ! number of GRUs in file + integer(i4b) :: iVar, i ! loop indices + integer(i4b),dimension(1) :: ndx ! intermediate array of loop indices + integer(i4b) :: iGRU ! loop index + integer(i4b) :: iHRU ! loop index + integer(i4b) :: dimID ! varible dimension ids + integer(i4b) :: ncVarID ! variable ID in netcdf file + character(256) :: dimName ! not used except as a placeholder in call to inq_dim function + integer(i4b) :: dimLen ! data dimensions + integer(i4b) :: ncID ! netcdf file ID + integer(i4b) :: ixFile ! index in file + integer(i4b) :: iHRU_local ! index of HRU in the data subset + integer(i4b) :: iHRU_global ! index of HRU in the netcdf file + real(rkind),allocatable :: varData(:,:) ! variable data storage + integer(i4b) :: nSoil, nSnow, nToto ! # layers + integer(i4b) :: nTDH ! number of points in time-delay histogram + integer(i4b) :: iLayer,jLayer ! layer indices + character(len=32),parameter :: scalDimName ='scalarv' ! dimension name for scalar data + character(len=32),parameter :: midSoilDimName='midSoil' ! dimension name for soil-only layers + character(len=32),parameter :: midTotoDimName='midToto' ! dimension name for layered varaiables + character(len=32),parameter :: ifcTotoDimName='ifcToto' ! dimension name for layered varaiables + character(len=32),parameter :: tdhDimName ='tdh' ! dimension name for time-delay basin variables ! -------------------------------------------------------------------------------------------------------- - ! Start procedure here err=0; message="read_icond/" @@ -231,6 +224,7 @@ subroutine read_icond(iconFile, & ! intent(in): name of err = nf90_inquire_dimension(ncID,dimID,len=fileHRU); if(err/=nf90_noerr)then; message=trim(message)//'problem reading hru dimension/'//trim(nf90_strerror(err)); return; end if ! loop through prognostic variables + no_icond_enth=.false. do iVar = 1,size(prog_meta) ! skip variables that are computed later @@ -241,8 +235,12 @@ subroutine read_icond(iconFile, & ! intent(in): name of prog_meta(iVar)%varName=='mLayerHeight' ) cycle ! get variable id - err = nf90_inq_varid(ncID,trim(prog_meta(iVar)%varName),ncVarID); call netcdf_err(err,message) - if(err/=0)then + err = nf90_inq_varid(ncID,trim(prog_meta(iVar)%varName),ncVarID) + if(err/=nf90_noerr)then + if(prog_meta(iVar)%varName=='scalarCanairEnthalpy' .or. & + prog_meta(iVar)%varName=='scalarCanopyEnthalpy' .or. & + prog_meta(iVar)%varName=='mLayerEnthalpy' )then; err=nf90_noerr; no_icond_enth=.true.; cycle; endif ! skip enthalpy variables if not in file + call netcdf_err(err,message) message=trim(message)//': problem with getting variable id, var='//trim(prog_meta(iVar)%varName) return endif @@ -318,13 +316,15 @@ subroutine read_icond(iconFile, & ! intent(in): name of if(err==20)then; message=trim(message)//"data set to the fill value (name='"//trim(prog_meta(iVar)%varName)//"')"; return; endif - ! fix the snow albedo - if(progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarSnowAlbedo)%dat(1) < 0._rkind)then - progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarSnowAlbedo)%dat(1) = mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%albedoMax)%dat(1) - endif + if(prog_meta(iVar)%varName=='iLayerHeight')then ! last variable in the loop, so we can correct prognostic variables if had legacy starting values + ! make sure snow albedo is not negative + if(progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarSnowAlbedo)%dat(1) < 0._rkind)then + progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarSnowAlbedo)%dat(1) = mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%albedoMax)%dat(1) + endif - ! initialize the spectral albedo - progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(1:nBand) = progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarSnowAlbedo)%dat(1) + ! initialize the spectral albedo + progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(1:nSpecBand) = progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarSnowAlbedo)%dat(1) + endif ! (if last variable in the loop) end do ! iHRU end do ! iGRU @@ -356,7 +356,6 @@ subroutine read_icond(iconFile, & ! intent(in): name of ! -------------------------------------------------------------------------------------------------------- ! (3) update soil layers (diagnostic variables) ! -------------------------------------------------------------------------------------------------------- - ! loop through GRUs and HRUs do iGRU = 1,nGRU do iHRU = 1,gru_struc(iGRU)%hruCount @@ -460,6 +459,9 @@ subroutine read_icond(iconFile, & ! intent(in): name of end do ! end looping through basin variables endif ! end if case for tdh variables being in init. cond. file endif ! end if case for not being a singleHRU run + + call nc_file_close(ncID,err,cmessage) + if(err/=0)then;message=trim(message)//trim(cmessage);return;end if end subroutine read_icond diff --git a/build/source/noah-mp/module_model_constants.F b/build/source/noah-mp/module_model_constants.F old mode 100755 new mode 100644 diff --git a/build/source/noah-mp/module_sf_noahlsm.F b/build/source/noah-mp/module_sf_noahlsm.F old mode 100755 new mode 100644 index e3fc5166b..56da70cd6 --- a/build/source/noah-mp/module_sf_noahlsm.F +++ b/build/source/noah-mp/module_sf_noahlsm.F @@ -11,7 +11,7 @@ MODULE module_sf_noahlsm ! VEGETATION PARAMETERS INTEGER :: LUCATS , BARE INTEGER :: NATURAL - integer, PARAMETER :: NLUS=50 + integer, PARAMETER :: NLUS=200 CHARACTER(LEN=256) LUTYPE INTEGER, DIMENSION(1:NLUS) :: NROTBL real, dimension(1:NLUS) :: SNUPTBL, RSTBL, RGLTBL, HSTBL, & @@ -42,6 +42,5 @@ MODULE module_sf_noahlsm REAL(rkind) :: LVCOEF_DATA CHARACTER*256 :: err_message - integer, private :: iloc, jloc END MODULE module_sf_noahlsm diff --git a/build/source/noah-mp/module_sf_noahmplsm.F b/build/source/noah-mp/module_sf_noahmplsm.F old mode 100755 new mode 100644 index bb21f2901..7b1236442 --- a/build/source/noah-mp/module_sf_noahmplsm.F +++ b/build/source/noah-mp/module_sf_noahmplsm.F @@ -205,7 +205,7 @@ MODULE NOAHMP_VEG_PARAMETERS IMPLICIT NONE INTEGER, PARAMETER :: MAX_VEG_PARAMS = 33 - INTEGER, PARAMETER :: MVT = 27 + INTEGER, PARAMETER :: MVT = 200 INTEGER, PARAMETER :: MBAND = 2 INTEGER, PRIVATE :: ISURBAN @@ -506,7 +506,7 @@ MODULE NOAHMP_ROUTINES ! ================================================================================================== ! -------------------------------------------------------------------------------------------------- SUBROUTINE PHENOLOGY (VEGTYP , ISURBAN, SNOWH , TV , LAT , YEARLEN , JULIAN , & !in - LAI , SAI , TROOT , HTOP , ELAI , ESAI , IGS) + LAI , SAI , HTOP , ELAI , ESAI , IGS) !out ! -------------------------------------------------------------------------------------------------- ! vegetation phenology considering vegeation canopy being buries by snow and evolution in time @@ -523,7 +523,6 @@ SUBROUTINE PHENOLOGY (VEGTYP , ISURBAN, SNOWH , TV , LAT , YEARLEN , JULI REAL(rkind) , INTENT(IN ) :: LAT !latitude (radians) INTEGER , INTENT(IN ) :: YEARLEN!Number of days in the particular year REAL(rkind) , INTENT(IN ) :: JULIAN !Julian day of year (fractional) ( 0 <= JULIAN < YEARLEN ) - real(rkind) , INTENT(IN ) :: TROOT !root-zone averaged temperature (k) REAL(rkind) , INTENT(INOUT) :: LAI !LAI, unadjusted for burying by snow REAL(rkind) , INTENT(INOUT) :: SAI !SAI, unadjusted for burying by snow @@ -537,10 +536,7 @@ SUBROUTINE PHENOLOGY (VEGTYP , ISURBAN, SNOWH , TV , LAT , YEARLEN , JULI REAL(rkind) :: DB !thickness of canopy buried by snow (m) REAL(rkind) :: FB !fraction of canopy buried by snow - REAL(rkind) :: SNOWHC !critical snow depth at which short vege - !is fully covered by snow - - INTEGER :: K !index + REAL(rkind) :: SNOWHC !critical snow depth at which short vegetation is fully covered by snow INTEGER :: IT1,IT2 !interpolation months REAL(rkind) :: DAY !current day of year ( 0 <= DAY < YEARLEN ) REAL(rkind) :: WT1,WT2 !interpolation weights @@ -559,7 +555,7 @@ SUBROUTINE PHENOLOGY (VEGTYP , ISURBAN, SNOWH , TV , LAT , YEARLEN , JULI ENDIF T = 12. * DAY / REAL(YEARLEN) - IT1 = T + 0.5 + IT1 = INT(T + 0.5) IT2 = IT1 + 1 WT1 = (IT1+0.5) - T WT2 = 1.-WT1 @@ -588,7 +584,6 @@ SUBROUTINE PHENOLOGY (VEGTYP , ISURBAN, SNOWH , TV , LAT , YEARLEN , JULI DB = MIN( MAX(SNOWH - HVB(VEGTYP),0.), HVT(VEGTYP)-HVB(VEGTYP) ) FB = DB / MAX(1.E-06,HVT(VEGTYP)-HVB(VEGTYP)) - !print*, 'HVB(VEGTYP), HVT(VEGTYP), DB, FB = ', HVB(VEGTYP), HVT(VEGTYP), DB, FB IF(HVT(VEGTYP)> 0. .AND. HVT(VEGTYP) <= 0.5) THEN SNOWHC = HVT(VEGTYP)*EXP(-SNOWH/0.1) @@ -614,32 +609,27 @@ END SUBROUTINE PHENOLOGY ! ================================================================================================== ! ================================================================================================== ! ================================================================================================== - SUBROUTINE RADIATION (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in - SNEQVO ,SNEQV ,DT ,COSZ ,SNOWH , & !in - TG ,TV ,FSNO ,QSNOW ,FWET , & !in - ELAI ,ESAI ,SMC ,SOLAD ,SOLAI , & !in - FVEG ,ILOC ,JLOC , & !in - ALBOLD ,TAUSS , & !inout + SUBROUTINE RADIATION (VEGTYP ,IST ,ISC ,NSOIL ,SNEQVO , & !in + SNEQV ,DT ,COSZ ,TG ,TV , & !in + FSNO ,QSNOW ,FWET ,ELAI ,ESAI , & !in + SMC ,SOLAD ,SOLAI ,FVEG , & !in + ALBOLD ,TAUSS , & !inout FSUN ,LAISUN ,LAISHA ,PARSUN ,PARSHA , & !out - SAV ,SAG ,FSR ,FSA ,FSRV , & - FSRG ,BGAP ,WGAP) !out + SAV ,SAG ,FSR ,FSA ,FSRV , & !out + FSRG ,BGAP ,WGAP) !out ! -------------------------------------------------------------------------------------------------- IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- ! input - INTEGER, INTENT(IN) :: ILOC - INTEGER, INTENT(IN) :: JLOC INTEGER, INTENT(IN) :: VEGTYP !vegetation type INTEGER, INTENT(IN) :: IST !surface type INTEGER, INTENT(IN) :: ISC !soil color type (1-lighest; 8-darkest) - INTEGER, INTENT(IN) :: ICE !ice (ice = 1) INTEGER, INTENT(IN) :: NSOIL !number of soil layers REAL(rkind), INTENT(IN) :: DT !time step [s] REAL(rkind), INTENT(IN) :: QSNOW !snowfall (mm/s) REAL(rkind), INTENT(IN) :: SNEQVO !snow mass at last time step(mm) REAL(rkind), INTENT(IN) :: SNEQV !snow mass (mm) - REAL(rkind), INTENT(IN) :: SNOWH !snow height (mm) REAL(rkind), INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) REAL(rkind), INTENT(IN) :: TG !ground temperature (k) REAL(rkind), INTENT(IN) :: TV !vegetation temperature (k) @@ -702,15 +692,14 @@ SUBROUTINE RADIATION (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in ! surface abeldo - CALL ALBEDO (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in - DT ,COSZ ,FAGE ,ELAI ,ESAI , & !in - TG ,TV ,SNOWH ,FSNO ,FWET , & !in - SMC ,SNEQVO ,SNEQV ,QSNOW ,FVEG , & !in - ILOC ,JLOC , & !in + CALL ALBEDO (VEGTYP ,IST ,ISC ,NSOIL ,DT , & !in + COSZ ,FAGE ,ELAI ,ESAI ,TG , & !in + TV ,FSNO ,FWET ,SMC ,SNEQVO , & !in + SNEQV ,QSNOW ,FVEG , & !in ALBOLD ,TAUSS , & !inout ALBGRD ,ALBGRI ,ALBD ,ALBI ,FABD , & !out - FABI ,FTDD ,FTID ,FTII ,FSUN , & !) !out - FREVI ,FREVD ,FREGD ,FREGI ,BGAP , & !inout + FABI ,FTDD ,FTID ,FTII ,FSUN , & !out + FREVI ,FREVD ,FREGD ,FREGI ,BGAP , & !out WGAP) ! surface radiation @@ -728,20 +717,19 @@ SUBROUTINE RADIATION (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in CALL SURRAD (MPE ,FSUN ,FSHA ,ELAI ,VAI , & !in LAISUN ,LAISHA ,SOLAD ,SOLAI ,FABD , & !in FABI ,FTDD ,FTID ,FTII ,ALBGRD , & !in - ALBGRI ,ALBD ,ALBI ,ILOC ,JLOC , & !in + ALBGRI ,ALBD ,ALBI , & !in PARSUN ,PARSHA ,SAV ,SAG ,FSA , & !out - FSR , & !out + FSR , & !out FREVI ,FREVD ,FREGD ,FREGI ,FSRV , & !inout FSRG) END SUBROUTINE RADIATION ! ================================================================================================== ! -------------------------------------------------------------------------------------------------- - SUBROUTINE ALBEDO (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in - DT ,COSZ ,FAGE ,ELAI ,ESAI , & !in - TG ,TV ,SNOWH ,FSNO ,FWET , & !in - SMC ,SNEQVO ,SNEQV ,QSNOW ,FVEG , & !in - ILOC ,JLOC , & !in + SUBROUTINE ALBEDO (VEGTYP ,IST ,ISC ,NSOIL ,DT , & !in + COSZ ,FAGE ,ELAI ,ESAI ,TG , & !in + TV ,FSNO ,FWET ,SMC ,SNEQVO , & !in + SNEQV ,QSNOW ,FVEG , & !in ALBOLD ,TAUSS , & !inout ALBGRD ,ALBGRI ,ALBD ,ALBI ,FABD , & !out FABI ,FTDD ,FTID ,FTII ,FSUN , & !out @@ -758,18 +746,14 @@ SUBROUTINE ALBEDO (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- ! input - INTEGER, INTENT(IN) :: ILOC - INTEGER, INTENT(IN) :: JLOC INTEGER, INTENT(IN) :: NSOIL !number of soil layers INTEGER, INTENT(IN) :: VEGTYP !vegetation type INTEGER, INTENT(IN) :: IST !surface type INTEGER, INTENT(IN) :: ISC !soil color type (1-lighest; 8-darkest) - INTEGER, INTENT(IN) :: ICE !ice (ice = 1) REAL(rkind), INTENT(IN) :: DT !time step [sec] REAL(rkind), INTENT(IN) :: QSNOW !snowfall REAL(rkind), INTENT(IN) :: COSZ !cosine solar zenith angle for next time step - REAL(rkind), INTENT(IN) :: SNOWH !snow height (mm) REAL(rkind), INTENT(IN) :: TG !ground temperature (k) REAL(rkind), INTENT(IN) :: TV !vegetation temperature (k) REAL(rkind), INTENT(IN) :: ELAI !LAI, one-sided, adjusted for burying by snow @@ -869,17 +853,16 @@ SUBROUTINE ALBEDO (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in ! snow albedos: only if COSZ > 0 and FSNO > 0 IF(OPT_ALB == 1) & - CALL SNOWALB_BATS (NBAND, FSNO,COSZ,FAGE,ALBSND,ALBSNI) + CALL SNOWALB_BATS (NBAND,COSZ,FAGE,ALBSND,ALBSNI) IF(OPT_ALB == 2) THEN - CALL SNOWALB_CLASS (NBAND,QSNOW,DT,ALB,ALBOLD,ALBSND,ALBSNI,ILOC,JLOC) + CALL SNOWALB_CLASS (NBAND,QSNOW,DT,ALB,ALBOLD,ALBSND,ALBSNI) ALBOLD = ALB END IF ! ground surface albedo - CALL GROUNDALB (NSOIL ,NBAND ,ICE ,IST ,ISC , & !in - FSNO ,SMC ,ALBSND ,ALBSNI ,COSZ , & !in - TG ,ILOC ,JLOC , & !in + CALL GROUNDALB (NSOIL ,NBAND ,IST ,ISC ,FSNO , & !in + SMC ,ALBSND ,ALBSNI ,COSZ ,TG , & !in ALBGRD ,ALBGRI ) !out @@ -890,15 +873,15 @@ SUBROUTINE ALBEDO (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in IC = 0 ! direct CALL TWOSTREAM (IB ,IC ,VEGTYP ,COSZ ,VAI , & !in FWET ,TV ,ALBGRD ,ALBGRI ,RHO , & !in - TAU ,FVEG ,IST ,ILOC ,JLOC , & !in - FABD ,ALBD ,FTDD ,FTID ,GDIR , &!) !out + TAU ,FVEG , & !in + FABD ,ALBD ,FTDD ,FTID ,GDIR , & !out FREVD ,FREGD ,BGAP ,WGAP) IC = 1 ! diffuse CALL TWOSTREAM (IB ,IC ,VEGTYP ,COSZ ,VAI , & !in FWET ,TV ,ALBGRD ,ALBGRI ,RHO , & !in - TAU ,FVEG ,IST ,ILOC ,JLOC , & !in - FABI ,ALBI ,FTDI ,FTII ,GDIR , & !) !out + TAU ,FVEG , & !in + FABI ,ALBI ,FTDI ,FTII ,GDIR , & !out FREVI ,FREGI ,BGAP ,WGAP) END DO @@ -924,9 +907,9 @@ END SUBROUTINE ALBEDO SUBROUTINE SURRAD (MPE ,FSUN ,FSHA ,ELAI ,VAI , & !in LAISUN ,LAISHA ,SOLAD ,SOLAI ,FABD , & !in FABI ,FTDD ,FTID ,FTII ,ALBGRD , & !in - ALBGRI ,ALBD ,ALBI ,ILOC ,JLOC , & !in + ALBGRI ,ALBD ,ALBI , & !in PARSUN ,PARSHA ,SAV ,SAG ,FSA , & !out - FSR , & !) !out + FSR , & !out FREVI ,FREVD ,FREGD ,FREGI ,FSRV , & FSRG) !inout @@ -934,9 +917,6 @@ SUBROUTINE SURRAD (MPE ,FSUN ,FSHA ,ELAI ,VAI , & !in IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- ! input - - INTEGER, INTENT(IN) :: ILOC - INTEGER, INTENT(IN) :: JLOC REAL(rkind), INTENT(IN) :: MPE !prevents underflow errors if division by zero REAL(rkind), INTENT(IN) :: FSUN !sunlit fraction of canopy @@ -1096,7 +1076,7 @@ SUBROUTINE SNOW_AGE (DT,TG,SNEQVO,SNEQV,TAUSS,FAGE) END SUBROUTINE SNOW_AGE ! ================================================================================================== ! -------------------------------------------------------------------------------------------------- - SUBROUTINE SNOWALB_BATS (NBAND,FSNO,COSZ,FAGE,ALBSND,ALBSNI) + SUBROUTINE SNOWALB_BATS (NBAND,COSZ,FAGE,ALBSND,ALBSNI) ! -------------------------------------------------------------------------------------------------- IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- @@ -1105,7 +1085,6 @@ SUBROUTINE SNOWALB_BATS (NBAND,FSNO,COSZ,FAGE,ALBSND,ALBSNI) INTEGER,INTENT(IN) :: NBAND !number of waveband classes REAL(rkind),INTENT(IN) :: COSZ !cosine solar zenith angle - REAL(rkind),INTENT(IN) :: FSNO !snow cover fraction (-) REAL(rkind),INTENT(IN) :: FAGE !snow age correction ! output @@ -1115,8 +1094,6 @@ SUBROUTINE SNOWALB_BATS (NBAND,FSNO,COSZ,FAGE,ALBSND,ALBSNI) ! --------------------------------------------------------------------------------------------- ! ------------------------ local variables ---------------------------------------------------- - INTEGER :: IB !waveband class - REAL(rkind) :: FZEN !zenith angle correction REAL(rkind) :: CF1 !temperary variable REAL(rkind) :: SL2 !2.*SL @@ -1149,14 +1126,12 @@ SUBROUTINE SNOWALB_BATS (NBAND,FSNO,COSZ,FAGE,ALBSND,ALBSNI) END SUBROUTINE SNOWALB_BATS ! ================================================================================================== ! -------------------------------------------------------------------------------------------------- - SUBROUTINE SNOWALB_CLASS (NBAND,QSNOW,DT,ALB,ALBOLD,ALBSND,ALBSNI,ILOC,JLOC) + SUBROUTINE SNOWALB_CLASS (NBAND,QSNOW,DT,ALB,ALBOLD,ALBSND,ALBSNI) ! -------------------------------------------------------------------------------------------------- IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- ! input - INTEGER,INTENT(IN) :: ILOC !grid index - INTEGER,INTENT(IN) :: JLOC !grid index INTEGER,INTENT(IN) :: NBAND !number of waveband classes REAL(rkind),INTENT(IN) :: QSNOW !snowfall (mm/s) @@ -1171,11 +1146,6 @@ SUBROUTINE SNOWALB_CLASS (NBAND,QSNOW,DT,ALB,ALBOLD,ALBSND,ALBSNI,ILOC,JLOC) REAL(rkind), DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir) REAL(rkind), DIMENSION(1:2),INTENT(OUT) :: ALBSNI !snow albedo for diffuse ! --------------------------------------------------------------------------------------------- - -! ------------------------ local variables ---------------------------------------------------- - INTEGER :: IB !waveband class - -! --------------------------------------------------------------------------------------------- ! zero albedos for all points ALBSND(1: NBAND) = 0. @@ -1201,9 +1171,8 @@ SUBROUTINE SNOWALB_CLASS (NBAND,QSNOW,DT,ALB,ALBOLD,ALBSND,ALBSNI,ILOC,JLOC) END SUBROUTINE SNOWALB_CLASS ! ================================================================================================== ! -------------------------------------------------------------------------------------------------- - SUBROUTINE GROUNDALB (NSOIL ,NBAND ,ICE ,IST ,ISC , & !in - FSNO ,SMC ,ALBSND ,ALBSNI ,COSZ , & !in - TG ,ILOC ,JLOC , & !in + SUBROUTINE GROUNDALB (NSOIL ,NBAND ,IST ,ISC ,FSNO , & !in + SMC ,ALBSND ,ALBSNI ,COSZ ,TG , & !in ALBGRD ,ALBGRI ) !out ! -------------------------------------------------------------------------------------------------- USE NOAHMP_RAD_PARAMETERS @@ -1212,11 +1181,8 @@ SUBROUTINE GROUNDALB (NSOIL ,NBAND ,ICE ,IST ,ISC , & !in ! -------------------------------------------------------------------------------------------------- !input - INTEGER, INTENT(IN) :: ILOC !grid index - INTEGER, INTENT(IN) :: JLOC !grid index INTEGER, INTENT(IN) :: NSOIL !number of soil layers INTEGER, INTENT(IN) :: NBAND !number of solar radiation waveband classes - INTEGER, INTENT(IN) :: ICE !value of ist for land ice INTEGER, INTENT(IN) :: IST !surface type INTEGER, INTENT(IN) :: ISC !soil color class (1-lighest; 8-darkest) REAL(rkind), INTENT(IN) :: FSNO !fraction of surface covered with snow (-) @@ -1233,7 +1199,7 @@ SUBROUTINE GROUNDALB (NSOIL ,NBAND ,ICE ,IST ,ISC , & !in !local - INTEGER :: IB !waveband number (1=vis, 2=nir) + INTEGER :: IB !waveband number (1=vis, 2=nir) REAL(rkind) :: INC !soil water correction factor for soil albedo REAL(rkind) :: ALBSOD !soil albedo (direct) REAL(rkind) :: ALBSOI !soil albedo (diffuse) @@ -1268,8 +1234,8 @@ END SUBROUTINE GROUNDALB ! -------------------------------------------------------------------------------------------------- SUBROUTINE TWOSTREAM (IB ,IC ,VEGTYP ,COSZ ,VAI , & !in FWET ,T ,ALBGRD ,ALBGRI ,RHO , & !in - TAU ,FVEG ,IST ,ILOC ,JLOC , & !in - FAB ,FRE ,FTD ,FTI ,GDIR , & !) !out + TAU ,FVEG , & !in + FAB ,FRE ,FTD ,FTI ,GDIR , & !out FREV ,FREG ,BGAP ,WGAP) ! -------------------------------------------------------------------------------------------------- @@ -1286,9 +1252,6 @@ SUBROUTINE TWOSTREAM (IB ,IC ,VEGTYP ,COSZ ,VAI , & !in ! -------------------------------------------------------------------------------------------------- ! input - INTEGER, INTENT(IN) :: ILOC !grid index - INTEGER, INTENT(IN) :: JLOC !grid index - INTEGER, INTENT(IN) :: IST !surface type INTEGER, INTENT(IN) :: IB !waveband number INTEGER, INTENT(IN) :: IC !0=unit incoming direct; 1=unit incoming diffuse INTEGER, INTENT(IN) :: VEGTYP !vegetation type @@ -1336,8 +1299,7 @@ SUBROUTINE TWOSTREAM (IB ,IC ,VEGTYP ,COSZ ,VAI , & !in REAL(rkind) :: DENFVEG REAL(rkind) :: VAI_SPREAD !jref:start - REAL(rkind) :: FREVEG,FREBAR,FTDVEG,FTIVEG,FTDBAR,FTIBAR - REAL(rkind) :: THETAZ + REAL(rkind) :: FREVEG,FREBAR !jref:end ! variables for the modified two-stream scheme @@ -1510,17 +1472,12 @@ SUBROUTINE TWOSTREAM (IB ,IC ,VEGTYP ,COSZ ,VAI , & !in FAB(IB) = 1. - FRE(IB) - (1.-ALBGRD(IB))*FTD(IB) & - (1.-ALBGRI(IB))*FTI(IB) -!if(iloc == 1.and.jloc == 2) then - !write(*,'(a7,2i2,5(a6,f8.4),2(a9,f8.4))') "ib,ic: ",ib,ic," GAP: ",GAP," FTD: ",FTD(IB)," FTI: ",FTI(IB)," FRE: ", & - ! FRE(IB)," FAB: ",FAB(IB)," ALBGRD: ",ALBGRD(IB)," ALBGRI: ",ALBGRI(IB) -!end if - END SUBROUTINE TWOSTREAM ! ================================================================================================== ! ================================================================================================== ! ---------------------------------------------------------------------- - SUBROUTINE STOMATA (VEGTYP ,MPE ,APAR ,FOLN ,ILOC , JLOC, & !in - TV ,EI ,EA ,SFCTMP ,SFCPRS , & !in + SUBROUTINE STOMATA (VEGTYP ,MPE ,APAR ,FOLN , & !in + TV ,EI0 ,EA ,SFCTMP ,SFCPRS , & !in O2 ,CO2 ,IGS ,BTRAN ,RB , & !in RS ,PSN ) !out ! -------------------------------------------------------------------------------------------------- @@ -1529,15 +1486,13 @@ SUBROUTINE STOMATA (VEGTYP ,MPE ,APAR ,FOLN ,ILOC , JLOC, & !in IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- ! input - INTEGER,INTENT(IN) :: ILOC !grid index - INTEGER,INTENT(IN) :: JLOC !grid index INTEGER,INTENT(IN) :: VEGTYP !vegetation physiology type REAL(rkind), INTENT(IN) :: IGS !growing season index (0=off, 1=on) REAL(rkind), INTENT(IN) :: MPE !prevents division by zero errors REAL(rkind), INTENT(IN) :: TV !foliage temperature (k) - REAL(rkind), INTENT(IN) :: EI !vapor pressure inside leaf (sat vapor press at tv) (pa) + REAL(rkind), INTENT(IN) :: EI0 !vapor pressure inside leaf (sat vapor press at tv) (pa) REAL(rkind), INTENT(IN) :: EA !vapor pressure of canopy air (pa) REAL(rkind), INTENT(IN) :: APAR !par absorbed per unit lai (w/m2) REAL(rkind), INTENT(IN) :: O2 !atmospheric o2 concentration (pa) @@ -1569,6 +1524,7 @@ SUBROUTINE STOMATA (VEGTYP ,MPE ,APAR ,FOLN ,ILOC , JLOC, & !in REAL(rkind) :: F2 !generic temperature inhibition (statement function) REAL(rkind) :: TC !foliage temperature (degree Celsius) REAL(rkind) :: CS !co2 concentration at leaf surface (pa) + REAL(rkind) :: EI !vapor pressure inside leaf (sat vapor press at tv) (pa) REAL(rkind) :: KC !co2 Michaelis-Menten constant (pa) REAL(rkind) :: KO !o2 Michaelis-Menten constant (pa) REAL(rkind) :: A,B,C,Q !intermediate calculations for RS @@ -1588,7 +1544,6 @@ SUBROUTINE STOMATA (VEGTYP ,MPE ,APAR ,FOLN ,ILOC , JLOC, & !in F1(AB,BC) = AB**((BC-25.)/10.) F2(AB) = 1. + EXP((-2.2E05+710.*(AB+273.16))/(8.314*(AB+273.16))) - REAL(rkind) :: T ! --------------------------------------------------------------------------------------------- ! MPC change @@ -1598,11 +1553,14 @@ SUBROUTINE STOMATA (VEGTYP ,MPE ,APAR ,FOLN ,ILOC , JLOC, & !in ! initialize RS=RSMAX and PSN=0 because will only do calculations ! for APAR > 0, in which case RS <= RSMAX and PSN >= 0 - + if (EI0 ERROR: The full path to the main/entry input file for OpenWQ that is provided in 'openwq_mainJSONFile_fullPath.txt' has not been found. The simulation aborted has been!"; + + // Print it (Console and/or Log file) + std::cout << msg_string << std::endl; + + exit(EXIT_FAILURE); + } + + } + + OpenWQ_wqconfig_ref->set_OpenWQ_masterjson(master_json); + + OpenWQ_couplercalls_ref->InitialConfig( + *OpenWQ_hostModelconfig_ref, + *OpenWQ_json_ref, // create OpenWQ_json object + *OpenWQ_wqconfig_ref, // create OpenWQ_wqconfig object + *OpenWQ_units_ref, // functions for unit conversion + *OpenWQ_utils_ref, // utility methods/functions + *OpenWQ_readjson_ref, // read json files + *OpenWQ_vars_ref, + *OpenWQ_initiate_ref, // initiate modules + *OpenWQ_transp_ref, // transport modules + *OpenWQ_LE_ref, + *OpenWQ_chem_ref, // biochemistry modules + *OpenWQ_SI_ref, + *OpenWQ_TS_ref, + *OpenWQ_extwatflux_ss_ref, // sink and source modules) + *OpenWQ_output_ref); + + } + return 0; +} + +// soilMoist_depVar does not have a value - it is passed as 0 +int CLASSWQ_openwq::openwq_run_time_start( + bool last_hru_flag, + int index_hru, + int nSnow_2openwq, + int nSoil_2openwq, + int simtime_summa[], + double soilMoist_depVar_summa_frac[], + double soilTemp_depVar_summa_K[], + double airTemp_depVar_summa_K, + double sweWatVol_stateVar_summa_m3[], + double canopyWatVol_stateVar_summa_m3, + double soilWatVol_stateVar_summa_m3[], + double aquiferWatVol_stateVar_summa_m3) { + + time_t simtime = OpenWQ_units_ref->convertTime_ints2time_t( + *OpenWQ_wqconfig_ref, + simtime_summa[0], + simtime_summa[1], + simtime_summa[2], + simtime_summa[3], + simtime_summa[4], + 0); + + int runoff_vol = 0; + + // Updating Chemistry dependencies and volumes (out of order because of looping) + + OpenWQ_hostModelconfig_ref->set_dependVar_at(1,index_hru,0,0, airTemp_depVar_summa_K); + OpenWQ_hostModelconfig_ref->set_waterVol_hydromodel_at(canopy_index_openwq,index_hru,0,0, canopyWatVol_stateVar_summa_m3); // canopy + OpenWQ_hostModelconfig_ref->set_waterVol_hydromodel_at(runoff_index_openwq,index_hru,0,0, runoff_vol); // runoff + OpenWQ_hostModelconfig_ref->set_waterVol_hydromodel_at(aquifer_index_openwq,index_hru,0,0, aquiferWatVol_stateVar_summa_m3); // aquifer + + // update Vars that rely on Snow + for (int z = 0; z < nSnow_2openwq; z++) { + OpenWQ_hostModelconfig_ref->set_waterVol_hydromodel_at(snow_index_openwq,index_hru,0,z, sweWatVol_stateVar_summa_m3[z]); // snow + } + + // Update Vars that rely on Soil + for (int z = 0; z < nSoil_2openwq; z++) { + OpenWQ_hostModelconfig_ref->set_dependVar_at(0,index_hru,0,z,soilMoist_depVar_summa_frac[z]); + OpenWQ_hostModelconfig_ref->set_dependVar_at(2,index_hru,0,z,soilTemp_depVar_summa_K[z]); + OpenWQ_hostModelconfig_ref->set_waterVol_hydromodel_at(soil_index_openwq,index_hru,0,z, soilWatVol_stateVar_summa_m3[z]); // soil + + } + + if (get_numHRU() -1 == index_hru ) { + OpenWQ_couplercalls_ref->RunTimeLoopStart( + *OpenWQ_hostModelconfig_ref, + *OpenWQ_json_ref, + *OpenWQ_wqconfig_ref, // create OpenWQ_wqconfig object + *OpenWQ_units_ref, // functions for unit conversion + *OpenWQ_utils_ref, // utility methods/functions + *OpenWQ_readjson_ref, // read json files + *OpenWQ_vars_ref, + *OpenWQ_initiate_ref, // initiate modules + *OpenWQ_transp_ref, // transport modules + *OpenWQ_LE_ref, + *OpenWQ_chem_ref, // biochemistry modules + *OpenWQ_SI_ref, + *OpenWQ_TS_ref, + *OpenWQ_extwatflux_ss_ref, // sink and source modules) + *OpenWQ_solver_ref, + *OpenWQ_output_ref, + simtime); + } + + return 0; +} + +int CLASSWQ_openwq::openwq_run_space( + int simtime_summa[], + int source, int ix_s, int iy_s, int iz_s, + int recipient, int ix_r, int iy_r, int iz_r, + double wflux_s2r, double wmass_source) { + + // Convert Fortran Index to C++ index + ix_s -= 1; iy_s -= 1; iz_s -= 1; + ix_r -= 1; iy_r -= 1; iz_r -= 1; + + + time_t simtime = OpenWQ_units_ref->convertTime_ints2time_t( + *OpenWQ_wqconfig_ref, + simtime_summa[0], + simtime_summa[1], + simtime_summa[2], + simtime_summa[3], + simtime_summa[4], + 0); + + OpenWQ_couplercalls_ref->RunSpaceStep( + *OpenWQ_hostModelconfig_ref, + *OpenWQ_json_ref, + *OpenWQ_wqconfig_ref, // create OpenWQ_wqconfig object + *OpenWQ_units_ref, // functions for unit conversion + *OpenWQ_utils_ref, // utility methods/functions + *OpenWQ_readjson_ref, // read json files + *OpenWQ_vars_ref, + *OpenWQ_initiate_ref, // initiate modules + *OpenWQ_transp_ref, // transport modules + *OpenWQ_TS_ref, + *OpenWQ_LE_ref, + *OpenWQ_chem_ref, // biochemistry modules + *OpenWQ_SI_ref, + *OpenWQ_extwatflux_ss_ref, // sink and source modules + *OpenWQ_solver_ref, + *OpenWQ_output_ref, + simtime, + source, ix_s, iy_s, iz_s, + recipient, ix_r, iy_r, iz_r, + wflux_s2r, wmass_source); + + return 0; +} + +int CLASSWQ_openwq::openwq_run_space_in( + int simtime_summa[], + std::string source_EWF_name, + int recipient, int ix_r, int iy_r, int iz_r, + double wflux_s2r) { + + // Convert Fortran Index to C++ index + ix_r -= 1; iy_r -= 1; iz_r -= 1; + + time_t simtime = OpenWQ_units_ref->convertTime_ints2time_t( + *OpenWQ_wqconfig_ref, + simtime_summa[0], + simtime_summa[1], + simtime_summa[2], + simtime_summa[3], + simtime_summa[4], + 0); + + OpenWQ_couplercalls_ref->RunSpaceStep_IN( + *OpenWQ_hostModelconfig_ref, + *OpenWQ_json_ref, + *OpenWQ_wqconfig_ref, + *OpenWQ_units_ref, + *OpenWQ_utils_ref, + *OpenWQ_readjson_ref, + *OpenWQ_vars_ref, + *OpenWQ_initiate_ref, + *OpenWQ_transp_ref, + *OpenWQ_chem_ref, + *OpenWQ_TS_ref, + *OpenWQ_extwatflux_ss_ref, + *OpenWQ_solver_ref, + *OpenWQ_output_ref, + simtime, + source_EWF_name, + recipient, ix_r, iy_r, iz_r, + wflux_s2r); + + return 0; +} + +int CLASSWQ_openwq::openwq_run_time_end( + int simtime_summa[]) { + + time_t simtime = OpenWQ_units_ref->convertTime_ints2time_t( + *OpenWQ_wqconfig_ref, + simtime_summa[0], + simtime_summa[1], + simtime_summa[2], + simtime_summa[3], + simtime_summa[4], + 0); + + + OpenWQ_couplercalls_ref->RunTimeLoopEnd( + *OpenWQ_hostModelconfig_ref, + *OpenWQ_json_ref, + *OpenWQ_wqconfig_ref, // create OpenWQ_wqconfig object + *OpenWQ_units_ref, // functions for unit conversion + *OpenWQ_utils_ref, // utility methods/functions + *OpenWQ_readjson_ref, // read json files + *OpenWQ_vars_ref, + *OpenWQ_initiate_ref, // initiate modules + *OpenWQ_transp_ref, // transport modules + *OpenWQ_LE_ref, + *OpenWQ_chem_ref, // biochemistry modules + *OpenWQ_SI_ref, + *OpenWQ_TS_ref, + *OpenWQ_extwatflux_ss_ref, // sink and source modules) + *OpenWQ_solver_ref, + *OpenWQ_output_ref, + simtime); + + return 0; +} + +int CLASSWQ_openwq::get_numHRU(){ + return this->num_HRU; +} diff --git a/build/source/openwq/OpenWQ_hydrolink.h b/build/source/openwq/OpenWQ_hydrolink.h new file mode 100644 index 000000000..615e187b7 --- /dev/null +++ b/build/source/openwq/OpenWQ_hydrolink.h @@ -0,0 +1,141 @@ +// This program, openWQ, is free software: you can redistribute it and/or modify +// it under the terms of the GNU General Public License as published by +// the Free Software Foundation, either version 3 of the License, or +// (at your option) aNCOLS later version. +// +// This program is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU General Public License for more details. + +// You should have received a copy of the GNU General Public License +// along with this program. If not, see . + +#ifndef OPENWQ_HYDROLINK_INCLUDED +#define OPENWQ_HYDROLINK_INCLUDED + +#include "couplercalls/headerfile_CC.hpp" +#include "global/OpenWQ_hostModelConfig.hpp" +#include "global/OpenWQ_json.hpp" +#include "global/OpenWQ_wqconfig.hpp" +#include "global/OpenWQ_vars.hpp" +#include "readjson/headerfile_RJSON.hpp" +#include "initiate/headerfile_INIT.hpp" +#include "models_CH/headerfile_CH.hpp" +#include "models_TD/headerfile_td.hpp" +#include "models_LE/headerfile_le.hpp" +#include "extwatflux_ss/headerfile_EWF_SS.hpp" +#include "units/headerfile_units.hpp" +#include "utils/headerfile_UTILS.hpp" +#include "compute/headerfile_compute.hpp" +#include "output/headerfile_OUT.hpp" +#include +#include +#include +#include + +// Global Indexes for Compartments + inline int canopy_index_openwq = 0; + inline int snow_index_openwq = 1; + inline int runoff_index_openwq = 2; + inline int soil_index_openwq = 3; + inline int aquifer_index_openwq = 4; + inline int max_snow_layers = 5; + +class CLASSWQ_openwq +{ + + // Instance Variables + private: + + std::unique_ptr OpenWQ_hostModelconfig_ref = + std::make_unique(); + std::unique_ptr OpenWQ_couplercalls_ref = + std::make_unique(); + std::unique_ptr OpenWQ_json_ref = + std::make_unique(); + std::unique_ptr OpenWQ_wqconfig_ref = + std::make_unique(); + std::unique_ptr OpenWQ_units_ref = + std::make_unique(); + std::unique_ptr OpenWQ_utils_ref = + std::make_unique(); + std::unique_ptr OpenWQ_readjson_ref = + std::make_unique(); + std::unique_ptr OpenWQ_initiate_ref = + std::make_unique(); + std::unique_ptr OpenWQ_transp_ref = + std::make_unique(); + std::unique_ptr OpenWQ_LE_ref = + std::make_unique(); + std::unique_ptr OpenWQ_SI_ref = + std::make_unique(); + std::unique_ptr OpenWQ_TS_ref = + std::make_unique(); + + std::unique_ptr OpenWQ_chem_ref = + std::make_unique(); + std::unique_ptr OpenWQ_extwatflux_ss_ref = + std::make_unique(); + std::unique_ptr OpenWQ_solver_ref = + std::make_unique(); + std::unique_ptr OpenWQ_output_ref = + std::make_unique(); + + std::unique_ptr OpenWQ_vars_ref; // Requires input from summa + + int num_HRU; + const float *hru_area; + + // Constructor + public: + CLASSWQ_openwq(); + ~CLASSWQ_openwq(); + + // Methods + void printNum() { + std::cout << "num = " << this->num_HRU << std::endl; + } + + int decl( + int num_HRU, // num HRU + int nCanopy_2openwq, // num layers of canopy (fixed to 1) + int nSnow_2openwq, // num layers of snow (fixed to max of 5 because it varies) + int nSoil_2openwq, // num layers of snoil (variable) + int nRunoff_2openwq, // num layers of runoff (fixed to 1) + int nAquifer_2openwq, // num layers of aquifer (fixed to 1) + int nYdirec_2openwq); // num of layers in y-dir (set to 1 because not used in summa) + + int openwq_run_time_start( + bool last_hru_flag, + int hru_index, + int nSnow_2openwq, + int nSoil_2openwq, + int simtime_summa[], + double soilMoist_depVar_summa_frac[], + double soilTemp_depVar_summa_K[], + double airTemp_depVar_summa_K, + double sweWatVol_stateVar_summa_m3[], + double canopyWatVol_stateVar_summa_m3, + double soilWatVol_stateVar_summa_m3[], + double aquiferWatVol_stateVar_summa_m3); + + int openwq_run_space( + int simtime_summa[], + int source, int ix_s, int iy_s, int iz_s, + int recipient, int ix_r, int iy_r, int iz_r, + double wflux_s2r, double wmass_source); + + int openwq_run_space_in( + int simtime_summa[], + std::string source_EWF_name, + int recipient, int ix_r, int iy_r, int iz_r, + double wflux_s2r); + + int openwq_run_time_end( + int simtime_summa[]); + + int get_numHRU(); + +}; +#endif \ No newline at end of file diff --git a/build/source/openwq/OpenWQ_interface.cpp b/build/source/openwq/OpenWQ_interface.cpp new file mode 100644 index 000000000..38c482613 --- /dev/null +++ b/build/source/openwq/OpenWQ_interface.cpp @@ -0,0 +1,109 @@ +#include "OpenWQ_hydrolink.h" +#include "OpenWQ_interface.h" +/** + * Below is the implementation of the C interface for SUMMA. When Summa calls a function + * the functions below are the ones that are invoked first. + * The openWQ object is then passed from Fortran to these functions so that the OpenWQ object + * can be called. The openWQ object methods are defined above. + */ +// Interface functions to create Object +CLASSWQ_openwq* create_openwq() { + return new CLASSWQ_openwq(); +} + +void delete_openwq(CLASSWQ_openwq* openWQ) { + delete openWQ; +} + +int openwq_decl( + CLASSWQ_openwq *openWQ, + int hruCount, // num HRU + int nCanopy_2openwq, // num layers of canopy (fixed to 1) + int nSnow_2openwq, // num layers of snow (fixed to max of 5 because it varies) + int nSoil_2openwq, // num layers of snoil (variable) + int nRunoff_2openwq, // num layers of runoff (fixed to 1) + int nAquifer_2openwq, // num layers of aquifer (fixed to 1) + int nYdirec_2openwq){ // num of layers in y-dir (set to 1 because not used in summa) + + return openWQ->decl( + hruCount, + nCanopy_2openwq, + nSnow_2openwq, + nSoil_2openwq, + nRunoff_2openwq, + nAquifer_2openwq, + nYdirec_2openwq); + +} + + +int openwq_run_time_start( + CLASSWQ_openwq *openWQ, + bool last_hru_flag, + int hru_index, + int nSnow_2openwq, + int nSoil_2openwq, + int simtime_summa[], + double soilMoist_depVar_summa_frac[], + double soilTemp_depVar_summa_K[], + double airTemp_depVar_summa_K, + double sweWatVol_stateVar_summa_m3[], + double canopyWatVol_stateVar_summa_m3, + double soilWatVol_stateVar_summa_m3[], + double aquiferWatVol_stateVar_summa_m3) { + + return openWQ->openwq_run_time_start( + last_hru_flag, + hru_index, + nSnow_2openwq, + nSoil_2openwq, + simtime_summa, + soilMoist_depVar_summa_frac, + soilTemp_depVar_summa_K, + airTemp_depVar_summa_K, + sweWatVol_stateVar_summa_m3, + canopyWatVol_stateVar_summa_m3, + soilWatVol_stateVar_summa_m3, + aquiferWatVol_stateVar_summa_m3); +} + + +int openwq_run_space( + CLASSWQ_openwq *openWQ, + int simtime_summa[], + int source, int ix_s, int iy_s, int iz_s, + int recipient, int ix_r, int iy_r, int iz_r, + double wflux_s2r, double wmass_source) { + + return openWQ->openwq_run_space( + simtime_summa, + source, ix_s, iy_s, iz_s, + recipient, ix_r, iy_r, iz_r, + wflux_s2r, wmass_source); +} + +int openwq_run_space_in( + CLASSWQ_openwq *openWQ, + int simtime_summa[], + char* source_EWF_name, + int recipient, int ix_r, int iy_r, int iz_r, + double wflux_s2r) { + + // convert source_EWF_name to string + std::string source_EWF_name_str(source_EWF_name); + + return openWQ->openwq_run_space_in( + simtime_summa, + source_EWF_name_str, + recipient, ix_r, iy_r, iz_r, + wflux_s2r); +} + + +int openwq_run_time_end( + CLASSWQ_openwq *openWQ, + int simtime_summa[]) { + + return openWQ->openwq_run_time_end( + simtime_summa); +} diff --git a/build/source/openwq/OpenWQ_interface.h b/build/source/openwq/OpenWQ_interface.h new file mode 100644 index 000000000..91474735f --- /dev/null +++ b/build/source/openwq/OpenWQ_interface.h @@ -0,0 +1,69 @@ +/** + * This is the C interface for SUMMA, these are the functions that are called + * by SUMMA and the iso bindings. + * These are only their definition and their actual implementation is in + * OpenWQ_hydrolink.cpp + */ + +#ifdef __cplusplus +extern "C" { + class CLASSWQ_openwq; + typedef CLASSWQ_openwq CLASSWQ_openwq; + #else + typedef struct CLASSWQ_openwq CLASSWQ_openwq; + #endif + + // Create OpenWQ Object + CLASSWQ_openwq* create_openwq(); + + // Delete OpenWQ Object + void delete_openwq(CLASSWQ_openwq* openWQ); + + // OpenWQ initalization method + int openwq_decl( + CLASSWQ_openwq *openWQ, + int hruCount, // num HRU + int nCanopy_2openwq, // num layers of canopy (fixed to 1) + int nSnow_2openwq, // num layers of snow (fixed to max of 5 because it varies) + int nSoil_2openwq, // num layers of snoil (variable) + int nRunoff_2openwq, // num layers of runoff (fixed to 1) + int nAquifer_2openwq, // num layers of aquifer (fixed to 1) + int nYdirec_2openwq); // num of layers in y-dir (set to 1 because not used in summa) + + int openwq_run_time_start( + CLASSWQ_openwq *openWQ, + bool last_hru_flag, + int index_hru, + int nSnow_2openwq, + int nSoil_2openwq, + int simtime_summa[], + double soilMoist_depVar[], + double soilTemp_K_depVar[], + double airTemp_K_depVar, + double sweWatVol_stateVar[], + double canopyWat, + double soilWatVol_stateVar[], + double aquiferStorage); + + // OpenWQ run functions, this function decides which C++ code to call + int openwq_run_space( + CLASSWQ_openwq *openWQ, + int simtime_summa[], + int source, int ix_s, int iy_s, int iz_s, + int recipient, int ix_r, int iy_r, int iz_r, + double wflux_s2r, double wmass_source); + + int openwq_run_space_in( + CLASSWQ_openwq *openWQ, + int simtime_summa[], + char* source_EWF_name, + int recipient, int ix_r, int iy_r, int iz_r, + double wflux_s2r); + + int openwq_run_time_end( + CLASSWQ_openwq *openWQ, + int simtime_summa[]); + + #ifdef __cplusplus +} +#endif \ No newline at end of file diff --git a/build/source/openwq/README.md b/build/source/openwq/README.md new file mode 100644 index 000000000..5981471cf --- /dev/null +++ b/build/source/openwq/README.md @@ -0,0 +1,9 @@ +# OpenWQ Integration + +This directory contains the source code that enables Summa to couple to openWQ. + +To compile with openWQ support, you need to do the following steps: + - clone the openWQ repository: `git clone -b develop https://github.com/ue-hydro/openwq.git` + - The above needs to be done in build/source/openwq + - To compile Summa-OpenWQ, compile summa normally with CMake, but add the flag `-DENABLE_OPENWQ=ON` + - Compiling with openWQ support works for both Sundials and non-sundials builds of SUMMA. \ No newline at end of file diff --git a/build/source/openwq/openWQ.f90 b/build/source/openwq/openWQ.f90 new file mode 100644 index 000000000..fd33f8cca --- /dev/null +++ b/build/source/openwq/openWQ.f90 @@ -0,0 +1,188 @@ +module openwq + + USE, intrinsic :: iso_c_binding + USE nrtype + private + public :: CLASSWQ_openwq + + include "openWQInterface.f90" + + type CLASSWQ_openwq + private + type(c_ptr) :: ptr ! pointer to openWQ class + + contains + ! procedure :: get_num => openWQ_get_num + procedure :: decl => openWQ_init + procedure :: openwq_run_time_start => openwq_run_time_start + procedure :: openwq_run_space => openwq_run_space + procedure :: openwq_run_space_in => openwq_run_space_in + procedure :: openwq_run_time_end => openwq_run_time_end + + end type + + interface CLASSWQ_openwq + procedure create_openwq + end interface + contains + function create_openwq() + implicit none + type(CLASSWQ_openwq) :: create_openwq + create_openwq%ptr = create_openwq_c() + end function + + ! supposed to be decl but needed to openWQ_decl in the interface file + ! returns integer of either a failure(-1) or success(0) + integer function openWQ_init( & + this, & ! openwq object + num_hru, & ! num HRU + nCanopy_2openwq, & ! num layers of canopy (fixed to 1) + nSnow_2openwq, & ! num layers of snow (fixed to max of 5 because it varies) + nSoil_2openwq, & ! num layers of snoil (variable) + nRunoff_2openwq, & ! num layers of runoff (fixed to 1) + nAquifer_2openwq, & ! num layers of aquifer (fixed to 1) + nYdirec_2openwq) ! num of layers in y-dir (set to 1 because not used in summa) + + implicit none + class(CLASSWQ_openwq) :: this + integer(i4b), intent(in) :: num_hru + integer(i4b), intent(in) :: nCanopy_2openwq + integer(i4b), intent(in) :: nSnow_2openwq + integer(i4b), intent(in) :: nSoil_2openwq + integer(i4b), intent(in) :: nRunoff_2openwq + integer(i4b), intent(in) :: nAquifer_2openwq + + integer(i4b), intent(in) :: nYdirec_2openwq + + openWQ_init = openwq_decl_c( & + this%ptr, & ! openwq object + num_hru, & ! num HRU + nCanopy_2openwq, & ! num layers of canopy (fixed to 1) + nSnow_2openwq, & ! num layers of snow (fixed to max of 5 because it varies) + nSoil_2openwq, & ! num layers of snoil (variable) + nRunoff_2openwq, & ! num layers of runoff (fixed to 1) + nAquifer_2openwq, & ! num layers of aquifer (fixed to 1) + nYdirec_2openwq) ! num of layers in y-dir (set to 1 because not used in summa) + + end function + + + integer function openwq_run_time_start( & + this, & + last_hru_flag, & + hru_index, & + nSnow_2openwq, & + nSoil_2openwq, & + simtime, & + soilMoist_depVar_summa_frac, & + soilTemp_depVar_summa_K, & + airTemp_depVar_summa_K, & + sweWatVol_stateVar_summa_m3, & + canopyWatVol_stateVar_summa_m3, & + soilWatVol_stateVar_summa_m3, & + aquiferWatVol_stateVar_summa_m3) + + implicit none + class(CLASSWQ_openwq) :: this + logical(1), intent(in) :: last_hru_flag + integer(i4b), intent(in) :: hru_index + integer(i4b), intent(in) :: nSnow_2openwq + integer(i4b), intent(in) :: nSoil_2openwq + integer(i4b), intent(in) :: simtime(5) ! 5 is the number of timevars + real(rkind), intent(in) :: airTemp_depVar_summa_K + real(rkind), intent(in) :: soilTemp_depVar_summa_K(nSoil_2openwq) + real(rkind), intent(in) :: soilMoist_depVar_summa_frac(nSoil_2openwq) + real(rkind), intent(in) :: canopyWatVol_stateVar_summa_m3 + real(rkind), intent(in) :: sweWatVol_stateVar_summa_m3(nSnow_2openwq) + real(rkind), intent(in) :: soilWatVol_stateVar_summa_m3(nSoil_2openwq) + real(rkind), intent(in) :: aquiferWatVol_stateVar_summa_m3 + + openwq_run_time_start = openwq_run_time_start_c( & + this%ptr, & + last_hru_flag, & + hru_index, & + nSnow_2openwq, & + nSoil_2openwq, & + simtime, & + soilMoist_depVar_summa_frac, & + soilTemp_depVar_summa_K, & + airTemp_depVar_summa_K, & + sweWatVol_stateVar_summa_m3, & + canopyWatVol_stateVar_summa_m3, & + soilWatVol_stateVar_summa_m3, & + aquiferWatVol_stateVar_summa_m3) + + end function + + integer function openwq_run_space( & + this, & + simtime, & + source,ix_s,iy_s,iz_s, & + recipient,ix_r,iy_r,iz_r, & + wflux_s2r,wmass_source) + + implicit none + class(CLASSWQ_openwq) :: this + integer(i4b), intent(in) :: simtime(5) ! 5 is the number of timevars + integer(i4b), intent(in) :: source + integer(i4b), intent(in) :: ix_s + integer(i4b), intent(in) :: iy_s + integer(i4b), intent(in) :: iz_s + integer(i4b), intent(in) :: recipient + integer(i4b), intent(in) :: ix_r + integer(i4b), intent(in) :: iy_r + integer(i4b), intent(in) :: iz_r + real(rkind), intent(in) :: wflux_s2r + real(rkind), intent(in) :: wmass_source + + openwq_run_space = openwq_run_space_c( & + this%ptr, & + simtime, & + source,ix_s,iy_s,iz_s, & + recipient,ix_r,iy_r,iz_r, & + wflux_s2r,wmass_source) + + end function + + integer function openwq_run_space_in( & + this, & + simtime, & + source_EWF_name, & + recipient,ix_r,iy_r,iz_r, & + wflux_s2r) + + implicit none + class(CLASSWQ_openwq) :: this + integer(i4b), intent(in) :: simtime(5) ! 5 is the number of timevars + integer(i4b), intent(in) :: recipient + integer(i4b), intent(in) :: ix_r + integer(i4b), intent(in) :: iy_r + integer(i4b), intent(in) :: iz_r + real(rkind), intent(in) :: wflux_s2r + character(*), intent(in) :: source_EWF_name + + openwq_run_space_in = openwq_run_space_in_c( & + this%ptr, & + simtime, & + source_EWF_name, & + recipient,ix_r,iy_r,iz_r, & + wflux_s2r) + + end function + + + integer function openwq_run_time_end( & + this, & + simtime) + + implicit none + class(CLASSWQ_openwq) :: this + integer(i4b), intent(in) :: simtime(5) ! 5 is the number of timevars + + openwq_run_time_end = openwq_run_time_end_c( & + this%ptr, & + simtime) + + end function + +end module openwq \ No newline at end of file diff --git a/build/source/openwq/openWQInterface.f90 b/build/source/openwq/openWQInterface.f90 new file mode 100644 index 000000000..7bf39a1d5 --- /dev/null +++ b/build/source/openwq/openWQInterface.f90 @@ -0,0 +1,133 @@ +! OpenWQ C Interface +! This file contains the Fortran functions that are callable from C. +! These function are mapped to the C functions in defined in OpenWQ_interface.h +! and implmeneted in OpenWQ_interface.c + + +interface + function create_openwq_c() bind(C, name="create_openwq") + + use iso_c_binding + implicit none + type(c_ptr) :: create_openwq_c + + end function + + function openwq_decl_c( & + openWQ, & + num_hru, & + nCanopy_2openwq, & + nSnow_2openwq, & + nSoil_2openwq, & + nRunoff_2openwq, & + nAquifer_2openwq, & + y_direction) bind(C, name="openwq_decl") + + use iso_c_binding + implicit none + integer(c_int) :: openwq_decl_c ! returns a return value of 0 (success) or -1 (failure) + type(c_ptr), intent(in), value :: openWQ + integer(c_int), intent(in), value :: num_hru + integer(c_int), intent(in), value :: nCanopy_2openwq + integer(c_int), intent(in), value :: nSnow_2openwq + integer(c_int), intent(in), value :: nSoil_2openwq + integer(c_int), intent(in), value :: nAquifer_2openwq + integer(c_int), intent(in), value :: nRunoff_2openwq + integer(c_int), intent(in), value :: y_direction + + end function + + function openwq_run_time_start_c(& + openWQ, & + last_hru_flag, & + hru_index, & + nSnow_2openwq, & + nSoil_2openwq, & + simtime_summa, & + soilMoist_depVar_summa_frac, & + soilTemp_depVar_summa_K, & + airTemp_depVar_summa_K, & + sweWatVol_stateVar_summa_m3, & + canopyWatVol_stateVar_summa_m3, & + soilWatVol_stateVar_summa_m3, & + aquiferWatVol_stateVar_summa_m3) bind(C, name="openwq_run_time_start") + + use iso_c_binding + implicit none + integer(c_int) :: openwq_run_time_start_c ! returns 0 (success) or -1 (failure) + type(c_ptr), intent(in), value :: openWQ + logical(c_bool), intent(in) :: last_hru_flag + integer(c_int), intent(in), value :: hru_index + integer(c_int), intent(in), value :: nSnow_2openwq + integer(c_int), intent(in), value :: nSoil_2openwq + integer(c_int), intent(in) :: simtime_summa(5) + real(c_double), intent(in) :: soilMoist_depVar_summa_frac(nSoil_2openwq) + real(c_double), intent(in) :: soilTemp_depVar_summa_K(nSoil_2openwq) + real(c_double), intent(in), value :: airTemp_depVar_summa_K + real(c_double), intent(in) :: sweWatVol_stateVar_summa_m3(nSnow_2openwq) + real(c_double), intent(in), value :: canopyWatVol_stateVar_summa_m3 + real(c_double), intent(in) :: soilWatVol_stateVar_summa_m3(nSoil_2openwq) + real(c_double), intent(in), value :: aquiferWatVol_stateVar_summa_m3 + + end function + + function openwq_run_space_c(& + openWQ, & + simtime, & + source,ix_s,iy_s,iz_s, & + recipient,ix_r,iy_r,iz_r, & + wflux_s2r, & + wmass_source) bind(C, name="openwq_run_space") + + use iso_c_binding + implicit none + integer(c_int) :: openwq_run_space_c ! returns 0 (success) or -1 (failure) + type(c_ptr), intent(in), value :: openWQ + integer(c_int), intent(in) :: simtime(5) + integer(c_int), intent(in), value :: source + integer(c_int), intent(in), value :: ix_s + integer(c_int), intent(in), value :: iy_s + integer(c_int), intent(in), value :: iz_s + integer(c_int), intent(in), value :: recipient + integer(c_int), intent(in), value :: ix_r + integer(c_int), intent(in), value :: iy_r + integer(c_int), intent(in), value :: iz_r + real(c_double), intent(in), value :: wflux_s2r + real(c_double), intent(in), value :: wmass_source + + end function + + function openwq_run_space_in_c( & + openWQ, & + simtime, & + source_EWF_name, & + recipient,ix_r,iy_r,iz_r, & + wflux_s2r) bind(C, name="openwq_run_space_in") + + USE iso_c_binding + implicit none + integer(c_int) :: openwq_run_space_in_c + type(c_ptr), intent(in), value :: openWQ + integer(c_int), intent(in) :: simtime(5) + integer(c_int), intent(in), value :: recipient + integer(c_int), intent(in), value :: ix_r + integer(c_int), intent(in), value :: iy_r + integer(c_int), intent(in), value :: iz_r + real(c_double), intent(in), value :: wflux_s2r + character(c_char), intent(in) :: source_EWF_name + + end function + + function openwq_run_time_end_c( & + openWQ, & + simtime) bind(C, name="openwq_run_time_end") + + USE iso_c_binding + implicit none + integer(c_int) :: openwq_run_time_end_c ! returns 0 (success) or -1 (failure) + type(c_ptr), intent(in), value :: openWQ + integer(c_int), intent(in) :: simtime(5) + + end function + +end interface \ No newline at end of file diff --git a/build/source/openwq/summa_openWQ.f90 b/build/source/openwq/summa_openWQ.f90 new file mode 100644 index 000000000..6cf46b692 --- /dev/null +++ b/build/source/openwq/summa_openWQ.f90 @@ -0,0 +1,1032 @@ +module summa_openwq + USE nrtype + USE openWQ,only:CLASSWQ_openwq + USE data_types,only:gru_hru_doubleVec + implicit none + private + ! Subroutines + public :: openwq_init + public :: openwq_run_time_start + public :: openwq_run_space_step + public :: openwq_run_time_end + private:: openWQ_run_time_start_inner ! inner call at the HRU level + + ! Global Data for prognostic Variables of HRUs + type(gru_hru_doubleVec),save,public :: progStruct_timestep_start ! copy of progStruct at the start of timestep for passing fluxes + type(CLASSWQ_openwq),save,public :: openwq_obj + + + contains + +! Initialize the openWQ object +subroutine openwq_init(err) + USE globalData,only:gru_struc ! gru-hru mapping structures + USE globalData,only:prog_meta + USE globalData,only:maxLayers,maxSnowLayers + USE allocspace_progStuct_module,only:allocGlobal_progStruct ! module to allocate space for global data structures + implicit none + + ! Dummy Varialbes + integer(i4b), intent(out) :: err + + ! local variables + integer(i4b) :: hruCount + integer(i4b) :: nSoil + ! OpenWQ dimensions + integer(i4b) :: nCanopy_2openwq = 1 ! Canopy has only 1 layer + integer(i4b) :: nRunoff_2openwq = 1 ! Runoff has only 1 layer (not a summa variable - openWQ keeps track of this) + integer(i4b) :: nAquifer_2openwq = 1 ! GW has only 1 layer + integer(i4b) :: nYdirec_2openwq = 1 ! number of layers in the y-dir (not used in summa) + ! error handling + character(len=256) :: message + + ! nx -> num of HRUs) + ! ny -> 1 + ! nz -> num of layers (snow + soil) + openwq_obj = CLASSWQ_openwq() ! initialize openWQ object + + hruCount = sum( gru_struc(:)%hruCount ) + + nSoil = maxLayers - maxSnowLayers + + ! intialize openWQ + err=openwq_obj%decl( & + hruCount, & ! num HRU + nCanopy_2openwq, & ! num layers of canopy (fixed to 1) + maxSnowLayers, & ! num layers of snow (fixed to max of 5 because it varies) + nSoil, & ! num layers of snoil (variable) + nRunoff_2openwq, & ! num layers of runoff (fixed to 1) + nAquifer_2openwq, & ! num layers of aquifer (fixed to 1) + nYdirec_2openwq) ! num of layers in y-dir (set to 1 because not used in summa) + + + ! Create copy of state information, needed for passing to openWQ with fluxes that require + ! the previous time_steps volume + call allocGlobal_progStruct(prog_meta,progStruct_timestep_start,maxSnowLayers,err,message) + +end subroutine openwq_init + +! Pass Summa State to openWQ +subroutine openwq_run_time_start(summa1_struc) + USE summa_type, only: summa1_type_dec ! master summa data type + USE var_lookup,only: iLookINDEX + implicit none + + ! Dummy Varialbes + type(summa1_type_dec), intent(in) :: summa1_struc + ! local variables + integer(i4b) :: openWQArrayIndex !index into OpenWQ's state structure + integer(i4b) :: iGRU + integer(i4b) :: iHRU + integer(i4b) :: nHRU ! number of HRUs in the GRU (used in looping) + integer(i4b) :: nSoil + integer(i4b) :: nSnow + logical(1) :: lastHRUFlag + summaVars: associate(& + progStruct => summa1_struc%progStruct , & + timeStruct => summa1_struc%timeStruct , & + attrStruct => summa1_struc%attrStruct , & + indxStruct => summa1_struc%indxStruct , & + nGRU => summa1_struc%nGRU & + ) + ! ############################ + + openWQArrayIndex = 0 + lastHRUFlag = .false. + + do iGRU=1,nGRU + nHRU = size(progStruct%gru(iGRU)%hru(:)) + do iHRU=1,nHRU + if (iGRU == nGRU .and. iHRU == nHRU )then + lastHRUFlag = .true. + end if + + nSnow = indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%nSnow)%dat(1) + nSoil = indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%nSoil)%dat(1) + + call openwq_run_time_start_inner(openWQArrayIndex, iGRU, iHRU, & + summa1_struc,& + nSnow, nSoil, lastHRUFlag) + + openWQArrayIndex = openWQArrayIndex + 1 + + end do ! end HRU + end do ! end GRU + + end associate summaVars +end subroutine + + +subroutine openWQ_run_time_start_inner(openWQArrayIndex, iGRU, iHRU, & + summa1_struc, nSnow, nSoil, last_hru_flag) + USE summa_type,only: summa1_type_dec ! master summa data type + USE var_lookup,only: iLookPROG ! named variables for state variables + USE var_lookup,only: iLookATTR ! named variables for real valued attribute data structure + USE var_lookup,only: iLookINDEX + USE var_lookup,only: iLookVarType ! named variables for real valued attribute data structure + USE var_lookup,only: iLookTIME ! named variables for time data structure + USE globalData,only:prog_meta + USE globalData,only:realMissing + USE multiconst,only:iden_water ! intrinsic density of liquid water (kg m-3) + implicit none + integer(i4b), intent(in) :: openWQArrayIndex !index into OpenWQ's state structure + integer(i4b), intent(in) :: iGRU + integer(i4b), intent(in) :: iHRU + type(summa1_type_dec), intent(in) :: summa1_struc + integer(i4b), intent(in) :: nSnow + integer(i4b), intent(in) :: nSoil + logical(1),intent(in) :: last_hru_flag + + ! local variables + integer(i4b) :: simtime(5) ! 5 time values yy-mm-dd-hh-min + real(rkind) :: canopyWatVol_stateVar_summa_m3 ! OpenWQ State Var + real(rkind) :: sweWatVol_stateVar_summa_m3(nSnow) ! OpenWQ State Var + real(rkind) :: soilTemp_depVar_summa_K(nSoil) ! OpenWQ State Var + real(rkind) :: soilWatVol_stateVar_summa_m3(nSoil)! OpenWQ State Var + real(rkind) :: soilMoist_depVar_summa_frac(nSoil) ! OpenWQ State Var + real(rkind) :: aquiferWatVol_stateVar_summa_m3 ! OpenWQ State Var + ! counter variables + integer(i4b) :: ilay + integer(i4b) :: iVar + integer(i4b) :: iDat + integer(i4b) :: index + integer(i4b) :: offset + ! error handling + integer(i4b) :: err + + summaVars: associate(& + progStruct => summa1_struc%progStruct , & + timeStruct => summa1_struc%timeStruct , & + hru_area_m2 => summa1_struc%attrStruct%gru(iGRU)%hru(iHRU)%var(iLookATTR%HRUarea) ,& + Tair_summa_K => summa1_struc%progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarCanairTemp)%dat(1) ,& ! air temperature (K) + scalarCanopyWat_summa_kg_m2 => summa1_struc%progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarCanopyWat)%dat(1) ,& ! canopy water (kg m-2) + mLayerDepth_summa_m => summa1_struc%progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerDepth)%dat(:) ,& ! depth of each layer (m) + mLayerVolFracWat_summa_frac => summa1_struc%progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerVolFracWat)%dat(:) ,& ! volumetric fraction of total water in each layer (-) + Tsoil_summa_K => summa1_struc%progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerTemp)%dat(:) ,& ! soil temperature (K) for each layer + AquiferStorWat_summa_m => summa1_struc%progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarAquiferStorage)%dat(1) & ! aquifer storage (m) + ) + + ! ############################ + ! Update unlayered variables and dependencies (1 layer only) + ! ############################ + + if(Tair_summa_K == realMissing) then + stop 'Error: OpenWQ requires air temperature (K)' + endif + + ! Vegetation + ! unit for volume = m3 (summa-to-openwq unit conversions needed) + ! scalarCanopyWat [kg m-2], so needs to to multiply by hru area [m2] and divide by water density + if(scalarCanopyWat_summa_kg_m2 == realMissing) then + canopyWatVol_stateVar_summa_m3 = 0._rkind + else + canopyWatVol_stateVar_summa_m3 = scalarCanopyWat_summa_kg_m2 * hru_area_m2 / iden_water + endif + + ! Aquifer + ! unit for volume = m3 (summa-to-openwq unit conversions needed) + ! scalarAquiferStorage [m], so needs to to multiply by hru area [m2] only + if(AquiferStorWat_summa_m == realMissing) then + stop 'Error: OpenWQ requires aquifer storage (m3)' + endif + aquiferWatVol_stateVar_summa_m3 = AquiferStorWat_summa_m * hru_area_m2 + + ! ############################ + ! Update layered variables and dependenecies + ! ############################ + + if (nSnow .gt. 0)then + do ilay = 1, nSnow + ! Snow + ! unit for volume = m3 (summa-to-openwq unit conversions needed) + ! mLayerVolFracIce and mLayerVolFracLiq [-], so needs to to multiply by hru area [m2] and divide by water density + ! But needs to account for both ice and liquid, and convert to liquid volumes + if(mLayerVolFracWat_summa_frac(ilay) /= realMissing) then + sweWatVol_stateVar_summa_m3(ilay) = & + mLayerVolFracWat_summa_frac(ilay) * mLayerDepth_summa_m(ilay) * hru_area_m2 + else + sweWatVol_stateVar_summa_m3(ilay) = 0._rkind + endif + enddo ! end snow layers + endif ! end snow + + + do ilay = 1, nSoil + ! Soil + ! Tsoil + ! (Summa in K) + if(Tsoil_summa_K(nSnow+ilay) == realMissing) then + stop 'Error: OpenWQ requires soil temperature (K)' + endif + soilTemp_depVar_summa_K(ilay) = Tsoil_summa_K(nSnow+ilay) + + soilMoist_depVar_summa_frac(ilay) = 0 ! TODO: Find the value for this varaibles + ! Soil + ! unit for volume = m3 (summa-to-openwq unit conversions needed) + ! mLayerMatricHead [m], so needs to to multiply by hru area [m2] + if(mLayerVolFracWat_summa_frac(nSnow+ilay) == realMissing) then + stop 'Error: OpenWQ requires soil water (m3)' + endif + soilWatVol_stateVar_summa_m3(ilay) = & + mLayerVolFracWat_summa_frac(nSnow+ilay) * hru_area_m2 * mLayerDepth_summa_m(nSnow+ilay) + enddo + + + ! Copy the prog structure + do iVar = 1, size(progStruct%gru(iGRU)%hru(iHRU)%var) + do iDat = 1, size(progStruct%gru(iGRU)%hru(iHRU)%var(iVar)%dat) + select case(prog_meta(iVar)%vartype) + case(iLookVarType%ifcSoil); + offset = 0 + case(iLookVarType%ifcToto); + offset = 0 + case default + offset = 1 + end select + do index = offset , size(progStruct%gru(iGRU)%hru(iHRU)%var(iVar)%dat) - 1 + offset + progStruct_timestep_start%gru(iGRU)%hru(iHRU)%var(iVar)%dat(index) = progStruct%gru(iGRU)%hru(iHRU)%var(iVar)%dat(index) + enddo + end do + end do + + + simtime(1) = timeStruct%var(iLookTIME%iyyy) ! Year + simtime(2) = timeStruct%var(iLookTIME%im) ! month + simtime(3) = timeStruct%var(iLookTIME%id) ! hour + simtime(4) = timeStruct%var(iLookTIME%ih) ! day + simtime(5) = timeStruct%var(iLookTIME%imin) ! minute + + err=openwq_obj%openwq_run_time_start(& + last_hru_flag, & + openWQArrayIndex, & ! total HRUs + nSnow, & + nSoil, & + simtime, & + soilMoist_depVar_summa_frac, & + soilTemp_depVar_summa_K, & + Tair_summa_K, & ! air temperature (K) + sweWatVol_stateVar_summa_m3, & + canopyWatVol_stateVar_summa_m3, & + soilWatVol_stateVar_summa_m3, & + aquiferWatVol_stateVar_summa_m3) + end associate summaVars + +end subroutine openWQ_run_time_start_inner + + +subroutine openwq_run_space_step(summa1_struc) + USE var_lookup,only: iLookPROG ! named variables for state variables + USE var_lookup,only: iLookTIME ! named variables for time data structure + USE var_lookup,only: iLookFLUX ! named varaibles for flux data + USE var_lookup,only: iLookATTR ! named variables for real valued attribute data structure + USE var_lookup,only: iLookINDEX + USE var_lookup, only: iLookTYPE ! look-up values for classification of veg, soils etc. + USE summa_type,only: summa1_type_dec ! master summa data type + USE data_types,only: var_dlength,var_i + USE globalData,only: gru_struc + USE globalData,only: data_step ! time step of forcing data (s) + USE globalData,only: realMissing + USE multiconst,only:& + iden_ice, & ! intrinsic density of ice (kg m-3) + iden_water ! intrinsic density of liquid water (kg m-3) + USE module_sf_noahmplsm,only:isWater ! Identifier for water land cover type + + implicit none + + type(summa1_type_dec), intent(in) :: summa1_struc + + + integer(i4b) :: hru_index ! needed because openWQ saves hrus as a single array + integer(i4b) :: iHRU ! variable needed for looping + integer(i4b) :: iGRU ! variable needed for looping + integer(i4b) :: iLayer ! varaible needed for looping + + integer(i4b) :: simtime(5) ! 5 time values yy-mm-dd-hh-min + integer(i4b) :: err + + ! compartment indexes in OpenWQ (defined in the hydrolink) + integer(i4b) :: canopy_index_openwq = 0 + integer(i4b) :: snow_index_openwq = 1 + integer(i4b) :: runoff_index_openwq = 2 + integer(i4b) :: soil_index_openwq = 3 + integer(i4b) :: aquifer_index_openwq = 4 + integer(i4b) :: OpenWQindex_s + integer(i4b) :: OpenWQindex_r + integer(i4b) :: iy_r + integer(i4b) :: iz_r + integer(i4b) :: iy_s + integer(i4b) :: iz_s + real(rkind) :: wflux_s2r + real(rkind) :: wmass_source + + ! Summa to OpenWQ units + ! PrecipVars + real(rkind) :: scalarRainfall_summa_m3 + real(rkind) :: scalarSnowfall_summa_m3 + real(rkind) :: scalarThroughfallRain_summa_m3 + real(rkind) :: scalarThroughfallSnow_summa_m3 + ! CanopyVars + real(rkind) :: canopyStorWat_kg_m3 + real(rkind) :: scalarCanopySnowUnloading_summa_m3 + real(rkind) :: scalarCanopyLiqDrainage_summa_m3 + real(rkind) :: scalarCanopyTranspiration_summa_m3 + real(rkind) :: scalarCanopyEvaporation_summa_m3 + real(rkind) :: scalarCanopySublimation_summa_m3 + ! runoff vars + real(rkind) :: scalarRunoffVol_m3 + real(rkind) :: scalarSurfaceRunoff_summa_m3 + real(rkind) :: scalarInfiltration_summa_m3 + ! Snow_SoilVars + real(rkind) :: mLayerLiqFluxSnow_summa_m3 + real(rkind) :: iLayerLiqFluxSoil_summa_m3 + real(rkind) :: mLayerVolFracWat_summa_m3 + real(rkind) :: scalarSnowSublimation_summa_m3 + real(rkind) :: scalarSfcMeltPond_summa_m3 + real(rkind) :: scalarGroundEvaporation_summa_m3 + real(rkind) :: scalarExfiltration_summa_m3 + real(rkind) :: mLayerBaseflow_summa_m3 + real(rkind) :: scalarSoilDrainage_summa_m3 + real(rkind) :: mLayerTranspire_summa_m3 + ! AquiferVars + real(rkind) :: scalarAquiferBaseflow_summa_m3 + real(rkind) :: scalarAquiferRecharge_summa_m3 + real(rkind) :: scalarAquiferStorage_summa_m3 + real(rkind) :: scalarAquiferTranspire_summa_m3 + + summaVars: associate(& + timeStruct => summa1_struc%timeStruct , & + fluxStruct => summa1_struc%fluxStruct , & + nGRU => summa1_struc%nGRU) + + + + simtime(1) = timeStruct%var(iLookTIME%iyyy) ! Year + simtime(2) = timeStruct%var(iLookTIME%im) ! month + simtime(3) = timeStruct%var(iLookTIME%id) ! hour + simtime(4) = timeStruct%var(iLookTIME%ih) ! day + simtime(5) = timeStruct%var(iLookTIME%imin) ! minute + + hru_index = 0 + + ! Summa does not have a y-direction, + ! so the dimension will always be 1 + iy_r = 1 + iy_s = 1 + + do iGRU=1,nGRU + do iHRU=1,gru_struc(iGRU)%hruCount + hru_index = hru_index + 1 + if (summa1_struc%typeStruct%gru(iGRU)%hru(iHRU)%var(iLookTYPE%vegTypeIndex) == isWater) cycle + + ! #################################################################### + ! Associate relevant variables + ! #################################################################### + + DomainVars: associate( & + ! General Summa info + hru_area_m2 => summa1_struc%attrStruct%gru(iGRU)%hru(iHRU)%var(iLookATTR%HRUarea) & + ) + + PrecipVars: associate( & + ! Precipitation + scalarRainfall_summa_kg_m2_s => fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarRainfall)%dat(1) ,& + scalarSnowfall_summa_kg_m2_s => fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarSnowfall)%dat(1) ,& + scalarThroughfallRain_summa_kg_m2_s => fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarThroughfallRain)%dat(1) ,& + scalarThroughfallSnow_summa_kg_m2_s => fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarThroughfallSnow)%dat(1) & + ) + + CanopyVars: associate( & + ! Canopy + scalarCanopyWat_summa_kg_m2 => progStruct_timestep_start%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarCanopyWat)%dat(1) ,& + scalarCanopySnowUnloading_summa_kg_m2_s => fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarCanopySnowUnloading)%dat(1) ,& + scalarCanopyLiqDrainage_summa_kg_m2_s => fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) ,& + scalarCanopyTranspiration_summa_kg_m2_s => fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarCanopyTranspiration)%dat(1) ,& + scalarCanopyEvaporation_summa_kg_m2_s => fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarCanopyEvaporation)%dat(1) ,& + scalarCanopySublimation_summa_kg_m2_s => fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarCanopySublimation)%dat(1) & + ) + + RunoffVars: associate(& + scalarSurfaceRunoff_m_s => fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarSurfaceRunoff)%dat(1) ,& + scalarInfiltration_m_s => fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarInfiltration)%dat(1) & + ) + + Snow_SoilVars: associate(& + ! Snow + Soil - Control Volume + current_nSnow => summa1_struc%indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%nSnow)%dat(1) ,& + current_nSoil => summa1_struc%indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%nSoil)%dat(1) ,& + nSnow => gru_struc(iGRU)%hruInfo(iHRU)%nSnow ,& + nSoil => gru_struc(iGRU)%hruInfo(iHRU)%nSoil ,& + ! Layer depth and water frac + mLayerDepth_summa_m => progStruct_timestep_start%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerDepth)%dat(:) ,& + mLayerVolFracWat_summa_frac => progStruct_timestep_start%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerVolFracWat)%dat(:) ,& + ! Snow Fluxes + scalarSnowSublimation_summa_kg_m2_s => fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarSnowSublimation)%dat(1) ,& + scalarSfcMeltPond_kg_m2 => summa1_struc%progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarSfcMeltPond)%dat(1) ,& + iLayerLiqFluxSnow_summa_m_s => fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%iLayerLiqFluxSnow)%dat(:) ,& + + ! Soil Fluxes + scalarGroundEvaporation_summa_kg_m2_s => fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarGroundEvaporation)%dat(1) ,& + iLayerLiqFluxSoil_summa_m_s => fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%iLayerLiqFluxSoil)%dat(:) ,& + scalarExfiltration_summa_m_s => fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarExfiltration)%dat(1) ,& + mLayerBaseflow_summa_m_s => fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%mLayerBaseflow)%dat(:) ,& + scalarSoilDrainage_summa_m_s => fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarSoilDrainage)%dat(1) ,& + mLayerTranspire_summa_m_s => fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%mLayerTranspire)%dat(:) & + ) + + AquiferVars: associate(& + ! Aquifer + scalarAquiferStorage_summa_m => progStruct_timestep_start%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarAquiferStorage)%dat(1), & + scalarAquiferRecharge_summa_m_s => fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarAquiferRecharge)%dat(1) , & + scalarAquiferBaseflow_summa_m_s => fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarAquiferBaseflow)%dat(1) , & + scalarAquiferTranspire_summa_m_s => fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarAquiferTranspire)%dat(1) & + ) + + ! #################################################################### + ! Converte associate variable units: from SUMMA to OpenWQ units + ! Here only scalar/unlayered variables + ! OpenWQ: Volume (m3), Time (sec) + ! Where: Vol in kg/m2, then convert to m3 by multipling by (hru_area_m2 / iden_water) + ! Where: Flux in kg/m2/s, then convert to m3/time_step by multiplying by (hru_area_m2 * data_step / iden_water) + ! #################################################################### + + ! PrecipVars + scalarRainfall_summa_m3 = scalarRainfall_summa_kg_m2_s * hru_area_m2 * data_step / iden_water + scalarSnowfall_summa_m3 = scalarSnowfall_summa_kg_m2_s * hru_area_m2 * data_step / iden_water + scalarThroughfallRain_summa_m3 = scalarThroughfallRain_summa_kg_m2_s * hru_area_m2 * data_step / iden_water ! flux + scalarThroughfallSnow_summa_m3 = scalarThroughfallSnow_summa_kg_m2_s * hru_area_m2 * data_step / iden_water ! flux + + ! CanopyVars + canopyStorWat_kg_m3 = scalarCanopyWat_summa_kg_m2 * hru_area_m2 / iden_water ! vol + scalarCanopySnowUnloading_summa_m3 = scalarCanopySnowUnloading_summa_kg_m2_s * hru_area_m2 * data_step / iden_water ! flux + scalarCanopyLiqDrainage_summa_m3 = scalarCanopyLiqDrainage_summa_kg_m2_s * hru_area_m2 * data_step / iden_water ! flux + scalarCanopyTranspiration_summa_m3 = scalarCanopyTranspiration_summa_kg_m2_s * hru_area_m2 * data_step / iden_water ! flux + scalarCanopyEvaporation_summa_m3 = scalarCanopyEvaporation_summa_kg_m2_s * hru_area_m2 * data_step / iden_water ! flux + scalarCanopySublimation_summa_m3 = scalarCanopySublimation_summa_kg_m2_s * hru_area_m2 * data_step / iden_water ! flux + + ! runoff vars + scalarSurfaceRunoff_summa_m3 = scalarSurfaceRunoff_m_s * hru_area_m2 * data_step + scalarInfiltration_summa_m3 = scalarInfiltration_m_s * hru_area_m2 * data_step + + + ! Snow_SoilVars (unlayered variables) + ! Other variables are layered and added below as needed + scalarSnowSublimation_summa_m3 = scalarSnowSublimation_summa_kg_m2_s * hru_area_m2 * data_step / iden_water + scalarGroundEvaporation_summa_m3 = scalarGroundEvaporation_summa_kg_m2_s * hru_area_m2 * data_step / iden_water + scalarSfcMeltPond_summa_m3 = scalarSfcMeltPond_kg_m2 * hru_area_m2 / iden_water + scalarExfiltration_summa_m3 = scalarExfiltration_summa_m_s * hru_area_m2 * data_step + scalarSoilDrainage_summa_m3 = scalarSoilDrainage_summa_m_s * hru_area_m2 * data_step + + + ! AquiferVars + scalarAquiferStorage_summa_m3 = scalarAquiferStorage_summa_m * hru_area_m2 + scalarAquiferRecharge_summa_m3 = scalarAquiferRecharge_summa_m_s * hru_area_m2 * data_step + scalarAquiferBaseflow_summa_m3 = scalarAquiferBaseflow_summa_m_s * hru_area_m2 * data_step + scalarAquiferTranspire_summa_m3 = scalarAquiferTranspire_summa_m_s * hru_area_m2 * data_step + + ! Reset Runoff (it's not tracked by SUMMA, so need to track it here) + scalarRunoffVol_m3 = 0._rkind !initialization of this variable is required to limit the runoff aggreggation to each hru. + + ! #################################################################### + ! Apply Fluxes + ! Call RunSpaceStep + ! #################################################################### + + ! -------------------------------------------------------------------- + ! %%%%%%%%%%%%%%%%%%%%%%%%%%% + ! 1 Fluxes involving the canopy + ! %%%%%%%%%%%%%%%%%%%%%%%%%%% + ! -------------------------------------------------------------------- + if(scalarCanopyWat_summa_kg_m2 /= realMissing) then + + ! ==================================================== + ! 1.1 precipitation -> canopy + ! ==================================================== + ! *Source*: + ! PRECIP (external flux, so need call openwq_run_space_in) + ! *Recipient*: canopy (only 1 z layer) + OpenWQindex_r = canopy_index_openwq + iz_r = 1 + ! *Flux*: the portion of rainfall and snowfall not throughfall + wflux_s2r = (scalarRainfall_summa_m3 - scalarThroughfallRain_summa_m3) & + + (scalarSnowfall_summa_m3 - scalarThroughfallSnow_summa_m3) + ! *Call openwq_run_space_in* if wflux_s2r not 0 + err=openwq_obj%openwq_run_space_in( & + simtime, & + 'PRECIP', & + OpenWQindex_r, hru_index, iy_r, iz_r, & + wflux_s2r) + + ! ==================================================== + ! 1.2 canopy -> upper snow layer or runoff pool + ! scalarCanopySnowUnloading + scalarCanopyLiqDrainage + ! ==================================================== + ! *Flux* + ! snow uloading + liq drainage + wflux_s2r = scalarCanopySnowUnloading_summa_m3 & + + scalarCanopyLiqDrainage_summa_m3 + ! *Source* + ! canopy (only 1 z layer) + OpenWQindex_s = canopy_index_openwq + iz_s = 1 + wmass_source = canopyStorWat_kg_m3 + ! *Recipient* depends on snow layers + if (current_nSnow .gt. 0)then + OpenWQindex_r = snow_index_openwq + iz_r = 1 ! upper layer + else + OpenWQindex_r = runoff_index_openwq + iz_r = 1 ! (has only 1 layer) + scalarRunoffVol_m3 = scalarRunoffVol_m3 + wflux_s2r; + end if + ! *Call openwq_run_space* if wflux_s2r not 0 + err=openwq_obj%openwq_run_space( & + simtime, & + OpenWQindex_s, hru_index, iy_s, iz_s, & + OpenWQindex_r, hru_index, iy_r, iz_r, & + wflux_s2r, & + wmass_source) + + ! ==================================================== + ! 1.3 canopy -> OUT (lost from model) (Evap + Subl) + ! ==================================================== + ! *Source*: + ! canopy (only 1 z layer) + OpenWQindex_s = canopy_index_openwq + iz_s = 1 + wmass_source = canopyStorWat_kg_m3 + ! *Recipient*: + ! lost from system + OpenWQindex_r = -1 + iz_r = -1 + ! *Flux* + ! transpiration + evaporation + sublimation + wflux_s2r = scalarCanopyEvaporation_summa_m3 & + + scalarCanopySublimation_summa_m3 + + ! *Call openwq_run_space* if wflux_s2r not 0 + err=openwq_obj%openwq_run_space( & + simtime, & + OpenWQindex_s, hru_index, iy_s, iz_s, & + OpenWQindex_r, hru_index, iy_r, iz_r, & + wflux_s2r, & + wmass_source) + + endif + + ! -------------------------------------------------------------------- + ! %%%%%%%%%%%%%%%%%%%%%%%%%%% + ! 2. Snow / runoff + ! %%%%%%%%%%%%%%%%%%%%%%%%%%% + ! -------------------------------------------------------------------- + ! do all the snow fluxes + + ! ==================================================== + ! 2.1 precicipitation -> upper snow/runoff layer + ! scalarThroughfallRain + scalarThroughfallSnow + ! ==================================================== + ! *Flux* + ! throughfall rain and snow + wflux_s2r = scalarThroughfallRain_summa_m3 & + + scalarThroughfallSnow_summa_m3 + if (current_nSnow .gt. 0)then + ! *Source*: + ! PRECIP (external flux, so need call openwq_run_space_in) + ! *Recipient*: + ! snow+soil (upper layer) + OpenWQindex_r = snow_index_openwq + iz_r = 1 + else + OpenWQindex_r = runoff_index_openwq + iz_r = 1 + scalarRunoffVol_m3 = scalarRunoffVol_m3 + wflux_s2r ! Needed because runoff volume is not tracked + end if + ! *Call openwq_run_space* if wflux_s2r not 0 + err=openwq_obj%openwq_run_space_in( & + simtime, & + 'PRECIP', & + OpenWQindex_r, hru_index, iy_r, iz_r, & + wflux_s2r & + ) + + ! Below fluxes only occur when there is no snow + if (current_nSnow .gt. 0)then + + ! ==================================================== + ! 2.2 snow -> OUT (lost from model) (sublimation) + ! ==================================================== + ! *Source*: + ! snow (upper layer) + OpenWQindex_s = snow_index_openwq + iz_s = 1 + mLayerVolFracWat_summa_m3 = mLayerVolFracWat_summa_frac(1) * hru_area_m2 * mLayerDepth_summa_m(1) + wmass_source = mLayerVolFracWat_summa_m3 + ! *Recipient*: + ! lost from system + OpenWQindex_r = -1 + iz_r = -1 + ! *Flux* + ! snow sublimation + wflux_s2r = scalarSnowSublimation_summa_m3 + ! *Call openwq_run_space* if wflux_s2r not 0 + err=openwq_obj%openwq_run_space( & + simtime, & + OpenWQindex_s, hru_index, iy_s, iz_s, & + OpenWQindex_r, hru_index, iy_r, iz_r, & + wflux_s2r, & + wmass_source) + + ! ==================================================== + ! 2.3 snow internal fluxes + ! ==================================================== + do iLayer = 1, nSnow-1 ! last layer of snow becomes different fluxes + ! *Source*: + ! snow(iLayer) + OpenWQindex_s = snow_index_openwq + iz_s = iLayer + mLayerVolFracWat_summa_m3 = mLayerVolFracWat_summa_frac(iLayer) * hru_area_m2 * mLayerDepth_summa_m(iLayer) + wmass_source = mLayerVolFracWat_summa_m3 + ! *Recipient*: + ! snow(iLayer+1) + OpenWQindex_r = snow_index_openwq + iz_r = iLayer + 1 + ! *Flux* + mLayerLiqFluxSnow_summa_m3 = iLayerLiqFluxSnow_summa_m_s(iLayer) * hru_area_m2 * data_step + wflux_s2r = mLayerLiqFluxSnow_summa_m3 + ! *Call openwq_run_space* if wflux_s2r not 0 + err=openwq_obj%openwq_run_space( & + simtime, & + OpenWQindex_s, hru_index, iy_s, iz_s, & + OpenWQindex_r, hru_index, iy_r, iz_r, & + wflux_s2r, & + wmass_source) + end do + + ! ==================================================== + ! 2.4 snow drainage from the last soil layer -> runoff + ! ==================================================== + ! *Flux* + mLayerLiqFluxSnow_summa_m3 = iLayerLiqFluxSnow_summa_m_s(nSnow) * hru_area_m2 * data_step + wflux_s2r = mLayerLiqFluxSnow_summa_m3 + ! *Source*: + ! snow(nSnow) + OpenWQindex_s = snow_index_openwq + iz_s = iLayer + mLayerVolFracWat_summa_m3 = mLayerVolFracWat_summa_frac(nSnow) * hru_area_m2 * mLayerDepth_summa_m(nSnow) + wmass_source = mLayerVolFracWat_summa_m3 + ! *Recipient*: + ! runoff (has one layer only) + OpenWQindex_r = runoff_index_openwq + iz_r = 1 + scalarRunoffVol_m3 = scalarRunoffVol_m3 + wflux_s2r; + ! *Call openwq_run_space* if wflux_s2r not 0 + err=openwq_obj%openwq_run_space( & + simtime, & + OpenWQindex_s, hru_index, iy_s, iz_s, & + OpenWQindex_r, hru_index, iy_r, iz_r, & + wflux_s2r, & + wmass_source) + end if + + ! ==================================================== + ! 2.5 snow without a layer -> runoff + ! scalarSfcMeltPond should be 0 if this occurs + ! ==================================================== + ! *Source* + ! snow (this is the case of snow without layer) + + ! need the if condition to protect from invalid read + ! if the size of mLayerVolFracWat_summa_frac matches the number of soil layers + ! then summa is expecting no snow for this HRU over the simulation of the model + if ((nSnow .gt. 0)) then + ! *Flux* + ! snow uloading + liq drainage + wflux_s2r = scalarSfcMeltPond_summa_m3 + ! *Source* + OpenWQindex_s = snow_index_openwq + iz_s = 1 + mLayerVolFracWat_summa_m3 = mLayerVolFracWat_summa_frac(nSnow) * hru_area_m2 * mLayerDepth_summa_m(nSnow) + wmass_source = mLayerVolFracWat_summa_m3 + ! *Recipient* + ! runoff (has one layer only) + OpenWQindex_r = runoff_index_openwq + iz_r = 1 + scalarRunoffVol_m3 = scalarRunoffVol_m3 + wflux_s2r; + ! *Call openwq_run_space* if wflux_s2r not 0 + err=openwq_obj%openwq_run_space( & + simtime, & + OpenWQindex_s, hru_index, iy_s, iz_s, & + OpenWQindex_r, hru_index, iy_r, iz_r, & + wflux_s2r, & + wmass_source) + endif + ! -------------------------------------------------------------------- + ! %%%%%%%%%%%%%%%%%%%%%%%%%%% + ! 3. runoff + ! %%%%%%%%%%%%%%%%%%%%%%%%%%% + ! -------------------------------------------------------------------- + + ! ==================================================== + ! 3.1 infiltration + ! runoff -> top layer of the soil + ! ==================================================== + ! *Flux* + wflux_s2r = scalarInfiltration_summa_m3 + ! *Source*: + ! runoff (has 1 layer only) + OpenWQindex_s = runoff_index_openwq + iz_s = 1 + wmass_source = scalarRunoffVol_m3 + ! *Recipient*: + ! soil upper layer + OpenWQindex_r = soil_index_openwq + iz_r = 1 + scalarRunoffVol_m3 = scalarRunoffVol_m3 - wflux_s2r; + ! *Call openwq_run_space* if wflux_s2r not 0 + err=openwq_obj%openwq_run_space( & + simtime, & + OpenWQindex_s, hru_index, iy_s, iz_s, & + OpenWQindex_r, hru_index, iy_r, iz_r, & + wflux_s2r, & + wmass_source) + + ! ==================================================== + ! 3.2 surface runoff + ! runoff -> OUT lost from the system + ! ==================================================== + ! *Source*: + ! runoff (has only 1 layer) + OpenWQindex_s = runoff_index_openwq + iz_s = 1 + wmass_source = scalarRunoffVol_m3 + ! *Recipient*: + ! lost from system + OpenWQindex_r = -1 + iz_r = -1 + ! *Flux* + ! wflux_s2r = scalarSurfaceRunoff_summa_m3 + wflux_s2r = scalarRunoffVol_m3 + ! *Call openwq_run_space* if wflux_s2r not 0 + err=openwq_obj%openwq_run_space( & + simtime, & + OpenWQindex_s, hru_index, iy_s, iz_s, & + OpenWQindex_r, hru_index, iy_r, iz_r, & + wflux_s2r, & + wmass_source) + + ! -------------------------------------------------------------------- + ! %%%%%%%%%%%%%%%%%%%%%%%%%%% + ! 4. soil + ! %%%%%%%%%%%%%%%%%%%%%%%%%%% + ! -------------------------------------------------------------------- + + ! ==================================================== + ! 4.1 soil fluxes + ! upper soil -> OUT (lost from system) (ground evaporation) + ! ==================================================== + ! *Source*: + ! upper soil layer + OpenWQindex_s = soil_index_openwq + iz_s = 1 + mLayerVolFracWat_summa_m3 = mLayerVolFracWat_summa_frac(nSnow+1) * hru_area_m2 * mLayerDepth_summa_m(nSnow+1) + wmass_source = mLayerVolFracWat_summa_m3 + ! *Recipient*: + ! lost from system + OpenWQindex_r = -1 + iz_r = -1 + ! *Flux* + wflux_s2r = scalarGroundEvaporation_summa_m3 + ! *Call openwq_run_space* if wflux_s2r not 0 + err=openwq_obj%openwq_run_space( & + simtime, & + OpenWQindex_s, hru_index, iy_s, iz_s, & + OpenWQindex_r, hru_index, iy_r, iz_r, & + wflux_s2r, & + wmass_source) + + ! ==================================================== + ! 4.2 exfiltration + ! Lost from the system (first soil layer) + ! ==================================================== + ! *Source*: + ! upper soil layer + OpenWQindex_s = soil_index_openwq + iz_s = 1 + mLayerVolFracWat_summa_m3 = mLayerVolFracWat_summa_frac(nSnow+1) * hru_area_m2 * mLayerDepth_summa_m(nSnow+1) + wmass_source = mLayerVolFracWat_summa_m3 + ! *Recipient*: + ! lost from system + OpenWQindex_r = -1 + iz_r = -1 + ! *Flux* + wflux_s2r = scalarExfiltration_summa_m3 + ! *Call openwq_run_space* if wflux_s2r not 0 + err=openwq_obj%openwq_run_space( & + simtime, & + OpenWQindex_s, hru_index, iy_s, iz_s, & + OpenWQindex_r, hru_index, iy_r, iz_r, & + wflux_s2r, & + wmass_source) + + ! ==================================================== + ! 4.3 mLayerBaseflow + ! Lost from the system at each soil layer + ! ==================================================== + do iLayer = 1, nSoil + + ! *Source*: + ! each soil layer + OpenWQindex_s = soil_index_openwq + !iz_s = nSnow + iLayer + iz_s = iLayer + mLayerVolFracWat_summa_m3 = mLayerVolFracWat_summa_frac(iLayer+nSnow) * hru_area_m2 * mLayerDepth_summa_m(iLayer+nSnow) + wmass_source = mLayerVolFracWat_summa_m3 + ! *Recipient*: + ! lost from system + OpenWQindex_r = -1 + iz_r = -1 + ! *Flux* + mLayerBaseflow_summa_m3 = mLayerBaseflow_summa_m_s(iLayer) * hru_area_m2 * data_step + if (iLayer == 1)then + mLayerBaseflow_summa_m3 = mLayerBaseflow_summa_m3 - scalarExfiltration_summa_m3 + endif + wflux_s2r = mLayerBaseflow_summa_m3 + ! *Call openwq_run_space* if wflux_s2r not 0 + err=openwq_obj%openwq_run_space( & + simtime, & + OpenWQindex_s, hru_index, iy_s, iz_s, & + OpenWQindex_r, hru_index, iy_r, iz_r, & + wflux_s2r, & + wmass_source) + end do + + ! ==================================================== + ! 4.4 transpiration from the soil + ! Lost from the system + ! ==================================================== + do iLayer = 1, nSoil + ! *Source*: + ! all soil layers + OpenWQindex_s = soil_index_openwq + iz_s = iLayer + mLayerVolFracWat_summa_m3 = mLayerVolFracWat_summa_frac(iLayer+nSnow) * hru_area_m2 * mLayerDepth_summa_m(iLayer+nSnow) + wmass_source = mLayerVolFracWat_summa_m3 + ! *Recipient*: + ! lost from system + OpenWQindex_r = -1 + iz_r = -1 + mLayerTranspire_summa_m3 = mLayerTranspire_summa_m_s(iLayer) * hru_area_m2 * data_step + ! *Flux* + wflux_s2r = mLayerTranspire_summa_m3 + ! *Call openwq_run_space* if wflux_s2r not 0 + err=openwq_obj%openwq_run_space( & + simtime, & + OpenWQindex_s, hru_index, iy_s, iz_s, & + OpenWQindex_r, hru_index, iy_r, iz_r, & + wflux_s2r, & + wmass_source) + end do + + ! ==================================================== + ! 4.5 soil internal fluxes + ! ==================================================== + do iLayer = 1, nSoil - 1 ! last layer of soil becomes different fluxes + ! *Source*: + ! soil layer iLayer + OpenWQindex_s = soil_index_openwq + iz_s = iLayer + mLayerVolFracWat_summa_m3 = mLayerVolFracWat_summa_frac(iLayer+nSnow) * hru_area_m2 * mLayerDepth_summa_m(iLayer+nSnow) + wmass_source = mLayerVolFracWat_summa_m3 + ! *Recipient*: + ! soi layer iLayer+1 + OpenWQindex_r = soil_index_openwq + iz_r = iLayer + 1 + ! *Flux* + ! flux between soil layer + iLayerLiqFluxSoil_summa_m3 = iLayerLiqFluxSoil_summa_m_s(iLayer) * hru_area_m2 * data_step + wflux_s2r = iLayerLiqFluxSoil_summa_m3 + ! *Call openwq_run_space* if wflux_s2r not 0 + err=openwq_obj%openwq_run_space( & + simtime, & + OpenWQindex_s, hru_index, iy_s, iz_s, & + OpenWQindex_r, hru_index, iy_r, iz_r, & + wflux_s2r, & + wmass_source) + end do + + ! ==================================================== + ! 4.6 soil Draianage into the aquifer + ! ==================================================== + ! *Source*: + ! lower soil layer + OpenWQindex_s = soil_index_openwq + iz_s = nSoil + mLayerVolFracWat_summa_m3 = mLayerVolFracWat_summa_frac(nSoil) * hru_area_m2 * mLayerDepth_summa_m(nSoil) + wmass_source = mLayerVolFracWat_summa_m3 + ! *Recipient*: + ! aquifer (has only 1 layer) + OpenWQindex_r = aquifer_index_openwq + iz_r = 1 + ! *Flux* + ! flux between soil layer (it's -1 because the first layer gets) + wflux_s2r = scalarSoilDrainage_summa_m3 + ! *Call openwq_run_space* if wflux_s2r not 0 + err=openwq_obj%openwq_run_space( & + simtime, & + OpenWQindex_s, hru_index, iy_s, iz_s, & + OpenWQindex_r, hru_index, iy_r, iz_r, & + wflux_s2r, & + wmass_source) + + ! -------------------------------------------------------------------- + ! %%%%%%%%%%%%%%%%%%%%%%%%%%% + ! 5 Aquifer Fluxes + ! %%%%%%%%%%%%%%%%%%%%%%%%%%% + ! -------------------------------------------------------------------- + + ! ==================================================== + ! 5.1 Aquifer -> OUT (lost from model) (baseflow) + ! ==================================================== + ! *Source*: + ! aquifer (only 1 z layer) + OpenWQindex_s = aquifer_index_openwq + iz_s = 1 + wmass_source = scalarAquiferStorage_summa_m3 + ! *Recipient*: + ! lost from system + OpenWQindex_r = -1 + iz_r = -1 + ! *Flux* + wflux_s2r = scalarAquiferBaseflow_summa_m3 + ! *Call openwq_run_space* if wflux_s2r not 0 + err=openwq_obj%openwq_run_space( & + simtime, & + OpenWQindex_s, hru_index, iy_s, iz_s, & + OpenWQindex_r, hru_index, iy_r, iz_r, & + wflux_s2r, & + wmass_source) + + ! ==================================================== + ! 5.2 Aquifer -> OUT (lost from model) (transpiration) + ! ==================================================== + ! *Source*: + ! aquifer (only 1 z layer) + OpenWQindex_s = aquifer_index_openwq + iz_s = 1 + wmass_source = scalarAquiferStorage_summa_m3 + ! *Recipient*: + ! lost from system + OpenWQindex_r = -1 + iz_r = -1 + ! *Flux* + wflux_s2r = scalarAquiferTranspire_summa_m3 + ! *Call openwq_run_space* if wflux_s2r not 0 + err=openwq_obj%openwq_run_space( & + simtime, & + OpenWQindex_s, hru_index, iy_s, iz_s, & + OpenWQindex_r, hru_index, iy_r, iz_r, & + wflux_s2r, & + wmass_source) + + end associate AquiferVars + end associate Snow_SoilVars + end associate RunoffVars + end associate CanopyVars + end associate PrecipVars + end associate DomainVars + + end do + end do +end associate summaVars +end subroutine openwq_run_space_step + + +subroutine openwq_run_time_end(summa1_struc) + USE summa_type, only:summa1_type_dec ! master summa data type + USE var_lookup, only:iLookTIME ! named variables for time data structure + implicit none + + ! Dummy Varialbes + type(summa1_type_dec), intent(in) :: summa1_struc + + ! Local Variables + integer(i4b) :: simtime(5) ! 5 time values yy-mm-dd-hh-min + integer(i4b) :: err ! error control + + summaVars: associate(& + timeStruct => summa1_struc%timeStruct & + ) + + simtime(1) = timeStruct%var(iLookTIME%iyyy) ! Year + simtime(2) = timeStruct%var(iLookTIME%im) ! month + simtime(3) = timeStruct%var(iLookTIME%id) ! hour + simtime(4) = timeStruct%var(iLookTIME%ih) ! day + simtime(5) = timeStruct%var(iLookTIME%imin) ! minute + + err=openwq_obj%openwq_run_time_end(simtime) ! minute + + end associate summaVars +end subroutine + + + +end module summa_openwq \ No newline at end of file diff --git a/build/source/openwq/summa_openWQ_allocspace.f90 b/build/source/openwq/summa_openWQ_allocspace.f90 new file mode 100644 index 000000000..6a1fa1842 --- /dev/null +++ b/build/source/openwq/summa_openWQ_allocspace.f90 @@ -0,0 +1,204 @@ +! SUMMA - Structure for Unifying Multiple Modeling Alternatives +! Copyright (C) 2014-2020 NCAR/RAL; University of Saskatchewan; University of Washington +! +! This file is part of SUMMA +! +! For more information see: http://www.ral.ucar.edu/projects/summa +! +! This program is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program. If not, see . + +module allocspace_progStuct_module + + ! data types + USE nrtype + + ! provide access to the derived types to define the data structures + USE data_types,only:& + ! final data vectors + dlength, & ! var%dat + ilength, & ! var%dat + ! no spatial dimension + var_i, & ! x%var(:) (i4b) + var_i8, & ! x%var(:) (i8b) + var_d, & ! x%var(:) (dp) + var_flagVec, & ! x%var(:)%dat (logical) + var_ilength, & ! x%var(:)%dat (i4b) + var_dlength, & ! x%var(:)%dat (dp) + ! gru dimension + gru_int, & ! x%gru(:)%var(:) (i4b) + gru_int8, & ! x%gru(:)%var(:) (i8b) + gru_double, & ! x%gru(:)%var(:) (dp) + gru_intVec, & ! x%gru(:)%var(:)%dat (i4b) + gru_doubleVec, & ! x%gru(:)%var(:)%dat (dp) + ! gru+hru dimension + gru_hru_int, & ! x%gru(:)%hru(:)%var(:) (i4b) + gru_hru_int8, & ! x%gru(:)%hru(:)%var(:) (i8b) + gru_hru_double, & ! x%gru(:)%hru(:)%var(:) (dp) + gru_hru_intVec, & ! x%gru(:)%hru(:)%var(:)%dat (i4b) + gru_hru_doubleVec ! x%gru(:)%hru(:)%var(:)%dat (dp) + + ! metadata structure + USE data_types,only:var_info ! data type for metadata + + ! access missing values + USE globalData,only:integerMissing ! missing integer + USE globalData,only:realMissing ! missing real number + + USE globalData,only: nTimeDelay ! number of timesteps in the time delay histogram + USE globalData,only: nSpecBand ! number of spectral bands + + ! access variable types + USE var_lookup,only:iLookVarType ! look up structure for variable typed + USE var_lookup,only:maxvarFreq ! allocation dimension (output frequency) + + ! privacy + implicit none + private + public::allocGlobal_progStruct + + + ! ----------------------------------------------------------------------------------------------------------------------------------- + contains + ! ************************************************************************************************ + ! public subroutine allocGlobal_progStruct: allocate space for progStruct_timestep_start + ! Modified copy of the subroutine allocGlobal() from allocspace.f90 specificly for allocating + ! the array progStruct_timestep_start + ! ************************************************************************************************ + subroutine allocGlobal_progStruct(metaStruct,dataStruct,nSnow,err,message) + ! NOTE: safety -- ensure only used in allocGlobal + USE globalData,only: gru_struc ! gru-hru mapping structures + USE allocspace_module, only:allocLocal + implicit none + ! input + type(var_info),intent(in) :: metaStruct(:) ! metadata structure + integer(i4b),intent(in) :: nSnow + ! output + class(*),intent(out) :: dataStruct ! data structure + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! local variables + logical(lgt) :: check ! .true. if structure is already allocated + integer(i4b) :: iHRU ! loop index through HRUs + integer(i4b) :: iGRU ! loop index through GRUs + integer(i4b) :: nGRU ! number of GRUs + logical(lgt) :: spatial ! spatial flag + character(len=256) :: cmessage ! error message of the downwind routine + ! initialize error control + err=0; message='allocGlobal_progStruct/' + ! initialize allocation check + check=.false. + + ! get the number of GRUs + nGRU = size(gru_struc) + + ! * allocate GRU dimension + select type(dataStruct) + ! gru dimension only + class is (gru_int); if(allocated(dataStruct%gru))then; check=.true.; else; allocate(dataStruct%gru(nGRU),stat=err); end if + class is (gru_int8); if(allocated(dataStruct%gru))then; check=.true.; else; allocate(dataStruct%gru(nGRU),stat=err); end if + class is (gru_intVec); if(allocated(dataStruct%gru))then; check=.true.; else; allocate(dataStruct%gru(nGRU),stat=err); end if + class is (gru_double); if(allocated(dataStruct%gru))then; check=.true.; else; allocate(dataStruct%gru(nGRU),stat=err); end if + class is (gru_doubleVec); if(allocated(dataStruct%gru))then; check=.true.; else; allocate(dataStruct%gru(nGRU),stat=err); end if + ! gru+hru dimensions + class is (gru_hru_int); if(allocated(dataStruct%gru))then; check=.true.; else; allocate(dataStruct%gru(nGRU),stat=err); end if + class is (gru_hru_int8); if(allocated(dataStruct%gru))then; check=.true.; else; allocate(dataStruct%gru(nGRU),stat=err); end if + class is (gru_hru_intVec); if(allocated(dataStruct%gru))then; check=.true.; else; allocate(dataStruct%gru(nGRU),stat=err); end if + class is (gru_hru_double); if(allocated(dataStruct%gru))then; check=.true.; else; allocate(dataStruct%gru(nGRU),stat=err); end if + class is (gru_hru_doubleVec); if(allocated(dataStruct%gru))then; check=.true.; else; allocate(dataStruct%gru(nGRU),stat=err); end if + end select + + ! check errors + if(check) then; err=20; message=trim(message)//'GRU structure was unexpectedly allocated already'; return; end if + if(err/=0)then; err=20; message=trim(message)//'problem allocating GRU dimension'; return; end if + + ! * allocate HRU dimension + do iGRU=1,nGRU + ! allocate the HRU dimension + select type(dataStruct) + class is (gru_hru_int); if(allocated(dataStruct%gru(iGRU)%hru))then; check=.true.; else; allocate(dataStruct%gru(iGRU)%hru(gru_struc(iGRU)%hruCount),stat=err); end if + class is (gru_hru_int8); if(allocated(dataStruct%gru(iGRU)%hru))then; check=.true.; else; allocate(dataStruct%gru(iGRU)%hru(gru_struc(iGRU)%hruCount),stat=err); end if + class is (gru_hru_intVec); if(allocated(dataStruct%gru(iGRU)%hru))then; check=.true.; else; allocate(dataStruct%gru(iGRU)%hru(gru_struc(iGRU)%hruCount),stat=err); end if + class is (gru_hru_double); if(allocated(dataStruct%gru(iGRU)%hru))then; check=.true.; else; allocate(dataStruct%gru(iGRU)%hru(gru_struc(iGRU)%hruCount),stat=err); end if + class is (gru_hru_doubleVec); if(allocated(dataStruct%gru(iGRU)%hru))then; check=.true.; else; allocate(dataStruct%gru(iGRU)%hru(gru_struc(iGRU)%hruCount),stat=err); end if + class default ! do nothing: It is acceptable to not be any of these specified cases + end select + ! check errors + if(check) then; err=20; message=trim(message)//'HRU structure was unexpectedly allocated already'; return; end if + if(err/=0)then; err=20; message=trim(message)//'problem allocating HRU dimension'; return; end if + end do + + ! * allocate local data structures where there is a spatial dimension + gruLoop: do iGRU=1,nGRU + + ! initialize the spatial flag + spatial=.false. + + ! loop through HRUs + hruLoop: do iHRU=1,gru_struc(iGRU)%hruCount + + ! get the number of snow and soil layers + associate(& + ! nSnow => gru_struc(iGRU)%hruInfo(iHRU)%nSnow, & ! number of snow layers for each HRU + nSoil => gru_struc(iGRU)%hruInfo(iHRU)%nSoil ) ! number of soil layers for each HRU + + ! allocate space for structures WITH an HRU dimension + select type(dataStruct) + class is (gru_hru_int); call allocLocal(metaStruct,dataStruct%gru(iGRU)%hru(iHRU),nSnow,nSoil,err,cmessage); spatial=.true. + class is (gru_hru_int8); call allocLocal(metaStruct,dataStruct%gru(iGRU)%hru(iHRU),nSnow,nSoil,err,cmessage); spatial=.true. + class is (gru_hru_intVec); call allocLocal(metaStruct,dataStruct%gru(iGRU)%hru(iHRU),nSnow,nSoil,err,cmessage); spatial=.true. + class is (gru_hru_double); call allocLocal(metaStruct,dataStruct%gru(iGRU)%hru(iHRU),nSnow,nSoil,err,cmessage); spatial=.true. + class is (gru_hru_doubleVec); call allocLocal(metaStruct,dataStruct%gru(iGRU)%hru(iHRU),nSnow,nSoil,err,cmessage); spatial=.true. + class default; exit hruLoop + end select + + ! error check + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if + + ! end association to info in data structures + end associate + + end do hruLoop ! loop through HRUs + + ! allocate space for structures *WITHOUT* an HRU dimension + select type(dataStruct) + class is (gru_double); call allocLocal(metaStruct,dataStruct%gru(iGRU),nSnow=0,nSoil=0,err=err,message=cmessage); spatial=.true. + class is (gru_doubleVec); call allocLocal(metaStruct,dataStruct%gru(iGRU),nSnow=0,nSoil=0,err=err,message=cmessage); spatial=.true. + class default + if(.not.spatial) exit gruLoop ! no need to allocate spatial dimensions if none exist for a given variable + cycle gruLoop ! can have an HRU dimension if we get to here + end select + + ! error check + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if + + end do gruLoop ! loop through GRUs + + ! * allocate local data structures where there is no spatial dimension + select type(dataStruct) + class is (var_i); call allocLocal(metaStruct,dataStruct,err=err,message=cmessage) + class is (var_i8); call allocLocal(metaStruct,dataStruct,err=err,message=cmessage) + class is (var_d); call allocLocal(metaStruct,dataStruct,err=err,message=cmessage) + class is (var_ilength); call allocLocal(metaStruct,dataStruct,err=err,message=cmessage) + class is (var_dlength); call allocLocal(metaStruct,dataStruct,err=err,message=cmessage) + ! check identified the data type + class default; if(.not.spatial)then; err=20; message=trim(message)//'unable to identify derived data type'; return; end if + end select + + ! error check + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if + + end subroutine allocGlobal_progStruct + +end module allocspace_progStuct_module + \ No newline at end of file diff --git a/case_study/base_settings/readme.md b/case_study/base_settings/readme.md deleted file mode 100644 index 9f2fa2df6..000000000 --- a/case_study/base_settings/readme.md +++ /dev/null @@ -1,37 +0,0 @@ -# Lookup table provenance -This information cannot easily be encoded in the files themselves, due to the way files are being read. - -#### GENPARM -- 2021-08-10: Added NOAH-MP default parameters (NCAR Research Applications Laboratory, RAL, 2021) - -#### MPTABLE -- 2021-08-10: Added NOAH-MP default parameters (NCAR RAL, 2021) - -#### SOILPARM -- 2021-08-10: Added NOAH-MP default parameters (NCAR RAL, 2021) -- 2021-08-10: Added ROSETTA table values (see `ROSETTA soil parameter values`) - -#### VEGPARM -- 2021-08-10: Added NOAH-MP default parameters (NCAR RAL, 2021) - - -## ROSETTA soil parameter values -ROSETTA soil parameters are a combination of the NOAH-MP STAS and STAS-RUC tables (NCAR RAL, 2021), updated with five additional parameters derived by the ROSETTA model (U.S. Department of Agriculture: Agricultural Research Service (USDA ARS), 2021). - -Columns `BB`, `DRYSMC`, `HC`, `MAXSMC`, `SATPIS`, `SATDK`, `SATDW`, `WLTSMC` and `QTZ` are duplicated from the STAS-RUC table. - -Column `REFSMC` is duplicated from the STAS table. - -Columns `theta_res`, `theta_sat`, `vGn_alpha`, `vGn_n` and `k_soil` are duplicated/derived from table values provided by the U.S. Department of Agriculture, Agricultural Research Service, (USDA ARS, 2021) as follows: - -- `theta_res` = `x`, where x is taken from column `qr` [-]; -- `theta_sat` = `x`, where x is taken from column `qs` [-]; -- `vGn_alpha` = `-1 * 10^x * 100`, where x is taken from column `log(a)` [log(cm-1)] > [m-1] while also changing the sign of the alpha parameter so that matric head calculations use SUMMA's convention of negative values for matric head; -- `vGn_n` = `10^x`, where x is taken from column `log(n)` [-]; -- `k_soil` = `10^x / 100 / (60 * 60 * 24)`, where x is taken from column `Ks` [log(cm d-1)] > [m s-1]. - - -## References -NCAR Research Applications Laboratory, RAL, 2021. Noah-Multiparameterization Land Surface Model (Noah-MP LSM) [WWW Document]. URL https://ral.ucar.edu/solutions/products/noah-multiparameterization-land-surface-model-noah-mp-lsm (accessed 11.15.21). - -U.S. Department of Agriculture: Agricultural Research Service (USDA ARS), 2021. ROSETTA Class Average Hydraulic Parameters [WWW Document]. URL https://www.ars.usda.gov/pacific-west-area/riverside-ca/agricultural-water-efficiency-and-salinity-research-unit/docs/model/rosetta-class-average-hydraulic-parameters/ (accessed 11.15.21). diff --git a/case_study/readme.md b/case_study/readme.md deleted file mode 100644 index 72624911a..000000000 --- a/case_study/readme.md +++ /dev/null @@ -1,30 +0,0 @@ -# SUMMA case studies -This folder contains a case study to show how a typical SUMMA setup looks. The folder serves a double purpose as a way to track default versions of certain input files, such as the Noah-MP tables and spatially constant parameter files. - -For more details about SUMMA inputs, see the [online documentation](https://summa.readthedocs.io/en/latest/input_output/SUMMA_input/). - - -## Base settings -This folder contains the setting files that typically do not change for different model applications. Currently these include: -- `GENPARM.TBL`: lookup table for general parameters (legacy, currently unused) -- `MPTABLE.TBL`: lookup table for vegetation parameters -- `SOILPARM.TBL`: lookup table for soil parameters -- `VEGPARM.TBL`: lookup table for vegetation parameters -- `basinParamInfo.txt`: default values for GRU(basin)-level parameters -- `localParamInfo.txt`: default values for HRU(local)-level parameters - - -## Reynolds Mountain East -Contains input files needed to reproduce Figure 6a in Clark et al. (2015): -- Folder `forcing` contains forcing data, surprisingly -- `fileManager.txt`: main configuration file SUMMA expects as a command line argument -- `modelDecisions.txt`: specifies which modeling options (parametrizations, numerical method, etc.) to activate -- `forcingFileList.txt`: list of files in the forcing folder -- `outputControl.txt`: specifies which variables to output and, optionally, at which aggregation level -- `initialState.nc`: initial model states on a per-HRU basis -- `localAttributes.nc`: domain settings on a per-HRU basis -- `trialParams.nc`: experiment-specific parameter values on a per-HRU basis (can be empty if default parameters and lookup table values are used) - - -## References - * Clark, M. P., B. Nijssen, J. D. Lundquist, D. Kavetski, D. E. Rupp, R. A. Woods, J. E. Freer, E. D. Gutmann, A. W. Wood, D. J. Gochis, R. M. Rasmussen, D. G. Tarboton, V. Mahat, G. N. Flerchinger, D. G. Marks, 2015: A unified approach for process-based hydrologic modeling: Part 2. Model implementation and case studies. _Water Resources Research_, [doi:10.1002/2015WR017200](http://dx.doi.org/10.1002/2015WR017200). \ No newline at end of file diff --git a/case_study/reynolds/evaluation/reynolds_evalData.nc b/case_study/reynolds/evaluation/reynolds_evalData.nc deleted file mode 100644 index 41783058f..000000000 Binary files a/case_study/reynolds/evaluation/reynolds_evalData.nc and /dev/null differ diff --git a/case_study/reynolds/fileManager_reynoldsConstantDecayRate.txt b/case_study/reynolds/fileManager_reynoldsConstantDecayRate.txt deleted file mode 100644 index d6f4fbac9..000000000 --- a/case_study/reynolds/fileManager_reynoldsConstantDecayRate.txt +++ /dev/null @@ -1,20 +0,0 @@ -controlVersion 'SUMMA_FILE_MANAGER_V3.0.0' ! filemanager version -simStartTime '2005-09-01 00:00' ! simulation start time -simEndTime '2006-09-01 00:00' ! simulation end time -tmZoneInfo 'localTime' ! time zone information -settingsPath './site_settings/' ! path to settings folder -forcingPath './forcing/' ! path to forcing folder -outputPath './output/' ! path to output folder -forcingListFile 'forcingFileList.txt' ! input file names (relative to forcingPath) -outFilePrefix 'reynolds_constantDecayRate' ! prefix to include in model output file names -decisionsFile 'modelDecisions_reynoldsConstantDecayRate.txt' ! model decisions file (relative to settingsPath) -outputControlFile 'outputControl.txt' ! requested model outputs (relative to settingsPath) -initConditionFile 'initialState.nc' ! initial model states (relative to settingsPath) -attributeFile 'localAttributes.nc' ! HRU-level attributes (relative to settingsPath) -globalHruParamFile '../../base_settings/localParamInfo.txt' ! HRU-level default parameters (relative to settingsPath) -globalGruParamFile '../../base_settings/basinParamInfo.txt' ! GRU-level default parameters (relative to settingsPath) -vegTableFile '../../base_settings/VEGPARM.TBL' ! Lookup table for vegetation parameters (relative to settingsPath) -soilTableFile '../../base_settings/SOILPARM.TBL' ! Lookup table for soil parameters (relative to settingsPath) -generalTableFile '../../base_settings/GENPARM.TBL' ! Lookup table for general parameters (relative to settingsPath) -noahmpTableFile '../../base_settings/MPTABLE.TBL' ! Lookup table for vegetation parameters (relative to settingsPath) -trialParamFile 'trialParams_reynoldsConstantDecayRate.nc' ! HRU-level parameters to test (relative to settingsPath) diff --git a/case_study/reynolds/fileManager_reynoldsVariableDecayRate.txt b/case_study/reynolds/fileManager_reynoldsVariableDecayRate.txt deleted file mode 100644 index 1cfa82ca1..000000000 --- a/case_study/reynolds/fileManager_reynoldsVariableDecayRate.txt +++ /dev/null @@ -1,20 +0,0 @@ -controlVersion 'SUMMA_FILE_MANAGER_V3.0.0' ! filemanager version -simStartTime '2005-09-01 00:00' ! simulation start time -simEndTime '2006-09-01 00:00' ! simulation end time -tmZoneInfo 'localTime' ! time zone information -settingsPath './site_settings/' ! path to settings folder -forcingPath './forcing/' ! path to forcing folder -outputPath './output/' ! path to output folder -forcingListFile 'forcingFileList.txt' ! input file names (relative to forcingPath) -outFilePrefix 'reynolds_variableDecayRate' ! prefix to include in model output file names -decisionsFile 'modelDecisions_reynoldsVariableDecayRate.txt' ! model decisions file (relative to settingsPath) -outputControlFile 'outputControl.txt' ! requested model outputs (relative to settingsPath) -initConditionFile 'initialState.nc' ! initial model states (relative to settingsPath) -attributeFile 'localAttributes.nc' ! HRU-level attributes (relative to settingsPath) -globalHruParamFile '../../base_settings/localParamInfo.txt' ! HRU-level default parameters (relative to settingsPath) -globalGruParamFile '../../base_settings/basinParamInfo.txt' ! GRU-level default parameters (relative to settingsPath) -vegTableFile '../../base_settings/VEGPARM.TBL' ! Lookup table for vegetation parameters (relative to settingsPath) -soilTableFile '../../base_settings/SOILPARM.TBL' ! Lookup table for soil parameters (relative to settingsPath) -generalTableFile '../../base_settings/GENPARM.TBL' ! Lookup table for general parameters (relative to settingsPath) -noahmpTableFile '../../base_settings/MPTABLE.TBL' ! Lookup table for vegetation parameters (relative to settingsPath) -trialParamFile 'trialParams_reynoldsVariableDecayRate.nc' ! HRU-level parameters to test (relative to settingsPath) diff --git a/case_study/reynolds/forcing/forcing_albedoDecayParametrization.nc b/case_study/reynolds/forcing/forcing_albedoDecayParametrization.nc deleted file mode 100644 index 1599f2928..000000000 Binary files a/case_study/reynolds/forcing/forcing_albedoDecayParametrization.nc and /dev/null differ diff --git a/case_study/reynolds/output/plot_reynolds_albedoDecayRate.py b/case_study/reynolds/output/plot_reynolds_albedoDecayRate.py deleted file mode 100644 index b75319c3f..000000000 --- a/case_study/reynolds/output/plot_reynolds_albedoDecayRate.py +++ /dev/null @@ -1,33 +0,0 @@ -'''Basic plot to compare the impact of albedo decay rate parametrization to observations at Reynolds Mountain East site.''' - -# modules -import xarray as xr -import matplotlib.pyplot as plt - -# specify the files relative to the 'output' folder -file_constant = 'reynolds_constantDecayRate_timestep.nc' -file_variable = 'reynolds_variableDecayRate_timestep.nc' -file_observed = '../evaluation/reynolds_evalData.nc' - -# load the simulations -sim_constant = xr.open_dataset(file_constant) -sim_variable = xr.open_dataset(file_variable) -observed = xr.open_dataset(file_observed) - -# specify the time period of interest -times = ['2005-09-01','2006-09-01'] - -# store the observations in temporary variables for clarity -plt_time = observed['time'].sel(time=slice(times[0],times[1])) -plt_snow = observed['zs_sheltered'].sel(time=slice(times[0],times[1])) / 100 # convert cm > m - -# make the figure with observations as shaded area and simulations as colored lines -plt.figure(figsize=(20,6)) -plt.fill_between(plt_time,plt_snow,color=[0.7,0.7,0.7],label='observations'); -sim_variable['scalarSnowDepth'].sel(time=slice(times[0],times[1])).plot(label='Variable albedo decay',color='b'); -sim_constant['scalarSnowDepth'].sel(time=slice(times[0],times[1])).plot(label='Constant albedo decay',color='r'); -plt.legend() -plt.title('Impact of albedo parametrization on snow depth simulations at Reynolds Mountain East') -plt.ylabel('Snow depth [m]'); -plt.savefig('reynolds_albedoDecayParametrizationImpact.png', bbox_inches='tight') -plt.close() \ No newline at end of file diff --git a/case_study/reynolds/readme.md b/case_study/reynolds/readme.md deleted file mode 100644 index c28fc4b05..000000000 --- a/case_study/reynolds/readme.md +++ /dev/null @@ -1,9 +0,0 @@ -# Case study: Reynolds Mountain East -This experiment compares the impact of two different albedo decay parametrizations on simulations of snow depth for a specific mountain side. Before starting, ensure you have a compiled SUMMA executable. Then generate the simulations by running SUMMA twice, with different settings: - -``` -summa.exe -m fileManager_reynoldsConstantDecayRate.txt -summa.exe -m fileManager_reynoldsVariableDecayRate.txt -``` - -Evaluation data and a sample (Python) script to evaluate these simulations are provided in sub-folder `evaluation` and `output` respectively. \ No newline at end of file diff --git a/case_study/reynolds/site_settings/forcingFileList.txt b/case_study/reynolds/site_settings/forcingFileList.txt deleted file mode 100644 index c9a243f26..000000000 --- a/case_study/reynolds/site_settings/forcingFileList.txt +++ /dev/null @@ -1,7 +0,0 @@ -! **************************************************************************************************** -! List of forcing data files used -! -! This file includes one "word" per line: -! (1) The name of a forcing file -! **************************************************************************************************** -forcing_albedoDecayParametrization.nc diff --git a/case_study/reynolds/site_settings/initialState.nc b/case_study/reynolds/site_settings/initialState.nc deleted file mode 100644 index f3040a2ae..000000000 Binary files a/case_study/reynolds/site_settings/initialState.nc and /dev/null differ diff --git a/case_study/reynolds/site_settings/localAttributes.nc b/case_study/reynolds/site_settings/localAttributes.nc deleted file mode 100644 index d10a5d47d..000000000 Binary files a/case_study/reynolds/site_settings/localAttributes.nc and /dev/null differ diff --git a/case_study/reynolds/site_settings/outputControl.txt b/case_study/reynolds/site_settings/outputControl.txt deleted file mode 100644 index 427e94d20..000000000 --- a/case_study/reynolds/site_settings/outputControl.txt +++ /dev/null @@ -1,40 +0,0 @@ -! --------- -! model variables -! --------- -nSnow | 1 -nSoil | 1 -pptrate | 1 -airtemp | 1 -scalarRainPlusMelt | 1 -scalarSWE | 1 -scalarSnowDepth | 1 -scalarThroughfallSnow | 1 -scalarThroughfallRain | 1 -scalarSnowSublimation | 1 -scalarInfiltration | 1 -scalarExfiltration | 1 -scalarSurfaceRunoff | 1 -scalarSurfaceTemp | 1 -scalarSenHeatTotal | 1 -scalarLatHeatTotal | 1 -scalarTotalRunoff | 1 -iLayerHeight | 1 -iLayerLiqFluxSoil | 1 -mLayerTemp | 1 -mLayerDepth | 1 -mLayerHeight | 1 -mLayerLiqFluxSoil | 1 -mLayerVolFracIce | 1 -mLayerVolFracLiq | 1 -mLayerVolFracWat | 1 -mLayerMatricHead | 1 -basin__SurfaceRunoff | 1 -basin__ColumnOutflow | 1 -basin__AquiferStorage | 1 -basin__AquiferRecharge | 1 -basin__AquiferBaseflow | 1 -basin__AquiferTranspire | 1 -averageInstantRunoff | 1 -averageRoutedRunoff | 1 -scalarLAI | 1 -scalarSAI | 1 diff --git a/case_study/reynolds/site_settings/trialParams_reynoldsConstantDecayRate.nc b/case_study/reynolds/site_settings/trialParams_reynoldsConstantDecayRate.nc deleted file mode 100644 index b2ee137b5..000000000 Binary files a/case_study/reynolds/site_settings/trialParams_reynoldsConstantDecayRate.nc and /dev/null differ diff --git a/case_study/reynolds/site_settings/trialParams_reynoldsVariableDecayRate.nc b/case_study/reynolds/site_settings/trialParams_reynoldsVariableDecayRate.nc deleted file mode 100644 index 2c3422eca..000000000 Binary files a/case_study/reynolds/site_settings/trialParams_reynoldsVariableDecayRate.nc and /dev/null differ diff --git a/ci/summa_install_utils b/ci/summa_install_utils deleted file mode 100644 index 77d3db7c6..000000000 --- a/ci/summa_install_utils +++ /dev/null @@ -1,102 +0,0 @@ -#!/usr/bin/env bash - -set -e - -export CC=/usr/bin/gcc-6 -export FC=/usr/bin/gfortran-6 - -if [ -z "$WORKDIR" ]; then - export WORKDIR=$HOME/workdir - mkdir -p $WORKDIR -fi - -if [ -z "$INSTALLDIR" ]; then - export INSTALLDIR=$HOME/installdir - mkdir -p $INSTALLDIR -fi - -function install_szip { - echo install_szip - cd $WORKDIR - wget --no-check-certificate -q http://www.hdfgroup.org/ftp/lib-external/szip/2.1.1/src/szip-2.1.1.tar.gz - tar -xzf szip-2.1.1.tar.gz - cd szip-2.1.1 - ./configure --prefix=$INSTALLDIR &> config.log - make &> make.log - make install - export CPPFLAGS="$CPPFLAGS -I${INSTALLDIR}/include" - export LDFLAGS="$LDFLAGS -L${INSTALLDIR}/lib" -} - -function install_hdf5 { - echo install_hdf5 - cd $WORKDIR - wget --no-check-certificate -q https://support.hdfgroup.org/ftp/HDF5/current/src/hdf5-1.10.5.tar.gz - tar -xzf hdf5-1.10.5.tar.gz - cd hdf5-1.10.5 - ./configure --prefix=$INSTALLDIR &> config.log - make - make install - export LIBDIR=${INSTALLDIR}/lib -} - -function install_netcdf_c { - echo install_netcdf_c - cd $WORKDIR - wget --no-check-certificate -q ftp://ftp.unidata.ucar.edu/pub/netcdf/netcdf-c-4.7.3.tar.gz - tar -xzf netcdf-c-4.7.3.tar.gz - cd netcdf-c-4.7.3 - ./configure --prefix=$INSTALLDIR &> config.log - make &> make.log - make install - export LD_LIBRARY_PATH=${INSTALLDIR}/lib -} - -function install_netcdf_fortran { - echo install_netcdf_fortran - cd $WORKDIR - wget --no-check-certificate -q ftp://ftp.unidata.ucar.edu/pub/netcdf/netcdf-fortran-4.5.2.tar.gz - tar -xzf netcdf-fortran-4.5.2.tar.gz - cd netcdf-fortran-4.5.2 - ./configure --prefix=$INSTALLDIR &> config.log - make &> make.log - make install -} - -function summa_before_install { - echo summa_before_install - # Install szip (used by hdf5) - install_szip - # Install HDF5 - install_hdf5 - # Install NetCDF-C - install_netcdf_c - # Install NetCDF fortran - install_netcdf_fortran -} - -function summa_install { - echo summa_install - cd ${TRAVIS_BUILD_DIR} - export F_MASTER=${TRAVIS_BUILD_DIR} - export FC=gfortran - export FC_EXE=gfortran-6 - export INCLUDES='-I${INSTALLDIR}/include -I/usr/include' - export LIBRARIES='-L${INSTALLDIR}/lib -lnetcdff -L/usr/lib -llapack -lblas' - make -C build/ -f Makefile &> make.log -} - -function summa_script { - echo summa_script - ${TRAVIS_BUILD_DIR}/bin/summa.exe -} - -function summa_after_success { - echo summa_after_success - echo "SUMMA build succeeded" -} - -function summa_after_failure { - echo summa_after_failure - echo "SUMMA build failed" -} diff --git a/docs/SUMMA_documentation.md b/docs/SUMMA_documentation.md index 79c8896c7..38ca091fd 100644 --- a/docs/SUMMA_documentation.md +++ b/docs/SUMMA_documentation.md @@ -2,10 +2,10 @@ The SUMMA documentation remains a work in progress. It can be navigated online on [summa.readthedocs.io](http://summa.readthedocs.io/) using the navigation panel to the left. -If you are new to SUMMA, start with the section on _Installation_ and make sure that you can run the SUMMA test suite. After that, it will depend on what you want to do. The _Development_ section is mostly of interest if you want to contribute to the SUMMA source code. Model users will want to read through the _Configuration_ and _Input/Output_ sections to understand how to configure SUMMA for there own applications. +If you are new to SUMMA, start with the section on _Installation_ and make sure that you can run the SUMMA test suite. After that, it will depend on what you want to do. The _Development_ section is mostly of interest if you want to contribute to the SUMMA source code. Model users will want to read through the _Configuration_ and _Input/Output_ sections to understand how to configure SUMMA for their own applications. ## Contributing to SUMMA Documentation -SUMMA documentation is hosted on [summa.readthedocs.io](http://summa.readthedocs.io/), written in [Markdown](https://daringfireball.net/projects/markdown/syntax) and built using [MkDocs](http://www.mkdocs.org/). If you want to contribute to the documentation, you can do so by forking the [SUMMA repository](https://www.github.com/NCAR/summa), creating a branch for your changes and editing the documentation files in the `docs` directory in the SUMMA repo. You may need to add `mkdocs.yml` in the top level SUMMA directory to ensure that your page shows up in the right place. +SUMMA documentation is hosted on [summa.readthedocs.io](http://summa.readthedocs.io/), written in [Markdown](https://daringfireball.net/projects/markdown/syntax) and built using [MkDocs](http://www.mkdocs.org/). If you want to contribute to the documentation, you can do so by forking the [SUMMA repository](https://www.github.com/NCAR/summa), creating a branch for your changes and editing the documentation files in the `docs` directory in the SUMMA repo. You will need to modify `mkdocs.yml` in the top level SUMMA directory if you're creating a new page to ensure that your page shows up in the right place. You need to install [MkDocs](http://www.mkdocs.org/) locally, so that you can make sure that your edits show up correctly before you make a pull request to the NCAR SUMMA repo. If you are new to Git, please review the [SUMMA and Git](development/SUMMA_and_git.md) and [SUMMA Git Workflow](development/SUMMA_git_workflow.md) pages. We will only accept documentation updates via a pull request. diff --git a/docs/assets/MeanNAmermean_MeanNAmerRMSE_differences.png b/docs/assets/MeanNAmermean_MeanNAmerRMSE_differences.png new file mode 100644 index 000000000..d7a276963 Binary files /dev/null and b/docs/assets/MeanNAmermean_MeanNAmerRMSE_differences.png differ diff --git a/docs/assets/NAmermean_NAmerRMSE_differences.png b/docs/assets/NAmermean_NAmerRMSE_differences.png new file mode 100644 index 000000000..a580c5159 Binary files /dev/null and b/docs/assets/NAmermean_NAmerRMSE_differences.png differ diff --git a/docs/assets/code_methodology_figures/SUMMA_horrendogram.png b/docs/assets/code_methodology_figures/SUMMA_horrendogram.png new file mode 100644 index 000000000..247d5b83a Binary files /dev/null and b/docs/assets/code_methodology_figures/SUMMA_horrendogram.png differ diff --git a/docs/assets/code_methodology_figures/SUMMA_parameters_spec_order.png b/docs/assets/code_methodology_figures/SUMMA_parameters_spec_order.png new file mode 100644 index 000000000..52a19295f Binary files /dev/null and b/docs/assets/code_methodology_figures/SUMMA_parameters_spec_order.png differ diff --git a/docs/assets/code_methodology_figures/SUMMA_parameters_spec_order.pptx b/docs/assets/code_methodology_figures/SUMMA_parameters_spec_order.pptx new file mode 100644 index 000000000..a4eb3f155 Binary files /dev/null and b/docs/assets/code_methodology_figures/SUMMA_parameters_spec_order.pptx differ diff --git a/docs/assets/code_methodology_figures/SUMMA_spatial.png b/docs/assets/code_methodology_figures/SUMMA_spatial.png new file mode 100644 index 000000000..f03014c9d Binary files /dev/null and b/docs/assets/code_methodology_figures/SUMMA_spatial.png differ diff --git a/docs/assets/code_methodology_figures/SUMMA_temperature_profile_example.png b/docs/assets/code_methodology_figures/SUMMA_temperature_profile_example.png new file mode 100644 index 000000000..8555fb534 Binary files /dev/null and b/docs/assets/code_methodology_figures/SUMMA_temperature_profile_example.png differ diff --git a/docs/assets/listedChanges.txt b/docs/assets/listedChanges.txt new file mode 100644 index 000000000..3ce5723d6 --- /dev/null +++ b/docs/assets/listedChanges.txt @@ -0,0 +1,116 @@ +These are the changes: (- for effects BE, c- for put commented fix in versions of old develop branch. +c-01) eval8summa.f90 calling subroutine soilCmpres with mLayerMatricHead not mLayerMatricHeadLiq version, commit ce60d55d Aug 25 2022 (makes a lot less compressibility because the water changes less than the liquid) +c-02) eval8summa.f90 soil min water is now theta_res, commit c19473df Apr 12 2022 + -03) eval8summa.f90 updateCp (update heat capacity true or false) and needCm flag, commit b69592b0 Nov 30 2022 + Original Summa BE equivalent to updateCp_closedForm==.false. needCm_closedForm==.false., however these are currently hard coded to true as energy is not conserved well without this. + These are both .true. if nrgConserv=enthalpyFD or enthalpyFDlu. + 04) paramCheck.f90 check k_macropore>k_soil, makes code fail right away if not true, commit 00a10bd7 Dec 7 2022 + 05) run_oneHRU.f90 and run_onGRU.f90 correct error readout id’s, does not effect code results, commit d3904b51 Dec 6 2022 + -06) Jacobian fixes, computed in various subroutines and then included in computJacob.f90: + 1) Fix bulk heat capacity depends on frac ice/liq if updateCp, not needed it don't updateCp + 2) Fix thermal conductivity at snow soil layer interfaces depends on frac ice/liq (ssdNrgFlux) if updateCp, not needed it don't updateCp + -3) Fix soil layer and aquifer transpiration depends on canopy nrg and wat (canopy transpiration), no effect if banded Jacobian + -4) Fix aquifer recharge depends on soil drainage from interface above + -5) Fix soil infiltration at surface depends on all layers below and above water and temp, not huge effect (but some) if banded Jacobian +c-07) Jacobian, scalarCanopyLiq derivatives were getting overwritten and thus zeroed out in calculations, commit cd5002c Jul 6, 2023 + 08) Throughout, made “indian bread” terminology for NaN say it’s not a number for advised clarity, and there might be other other spaces and comments changed (e.g. tabs deleted and comments deleted or clarified), does not effect code results +c-09) flxMapping.f90 flux mapping of soil resistance as an energy variable corrected (was missing and messed up splitting), commit 315583df June 5, 2023 +c-10) runOneGRU.f90 fixed basin aquifer recharge was summing incorrectly the HRU soil drainage instead of the HRU aquifer recharge, commit cd6f07f1 June 20, 2023 (only affects basin aquifer recharge so does not influence results except this basin variable) +c-11) read_icond.f90 canopy water only initialized to be 1e-4 positive at the start of the simulation if it is smaller (through canopy liquid), commit c0f7fa26 Jan 30, 2023, and commit 0f2e9df2 Aug 15, 2023 + The canopy water was being bumped up to at least 1e-4 at the start of every substep. + 12) Build with cmake now, with build options for no Sundials (BE), Sundials, Actors, Cluster, Personal Computer, Debug, Release, NexGen, and combinations of these. + NexGen and Actors do not currently work togethere. + set(CMAKE_CONFIGURATION_TYPES BE BE_Debug BE_Cluster BE_Cluster_Debug + BE_NexGen BE_NexGen_Debug BE_NexGen_Cluster BE_NexGen_Cluster_Debug + BE_Actors BE_Actors_Debug BE_Actors_Cluster BE_Actors_Cluster_Debug + Sundials Sundials_Debug Sundials_Cluster Sundials_Cluster_Debug + Sundials_NexGen Sundials_NexGen_Debug Sundials_NexGen_Cluster Sundials_NexGen_Cluster_Debug + Sundials_Actors Sundials_Actors_Debug Sundials_Actors_Cluster Sundials_Actors_Cluster_Debug) + 13) Sundials has options of IDA and KINSOL, ACTORS, and we added BMI/NGEN -- adds new files and some compiler directives in code + New decision choices in num_method + num_method [numrec or kinsol or ida] ! (07) choice of numerical method + Choice 'itertive' is backwards compatible to numrec + For compilation under NexGen, main driver is BMIed and the code is able to read NexGen forcing + 14) Added possible parameters for adding more steps for BEXX and Sundials tolerances, commit 0619a403 May 31, 2023 + be_steps | 1.0000 | 1.0000 | 512.0000 + relTolTempCas | 1.0d-6 | 1.0d-10| 1.0d-1 + absTolTempCas | 1.0d-6 | 1.0d-10| 1.0d-1 + relTolTempVeg | 1.0d-6 | 1.0d-10| 1.0d-1 + absTolTempVeg | 1.0d-6 | 1.0d-10| 1.0d-1 + relTolWatVeg | 1.0d-6 | 1.0d-10| 1.0d-1 + absTolWatVeg | 1.0d-6 | 1.0d-10| 1.0d-1 + relTolTempSoilSnow | 1.0d-6 | 1.0d-10| 1.0d-1 + absTolTempSoilSnow | 1.0d-6 | 1.0d-10| 1.0d-1 + relTolWatSnow | 1.0d-6 | 1.0d-10| 1.0d-1 + absTolWatSnow | 1.0d-6 | 1.0d-10| 1.0d-1 + relTolMatric | 1.0d-6 | 1.0d-10| 1.0d-1 + absTolMatric | 1.0d-6 | 1.0d-10| 1.0d-1 + relTolAquifr | 1.0d-6 | 1.0d-10| 1.0d-1 + absTolAquifr | 1.0d-6 | 1.0d-10| 1.0d-1 + This is backwards compatible to give default values if not put in. + 15) ascii_util.f90 memory leak, commit 44933953 May 9, 2023 + 16) Took out all calculation of numerical derivatives in flux routines, commit 9e5b703 Jun 28, 2023 + We can do that better with Sundials and a lot of them were wrong/not completely calculated. It made some of the flux routines very long to include that. + So now model decision choice + fDerivMeth [analytic or numericl] ! (08) method used to calculate flux derivatives + refers to whether or not you want Sundials to use the provided analytical Jacobian or a finite difference one that it calculates. + (the numrec num_method choice will not have numerical derivatives as an option). commit 9e5b703, Jun 28, 2023 +c-17) Use dense matrix as default with vegetation (so transpiration derivatives are accounted for). commit 8d15e4e2, Aug 7, 2023 + 18) Soil matrix compression per layer and total (mLayerCompres and scalarSoilCompress) are now outputted as averages over the data window (kg m-2 s-1) like all fluxes are done + Soil matrix compression is used in the balance computations, so to have instantaneous values outputted did not make sense. Does not affect solution. +c-19) If split to a scalar solution, soil compressibility was outputting as 0. Refactor for BE >1 fixes this since save inner splitting steps. + Or, if wanted to fix the old code would need to modify part of varSubStep. +c-20) Need to compute dTheta_dTkCanopy off of trial canopy water instead of previous canopy water, affects Jacobian and temperature adjustment in splitting operations, commit 19fca2ba Jun 7, 2023 +c-21) Flux modification flag was not initialized in varSubstep, commit 312004fd Sep 20, 2022, and commit 0c5af7db Aug 11, 2023 +c-22) SWE mass balance error should fail based on tolerance absConvTol_liquid*iden_water*10._rkind, not 1e-6. commit ? Reza changed this around June 16, 2021. + This will not affect solution, just might fail the test (and kill, throwing the error "SWE does not balance" at a different time/run) +c-23) After new snowfall, need to update the volume fraction water in the top layer of snow from changed liq and ice if there is a layer of snow, commit 9943858b Jan 30, 2023 + This is true for canopy water and sublimation also, commit 4ff60baa Jan 30, 2023 + All layers have their water updated from their liq and ice at the start of the next step, so this just affects the water output (not the solution) +c-24) Remove post-processing that changes solution to perfectly conserve mass and push errors into the state variables + -25) The residual vector is now quadruple precision. Change was by Reza, sometime 2021. Makes a difference when residuals are large in step direction (I'm seeing differences especially in temperature) +c-26) Wrong precision for parameter used in canopy air space, fixed in Sean's refactoring + -27) Reorder terms in residual calculations to have (paramTrial - param) so if same will give a zero, and to be more like the prime construction, commit 5f5a6f1a Aug 30, 2023 +c-28) Check upper bounds for water fractions (ie 1, or saturation) in feasibility checks, so will cut step if infeasible. commit a58ec0d1, Aug 31, 2023 + Before, when the solution went over the upper bound, usually a residual was large, and because of the post-processing, the residual make the state vector very off which resulted in a failure to converge. + Now, should be more efficiently catching these errors. + 29) Added buffers so IDA can deal with small negatives as agreeing with Sundials theory on how much error is accepted, commit cf659c5e Sep 12, 2023 +c-30) Made zMax increment on temperature and matric head 10 instead of 1 in a timestep to allow for more rapid changes, such as at after a cold start (and other times comes into play, results in more stable solution) commit cbaa747b Sep 11, 2023 +c-31) Better to have large residual than NaNs (and failures) in residual, changes for canopy energy commit 19c9bc7 Aug 18, 2022, and commit cf659c5e Sep 12, 2023 +c-32) First flux call fluxes need be added to the mask in the first flux call, otherwise can delete values if splits to scalar solution and solves canopy air before canopy (and canopy fluxes), commit 3637f3a0 Oct 13, 2023, and commit 2c018c10 Oct 18, 2023, and commit b5656281 Oct 19, 2023 + 33) New variable for output, meanStepSize (seconds over data window), commit 02baeba0 Oct 17, 2023 + 34) Improvements to error messages + +AFTER tag of v4.0.0-exp-Sundials + 35) Enthalpy formulation, new decision (renamed from howHeatCap) + nrgConserv [closedForm or enthalpyFD or enthalpyFDlu] ! (30) choice of variable in energy conservation backward Euler residual + refers to if you want the numrec or kinsol residual to be computed with closed form heat capacity (does not conserve energy) + or enthalpy finite difference, with enthalpy calculated in the soil with the analytical solution or the lookup tables. + Decision of numMethod=itertive will give give set nrgConserv=closedForm for backwards compatibility. + 36) New output values of the balances, inputted to the outputControl.txt as: + balanceCasNrg | 1 + balanceVegNrg | 1 + balanceSnowNrg | 1 + balanceSoilNrg | 1 + balanceVegMass | 1 + balanceSnowMass | 1 + balanceSoilMass | 1 + balanceAqMass | 1 + The balance*Nrg are in units of W/m^3 and the balance*Mass are in units of kg/m^3/s. + 37) Cm derivatives, will be used if needCm is on in eval8summa or eval8summaPrime. + 38) Sean's refactor and object-orientated work, numerous and ongoing changes affecting conciseness and speed. +c-39) six allocation errors commits c0624a68, b2709388, 0b921c65, a23ac832, e43c766d, 6d3ac180 Feb 21, 2024 +c-40) two uninitialized variables fixes, commit 11a47b2b, 6b130053 Feb 15, 13, 2024 +c-41) snow water upper bound should be 1, not iden_ice, commit 265721b5 Feb 13, 2024 + -42) constraints now just scale the state variable they effect, commit 24bae32c Feb 13, 2024 + -43) constraint corrections for state variable changes in liq_layer vs wat_layer, commit 523774e1 Feb 15, 2024 + 44) Kyle's actors work, ongoing changes + 45) Added parameters for model control IDA, default values are fine +idaMaxOrder | 5.0 | 1.0 | 5.0 +idaMaxInternalSteps | 500.0 | 500.0 | 999999.0 +idaMaxErrTestFail | 50.0 | 10.0 | 50.0 +idaMinStepSize | 0.0 | 0.0 | 3600.0 + 46) Added decision aquiferIni, where default is fullStart as a full aquifer, but may use emptyStart for RMSE calculation. +idaMaxStepSize | 0.0 | 0.0 | 3600.0 + -47) Logistic smoother on canopy wetted fraction, makes function less abrupt and better convergence, commit 3608dc99 Jun 6, 2024 + diff --git a/docs/assets/readme.md b/docs/assets/readme.md new file mode 100644 index 000000000..94af681d5 --- /dev/null +++ b/docs/assets/readme.md @@ -0,0 +1,19 @@ +# Explanation of figures + +Explanation of NAmermean_NAmerRMSE_differences.png and the mean of these points in figure MeanNAmermean_MeanNAmerRMSE_differences.png. These are results of runs for 6 years (52,608 hours) and 517,315 GRUs. These simulations were run to understand the nature of the code changes listed in file listedChanges.txt. + + +## The second half of the legend is what is plotted and the first half is what the RMSE is computed against. Most of them are ``be1`*`, the new BE1 code with various bug fixes taken out and the heat capacity (change #3) not updated on iterations, compared against dev, the old develop branch with a banded Jacobian, `devFix`, the old develop with the changes marked c in the change list all made, except #30 (do not increase Zmax), `devFixZ`, the old develop with the changes marked c in the change list all made and #30 (increasing Zmax), and `devFixZM`, the old develop with the changes marked c in the change list all made and #30 (increasing Zmax), as well as the as the max number of backtracks allowed till we just accept the solution increased from 5 to 100. We note that all dev* do not update heat capacity, and this makes a large substantial difference to the solution as well as improvement to the energy conservation as discussed in the energy conservation paper [ref]. + +The biggest RMSE is the blue, the new `be1` but the heat capacity not updated on iterations (change #3) compared to dev with none of the changes (and also does not update heat capacity). These are the most different solutions, as would be expected. + +Pink is the smallest RMSE, from the new `be1` with the Jacobian terms I fixed zeroed out (changes #6 and #7) with the RMSE compared to `devFix`, both solutions not updating heat capacity. + +Next smallest is usually is the red, the new `be1` with a lower precision for the residuals (the new code has quadruple precision, change #25) plotting over the with the RMSE compared to `devFix`, both solutions not updating heat capacity. (Note that the green dot should not be in the legend as it was a repeat of the red.) + +The pink and the red I see as sort of a baseline for how close we can reasonably expect the solutions to be — we can’t do better than this. We can see the mean of the solution (y-axis) changes from the blue to the red and pink solutions even through we are just changing the Jacobian and the residual precision. Note that even changing the order of the terms in the BE1 solution residual changes the solution, see change #27. + +Next are the brown and purple, purple is new `be1` where we change the constraints in how much we allow the temperature to change in a substep (Zmax)-- it was 1 degree and we changed it to be larger because it was found that was to constraining to get good convergence and stablity (change #30) (we fail if we remove the Zmax constraint completely), with the RMSE compared to `devFixZ` (`devFix` with the Zmax increased). Brown is the opposite direction (mean will be `devFixZ` and RMSE will be to `be1`). All solutions are not updating heat capacity. We see that these solutions basically plot on top of each other in the mean point plot, lending support to the idea that increasing Zmax stabilizes the solution. + +Next is the orange, the new `be1` with the Zmax increased as well as the max number of backtracks allowed till we just accept the solution increased from 5 to 100, compared to +`devFixZM` (`devFix` with the Zmax increased as well as the number of allowed backtracks). These solutions are substantially more different than the above, suggesting that increasing the number of backtracks makes the solution more unstable, but also that the changing the number of allowed backtracks changes the solution. \ No newline at end of file diff --git a/docs/configuration/SUMMA_model_decisions.md b/docs/configuration/SUMMA_model_decisions.md index 7122b182d..0ee270543 100644 --- a/docs/configuration/SUMMA_model_decisions.md +++ b/docs/configuration/SUMMA_model_decisions.md @@ -121,22 +121,24 @@ Ball-Berry: scaling of photosynthesis from the leaf to the canopy ## 14. num_method -Numerical method +Numerical method choice | Option | Description | |---|---| -| itertive | **TODO: Describe itertive
[Reference](http://doi.org/)** | -| non_iter | **TODO: Describe non_iter
[Reference](http://doi.org/)** | -| itersurf | **TODO: Describe itersurf
[Reference](http://doi.org/)** | +| itertive | **Use homegrown SUMMA Backward Euler solver (backwards compatible naming)** | +| homegrown | **Use homegrown SUMMA Backward Euler solver** | +| kinsol | **SUNDIALS (must have installed SUNDIALS) Backward Euler solution using KINSOL, backwards Euler solver with constant step-size
[SUNDIALS KINSOL](https://sundials.readthedocs.io/en/latest/kinsol/index.html)** | +| ida | **SUNDIALS (must have installed SUNDIALS) solution using IDA, adaptive step-size Implicit Differential-Algebraic solver
[SUNDIALS IDA](https://sundials.readthedocs.io/en/latest/ida/index.html)** | + ## 15. fDerivMeth -Method to calculate flux derivatives +Method to calculate flux derivatives for Jacobian | Option | Description | |---|---| -| numericl | **TODO: Describe numericl
[Reference](http://doi.org/)** | -| analytic | **TODO: Describe analytic
[Reference](http://doi.org/)** | +| numericl | **numerical derivatives** | +| analytic | **analytical derivatives, only works with SUNDIALS num_method (kinsol or ida
[SUNDIALS IDA](https://sundials.readthedocs.io/en/latest/kinsol/Mathematics_link.html#difference-quotient-jacobian-approximations)** | @@ -384,6 +386,7 @@ Method for new snow density | pahaut_76 | **An empirical calculation dependant on air temperature and wind speed.
[Pahaut, 1976](http://doi.org/)** | | constDens | **A constant new snow density of 330 kg/m^3
[Reference](http://doi.org/)** | + ## 40. snowUnload Method for unloading snow from the canopy @@ -393,3 +396,47 @@ Method for unloading snow from the canopy | meltDripUnload | **Contains a temperature unloading function where the parameter *snowUnloadingCoeff* controls the exponential unloading rate and *ratioDrip2Unloading* is the ratio of liquid water drip from the canopy to snow unloading.
[Hedstom and Pomeroy, 1998](https://doi.org/10.1002/(SICI)1099-1085(199808/09)12:10/11<1611::AID-HYP684>3.0.CO;2-4)
[Storck et al. 2002]( https://doi.org/10.1029/2002WR001281)** | | windUnload | **Contains temperature and wind dependent unloading functions. The rates of temperature and wind unloading are adjustable through parameters *rateTempUnloading* and *rateWindUnloading*. Both functions contain parameter thresholds for the minimum temperature and windspeed required for unloading.
[Roesch et al. 2001](https://doi.org/10.1007/s003820100153)** | + + +## 41. nrgConserv +Choice of variable in energy equations (BE residual or IDA state variable) + +| Option | Description | +|---|---| +| closedForm | **use temperature with closed form heat capacity
[Energy paper stub](http://doi.org/)** | +| enthalpyFormLU | **use enthalpy with soil temperature-enthalpy lookup table
[Energy paper stub](http://doi.org/)** | +| enthalpyForm | **use enthalpy with soil temperature-enthalpy analytical solutions
[Energy paper stub](http://doi.org/)** | + + + +## 42. aquiferIni +Choice of initial fill level for aquifer, should be used at default unless comparing solution methods + +| Option | Description | +|---|---| +| fullStart | **(default) start with initial value aquifer, usually full for cold start as easier to drain the aquifer to equilibrium than fill to equilibrium** | +| emptyStart | **start with empty aquifer, only used if comparing solution solution methods and not looking to simulate reality** | + + + +## 43. infRateMax +Choice of equation to determine maximum infiltration rate. + +| Option | Description | +|---|---| +| topmodel_GA | **(default) Topmodel-ish approximation of Green-Ampt** | +| GreenAmpt | **Green-Ampt infiltration rate** | +| noInfiltrationExcess | **Set max infiltration rate to something very high to make having infiltration excess runoff practically impossible**| + + + +## 44. surfRun_SE +Choice of equation to calculate saturation excess runoff. + +| Option | Description | +|---|---| +| homegrown_SE | **(default) Original SUMMA implementation for saturation excess** | +| FUSEPRMS | **PRMS saturation excess runoff as implemented in FUSE**| +| FUSEAVIC | **ARNO/VIC saturation excess runoff as implemented in FUSE**| +| FUSETOPM | **Topmodel saturation excess runoff as implemented in FUSE**| +| zero_SE | **No saturation excess runoff**| \ No newline at end of file diff --git a/docs/development/SUMMA_contributing.md b/docs/development/SUMMA_contributing.md new file mode 100644 index 000000000..65e0c151d --- /dev/null +++ b/docs/development/SUMMA_contributing.md @@ -0,0 +1,10 @@ +# SUMMA Contributions + +We welcome community contributions in the forms of bug reports or pull requests. For bug reports, head over to the `Issues` section on the [SUMMA GitHub page](https://github.com/CH-Earth/summa/issues). Please look around for existing issues and add to those when appropriate before opening a new one. + +For pull requests, please note that you will not be able to contribute to the main SUMMA repo directly. Using `git` is a requirement for contributions. For more information about working with the SUMMA code, please see the following documents: + +* [SUMMA and Git](../development/SUMMA_and_git.md) +* [Git Workflow for SUMMA](../development/SUMMA_git_workflow.md) +* [SUMMA Coding Conventions](../development/SUMMA_coding_conventions.md) +* [Modularity in SUMMA](../development/SUMMA_modularity_guidelines.md) \ No newline at end of file diff --git a/docs/development/SUMMA_modularity_guidelines.md b/docs/development/SUMMA_modularity_guidelines.md new file mode 100644 index 000000000..d6df1f594 --- /dev/null +++ b/docs/development/SUMMA_modularity_guidelines.md @@ -0,0 +1,189 @@ +# Developer Guidelines for Contributing New Modular Components + +New modular components may be added by using similar existing modular components as a template. The following steps (if applicable) may be used as a guideline. This process is illustrated using the addition of a new surface hydrology flux parameterization as an example. + +## Identify a similar model component + +* Identify the appropriate subdirectory within SUMMA's `source` directory such as: + * `driver`: high-level program operations including the main driver + * `dshare`: modules related to data storage and access + * `engine`: low-level operations for physical and numerical processes + * e.g., applies to flux calculations +* Identify the appropriate source file and module + * source files have self-explanatory names + * e.g., `soilLiqFlx.f90` corresponds to operations for liquid water fluxes in soil + * each source file generally contains one module + * e.g., `soilLiqFlx.f90` contains `soilLiqFlx_module` +* Identify the appropriate procedure + * isolate the module procedure + * e.g., within `soilLiqFlx_module`, the `surfaceFlx` module subroutine handles operations for surface hydrology fluxes + * isolate the internal procedure + * e.g., within the `contains` block of `surfaceFlx`, we have `update_surfaceFlx_prescribedHead` containing operations for specifying a prescribed pressure head surface boundary condition + * `update_surfaceFlx_prescribedHead` may be used as a template for our example contribution + * note that procedure names in SUMMA are organized using the terms *initialize*, *update*, and *finalize* to categorize operation types + * *initialize* procedures are used for initial setup steps (initialization of variables, memory allocation, etc.) + * *update* procedures are used for major computational operations (e.g., flux calculations) + * *finalize* procedures are for post-processing and final error control checks + +## Determine input and output variables +* Found by examining dummy variables in argument lists + * Note that internal procedures inherit the dummy variables from the applicable module procedure by default + * e.g., for the `update_surfaceFlx_prescribedHead` internal subroutine, the argument list of the `surfaceFlx` module subroutine applies: `subroutine surfaceFlx(io_soilLiqFlx,in_surfaceFlx,io_surfaceFlx,out_surfaceFlx)` +* Dummy variables may be objects with multiple data and procedure components + * Such objects are declared using derived types (most commonly defined in `data_types.f90`) + * Objects may be used to concisely interface data between the procedure and the caller + * for SUMMA objects, the nomenclature `in_foobar`, `io_foobar`, and `out_foobar` is used for objects that interface input, input-output, and output data between the `foobar` procedure and its caller, respectively +* The `intent` attribute within dummy variable declarations indicates usage for input, input-output, or output + * e.g., within `surfaceFlx` we have `type(in_type_surfaceFlx) ,intent(in) :: in_surfaceFlx`, indicating the `in_surfaceFlx` object is for input data only + * as noted above, the `in_surfaceFlx` object interfaces input data between the `surfaceFlx` module subroutine and its caller (the `soilLiqFlx` module subroutine) + +## Create a skeleton of the new procedure +* Choose a self explanatory name for the new procedure + * e.g. `update_surfaceFlx_example_flux` +* e.g., at the conclusion of this step, we would have a skeleton within the `contains` block of `surfaceFlx` similar to the following: + +```fortran +subroutine update_surfaceFlx_example_flux +! main computations for the calculation of an example flux + +end subroutine update_surfaceFlx_example_flux +``` + +* For new module procedures, the argument list from the template routine should be adjusted to match the needs of the new procedure +* For internal procedures (such as the example above), adding new data to interface objects from the corresponding module procedure may be required (see next step) + +## Update derived type definitions for interface objects +* It may be desirable to add data components to existing objects related to the template procedure + * e.g., adding a new numerical constant to be used in calculating a surface hydrology flux would require interfacing that data to the `update_surfaceFlx_example_flux` subroutine, which can be done using the `in_surfaceFlx` object +* Derived type definitions for interface objects are found in `source/dshare/data_types.f90` + * e.g., for the `in_surfaceFlx` object we have the `in_type_surfaceFlx` derived type in the `data_types` module: + + ```fortran + type, public :: in_type_surfaceFlx ! intent(in) data + ! input: model control + logical(lgt) :: firstSplitOper ! flag indicating if desire to compute infiltration + logical(lgt) :: deriv_desired ! flag to indicate if derivatives are desired + integer(i4b) :: ixRichards ! index defining the option for the Richards equation (moisture or mixdform) + integer(i4b) :: bc_upper ! index defining the type of boundary conditions + integer(i4b) :: nRoots ! number of layers that contain roots + integer(i4b) :: ixIce ! index of lowest ice layer + integer(i4b) :: nSoil ! number of soil layers + ! [...] ! additional data components here + contains + procedure :: initialize => initialize_in_surfaceFlx + end type in_type_surfaceFlx + ``` + + +* Adding a new numerical constant (say `example_flux_constant`) may be done as follows: + + ```fortran + type, public :: in_type_surfaceFlx ! intent(in) data + ! input: model control + logical(lgt) :: firstSplitOper ! flag indicating if desire to compute infiltration + logical(lgt) :: deriv_desired ! flag to indicate if derivatives are desired + integer(i4b) :: ixRichards ! index defining the option for the Richards equation (moisture or mixdform) + integer(i4b) :: bc_upper ! index defining the type of boundary conditions + integer(i4b) :: nRoots ! number of layers that contain roots + integer(i4b) :: ixIce ! index of lowest ice layer + integer(i4b) :: nSoil ! number of soil layers + ! input: values for the example flux + real(rkind) :: example_flux_constant ! numerical constant for example flux + ! [...] ! additional data components here + contains + procedure :: initialize => initialize_in_surfaceFlx + end type in_type_surfaceFlx + ``` + + * note that SUMMA uses the following `kind` parameters: `lgt` for logical variables, `i4b` for integer variables, and `rkind` for real variables + +* Additionally, we have procedure components for *initialize* and *finalize* operations for data interfacing + * e.g., `call in_surfaceFlx % initialize` points to the `initialize_in_surfaceFlx` class procedure (in the `contains` block of the `data_types` module) for initializing data components: + + ```fortran + subroutine initialize_in_surfaceFlx(in_surfaceFlx,nRoots,ixIce,nSoil,ibeg,iend,in_soilLiqFlx,io_soilLiqFlx,& + &model_decisions,prog_data,mpar_data,flux_data,diag_data,& + &iLayerHeight,dHydCond_dTemp,iceImpedeFac) + class(in_type_surfaceFlx),intent(out) :: in_surfaceFlx ! input object for surfaceFlx + ! [...] ! additional variable declarations here + + associate(& + ! model control + firstSplitOper => in_soilLiqFlx % firstSplitOper, & ! flag to compute infiltration + deriv_desired => in_soilLiqFlx % deriv_desired, & ! flag indicating if derivatives are desired + ixRichards => model_decisions(iLookDECISIONS%f_Richards)%iDecision,& ! index of the form of the Richards equation + ixBcUpperSoilHydrology => model_decisions(iLookDECISIONS%bcUpprSoiH)%iDecision & ! index defining the type of boundary conditions + &) + ! intent(in): model control + in_surfaceFlx % firstSplitOper = firstSplitOper ! flag indicating if desire to compute infiltration + in_surfaceFlx % deriv_desired = deriv_desired ! flag indicating if derivatives are desired + in_surfaceFlx % ixRichards = ixRichards ! index defining the form of the Richards equation (moisture or mixdform) + in_surfaceFlx % bc_upper = ixBcUpperSoilHydrology ! index defining the type of boundary conditions (Neumann or Dirichlet) + in_surfaceFlx % nRoots = nRoots ! number of layers that contain roots + in_surfaceFlx % ixIce = ixIce ! index of lowest ice layer + in_surfaceFlx % nSoil = nSoil ! number of soil layers + end associate + + ! [...] ! additional associate blocks here + end subroutine initialize_in_surfaceFlx + ``` + + * new data components, such as `example_flux_constant`, must be applied within the procedure components: + + ```fortran + subroutine initialize_in_surfaceFlx(in_surfaceFlx,nRoots,ixIce,nSoil,ibeg,iend,in_soilLiqFlx,io_soilLiqFlx,& + &model_decisions,prog_data,mpar_data,flux_data,diag_data,& + &iLayerHeight,dHydCond_dTemp,iceImpedeFac,example_flux_constant) + class(in_type_surfaceFlx),intent(out) :: in_surfaceFlx ! input object for surfaceFlx + ! [...] ! additional variable declarations here + real(rkind),intent(in) :: example_flux_constant ! declaration for new constant + + associate(& + ! model control + firstSplitOper => in_soilLiqFlx % firstSplitOper, & ! flag to compute infiltration + deriv_desired => in_soilLiqFlx % deriv_desired, & ! flag indicating if derivatives are desired + ixRichards => model_decisions(iLookDECISIONS%f_Richards)%iDecision,& ! index of the form of the Richards equation + ixBcUpperSoilHydrology => model_decisions(iLookDECISIONS%bcUpprSoiH)%iDecision & ! index defining the type of boundary conditions + &) + ! intent(in): model control + in_surfaceFlx % firstSplitOper = firstSplitOper ! flag indicating if desire to compute infiltration + in_surfaceFlx % deriv_desired = deriv_desired ! flag indicating if derivatives are desired + in_surfaceFlx % ixRichards = ixRichards ! index defining the form of the Richards equation (moisture or mixdform) + in_surfaceFlx % bc_upper = ixBcUpperSoilHydrology ! index defining the type of boundary conditions (Neumann or Dirichlet) + in_surfaceFlx % nRoots = nRoots ! number of layers that contain roots + in_surfaceFlx % ixIce = ixIce ! index of lowest ice layer + in_surfaceFlx % nSoil = nSoil ! number of soil layers + end associate + + ! [...] ! additional associate blocks here + + ! assignment statements for the example flux + in_surfaceFlx % example_flux_constant = example_flux_constant ! numerical constant for example flux + + end subroutine initialize_in_surfaceFlx + ``` + + * for the above example, we have added a dummy variable for the new example flux constant and an assignment statement to initialize the new data component `in_surfaceFlx % example_flux_constant` + * note that the corresponding call to `in_surfaceFlx` within the `soilLiqFlx` subroutine would need to be updated to include the additional argument `example_flux_constant` + +## Add operations to the skeleton procedure +* add main operations within the skeleton procedure created in the above steps to complete the new modular component + * for the example flux parameterization (using a toy model of constant infiltration), we have: + + ````fortran + subroutine update_surfaceFlx_example_flux + ! main computations for the calculation of an example flux + associate(& + ! input: flux at the upper boundary + scalarRainPlusMelt => in_surfaceFlx % scalarRainPlusMelt , & ! rain plus melt, used as input to the soil zone before computing surface runoff (m s-1) + ! input: numerical constants + example_flux_constant => in_surfaceFlx % example_flux_constant + ! output: runoff and infiltration + scalarSurfaceRunoff => out_surfaceFlx % scalarSurfaceRunoff , & ! surface runoff (m s-1) + scalarSurfaceInfiltration => out_surfaceFlx % scalarSurfaceInfiltration & ! surface infiltration (m s-1) + &) + scalarSurfaceInfiltration = example_flux_constant ! toy model of constant infiltration + scalarSurfaceRunoff = scalarRainPlusMelt - scalarSurfaceInfiltration ! compute surface runoff + end associate + end subroutine update_surfaceFlx_example_flux + ```` \ No newline at end of file diff --git a/docs/development/SUMMA_recipes.md b/docs/development/SUMMA_recipes.md new file mode 100644 index 000000000..d28bbb7b2 --- /dev/null +++ b/docs/development/SUMMA_recipes.md @@ -0,0 +1,32 @@ +# SUMMA Recipes + +This page contains instructions for certain common actions one might do when working with the SUMMA source code. + +## Add a variable + +To add a new variable, some infrastructure must be set up before the variable can be used. This all happens inside `./source/dshare/`: + +1. Add a new entry to `var_lookup.f90` under an appropriate category for your variable. For example, `scalarSaturatedArea` fits well under "Soil hydrology" in "(7) Diagnostic variables". Make not of the structure you've added the variable under. In this case, this would be `iLook_diag`. +2. Further down in `var_lookup.f90`, increment the correct data structure (here: `iLook_diag`) by 1. For example, if the current structure ends at 110, add the value 111. +3. Add a corresponding entry in `popMetadat.f90`. This defines how the variable will described in SUMMA's output files. Keep the ordering consistent with `var_lookup.f90`. +4. Add a corresponding entry to the correct data structure function in `get_ixname.f90`. + +If everything has gone well SUMMA should compile and run as normal. If not, SUMMA will exit the run early and provide diagnostics. Common errors are: + +* Data structure in `var_lookup.f90` not incremented (step 2): + +``` +FATAL ERROR: summa_initialize/summa_defineGlobalData/checkStruc/problem with structure constructor iLookDIAG [element=111] +``` + +* `popMetadat.f90` not updated (step 3): + +``` +FATAL ERROR: summa_initialize/summa_defineGlobalData/checkStruc/checkPopulated/diag_meta structure is not populated for named variable # 75 in structure iLookDIAG +``` + +* `get_ixname.f90` not updated (step 4): + +``` +FATAL ERROR: summa_initialize/summa_defineGlobalData/checkStruc/checkPopulated/get_ixUnknown/variable scalarSaturatedArea is not found in any structure +``` \ No newline at end of file diff --git a/docs/index.md b/docs/index.md index 51b37d674..bfa03c27c 100644 --- a/docs/index.md +++ b/docs/index.md @@ -5,7 +5,7 @@ [![Documentation Status](https://readthedocs.org/projects/summa/badge/?version=latest)](http://summa.readthedocs.org/en/latest/) [![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.800772.svg)](https://doi.org/10.5281/zenodo.800772) -SUMMA (Clark et al., [2015a](#clark_2015a);[b](#clark_2015b);[c](#clark_2015c); [2021](#clark_2021) is a hydrologic modeling framework that can be used for the systematic analysis of alternative model conceptualizations with respect to flux parameterizations, spatial configurations, and numerical solution techniques. It can be used to configure a wide range of hydrological model alternatives and we anticipate that systematic model analysis will help researchers and practitioners understand reasons for inter-model differences in model behavior. When applied across a large sample of catchments, SUMMA may provide insights in the dominance of different physical processes and regional variability in the suitability of different modeling approaches. An important application of SUMMA is selecting specific physics options to reproduce the behavior of existing models – these applications of "**model mimicry**" can be used to define reference (benchmark) cases in structured model comparison experiments, and can help diagnose weaknesses of individual models in different hydroclimatic regimes. +SUMMA (Clark et al., [2015a](#clark_2015a);[b](#clark_2015b);[c](#clark_2015c); [2021](#clark_2021)) is a hydrologic modeling framework that can be used for the systematic analysis of alternative model conceptualizations with respect to flux parameterizations, spatial configurations, and numerical solution techniques. It can be used to configure a wide range of hydrological model alternatives and we anticipate that systematic model analysis will help researchers and practitioners understand reasons for inter-model differences in model behavior. When applied across a large sample of catchments, SUMMA may provide insights in the dominance of different physical processes and regional variability in the suitability of different modeling approaches. An important application of SUMMA is selecting specific physics options to reproduce the behavior of existing models – these applications of "**model mimicry**" can be used to define reference (benchmark) cases in structured model comparison experiments, and can help diagnose weaknesses of individual models in different hydroclimatic regimes. SUMMA is built on a common set of conservation equations and a common numerical solver, which together constitute the “**structural core**” of the model. Different modeling approaches can then be implemented within the structural core, enabling a controlled and systematic analysis of alternative modeling options, and providing insight for future model development. @@ -13,9 +13,9 @@ The important modeling features are: 1. The formulation of the conservation model equations is cleanly separated from their numerical solution; - 1. Different model representations of physical processes (in particular, different flux parameterizations) can be used within a common set of conservation equations; and + 2. Different model representations of physical processes (in particular, different flux parameterizations) can be used within a common set of conservation equations; and - 1. The physical processes can be organized in different spatial configurations, including model elements of different shape and connectivity (e.g., nested multi-scale grids and HRUs). + 3. The physical processes can be organized in different spatial configurations, including model elements of different shape and connectivity (e.g., nested multi-scale grids and HRUs). ## Documentation diff --git a/docs/input_output/SUMMA_input.md b/docs/input_output/SUMMA_input.md index 62d4ce2fd..46593ad4e 100644 --- a/docs/input_output/SUMMA_input.md +++ b/docs/input_output/SUMMA_input.md @@ -32,37 +32,36 @@ The master configuration file is an [ASCII file](#infile_format_ASCII) and is pr The following items must be provided in the master configuration file. Order is not important, as the entries are each associated with a keyword. Each keyword and entry pair must be on its own line, but may be followed by a comment (started by the '!' character), and you can add lines of comments between the items. Each entry must be enclosed in single quotes `'entry'`. The associations of the keywords to the actual variable name that is used in the SUMMA source code can be found in `summaFileManager.f90`, along with its default value where appropriate. -`controlVersion`: Version of the file manager that should be used to process the master configuration file. At this time, this string should be equal to `'SUMMA_FILE_MANAGER_V3.0.0'`. Note, this version of the code is not backward compatible with versions using `SUMMA_FILE_MANAGER_V1.0` or `SUMMA_FILE_MANAGER_V2.0`. - -`simStartTime` : Start of the simulation specified as `'YYYY-MM-DD hh:mm'`. See [Time definition notes](#simulStartEndTimes). -`simEndTime` : End of the simulation specified as `'YYYY-MM-DD hh:mm'`. -`tmZoneInfo` : [Time zone information](#tmZoneInfo). -`settingsPath` : Base path for the configuration files. Most of the file paths in the remainder of the master configuration file are relative to this path (except `forcingPath` and `outputPath`). -`forcingPath` : Base path for the meteorological forcing files specified in the `forcingList`. -`outputPath` : Base path for the SUMMA output files. -`statePath` : (optional) Base path for the SUMMA state files, including the initial condition file. If not given, the initial condition (state) file is read from the settingsPath directory, and the state file outputs are written to the outputPath directory. If given, summa expects the initial condition file to be in the state file directory. -`decisionsFile` : File path for the [model decisions file](#infile_model_decisions) (relative to `settingsPath`). -`outputControlFile` : File path for the [output control file](#infile_output_control) (relative to `settingsPath`). -`attributeFile` : File path for the [local attributes file](#infile_local_attributes) (relative to `settingsPath`). -`globalHruParamFile` : File path for the [local parameters file](#infile_local_parameters) (relative to `settingsPath`). -`globalGruParamFile` : File path for the [basin parameters file](#infile_basin_parameters) (relative to `settingsPath`). -`forcingListFile` : File path for the [list of forcing files file](#infile_forcing_list) (relative to `settingsPath`). -`initConditionFile` : File path for the [initial conditions file](#infile_initial_conditions) (relative to `settingsPath`). -`trialParamFile` : File path for the [trial parameters file](#infile_trial_parameters) (relative to `settingsPath`). -`vegTableFile` : File path to the vegetation parameter table (defaults to `VEGPARM.TBL`) (relative to `settingsPath`) -`soilTableFile` : File path to the soil parameter table (defaults to `SOILPARM.TBL`) (relative to `settingsPath`) -`generalTableFile` : File path to the general parameter table (defaults to `GENPARM.TBL`) (relative to `settingsPath`) -`noahmpTableFile` : File path to the noah mp parameter table (defaults to `MPTABLE.TBL`) (relative to `settingsPath`) -`outFilePrefix` : Text string prepended to each output filename to identify a specific model setup. Note that the user can further modify the output file name at run-time by using the `-s|--suffix` command-line option. - -And example of this file is provide [here](#fileMgr_example). +- `controlVersion`: Version of the file manager that should be used to process the master configuration file. At this time, this string should be equal to `'SUMMA_FILE_MANAGER_V3.0.0'`. Note, this version of the code is not backward compatible with versions using `'SUMMA_FILE_MANAGER_V1.0'` or `'SUMMA_FILE_MANAGER_V2.0'`. +- `simStartTime` : Start of the simulation specified as `'YYYY-MM-DD hh:mm'`. See [Time definition notes](#simulStartEndTimes). +- `simEndTime` : End of the simulation specified as `'YYYY-MM-DD hh:mm'`. +- `tmZoneInfo` : [Time zone information](#tmZoneInfo). +- `settingsPath` : Base path for the configuration files. Most of the file paths in the remainder of the master configuration file are relative to this path (except `forcingPath` and `outputPath`). +- `forcingPath` : Base path for the meteorological forcing files specified in the `forcingList`. +- `outputPath` : Base path for the SUMMA output files. +- `statePath` : (optional) Base path for the SUMMA state files, including the initial condition file. If not given, the initial condition (state) file is read from the settingsPath directory, and the state file outputs are written to the outputPath directory. If given, summa expects the initial condition file to be in the state file directory. +- `decisionsFile` : File path for the [model decisions file](#infile_model_decisions) (relative to `settingsPath`). +- `outputControlFile` : File path for the [output control file](#infile_output_control) (relative to `settingsPath`). +- `attributeFile` : File path for the [local attributes file](#infile_local_attributes) (relative to `settingsPath`). +- `globalHruParamFile` : File path for the [local parameters file](#infile_local_parameters) (relative to `settingsPath`). +- `globalGruParamFile` : File path for the [basin parameters file](#infile_basin_parameters) (relative to `settingsPath`). +- `forcingListFile` : File path for the [list of forcing files file](#infile_forcing_list) (relative to `settingsPath`). +- `initConditionFile` : File path for the [initial conditions file](#infile_initial_conditions) (relative to `settingsPath`). +- `trialParamFile` : File path for the [trial parameters file](#infile_trial_parameters) (relative to `settingsPath`). +- `vegTableFile` : File path to the vegetation parameter table (defaults to `VEGPARM.TBL`) (relative to `settingsPath`). +- `soilTableFile` : File path to the soil parameter table (defaults to `SOILPARM.TBL`) (relative to `settingsPath`). +- `generalTableFile` : File path to the general parameter table (defaults to `GENPARM.TBL`) (relative to `settingsPath`). +- `noahmpTableFile` : File path to the noah mp parameter table (defaults to `MPTABLE.TBL`) (relative to `settingsPath`). +- `outFilePrefix` : Text string prepended to each output filename to identify a specific model setup. Note that the user can further modify the output file name at run-time by using the `-s|--suffix` command-line option. + +An example of this file is provide [here](#fileMgr_example). -## 1. Simulation Start and End Times +### Note on Simulation Start and End Times Start and end of the simulation are specified as `'YYYY-MM-DD hh:mm'`. Note that the strings needs to be enclosed in single quotes. These indicates the end of the first and last time step. Since the time stamps in the [forcing files](#infile_meteorological_forcing) are period-ending, SUMMA will start reading the forcing file for the time stamp that equals `simulStart`. -## 3. tmZoneInfo +### Note on tmZoneInfo The time zone information should be specified consistently in all the model forcing files. The local time for the individual model elements is calculated as `localTime = inputTime + timeOffset`, where `localTime` is the time in which local noon coincides with solar noon, `inputTime` is the time in the model forcing files, and `timeOffset` is determined according to the `tmZoneInfo` option that is selected. The `simulStart` and `simulFinsh` time stamps must be consistent with the `tmZoneInfo` option. The `utcTime` option is recommended for large domain simulations (but you need to ensure that your forcing files are consistent with this option). @@ -70,10 +69,8 @@ Time stamps in the output files will be consistent with the `tmZoneInfo` option | Option | Description | |---|---| -| ncTime | Time zone information is parsed as `ncTimeOffset` from the `units` attribute of the `time` variable in the NetCDF file with the - meteorological forcings. The `timeOffset` is then calculated as `timeOffset = longitude/15 - ncTimeOffset`. The `units` attribute must be compliant with the [CF conventions](http://cfconventions.org/Data/cf-conventions/cf-conventions-1.7/build/ch04s04.html). Note that the code internally uses fractional days and thus uses `longitude/360`. -| utcTime | `timeOffset` is calculated as `timeOffset = longitude/15` hours. In essence this assumes - that all time stamps in the forcing files are in UTC. This is the preferred option for large-domain simulations that span multiple time zones. Note that the code internally uses fractional days and thus uses `longitude/360`. +| `ncTime` | Time zone information is parsed as `ncTimeOffset` from the `units` attribute of the `time` variable in the NetCDF file with the meteorological forcings. The `timeOffset` is then calculated as `timeOffset = longitude/15 - ncTimeOffset`. The `units` attribute must be compliant with the [CF conventions](http://cfconventions.org/Data/cf-conventions/cf-conventions-1.7/build/ch04s04.html). Note that the code internally uses fractional days and thus uses `longitude/360`. [^1] [^2] | +| utcTime | `timeOffset` is calculated as `timeOffset = longitude/15` hours. In essence this assumes that all time stamps in the forcing files are in UTC. This is the preferred option for large-domain simulations that span multiple time zones. Note that the code internally uses fractional days and thus uses `longitude/360`. | | localTime | `timeOffset` is equal to zero. | For example, assume that a model element has longitude -120º (or 120W) and the `units` attribute of the `time` variable in the NetCDF forcing file is `seconds since 1992-01-01 00:00:00 -6:00`. For each of the `tmZoneInfo` options this will be processed the following way: @@ -87,7 +84,8 @@ For example, assume that a model element has longitude -120º (or 120W) and the Specifying time zone information in the NetCDF file and overriding it with the `tmZoneInfo` option can be confusing and is only provided to give the user some flexibility. ------------------- +### Filemanager example +``` controlVersion: 'SUMMA_FILE_MANAGER_V2.0' ! file manager version ! --- simulation times --- @@ -111,7 +109,7 @@ forcingList 'forcingFileList.txt' ! forcing file list initCondFile 'coldState.3l3h_100cm.nc' ! initial conditions trialParamFile 'trialParams.v1.nc' ! trial parameter file outFilePrefix 'sf_flathead_v1' ! output_prefix ------------------- +``` ## Model decisions file @@ -129,7 +127,7 @@ The model decisions and their options or values are listed in the following tabl |[simulFinsh](../configuration/SUMMA_model_decisions.md#simulFinsh) | 'YYYY-MM-DD hh:mm' | ( 2) simulation end time |[tmZoneInfo](../configuration/SUMMA_model_decisions.md#tmZoneInfo) | ncTime
utcTime
localTime | ( 3) time zone information |[soilCatTbl](../configuration/SUMMA_model_decisions.md#soilCatTbl) | STAS
STAS-RUC
ROSETTA | ( 4) soil-category dataset -|[vegeParTbl](../configuration/SUMMA_model_decisions.md#vegeParTbl) | USGS MODIFIED_IGBP_MODIS_NOAH | ( 5) vegetation category dataset +|[vegeParTbl](../configuration/SUMMA_model_decisions.md#vegeParTbl) | USGS
MODIFIED_IGBP_MODIS_NOAH | ( 5) vegetation category dataset |[soilStress](../configuration/SUMMA_model_decisions.md#soilStress) | NoahType
CLM_Type
SiB_Type | ( 6) choice of function for the soil moisture control on stomatal resistance |[stomResist](../configuration/SUMMA_model_decisions.md#stomResist) | BallBerry
Jarvis
simpleResistance
BallBerryFlex
BallBerryTest | ( 7) choice of function for stomatal resistance |[bbTempFunc](../configuration/SUMMA_model_decisions.md#bbTempFunc) | q10Func
Arrhenius | ( 8) Ball-Berry: leaf temperature controls on photosynthesis + stomatal resistance @@ -139,7 +137,7 @@ The model decisions and their options or values are listed in the following tabl |[bbNumerics](../configuration/SUMMA_model_decisions.md#bbNumerics) | NoahMPsolution
newtonRaphson | (12) Ball-Berry: iterative numerical solution method |[bbAssimFnc](../configuration/SUMMA_model_decisions.md#bbAssimFnc) | colimitation
minFunc | (13) Ball-Berry: controls on carbon assimilation |[bbCanIntg8](../configuration/SUMMA_model_decisions.md#bbCanIntg8) | constantScaling
laiScaling | (14) Ball-Berry: scaling of photosynthesis from the leaf to the canopy -|[num_method](../configuration/SUMMA_model_decisions.md#num_method) | itertive
non_iter
itersurf | (15) choice of numerical method +|[num_method](../configuration/SUMMA_model_decisions.md#num_method) | itertive
homegrown
kinsol
ida| (15) choice of numerical method |[fDerivMeth](../configuration/SUMMA_model_decisions.md#fDerivMeth) | numericl
analytic | (16) choice of method to calculate flux derivatives |[LAI_method](../configuration/SUMMA_model_decisions.md#LAI_method) | monTable
specified | (17) choice of method to determine LAI and SAI |[cIntercept](../configuration/SUMMA_model_decisions.md#cIntercept) | sparseCanopy
storageFunc
notPopulatedYet | (18) choice of parameterization for canopy interception @@ -165,6 +163,10 @@ The model decisions and their options or values are listed in the following tabl |[spatial_gw](../configuration/SUMMA_model_decisions.md#spatial_gw) | localColumn
singleBasin | (38) choice of method for spatial representation of groundwater |[subRouting](../configuration/SUMMA_model_decisions.md#subRouting) | timeDlay
qInstant | (39) choice of method for sub-grid routing |[snowDenNew](../configuration/SUMMA_model_decisions.md#snowDenNew) | hedAndPom
anderson
pahaut_76
constDens | (40) choice of method for new snow density +|[nrgConserv](../configuration/SUMMA_model_decisions.md#nrgConserv) | closedForm
enthalpyFormLU
enthalpyForm | (41) choice of variable in energy equations (BE residual or IDA state variable) +|[aquiferIni](../configuration/SUMMA_model_decisions.md#aquiferIni) | fullStart
emptyStart | (42) choice of initial fill level for aquifer, should be used at default unless comparing solution methods +|[infRateMax](../configuration/SUMMA_model_decisions.md#infRateMax) | topmodel_GA
GreenAmpt
noInfiltrationExcess | (43) choice of parametrization of maximum infiltration rate +|[surfRun_SE](../configuration/SUMMA_model_decisions.md#surfRun_SE) | homegrown_SE
FUSEPRMS
FUSEAVIC
FUSETOPM
zero_SE | (44) choice of initial fill level for aquifer, should be used at default unless comparing solution methods The model decisions for each simulation are included as global attributes in [SUMMA output files](SUMMA_output.md). @@ -224,6 +226,13 @@ Notes about forcing file format: SUMMA uses **adaptive time stepping** to solve the model equations. Atmospheric conditions are kept constant during the adaptive sub-steps that occur during a meteorological forcing time step. +### Common pitfalls +SUMMA requires complete timeseries in the meteorological forcing files; missing values such as `NaN` are not allowed. By design, SUMMA does not check the input files to limit the number of computations performed. The user is expected to ensure forcing files are completely and contain realistic. However, `NaN` values do have a tendency to slip in. In such cases SUMMA will usually abort a run early, with the following error message: + +``` +Note: The following floating-point exceptions are signalling: IEEE_INVALID_FLAG +``` + ## Initial conditions, restart or state file The initial conditions, restart, or state file is a [NetCDF file](#infile_format_nc) that specifies the model states at the start of the model simulation. This file is required. You will need to generate one before you run the model for the first time, but after that the model restart file can be the result from an earlier model simulation. The file is written by `build/source/netcdf/modelwrite.f90:writeRestart()` and read by `build/source/netcdf/read_icond.f90:read_icond_nlayers()` (number of snow and soil layers) and `build/source/netcdf/read_icond.f90:read_icond()` (actual model states). diff --git a/docs/installation/README_not_ngen.md b/docs/installation/README_not_ngen.md new file mode 100644 index 000000000..730e21374 --- /dev/null +++ b/docs/installation/README_not_ngen.md @@ -0,0 +1,66 @@ +# SummaSundials + +## About + +This is configured with the [CMakeLists.txt](CMakeLists.txt) and other files in this directory. + +### Getting the Latest Changes + +There are two steps to getting upstream submodule changes fully + 1. fetching and locally checking out the changes from the remote + 2. committing the new checkout revision for the submodule + +To fetch and check out the latest revision (for the [currently used branch](#viewing-the-current-branch)): + + git pull + +# Usage + +## Building Libraries + +If you want to use Sundials IDA or BE Kinsol, set -DUSE_SUNDIALS=ON in the build script. Then, before summa can be built, Sundials needs to be installed. + +### Installing SUNDIALS +Download the file `sundials-X.Y.Z.tar.gz` (where X.Y.Z is the latest SUNDIALS version) at https://github.com/LLNL/sundials/releases/latest. Move `sundials-X.Y.Z.tar.gz` into `top_dir`. In other words, `$ ls top_dir` should include `summa sundials-X.Y.Z.tar.gz. Download this to the folder your preferred ${SUN_DIR}. + +Extract the corresponding compressed file and rename + $ cd sun_dir + $ tar -xzf sundials-X.Y.Z.tar.gz && mv sundials-X.Y.Z sundials-software + $ rm sundials-X.Y.Z.tar.gz + +Create new empty directories to prep for SUNDIALS installation, within ${SUN_DIR}: + $ mkdir sundials + $ cd sundials + $ mkdir builddir instdir + +Copy CMake build script from SUMMA files to properly configure SUNDIALS from your chosen ${SUMMA_DIR} + $ cd builddir + $ cp ${SUMMA_DIR}/summa/build/cmake_external/build_cmakeSundials.bash . + +Build SUNDIALS configured for SUMMA, within `builddir`: + $ ./build_cmakeSundials.bash + $ make + $ make install + +We suggest you periodically update to the latest version. It is also possible to install using Git: + $ git clone https://github.com/LLNL/sundials.git sundials-software + $ cd sundials-software + $ git fetch --all --tags --prune + $ git checkout tags/vX.Y.Z + +Note if you need to recompile after a system upgrade, delete the contents of sundials/instdir and sundials/buildir EXCEPT sundials/buildir/build_cmakeSundials.bash before building and installing. + +### Building and installing SUMMA +First, you will need to tell CMake where Sundials is if you installed it and plan to use it: + $ export CMAKE_PREFIX_PATH=/sun_dir/sundials/instdir + +Then, a CMake build system must be generated. E.g., from the top `summa/build/cmake` directory, using SUNDIALS: + $ cmake -B ../cmake_build -S ../. -DUSE_SUNDIALS=ON + +After there is build system directory, the shared library can be built using the `summabmi` CMake target. For example, the SummaSundials shared library file (i.e., the build config's `summabmi` target) can be built using: + $ cmake --build ../cmake_build --target all -j + +This will build a `cmake_build/libsumma..` file, where the version is configured within the CMake config, and the extension depends on the local machine's operating system. + +There is an example of a bash script to build the summa libraries at /build/cmake/build[_actors].[system_type].bash. SUNDIALS is turned on here. These need to be run in the cmake directory. + diff --git a/docs/installation/SUMMA_installation.md b/docs/installation/SUMMA_installation.md index c5521d365..a9ee013aa 100644 --- a/docs/installation/SUMMA_installation.md +++ b/docs/installation/SUMMA_installation.md @@ -2,7 +2,86 @@ We have successfully installed SUMMA on a number of Unix-like (\*nix) operating systems, including Linux and Darwin (Mac OS X). Since we do a lot of our development on OS X, we have a [separate page](SUMMA_on_OS_X.md) on how to install the necessary tools and libraries on that platform. If you do not want to deal with installing programs and libraries and just want to run SUMMA, then we also have a SUMMA release that uses [Docker](https://www.docker.com). Details can be found on our [SUMMA using Docker](SUMMA_docker.md) page. If you plan to use Docker, then you can skip the rest of this page. -To compile SUMMA, you will need: +## Dependencies +To compile SUMMA, you will need (longer descriptions at the [bottom](#extended-description-of-dependencies) of this page): + +* A Fortran compiler. The open source GNU Fortran compiler (`gfortran`) is a good choice. +* The [NetCDF](http://www.unidata.ucar.edu/software/netcdf/) libraries, compiled/installed with Fortran support (i.e., `libnetcdff.*` is available on the system) +* The [LAPACK](http://www.netlib.org/lapack/) (Linear Algebra PACKage) library +* A copy of the SUMMA source code + +Optional but highly recommended: + +* The [SUNDIALS](https://sundials.readthedocs.io/en/latest/index.html) library, to benefit from recent advances to SUMMA's numerical implementation. Without the SUNDIALS library, the modeling options `num_method = kinsol` and `num_method = ida` won't work. SUNDIALS requires specific install instructions because by default its fortran module won't be build. A typical install will look as follows: + +```bash +git clone https://github.com/LLNL/sundials.git sundials-software +cd sundials-software +git fetch --all --tags --prune +git checkout tags/vX.Y.Z (use most recent tag) +cd sundials +mkdir builddir && mkdir instdir && cd builddir +cmake ../../sundials-software/ -DEXAMPLES_ENABLE_C=OFF -DEXAMPLES_ENABLE_F2003=OFF -DBUILD_FORTRAN_MODULE_INTERFACE=ON -DCMAKE_Fortran_COMPILER=gfortran -DCMAKE_INSTALL_PREFIX=../../sundials/instdir -DEXAMPLES_INSTALL_PATH=../../sundials/instdir/examples +make +make install +``` + +## Compilation +The preferred method to compile SUMMA is with `CMake`. This enables parallelization for faster builds and is generally easier than the [legacy approach using a Makefile](#legacy-makefile-instructions). CMake instructions can be found below. + +### CMake + +The SUMMA repository contains a number of CMake scripts in the `summa/build/cmake` directory. These scripts use CMake to compile SUMMA using the general `CMakeLists.txt` file found in the `summa/build` directory. The scripts compile SUMMA with a number of different options and for different OSX scenarios. Briefly: + +- `FindNetCDF.cmake`: used to find the location (i.e., system path) for the Fortran NetCDF library. This path is needed in the actual compile scripts. +- `FindOpenBLAS.cmake`: used to find the location (i.e., system path) for the OpenBLAS library. This path is needed in the actual compile scripts. +- `build.cluster.bash`: compile SUMMA with SUNDIALS support on Digital Research Alliance Canada (DRAC) or similar infrastructure (e.g. Graham, Fir). +- `build.mac.bash`: compile SUMMA with SUNDIALS support on macOS. Assumes MacPorts as local library manager (see example below). +- `build.pc.bash`: compile SUMMA with SUNDIALS support on Windows. Experimental. +- `build_actors.cluster.bash`: compile SUMMA with SUNDIALS and Actors support on Digital Research Alliance Canada or similar infrastructure (e.g. Graham, Fir). Key difference: addition of `caf` library and `-DUSE_ACTORS=ON` flag. +- `build_actors.mac.bash`: compile SUMMA with SUNDIALS and Actors support on macOS. Assumes MacPorts as local library manager (see example below). Key difference: addition of `-DUSE_ACTORS=ON` flag. +- `build_ngen.cluster.bash`: compile SUMMA with SUNDIALS support and NextGen integration on DRAC or similar. See specific instructions inside script. +- `build_ngen.mac.bash`: compile SUMMA with SUNDIALS support and NextGen integration on macOS. See specific instructions inside script. +- `summabmi.pc.in`: support file for NextGen integration. + +Most users will be able to compile SUMMA using one of the scripts above, after ensuring the paths in the scripts are set appropriately. As an example, imagine you're compiling on macOS but use Homebrew to manage your libraries, and that you installed SUNDIALS somewhere that's not the top-level summa folder. In this case, the default (MacPorts) path to the `gfortran` compiler, as well as the path to the SUNDIALS install directory, in the `build.mac.bash` script are not correct. You would need to update the script as follows: + +```bash +#!/bin/bash +export FC=/opt/homebrew/bin/gfortran # Fortran compiler family +export LIBRARY_LINKS='-llapack' # list of library links +export SUNDIALS_DIR=/your/path/to/sundials/instdir/ + +cmake -B ../cmake_build -S ../. -DUSE_SUNDIALS=ON -DSPECIFY_LAPACK_LINKS=ON -DCMAKE_BUILD_TYPE=Release +cmake --build ../cmake_build --target all -j +``` + +You can test if SUMMA was compiled successfully by navigating to the new `bin` directory and running the newly created executable without any command line arguments. If the compilation is successful, you will see the help output as shown below: + +```bash +> cd ~/path/to/summa/bin +> ./summa_sundials.exe + +Usage: summa.exe -m master_file [-s fileSuffix] [-g startGRU countGRU] [-h iHRU] [-r freqRestart] [-p freqProgress] [-c] + summa.exe summa executable + +Running options: + -m --master Define path/name of master file (required) + -n --newFile Define frequency [noNewFiles,newFileEveryOct1] of new output files + -s --suffix Add fileSuffix to the output files + -g --gru Run a subset of countGRU GRUs starting from index startGRU + -h --hru Run a single HRU with index of iHRU + -r --restart Define frequency [y,m,d,e,never] to write restart files + -p --progress Define frequency [m,d,h,never] to print progress + -v --version Display version information of the current build +``` + +Continue reading [SUMMA configuration](../configuration/SUMMA_configuration.md) to learn more about how to configure SUMMA for your application. We strongly recommend that you get the [test applications](SUMMA_test_cases.md) to help you get started. + +## Extra + +### Extended description of dependencies +This is an extended description of the shorter list described above. To compile SUMMA, you will need: * a Fortran compiler. We have successfully used the intel Fortran compiler (`ifort`, version 17.x) and the GNU Fortran compiler (`gfortran`, version 6 or higher), the latter of which is freely available. Since we do not use any compiler-specific extensions, you should be able to compile SUMMA with other Fortran compilers as well. @@ -16,21 +95,17 @@ To compile SUMMA, you will need: * the [LAPACK](http://www.netlib.org/lapack/) (Linear Algebra PACKage) library provides a series of routines for linear algebra operations, including matrix solvers. How to install the library depends on your \*nix variant and is not covered here. For example, on OS X you will get all the necessary LAPACK routines by installing the ATLAS software (again, this is easiest using a package manager; note that ATLAS can take many hours to build the first time when you install it). - * the [ATLAS](http://math-atlas.sourceforge.net/) (Automatically Tuned Linear Algebra Software) library. Note that this is required on OS X using the gfortran compiler to be able to use LAPACK. It's not clear that this is used on other \*nix machines. - * a copy of the SUMMA source code from [this repo](https://github.com/NCAR/summa). You have a number of options: * If you just want to use the latest stable release of SUMMA, then simply look for the [latest release](https://github.com/NCAR/summa/releases); * If you want the latest and greatest (and potentially erroneous), download a copy of the [development branch](https://github.com/ncar/summa/tree/develop) (or clone it); * If you may want to do SUMMA development, then fork the repo on github and start editing your own copy. + + +### Legacy Makefile instructions +These instructions have been included here for legacy users. If possible, use the CMake instructions for an easier install experience. - Note that you will not be able to contribute to the main SUMMA repo directly. If you are seriously interested in contributing, spend a little time learning git. It will be useful anyway. For more information about working with the SUMMA code, please see the following documents: - - * [SUMMA and Git](../development/SUMMA_and_git.md) - * [Git Workflow for SUMMA](../development/SUMMA_git_workflow.md) - * [SUMMA Coding Conventions](../development/SUMMA_coding_conventions.md) - -Once you have all the above, you can compile SUMMA using the following steps: +Once you have all the listed dependencies, you can compile SUMMA using the following steps for using the `Makefile`: 1. Navigate to your local copy of the SUMMA directory and go to the `build` subdirectory; @@ -74,6 +149,33 @@ Once you have all the above, you can compile SUMMA using the following steps: If you are using the `bash` shell, then you would set these environment variables with `export FC=gfortran` for example. You may need to modify the `Makefile` if you are using a different Fortran compiler or your setup is different. If someone wants to contribute an actual `configure` script that would be great. + * If you are compiling SUMMA using packages installed through `Homebrew` with `gfortran`, then use the following entries in Part 0 of Makefile: + Date updated: May-2024 + ``` + FC = gfortran + FC_EXE = gfortran + INCLUDES = -I/opt/homebrew/Cellar/netcdf-fortran/x.x.x/include -I/opt/homebrew/Cellar/lapack/x.x.x/include + LIBRARIES = -L/opt/homebrew/Cellar/netcdf-fortran/x.x.x/lib -lnetcdff -L/opt/homebrew/Cellar/lapack/x.x.x/lib -lblas -llapack + ``` + > Note: change `x.x.x` with the exact version number in both the `INCLUDE` and `LIBRARIES` variables. + This can be done by using `ls /opt/homebrew/Cellar/netcdf-fortran/` and then using `tab` button to find the current version installed on your machine. + Do the same for `lapack`. Currently, the most up-to-date `netcdf-fortran` version is `4.6.1` and lapack is `3.12.0`. + + * If you are compiling SUMMA on the [Graham cluster](https://docs.alliancecan.ca/wiki/Graham/en) of the [Digital Research Alliance of Canada](https://alliancecan.ca/en) using `ifort` then use the following entries in Part 0 of Makefile: + Date updated:July-2020 + ``` + FC = ifort + FC_EXE = /cvmfs/restricted.computecanada.ca/easybuild/software/2017/Core/ifort/2019.3.199/compilers_and_libraries_2019.3.199/linux/bin/intel64/ifort + INCLUDES = -I/cvmfs/soft.computecanada.ca/easybuild/software/2017/avx/Compiler/intel2016.4/netcdf-fortran/4.4.4/include + LIBRARIES = -L/cvmfs/soft.computecanada.ca/easybuild/software/2017/avx/Compiler/intel2016.4/netcdf-fortran/4.4.4/lib -lnetcdff -mkl + ``` + > Note: Before compiling, load the most recent intel module. Check the available versions with: +`module spider intel`. Then load the latest version: `module load intel/2019.3`. +Lapack and blas libraries are loaded with library argument `-mkl`. +------------------------------ + + + 1. Check that all variables in the Makefile are set correctly by typing `make check`. Inspect the variables and make sure that they make sense. If not, modify the Makefile further. 1. Type `make` (if you are in the `build` directory). If all goes well, this will build SUMMA and move the executable `summa.exe` to the `bin` directory. You may get some warnings (depending on your compiler settings), but you should not get any errors; @@ -97,5 +199,3 @@ Once you have all the above, you can compile SUMMA using the following steps: ``` If you get this far then SUMMA is installed correctly and functional. - -Continue reading [SUMMA configuration](../configuration/SUMMA_configuration.md) to learn more about how to configure SUMMA for your application. We strongly recommend that you get the [test applications](SUMMA_test_cases.md) to help you get started. diff --git a/docs/installation/SUMMA_on_OS_X.md b/docs/installation/SUMMA_on_OS_X.md index 08f50e59e..a69d0b11e 100755 --- a/docs/installation/SUMMA_on_OS_X.md +++ b/docs/installation/SUMMA_on_OS_X.md @@ -8,6 +8,7 @@ This document is mainly for people who want to use SUMMA in their modeling proje * [Git Workflow for SUMMA](../development/SUMMA_git_workflow.md) * [SUMMA Coding Conventions](../development/SUMMA_coding_conventions.md) +## Using MacPorts In the following I will assume that you don't have a Fortran compiler or NetCDF installed. If you do, just scroll down. @@ -60,6 +61,43 @@ In the following I will assume that you don't have a Fortran compiler or NetCDF * `sudo port install nco` : to manipulate NetCDF files, see the [NCO homepage](http://nco.sourceforge.net) * `sudo port install cdo` : to manipulate NetCDF files, see the [CDO homepage](https://code.mpimet.mpg.de/projects/cdo/) - 1. Now obtain the SUMMA source code from the [SUMMA source code repository](https://github.com/NCAR/summa). You may just want to download the latest tagged release. Unless you are planning to contribute to the source code, there is no need to clone or fork the repository. +## Using Homebrew +Note: This was tested on an Apple machine with silicon M3 Pro chip that is running MacOS Sonoma (14.4.1) with homebrew (4.2.20). +1. Install [Homebrew](https://brew.sh/) by opening the terminal and running the following command: + + /bin/bash -c "$(curl -fsSL https://raw.githubusercontent.com/Homebrew/install/HEAD/install.sh)" +1. Install NetCDF library and the Fortran version of the NetCDF library - 1. Untar or unzip the archive, then go to the `summa/build` directory and follow the instructions in the [SUMMA installation](SUMMA_installation.md) page. If you are using MacPorts, the `FC_ENV` can be set to `gfortran-6-macports`. + brew install netcdf netcdf-fortran +2. Install gcc and gfortran + + brew install gcc +4. Install other NetCD utilities + + brew install nco cdo ncview +5. Install LAPACK + + brew install lapack + +# Download and compile the source code + +* Now obtain the SUMMA source code from the [SUMMA source code repository](https://github.com/NCAR/summa). You may just want to download the latest tagged release. Unless you are planning to contribute to the source code, there is no need to clone or fork the repository. + +* Untar or unzip the archive, then go to the `summa/build` directory and follow the instructions in the [SUMMA installation](SUMMA_installation.md) page. + +* If you are using MacPorts, the `FC_ENV` can be set to `gfortran-6-macports`. + +* If you are using Homebrew, then use the following entries in Part 0 of Makefile: + +Note: change `x.x.x` with the exact version number in both the `INCLUDE` and `LIBRARIES` variables. +This can be done by using `ls /opt/homebrew/Cellar/netcdf-fortran/` and then using `tab` button to find the current version installed on your machine. +Do the same for `lapack`. Currently, the most up-to-date `netcdf-fortran` version is `4.6.1` and lapack is `3.12.0`. + +------------------------------ + +``` +FC = gfortran +FC_EXE = gfortran +INCLUDES = -I/opt/homebrew/Cellar/netcdf-fortran/x.x.x/include -I/opt/homebrew/Cellar/lapack/x.x.x/include +LIBRARIES = -L/opt/homebrew/Cellar/netcdf-fortran/x.x.x/lib -lnetcdff -L/opt/homebrew/Cellar/lapack/x.x.x/lib -lblas -llapack +``` diff --git a/docs/installation/SUMMA_test_cases.md b/docs/installation/SUMMA_test_cases.md index b6ce18f8c..90673817e 100644 --- a/docs/installation/SUMMA_test_cases.md +++ b/docs/installation/SUMMA_test_cases.md @@ -1,5 +1,6 @@ # Test Cases for SUMMA -We have developed a number of test cases that we use during model development to ensure that the model performs as expected after code changes. These test cases are also useful to ensure that your SUMMA installation is working correctly. The test cases consist of synthetic experiments with known solutions as well as test cases that were used in the original SUMMA papers (Clark et al., [2015a](../references.md#clark_2015a);[b](../references.md#clark_2015b);[c](../references.md#clark_2015c)) +We have developed a number of test cases that we use during model development to ensure that the model performs as expected after code changes. These test cases are also useful to ensure that your SUMMA installation is working correctly. The test cases consist of synthetic experiments with known solutions as well as test cases that were used in the original SUMMA papers (Clark et al., [2015a](../references.md#clark_2015a);[b](../references.md#clark_2015b);[c](../references.md#clark_2015c)). + +The full suite of SUMMA test cases can be obtained from the [HydroShare](http://www.hydroshare.org/resource/e4df3065264341a48017f6d2f4ad030c). Please note that these test cases are specific to SUMMA v3 and up, and won't run for earlier versions of the model code. After you unpack the archive, you can find information about how to install and run the test cases in `readme.md` in the top level directory. -The full suite of SUMMA test cases can be obtained from the [NCAR SUMMA page](https://ral.ucar.edu/projects/summa) under the _Test Cases_ tab. Please make sure you have the correct version of the test cases for your version of the SUMMA code. After you unpack the archive, you can find information about how to install and run the test cases in `readme.md` in the top level directory. diff --git a/docs/minor-changes.md b/docs/minor-changes.md deleted file mode 100644 index 613709f00..000000000 --- a/docs/minor-changes.md +++ /dev/null @@ -1,14 +0,0 @@ -# Minor changes - -This page provides simple, high-level documentation about what has changed in each new release of SUMMA. - -Documented here are minor changes that do not affect science outputs or are likely to affect only a minority of users: -- Minor bugfixes -- Correction of misspellings -- Changes to formatting -- Addition of print statements -- Etc. - -## Version 3.0.4 (pre-release) - -- [placeholder] diff --git a/docs/references.md b/docs/references.md index 720606663..465c6dd1e 100644 --- a/docs/references.md +++ b/docs/references.md @@ -5,3 +5,5 @@ Clark, M. P., B. Nijssen, J. D. Lundquist, D. Kavetski, D. E. Rupp, R. A. Woods, Clark, M. P., B. Nijssen, J. D. Lundquist, D. Kavetski, D. E. Rupp, R. A. Woods, J. E. Freer, E. D. Gutmann, A. W. Wood, D. J. Gochis, R. M. Rasmussen, D. G. Tarboton, V. Mahat, G. N. Flerchinger, D. G. Marks, 2015b: A unified approach for process-based hydrologic modeling: Part 2. Model implementation and case studies. _Water Resources Research_, [doi:10.1002/2015WR017200](http://dx.doi.org/10.1002/2015WR017200). Clark, M. P., B. Nijssen, J. D. Lundquist, D. Kavetski, D. E. Rupp, R. A. Woods, J. E. Freer, E. D. Gutmann, A. W. Wood, L. D. Brekke, J. R. Arnold, D. J. Gochis, R. M. Rasmussen, D. G. Tarboton, V. Mahat, G. N. Flerchinger, D. G. Marks, 2015c: The structure for unifying multiple modeling alternatives (SUMMA), Version 1.0: Technical Description. _NCAR Technical Note NCAR/TN-514+STR_, 50 pp., [doi:10.5065/D6WQ01TD](http://dx.doi.org/10.5065/D6WQ01TD). + +Clark, M. P., Zolfaghari, R., Green, K. R., Trim, S., Knoben, W. J. M., Bennett, A., Nijssen, B., Ireson, A., Spiteri, R. J., 2021: The Numerical Implementation of Land Models: Problem Formulation and Laugh Tests. _Journal of Hydrometeorology_, 22(6), 1627-1648. [doi:10.1175/JHM-D-20-0175.1](https://doi.org/10.1175/JHM-D-20-0175.1). \ No newline at end of file diff --git a/docs/requirements.txt b/docs/requirements.txt new file mode 100644 index 000000000..720f2ce67 --- /dev/null +++ b/docs/requirements.txt @@ -0,0 +1,2 @@ +mkdocs>=1.6.1 +pymdown-extensions>=10.0 # needed to ensure the nested lists with code blocks in 'development/modularity' renders properly \ No newline at end of file diff --git a/docs/sundials_bmi_flags/bmi_interface.txt b/docs/sundials_bmi_flags/bmi_interface.txt new file mode 100644 index 000000000..f15db32e6 --- /dev/null +++ b/docs/sundials_bmi_flags/bmi_interface.txt @@ -0,0 +1,38 @@ +Note, if you want to run with just BMI, not NextGen, do the following +First install BMI. Download the latest release of BMI from https://github.com/csdms/bmi-fortran.git +% git clone https://github.com/csdms/bmi-fortran.git +% git fetch --all --tags --prune +% git checkout tags/vX.Y.Z + +Make a directory outside the bmi-fortran folder and enter it, and make the install and build dirs, enter the build dir. +% export BMIF_VERSION=2.0 +% mkdir bmi +% cd bmi +% mkdir instdir +% mkdir buildir +% cd /buildir + +The install directory needs to be set while running the cmake inside the builddir, using home directory as $(YOUR_HOME) +% cmake ../../bmi-fortran/ -DCMAKE_INSTALL_PREFIX=$(YOUR_HOME)/bmi/instdir + +The default compiler is gfortran. To change it (it should be the same as the netcdf build and the later summa build), you could also add the following option to cmake with your $(YOUR_GFORTRAN) + -DCMAKE_Fortran_COMPILER=$(YOUR_GFORTRAN) + +You can do the last two steps by running from inside buildir: +cp ../../summa/build/makefiles/build_cmakeBMI build_cmake +./build_cmake + +If the above went well, staying in the buildir directory run: +% make +% make install + +To run a BMI interface, run the executable /bin/summa_bmi.exe +To run as previously, run the executable /bin/summa_sundials.exe with appropriate command line arguments. + +All BMI files are in build/source/driver. The important ones are as following: + +summa_bmi.f90: this contains the code that was in summa_driver.f90 and adds to it the BMI functions. It is now a module and uses the BMI library. + +summa_driver.f90: this is the main program called by summa_sundials.exe that will call all other modules similar to previous editions of the code. + +summa_driverBMI.f90: this is the main program called by summa_bmi.exe that will call all other modules in the BMI interface mode. \ No newline at end of file diff --git a/docs/sundials_bmi_flags/flags_params_sundials.txt b/docs/sundials_bmi_flags/flags_params_sundials.txt new file mode 100644 index 000000000..91f184dae --- /dev/null +++ b/docs/sundials_bmi_flags/flags_params_sundials.txt @@ -0,0 +1,13 @@ + +To switch between SUMMA-BE and SUMMA-SUNDIALS, the num_method in the model_decision file can be either one of the values "homegrown" (choice "itertive" is backward compatible), "kinsol", or "ida". + +In energy conservation residual for backward Euler, either the the analytical (closed form) heat capacity formula or the enthalpy finite difference formula (dH_T/dT) is used. The "nrgConserv" variable has been added to the var_lookup module to handle such decision. A user should add this variable to the model_decision file with one of the values "closedForm" or "enthalpyFD". Choice of num_method as "itertive" will set num_method=homegrown and nrgConserv=closedForm. + +All SUMMA-SUNDIALS files are in build/source/engine. The important ones are as following: + +summaSolve4ida.f90: contains public subroutine summaSolve4ida which solves the differential equation system F(y,y') = 0 by IDA (y is the state vector) and private subroutines setInitialCondition and setSolverParams. Subroutine setSolverParams can be used to to set parameters (maximum order, number of nonlinear iteration , etc) in IDA solver. + +eval8summaWithPrime.f90: contains public subroutine eval8summaWithPrime which computes the residual vector F(t,y,y') mainly by calling varExtract, updateVarsWithPrime, computFlux, and computResidWithPrime. We also switch between different forms of the energy equation in this subroutine. It also contains public function eval8summa4ida which is the interface wrapper for computing the residual vector required for the IDA solver. + +computJacobWithPrime.f90: contains public subroutine computJacobWithPrime which computes the Jacobian matrix dF/dy + c dF/dy'. It also contains the public function computJacob4ida which is the interface wrapper for computing the Jacobian matrix required for the IDA solver. + diff --git a/docs/whats-new.md b/docs/whats-new.md index 9702ad8f3..9f5bab15e 100644 --- a/docs/whats-new.md +++ b/docs/whats-new.md @@ -1,9 +1,15 @@ # What's new -This page provides simple, high-level documentation about what has changed in each new release of SUMMA. Please add any changes made in pull requests to under the `Pre-release` header. Use `Minor changes` for changes that do not affect science outputs or are likely to affect only a minority of users. Use `Major changes` for anything else. +This page provides simple, high-level documentation about what has changed in each new release of SUMMA. Please add any changes made in pull requests to under the `Pre-release` header. Use `Minor changes` sub-heading for changes that do not affect science outputs or are likely to affect only a minority of users. Use `Major changes` for anything else. ## Pre-release ### Major changes -- +- General cleanup and shortening of computFlux.f90, vegNrgFlux.f90, ssdNrgFlux.f90, vegLiqFlux.f90, snowLiqFlx.f90, soilLiqFlx.f90, groundwatr.f90, and bigAquifer.f90 +- Added object-oriented methods to simplify flux routine calls in computFlux and improve modularity + - classes for each flux routine were added to data_types.f90 + - large associate statemements are no longer needed in computFlux (associate blocks are now much shorter) + - the length of computFlux has been decreased substantially +- Added a new decision to set maximum infiltration rate method +- Bug fix: fixed a problem with snow sublimation due to a bug in transitioning from exponential to log wind profile below canopy. ### Minor changes - Updated SWE balance check in coupled_em for cases where all snow melts in one of the substeps diff --git a/mkdocs.yml b/mkdocs.yml index b95448820..a2031eb91 100644 --- a/mkdocs.yml +++ b/mkdocs.yml @@ -5,7 +5,7 @@ repo_url: https://www.github.com/NCAR/summa site_url: https://summa.readthedocs.org docs_dir: docs theme: readthedocs -pages: +nav: - Home: - SUMMA Overview: 'index.md' - SUMMA Documentation: 'SUMMA_documentation.md' @@ -21,8 +21,17 @@ pages: - SUMMA Input: 'input_output/SUMMA_input.md' - SUMMA Output: 'input_output/SUMMA_output.md' - Development: - - SUMMA Coding Conventions: 'development/SUMMA_coding_conventions.md' + - SUMMA Contributions: 'development/SUMMA_contributing.md' - SUMMA and Git: 'development/SUMMA_and_git.md' - SUMMA Git Workflow: 'development/SUMMA_git_workflow.md' -- References: 'references.md' + - SUMMA Coding Conventions: 'development/SUMMA_coding_conventions.md' + - SUMMA Modularity: 'development/SUMMA_modularity_guidelines.md' + - SUMMA Recipes: 'development/SUMMA_recipes.md' +- References: + - References: 'references.md' google_analytics: ['UA-108421993-5', 'summa.readthedocs.org'] +markdown_extensions: + - footnotes + - fenced_code + - codehilite + - pymdownx.superfences \ No newline at end of file diff --git a/test_ngen/domain_provo/forcing/SUMMA_input/.gitkeep b/test_ngen/domain_provo/forcing/SUMMA_input/.gitkeep new file mode 100644 index 000000000..e69de29bb diff --git a/case_study/base_settings/GENPARM.TBL b/test_ngen/domain_provo/settings/SUMMA/TBL_GENPARM.TBL old mode 100644 new mode 100755 similarity index 98% rename from case_study/base_settings/GENPARM.TBL rename to test_ngen/domain_provo/settings/SUMMA/TBL_GENPARM.TBL index 05c460196..17fc9172b --- a/case_study/base_settings/GENPARM.TBL +++ b/test_ngen/domain_provo/settings/SUMMA/TBL_GENPARM.TBL @@ -21,7 +21,7 @@ SALP_DATA REFDK_DATA 2.0E-6 REFKDT_DATA -1.0 +3.0 FRZK_DATA 0.15 ZBOT_DATA diff --git a/case_study/base_settings/MPTABLE.TBL b/test_ngen/domain_provo/settings/SUMMA/TBL_MPTABLE.TBL old mode 100644 new mode 100755 similarity index 78% rename from case_study/base_settings/MPTABLE.TBL rename to test_ngen/domain_provo/settings/SUMMA/TBL_MPTABLE.TBL index 97990c7e4..cbafef9bb --- a/case_study/base_settings/MPTABLE.TBL +++ b/test_ngen/domain_provo/settings/SUMMA/TBL_MPTABLE.TBL @@ -286,3 +286,126 @@ 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, / +&noah_mp_umd_veg_categories + VEG_DATASET_DESCRIPTION = "UMD" + NVEG = 13 +/ +&noah_mp_umd_parameters + ! NVEG = 13 + ! 1: Evergreen Needleleaf Forest + ! 2: Evergreen Broadleaf Forest + ! 3: Deciduous Needleleaf Forest + ! 4: Deciduous Broadleaf Forest + ! 5: Mixed Forests + ! 6: Woodlands + ! 7: Wooded Grassland + ! 8: Closed Shrublands + ! 9: Open Shrublands + ! 10: Grasslands + ! 11: Croplands + ! 12: Bare Soil + ! 13: Urban + + ISURBAN = 13 + ISWATER = 14 + ISBARREN = 12 + ISSNOW = 0 + EBLFOREST = 2 + + !------------------------------------------------------------------------------------------------------------- + ! 1 2 3 4 5 6 7 8 9 10 11 12 13 + !------------------------------------------------------------------------------------------------------------- + CH2OP = 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, + DLEAF = 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, + Z0MVT = 1.09, 1.10, 0.85, 0.80, 0.80, 1.09, 0.60, 0.20, 0.06, 0.12, 0.15, 0.00, 1.00, + HVT = 20.0, 20.0, 18.0, 16.0, 16.0, 20.0, 13.0, 1.1, 1.1, 1.0, 2.0, 0.0, 15.0, + HVB = 8.50, 8.00, 7.00, 11.50, 10.00, 8.50, 0.10, 0.10, 0.10, 0.05, 0.10, 0.00, 1.00, + DEN = 0.28, 0.02, 0.28, 0.10, 0.10, 0.28, 10.00, 10.00, 10.00, 100.00, 25.00, 0.01, 0.01, + RC = 1.20, 3.60, 1.20, 1.40, 1.40, 1.20, 0.12, 0.12, 0.12, 0.03, 0.08, 0.01, 1.00, + + ! Row 1: Vis + ! Row 2: Near IR + RHOL = 0.07, 0.10, 0.07, 0.10, 0.10, 0.07, 0.07, 0.07, 0.07, 0.11, 0.11, 0.00, 0.00, + 0.35, 0.45, 0.35, 0.45, 0.45, 0.35, 0.35, 0.35, 0.35, 0.58, 0.58, 0.00, 0.00, + + ! Row 1: Vis + ! Row 2: Near IR + RHOS = 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.36, 0.36, 0.00, 0.00, + 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.58, 0.58, 0.00, 0.00, + + ! Row 1: Vis + ! Row 2: Near IR + TAUL = 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.07, 0.07, 0.00, 0.00, + 0.10, 0.25, 0.10, 0.25, 0.25, 0.10, 0.10, 0.10, 0.10, 0.25, 0.25, 0.00, 0.00, + + ! Row 1: Vis + ! Row 2: Near IR + TAUS = 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.220, 0.220, 0.000, 0.000, + 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.380, 0.380, 0.000, 0.000, + + XL = 0.010, 0.010, 0.010, 0.250, 0.250, 0.010, 0.010, 0.010, 0.010, -0.300, -0.300, 0.000, 0.000, + CWPVT = 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, + C3PSN = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, + KC25 = 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, + AKC = 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, + KO25 = 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, + AKO = 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, + AVCMX = 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, + AQE = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, + + LTOVRC= 0.50, 0.55, 0.20, 0.55, 0.50, 0.50, 0.65, 0.65, 0.65, 0.50, 1.60, 0.00, 0.00, + DILEFC= 1.20, 0.50, 1.80, 0.60, 0.80, 1.20, 0.20, 0.20, 0.20, 0.20, 0.50, 0.00, 0.00, + DILEFW= 0.20, 4.00, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.10, 0.20, 0.00, 0.00, + RMF25 = 3.00, 0.65, 4.00, 3.00, 3.00, 3.00, 0.26, 0.26, 0.26, 1.80, 1.00, 0.00, 0.00, + SLA = 80, 80, 80, 80, 80, 80, 60, 60, 60, 60, 80, 0, 60, + FRAGR = 0.10, 0.20, 0.10, 0.20, 0.10, 0.10, 0.20, 0.20, 0.20, 0.20, 0.20, 0.10, 0.00, + TMIN = 265, 273, 268, 273, 268, 265, 273, 273, 273, 273, 273, 0, 0, + VCMX25= 50.0, 60.0, 60.0, 60.0, 55.0, 50.0, 40.0, 40.0, 40.0, 40.0, 80.0, 0.0, 0.0, + TDLEF = 278, 278, 268, 278, 268, 278, 278, 278, 278, 278, 278, 0, 278, + BP = 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3,0.1E+16, + MP = 6., 9., 6., 9., 9., 6., 9., 9., 9., 9., 9., 9., 9., + QE25 = 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.00, + RMS25 = 0.90, 0.30, 0.64, 0.10, 0.80, 0.90, 0.10, 0.10, 0.10, 0.10, 0.10, 0.00, 0.00, + RMR25 = 0.36, 0.05, 0.05, 0.01, 0.03, 0.36, 0.00, 0.00, 0.00, 1.20, 0.00, 0.00, 0.00, + ARM = 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, + FOLNMX= 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 0.0, + WDPOOL= 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 0.00, 0.00, 0.00, 0.00, + WRRAT = 30.00, 30.00, 30.00, 30.00, 30.00, 30.00, 3.00, 3.00, 3.00, 0.00, 0.00, 0.00, 0.00, + MRP = 0.37, 0.23, 0.37, 0.40, 0.30, 0.37, 0.19, 0.19, 0.19, 0.17, 0.23, 0.00, 0.00, + +! Monthly values, one row for each month: + SAIM = 0.4, 0.5, 0.3, 0.4, 0.4, 0.4, 0.4, 0.3, 0.2, 0.3, 0.3, 0.0, 0.0, + 0.4, 0.5, 0.3, 0.4, 0.4, 0.4, 0.4, 0.3, 0.2, 0.3, 0.3, 0.0, 0.0, + 0.4, 0.5, 0.3, 0.4, 0.4, 0.4, 0.4, 0.3, 0.2, 0.3, 0.3, 0.0, 0.0, + 0.3, 0.5, 0.4, 0.4, 0.4, 0.3, 0.4, 0.3, 0.2, 0.3, 0.3, 0.0, 0.0, + 0.4, 0.5, 0.4, 0.4, 0.4, 0.4, 0.4, 0.3, 0.2, 0.3, 0.3, 0.0, 0.0, + 0.5, 0.5, 0.7, 0.4, 0.4, 0.5, 0.4, 0.3, 0.2, 0.4, 0.3, 0.0, 0.0, + 0.5, 0.5, 1.3, 0.9, 0.7, 0.5, 0.7, 0.6, 0.4, 0.8, 0.4, 0.0, 0.0, + 0.6, 0.5, 1.2, 1.2, 0.8, 0.6, 1.2, 0.9, 0.6, 1.3, 0.5, 0.0, 0.0, + 0.6, 0.5, 1.0, 1.6, 1.0, 0.6, 1.4, 1.2, 0.8, 1.1, 0.4, 0.0, 0.0, + 0.7, 0.5, 0.8, 1.4, 1.0, 0.7, 1.1, 0.9, 0.7, 0.4, 0.3, 0.0, 0.0, + 0.6, 0.5, 0.6, 0.6, 0.5, 0.6, 0.5, 0.4, 0.3, 0.4, 0.3, 0.0, 0.0, + 0.5, 0.5, 0.5, 0.4, 0.4, 0.5, 0.4, 0.3, 0.2, 0.4, 0.3, 0.0, 0.0, + + LAIM = 4.0, 4.5, 0.0, 0.0, 2.0, 4.0, 0.2, 0.0, 0.0, 0.4, 0.0, 0.0, 0.0, + 4.0, 4.5, 0.0, 0.0, 2.0, 4.0, 0.2, 0.0, 0.0, 0.5, 0.0, 0.0, 0.0, + 4.0, 4.5, 0.0, 0.3, 2.2, 4.0, 0.4, 0.3, 0.2, 0.6, 0.0, 0.0, 0.0, + 4.0, 4.5, 0.6, 1.2, 2.6, 4.0, 1.0, 0.9, 0.6, 0.7, 0.0, 0.0, 0.0, + 4.0, 4.5, 1.2, 3.0, 3.5, 4.0, 2.4, 2.2, 1.5, 1.2, 1.0, 0.0, 0.0, + 4.0, 4.5, 2.0, 4.7, 4.3, 4.0, 4.1, 3.5, 2.3, 3.0, 2.0, 0.0, 0.0, + 4.0, 4.5, 2.6, 4.5, 4.3, 4.0, 4.1, 3.5, 2.3, 3.5, 3.0, 0.0, 0.0, + 4.0, 4.5, 1.7, 3.4, 3.7, 4.0, 2.7, 2.5, 1.7, 1.5, 3.0, 0.0, 0.0, + 4.0, 4.5, 1.0, 1.2, 2.6, 4.0, 1.0, 0.9, 0.6, 0.7, 1.5, 0.0, 0.0, + 4.0, 4.5, 0.5, 0.3, 2.2, 4.0, 0.4, 0.3, 0.2, 0.6, 0.0, 0.0, 0.0, + 4.0, 4.5, 0.2, 0.0, 2.0, 4.0, 0.2, 0.0, 0.0, 0.5, 0.0, 0.0, 0.0, + 4.0, 4.5, 0.0, 0.0, 2.0, 4.0, 0.2, 0.0, 0.0, 0.4, 0.0, 0.0, 0.0, + + SLAREA=0.0090, 0.0200, 0.0200, 0.0258, 0.0223, 0.0090, 0.0227, 0.0227, 0.0188, 0.0060, 0.0200, 0.0200, 0.0228, + +! Five types, one row for each type. + EPS = 0.46, 0.00, 0.00, 46.86, 30.98, 0.46, 21.62, 21.62, 0.11, 0.02, 0.00, 0.00, 41.87, + 3.34, 0.00, 0.00, 0.38, 0.96, 3.34, 0.92, 0.92, 0.22, 0.05, 0.00, 0.00, 0.98, + 1.85, 0.00, 0.00, 1.84, 1.84, 1.85, 1.73, 1.73, 1.26, 0.03, 0.00, 0.00, 1.82, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, +/ diff --git a/case_study/base_settings/SOILPARM.TBL b/test_ngen/domain_provo/settings/SUMMA/TBL_SOILPARM.TBL old mode 100644 new mode 100755 similarity index 78% rename from case_study/base_settings/SOILPARM.TBL rename to test_ngen/domain_provo/settings/SUMMA/TBL_SOILPARM.TBL index cfb0d545e..b87d1bae5 --- a/case_study/base_settings/SOILPARM.TBL +++ b/test_ngen/domain_provo/settings/SUMMA/TBL_SOILPARM.TBL @@ -1,14 +1,14 @@ Soil Parameters STAS 19,1 'BB DRYSMC F11 MAXSMC REFSMC SATPSI SATDK SATDW WLTSMC QTZ ' -1, 2.79, 0.010, -0.472, 0.339, 0.236, 0.069, 4.66E-5, 0.608E-6, 0.010, 0.92, 'SAND' +1, 2.79, 0.010, -0.472, 0.339, 0.236, 0.069, 1.07E-6, 0.608E-6, 0.010, 0.92, 'SAND' 2, 4.26, 0.028, -1.044, 0.421, 0.383, 0.036, 1.41E-5, 0.514E-5, 0.028, 0.82, 'LOAMY SAND' 3, 4.74, 0.047, -0.569, 0.434, 0.383, 0.141, 5.23E-6, 0.805E-5, 0.047, 0.60, 'SANDY LOAM' 4, 5.33, 0.084, 0.162, 0.476, 0.360, 0.759, 2.81E-6, 0.239E-4, 0.084, 0.25, 'SILT LOAM' 5, 5.33, 0.084, 0.162, 0.476, 0.383, 0.759, 2.81E-6, 0.239E-4, 0.084, 0.10, 'SILT' 6, 5.25, 0.066, -0.327, 0.439, 0.329, 0.355, 3.38E-6, 0.143E-4, 0.066, 0.40, 'LOAM' -7, 6.77, 0.067, -1.491, 0.404, 0.314, 0.135, 4.45E-6, 0.990E-5, 0.067, 0.60, 'SANDY CLAY LOAM' -8, 8.72, 0.120, -1.118, 0.464, 0.387, 0.617, 2.03E-6, 0.237E-4, 0.120, 0.10, 'SILTY CLAY LOAM' +7, 6.66, 0.067, -1.491, 0.404, 0.314, 0.135, 4.45E-6, 0.990E-5, 0.067, 0.60, 'SANDY CLAY LOAM' +8, 8.72, 0.120, -1.118, 0.464, 0.387, 0.617, 2.04E-6, 0.237E-4, 0.120, 0.10, 'SILTY CLAY LOAM' 9, 8.17, 0.103, -1.297, 0.465, 0.382, 0.263, 2.45E-6, 0.113E-4, 0.103, 0.35, 'CLAY LOAM' 10, 10.73, 0.100, -3.209, 0.406, 0.338, 0.098, 7.22E-6, 0.187E-4, 0.100, 0.52, 'SANDY CLAY' 11, 10.39, 0.126, -1.916, 0.468, 0.404, 0.324, 1.34E-6, 0.964E-5, 0.126, 0.10, 'SILTY CLAY' @@ -19,41 +19,41 @@ STAS 16, 4.26, 0.028, -1.044, 0.421, 0.283, 0.036, 1.41E-5, 0.514E-5, 0.028, 0.25, 'OTHER(land-ice)' 17, 11.55, 0.030, -10.472, 0.468, 0.454, 0.468, 9.74E-7, 0.112E-4, 0.030, 0.60, 'PLAYA' 18, 2.79, 0.006, -0.472, 0.200, 0.17, 0.069, 1.41E-4, 0.136E-3, 0.006, 0.52, 'LAVA' -19, 2.79, 0.01, -0.472, 0.339, 0.236, 0.069, 4.66E-5, 0.608E-6, 0.01, 0.92, 'WHITE SAND' +19, 2.79, 0.01, -0.472, 0.339, 0.236, 0.069, 1.07E-6, 0.608E-6, 0.01, 0.92, 'WHITE SAND' Soil Parameters STAS-RUC 19,1 'BB DRYSMC HC MAXSMC REFSMC SATPSI SATDK SATDW WLTSMC QTZ ' -1, 4.05, 0.045, 1.47, 0.395, 0.174, 0.121, 1.76E-4, 0.608E-6, 0.068, 0.92, 'SAND' -2, 4.38, 0.057, 1.41, 0.410, 0.179, 0.090, 1.56E-4, 0.514E-5, 0.075, 0.82, 'LOAMY SAND' -3, 4.90, 0.065, 1.34, 0.435, 0.249, 0.218, 3.47E-5, 0.805E-5, 0.114, 0.60, 'SANDY LOAM' -4, 5.30, 0.067, 1.27, 0.485, 0.369, 0.786, 7.20E-6, 0.239E-4, 0.179, 0.25, 'SILT LOAM' -5, 5.30, 0.034, 1.27, 0.485, 0.369, 0.786, 7.20E-6, 0.239E-4, 0.179, 0.10, 'SILT' -6, 5.39, 0.078, 1.21, 0.451, 0.314, 0.478, 6.95E-6, 0.143E-4, 0.155, 0.40, 'LOAM' -7, 7.12, 0.100, 1.18, 0.420, 0.299, 0.299, 6.30E-6, 0.990E-5, 0.175, 0.60, 'SANDY CLAY LOAM' -8, 7.75, 0.089, 1.32, 0.477, 0.357, 0.356, 1.70E-6, 0.237E-4, 0.218, 0.10, 'SILTY CLAY LOAM' -9, 8.52, 0.095, 1.23, 0.476, 0.391, 0.630, 2.45E-6, 0.113E-4, 0.250, 0.35, 'CLAY LOAM' -10, 10.40, 0.100, 1.18, 0.426, 0.316, 0.153, 2.17E-6, 0.187E-4, 0.219, 0.52, 'SANDY CLAY' -11, 10.40, 0.070, 1.15, 0.492, 0.409, 0.490, 1.03E-6, 0.964E-5, 0.283, 0.10, 'SILTY CLAY' -12, 11.40, 0.068, 1.09, 0.482, 0.400, 0.405, 1.28E-6, 0.112E-4, 0.286, 0.25, 'CLAY' -13, 5.39, 0.078, 1.21, 0.451, 0.314, 0.478, 6.95E-6, 0.143E-4, 0.155, 0.05, 'ORGANIC MATERIAL' +1, 4.05, 0.045, 1.47, 0.395, 0.236, 0.121, 1.76E-4, 0.608E-6, 0.068, 0.92, 'SAND' +2, 4.38, 0.057, 1.41, 0.410, 0.383, 0.090, 1.56E-4, 0.514E-5, 0.075, 0.82, 'LOAMY SAND' +3, 4.90, 0.065, 1.34, 0.435, 0.383, 0.218, 3.47E-5, 0.805E-5, 0.114, 0.60, 'SANDY LOAM' +4, 5.30, 0.067, 1.27, 0.485, 0.360, 0.786, 7.20E-6, 0.239E-4, 0.179, 0.25, 'SILT LOAM' +5, 5.30, 0.034, 1.27, 0.485, 0.383, 0.786, 7.20E-6, 0.239E-4, 0.179, 0.10, 'SILT' +6, 5.39, 0.078, 1.21, 0.451, 0.329, 0.478, 6.95E-6, 0.143E-4, 0.155, 0.40, 'LOAM' +7, 7.12, 0.100, 1.18, 0.420, 0.314, 0.299, 6.30E-6, 0.990E-5, 0.175, 0.60, 'SANDY CLAY LOAM' +8, 7.75, 0.089, 1.32, 0.477, 0.387, 0.356, 1.70E-6, 0.237E-4, 0.218, 0.10, 'SILTY CLAY LOAM' +9, 8.52, 0.095, 1.23, 0.476, 0.382, 0.630, 2.45E-6, 0.113E-4, 0.250, 0.35, 'CLAY LOAM' +10, 10.40, 0.100, 1.18, 0.426, 0.338, 0.153, 2.17E-6, 0.187E-4, 0.219, 0.52, 'SANDY CLAY' +11, 10.40, 0.070, 1.15, 0.492, 0.404, 0.490, 1.03E-6, 0.964E-5, 0.283, 0.10, 'SILTY CLAY' +12, 11.40, 0.068, 1.09, 0.482, 0.412, 0.405, 1.28E-6, 0.112E-4, 0.286, 0.25, 'CLAY' +13, 5.39, 0.078, 1.21, 0.451, 0.329, 0.478, 6.95E-6, 0.143E-4, 0.155, 0.05, 'ORGANIC MATERIAL' 14, 0.0, 0.0, 4.18, 1.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.00, 'WATER' -15, 4.05, 0.004, 2.03, 0.200, 0.10 , 0.121, 1.41E-4, 0.136E-3, 0.006, 0.60, 'BEDROCK' -16, 4.90, 0.065, 2.10, 0.435, 0.249, 0.218, 3.47E-5, 0.514E-5, 0.114, 0.05, 'OTHER(land-ice)' +15, 4.05, 0.004, 2.03, 0.200, 0.17, 0.121, 1.41E-4, 0.136E-3, 0.006, 0.60, 'BEDROCK' +16, 4.90, 0.065, 2.10, 0.435, 0.283, 0.218, 3.47E-5, 0.514E-5, 0.114, 0.05, 'OTHER(land-ice)' 17, 11.40, 0.030, 1.41, 0.468, 0.454, 0.468, 9.74E-7, 0.112E-4, 0.030, 0.60, 'PLAYA' 18, 4.05, 0.006, 1.41, 0.200, 0.17, 0.069, 1.41E-4, 0.136E-3, 0.060, 0.52, 'LAVA' 19, 4.05, 0.01, 1.47, 0.339, 0.236, 0.069, 1.76E-4, 0.608E-6, 0.060, 0.92, 'WHITE SAND' Soil Parameters ROSETTA 12,1 'theta_res theta_sat vGn_alpha vGn_n k_soil BB DRYSMC HC MAXSMC REFSMC SATPSI SATDK SATDW WLTSMC QTZ ' -1 0.098 0.459 -1.496 1.253 1.70799e-06 11.40 0.068 1.09 0.482 0.412 0.405 1.28E-6 0.112E-4 0.286 0.25 'CLAY' +1 0.098 0.459 -1.496 1.253 1.70799e-06 1.40 0.068 1.09 0.482 0.412 0.405 1.28E-6 0.112E-4 0.286 0.25 'CLAY' 2 0.079 0.442 -1.581 1.416 9.47297e-07 8.52 0.095 1.23 0.476 0.382 0.630 2.45E-6 0.113E-4 0.250 0.35 'CLAY LOAM' 3 0.061 0.399 -1.112 1.472 1.39472e-06 5.39 0.078 1.21 0.451 0.329 0.478 6.95E-6 0.143E-4 0.155 0.40 'LOAM' 4 0.049 0.390 -3.475 1.746 1.21755e-05 4.38 0.057 1.41 0.410 0.383 0.090 1.56E-4 0.514E-5 0.075 0.82 'LOAMY SAND' 5 0.053 0.375 -3.524 3.177 7.43852e-05 4.05 0.045 1.47 0.395 0.236 0.121 1.76E-4 0.608E-6 0.068 0.92 'SAND' -6 0.117 0.385 -3.342 1.208 1.31367e-06 10.40 0.100 1.18 0.426 0.338 0.153 2.17E-6 0.187E-4 0.219 0.52 'SANDY CLAY' +6 0.117 0.385 -3.342 1.208 1.31367e-06 0.40 0.100 1.18 0.426 0.338 0.153 2.17E-6 0.187E-4 0.219 0.52 'SANDY CLAY' 7 0.063 0.384 -2.109 1.330 1.52576e-06 7.12 0.100 1.18 0.420 0.314 0.299 6.30E-6 0.990E-5 0.175 0.60 'SANDY CLAY LOAM' 8 0.039 0.387 -2.667 1.449 4.43084e-06 4.90 0.065 1.34 0.435 0.383 0.218 3.47E-5 0.805E-5 0.114 0.60 'SANDY LOAM' 9 0.050 0.489 -0.658 1.679 5.06391e-06 5.30 0.034 1.27 0.485 0.383 0.786 7.20E-6 0.239E-4 0.179 0.10 'SILT' -10 0.111 0.481 -1.622 1.321 1.11298e-06 10.40 0.070 1.15 0.492 0.404 0.490 1.03E-6 0.964E-5 0.283 0.10 'SILTY CLAY' +10 0.111 0.481 -1.622 1.321 1.11298e-06 0.40 0.070 1.15 0.492 0.404 0.490 1.03E-6 0.964E-5 0.283 0.10 'SILTY CLAY' 11 0.090 0.482 -0.839 1.521 1.28673e-06 7.75 0.089 1.32 0.477 0.387 0.356 1.70E-6 0.237E-4 0.218 0.10 'SILTY CLAY LOAM' 12 0.065 0.439 -0.506 1.663 2.11099e-06 5.30 0.067 1.27 0.485 0.360 0.786 7.20E-6 0.239E-4 0.179 0.25 'SILT LOAM' diff --git a/case_study/base_settings/VEGPARM.TBL b/test_ngen/domain_provo/settings/SUMMA/TBL_VEGPARM.TBL old mode 100644 new mode 100755 similarity index 89% rename from case_study/base_settings/VEGPARM.TBL rename to test_ngen/domain_provo/settings/SUMMA/TBL_VEGPARM.TBL index 2d53237ae..293a0463b --- a/case_study/base_settings/VEGPARM.TBL +++ b/test_ngen/domain_provo/settings/SUMMA/TBL_VEGPARM.TBL @@ -209,3 +209,31 @@ BARE 16 NATURAL 14 +Vegetation Parameters +UMD +13,1, 'SHDFAC NROOT RS RGL HS SNUP MAXALB LAIMIN LAIMAX EMISSMIN EMISSMAX ALBEDOMIN ALBEDOMAX Z0MIN Z0MAX ZTOPV ZBOTV' +1 .70, 4, 125., 30., 47.35, 0.08, 52., 5.00, 6.40, .950, .950, .12, .12, .50, .50, 17.0, 8.5, 'Evergreen Needleleaf Forest' +2, .95, 4, 150., 30., 41.69, 0.08, 35., 3.08, 6.48, .950, .950, .12, .12, .50, .50, 35.0, 1.0, 'Evergreen Broadleaf Forest' +3, .70, 4, 150., 30., 47.35, 0.08, 54., 1.00, 5.16, .930, .940, .14, .15, .50, .50, 14.0, 7.0, 'Deciduous Needleleaf Forest' +4, .80, 4, 100., 30., 54.53, 0.08, 58., 1.85, 3.31, .930, .930, .16, .17, .50, .50, 20.0, 11.5, 'Deciduous Broadleaf Forest' +5, .80, 4, 125., 30., 51.93, 0.08, 53., 2.80, 5.50, .930, .970, .17, .25, .20, .50, 18.0, 10.0, 'Mixed Forests' +6, .70, 4, 125., 30., 47.35, 0.08, 52., 5.00, 6.40, .950, .950, .12, .12, .50, .50, 17.0, 8.5, 'Woodlands' +7, .70, 3, 300., 100., 42.00, 0.03, 60., 0.50, 3.66, .930, .930, .25, .30, .01, .05, 0.50, 0.01, 'Wooded Grassland' +8, .70, 3, 300., 100., 42.00, 0.03, 60., 0.50, 3.66, .930, .930, .25, .30, .01, .05, 0.50, 0.01, 'Closed Shrublands' +9, .70, 3, 170., 100., 39.18, 0.035, 65., 0.60, 2.60, .930, .950, .22, .30, .01, .06, 0.50, 0.01, 'Open Shrublands' +10, .80, 3, 40., 100., 36.35, 0.04, 70., 0.52, 2.90, .920, .960, .19, .23, .10, .12, 0.50, 0.01, 'Grasslands' +11, .80, 3, 40., 100., 36.25, 0.04, 66., 1.56, 5.68, .920, .985, .17, .23, .05, .15, 0.50, 0.01, 'Croplands' +12, .01, 1, 999., 999., 999.0, 0.02, 75., 0.10, 0.75, .900, .900, .38, .38, .01, .01, 0.02, 0.01, 'Bare Soil' +13, .10, 1, 200., 999., 999.0, 0.04, 46., 1.00, 1.00, .880, .880, .15, .15, .50, .50, 0.00, 0.00, 'Urban' +TOPT_DATA +298.0 +CMCMAX_DATA +0.5E-3 +CFACTR_DATA +0.5 +RSMAX_DATA +5000.0 +BARE +12 +NATURAL +5 diff --git a/test_ngen/domain_provo/settings/SUMMA/attributes.nc b/test_ngen/domain_provo/settings/SUMMA/attributes.nc new file mode 100755 index 000000000..f1c9b31ff Binary files /dev/null and b/test_ngen/domain_provo/settings/SUMMA/attributes.nc differ diff --git a/test_ngen/domain_provo/settings/SUMMA/basinParamInfo.txt b/test_ngen/domain_provo/settings/SUMMA/basinParamInfo.txt new file mode 100755 index 000000000..6b021898b --- /dev/null +++ b/test_ngen/domain_provo/settings/SUMMA/basinParamInfo.txt @@ -0,0 +1,35 @@ +! *********************************************************************************************************************** +! *********************************************************************************************************************** +! ***** DEFINITION OF BASIN PARAMETERS ********************************************************************************** +! *********************************************************************************************************************** +! *********************************************************************************************************************** +! Note: lines starting with "!" are treated as comment lines -- there is no limit on the number of comment lines. +! +! *********************************************************************************************************************** +! DEFINE BASIN MODEL PARAMETERS +! ------------------------------------ +! the format definition defines the format of the file, which can be changed +! the delimiters "| " must be present (format a1), as these are used to check the integrety of the file +! columns are: +! 1: parameter name +! 2: default parameter value +! 3: lower parameter limit +! 4: upper parameter limit +! *********************************************************************************************************************** +! +! ******************************************************************** +! define format string for parameter descriptions +! ******************************************************************** +'(a25,1x,a1,1x,3(f12.4,1x,a1,1x))' ! format string for parameter descriptions (must be in single quotes) +! ******************************************************************** +! baseflow +! ******************************************************************** +basin__aquiferHydCond | 0.0100 | 0.0001 | 10.0000 +basin__aquiferScaleFactor | 3.5000 | 0.1000 | 10.0000 +basin__aquiferBaseflowExp | 3.0000 | 1.0000 | 10.0000 +! ******************************************************************** +! within-grid routing +! ******************************************************************** +routingGammaShape | 2.5000 | 2.0000 | 5.0000 +routingGammaScale | 1000.0000 | 1.0000 | 100000.0000 +! ******************************************************************** diff --git a/test_ngen/domain_provo/settings/SUMMA/coldState.nc b/test_ngen/domain_provo/settings/SUMMA/coldState.nc new file mode 100755 index 000000000..1ddd3bfb3 Binary files /dev/null and b/test_ngen/domain_provo/settings/SUMMA/coldState.nc differ diff --git a/test_ngen/domain_provo/settings/SUMMA/fileManager.txt b/test_ngen/domain_provo/settings/SUMMA/fileManager.txt new file mode 100755 index 000000000..90666c381 --- /dev/null +++ b/test_ngen/domain_provo/settings/SUMMA/fileManager.txt @@ -0,0 +1,20 @@ +controlVersion 'SUMMA_FILE_MANAGER_V3.0.0' +simStartTime '2017-10-01 01:00' +simEndTime '2022-09-30 23:00' +tmZoneInfo 'utcTime' +outFilePrefix 'run_1' +settingsPath './extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/' +forcingPath './extern/summa/summa/test_ngen/domain_provo/forcing/SUMMA_input/' +outputPath './extern/summa/summa/test_ngen/domain_provo/simulations/run_1/SUMMA/' +initConditionFile 'coldState.nc' +attributeFile 'attributes.nc' +trialParamFile 'trialParams.nc' +forcingListFile 'forcingFileList.txt' +decisionsFile 'modelDecisions.txt' +outputControlFile 'outputControl.txt' +globalHruParamFile 'localParamInfo.txt' +globalGruParamFile 'basinParamInfo.txt' +vegTableFile 'TBL_VEGPARM.TBL' +soilTableFile 'TBL_SOILPARM.TBL' +generalTableFile 'TBL_GENPARM.TBL' +noahmpTableFile 'TBL_MPTABLE.TBL' diff --git a/test_ngen/domain_provo/settings/SUMMA/forcingFileList.txt b/test_ngen/domain_provo/settings/SUMMA/forcingFileList.txt new file mode 100755 index 000000000..46eb97af3 --- /dev/null +++ b/test_ngen/domain_provo/settings/SUMMA/forcingFileList.txt @@ -0,0 +1 @@ +ngen_forcings_summa_format.nc \ No newline at end of file diff --git a/test_ngen/domain_provo/settings/SUMMA/localParamInfo.txt b/test_ngen/domain_provo/settings/SUMMA/localParamInfo.txt new file mode 100755 index 000000000..b373266d8 --- /dev/null +++ b/test_ngen/domain_provo/settings/SUMMA/localParamInfo.txt @@ -0,0 +1,226 @@ +! ======================================================================================================================= +! ======================================================================================================================= +! ===== DEFINITION OF MODEL PARAMETERS ================================================================================== +! ======================================================================================================================= +! ======================================================================================================================= +! Note: lines starting with "!" are treated as comment lines -- there is no limit on the number of comment lines. +! +! ======================================================================================================================= +! DEFINE SITE MODEL PARAMETERS +! ------------------------------------ +! the format definition defines the format of the file, which can be changed +! the delimiters "| " must be present (format a2), as these are used to check the integrety of the file +! columns are: +! 1: parameter name +! 2: default parameter value +! 3: lower parameter limit +! 4: upper parameter limit +! ======================================================================================================================= +! +! ==================================================================== +! define format string for parameter descriptions +! ==================================================================== +'(a25,1x,3(a1,1x,f12.4,1x))' ! format string (must be in single quotes) +! ==================================================================== +! boundary conditions +! ==================================================================== +upperBoundHead | 0.0000 | -10.0000 | 1.0000 +lowerBoundHead | -10.000 | -50.0000 | -1.0000 +upperBoundTheta | 0.2004 | 0.1020 | 0.3680 +lowerBoundTheta | 0.1100 | 0.1020 | 0.3680 +upperBoundTemp | 274.1600 | 270.1600 | 280.1600 +lowerBoundTemp | 272.1600 | 270.1600 | 280.1600 +! ==================================================================== +! precipitation partitioning +! ==================================================================== +tempCritRain | 273.1600 | 272.1600 | 274.1600 +tempRangeTimestep | 2.0000 | 0.5000 | 5.0000 +frozenPrecipMultip | 1.0000 | 0.5000 | 1.5000 +! ==================================================================== +! snow properties +! ==================================================================== +snowfrz_scale | 50.0000 | 10.0000 | 100.0000 +fixedThermalCond_snow | 0.3500 | 0.1000 | 1.0000 +! ==================================================================== +! snow albedo +! ==================================================================== +albedoMax | 0.8400 | 0.7000 | 0.9000 +albedoMinWinter | 0.6500 | 0.5500 | 1.0000 +albedoMinSpring | 0.5500 | 0.3000 | 1.0000 +albedoMaxVisible | 0.9500 | 0.7000 | 0.9500 +albedoMinVisible | 0.7500 | 0.5000 | 0.7500 +albedoMaxNearIR | 0.6500 | 0.5000 | 0.7500 +albedoMinNearIR | 0.3000 | 0.1500 | 0.4500 +albedoDecayRate | 1.0d+6 | 0.1d+6 | 5.0d+6 +albedoSootLoad | 0.3000 | 0.1000 | 0.5000 +albedoRefresh | 1.0000 | 1.0000 | 10.0000 +! ==================================================================== +! radiation transfer within snow +! ==================================================================== +radExt_snow | 20.0000 | 20.0000 | 20.0000 +directScale | 0.0900 | 0.0000 | 0.5000 +Frad_direct | 0.7000 | 0.0000 | 1.0000 +Frad_vis | 0.5000 | 0.0000 | 1.0000 +! ==================================================================== +! new snow density +! ==================================================================== +newSnowDenMin | 100.0000 | 50.0000 | 100.0000 +newSnowDenMult | 100.0000 | 25.0000 | 75.0000 +newSnowDenScal | 5.0000 | 1.0000 | 5.0000 +constSnowDen | 100.0000 | 50.0000 | 250.0000 +newSnowDenAdd | 109.0000 | 80.0000 | 120.0000 +newSnowDenMultTemp | 6.0000 | 1.0000 | 12.0000 +newSnowDenMultWind | 26.0000 | 16.0000 | 36.0000 +newSnowDenMultAnd | 1.0000 | 1.0000 | 3.0000 +newSnowDenBase | 0.0000 | 0.0000 | 0.0000 +! ==================================================================== +! snow compaction +! ==================================================================== +densScalGrowth | 0.0460 | 0.0230 | 0.0920 +tempScalGrowth | 0.0400 | 0.0200 | 0.0600 +grainGrowthRate | 2.7d-6 | 1.0d-6 | 5.0d-6 +densScalOvrbdn | 0.0230 | 0.0115 | 0.0460 +tempScalOvrbdn | 0.0800 | 0.6000 | 1.0000 +baseViscosity | 9.0d+5 | 5.0d+5 | 1.5d+6 +! ==================================================================== +! water flow through snow +! ==================================================================== +Fcapil | 0.0600 | 0.0050 | 0.2000 +k_snow | 0.0150 | 0.0050 | 0.0500 +mw_exp | 3.0000 | 1.0000 | 5.0000 +! ==================================================================== +! turbulent heat fluxes +! ==================================================================== +z0Snow | 0.0010 | 0.0010 | 10.0000 +z0Soil | 0.0100 | 0.0010 | 10.0000 +z0Canopy | 0.1000 | 0.0010 | 10.0000 +zpdFraction | 0.6500 | 0.5000 | 0.8500 +critRichNumber | 0.2000 | 0.1000 | 1.0000 +Louis79_bparam | 9.4000 | 9.2000 | 9.6000 +Louis79_cStar | 5.3000 | 5.1000 | 5.5000 +Mahrt87_eScale | 1.0000 | 0.5000 | 2.0000 +leafExchangeCoeff | 0.0100 | 0.0010 | 0.0100 +windReductionParam | 0.2800 | 0.2500 | 1.0000 +! ==================================================================== +! stomatal conductance +! ==================================================================== +Kc25 | 296.0770 | 296.0770 | 296.0770 +Ko25 | 0.2961 | 0.2961 | 0.2961 +Kc_qFac | 2.1000 | 2.1000 | 2.1000 +Ko_qFac | 1.2000 | 1.2000 | 1.2000 +kc_Ha | 79430.0000 | 79430.0000 | 79430.0000 +ko_Ha | 36380.0000 | 36380.0000 | 36380.0000 +vcmax25_canopyTop | 40.0000 | 20.0000 | 100.0000 +vcmax_qFac | 2.4000 | 2.4000 | 2.4000 +vcmax_Ha | 65330.0000 | 65330.0000 | 65330.0000 +vcmax_Hd | 220000.0000 | 149250.0000 | 149250.0000 +vcmax_Sv | 710.0000 | 485.0000 | 485.0000 +vcmax_Kn | 0.6000 | 0.0000 | 1.2000 +jmax25_scale | 2.0000 | 2.0000 | 2.0000 +jmax_Ha | 43540.0000 | 43540.0000 | 43540.0000 +jmax_Hd | 152040.0000 | 152040.0000 | 152040.0000 +jmax_Sv | 495.0000 | 495.0000 | 495.0000 +fractionJ | 0.1500 | 0.1500 | 0.1500 +quantamYield | 0.0500 | 0.0500 | 0.0500 +vpScaleFactor | 1500.0000 | 1500.0000 | 1500.0000 +cond2photo_slope | 9.0000 | 1.0000 | 10.0000 +minStomatalConductance | 2000.0000 | 2000.0000 | 2000.0000 +! ==================================================================== +! vegetation properties +! ==================================================================== +winterSAI | 1.0000 | 0.0100 | 3.0000 +summerLAI | 3.0000 | 0.0100 | 10.0000 +rootScaleFactor1 | 2.0000 | 1.0000 | 10.0000 +rootScaleFactor2 | 5.0000 | 1.0000 | 10.0000 +rootingDepth | 2.0000 | 0.1000 | 6.0000 +rootDistExp | 1.0000 | 0.0100 | 1.0000 +plantWiltPsi | -150.0000 | -500.0000 | 0.0000 +soilStressParam | 5.8000 | 4.3600 | 6.3700 +critSoilWilting | 0.0750 | 0.0000 | 1.0000 +critSoilTranspire | 0.1750 | 0.0000 | 1.0000 +critAquiferTranspire | 0.2000 | 0.1000 | 10.0000 +minStomatalResistance | 50.0000 | 10.0000 | 200.0000 +leafDimension | 0.0400 | 0.0100 | 0.1000 +heightCanopyTop | 20.0000 | 0.0500 | 100.0000 +heightCanopyBottom | 2.0000 | 0.0000 | 5.0000 +specificHeatVeg | 874.0000 | 500.0000 | 1500.0000 +maxMassVegetation | 25.0000 | 1.0000 | 50.0000 +throughfallScaleSnow | 0.5000 | 0.1000 | 0.9000 +throughfallScaleRain | 0.5000 | 0.1000 | 0.9000 +refInterceptCapSnow | 6.6000 | 1.0000 | 10.0000 +refInterceptCapRain | 1.0000 | 0.0100 | 1.0000 +snowUnloadingCoeff | 0.0000 | 0.0000 | 1.5d-6 +canopyDrainageCoeff | 0.0050 | 0.0010 | 0.0100 +ratioDrip2Unloading | 0.4000 | 0.0000 | 1.0000 +canopyWettingFactor | 0.7000 | 0.0000 | 1.0000 +canopyWettingExp | 1.0000 | 0.4000 | 1.0000 +! ==================================================================== +! soil properties +! ==================================================================== +soil_dens_intr | 2700.0000 | 500.0000 | 4000.0000 +thCond_soil | 5.5000 | 2.9000 | 8.4000 +frac_sand | 0.1600 | 0.0000 | 1.0000 +frac_silt | 0.2800 | 0.0000 | 1.0000 +frac_clay | 0.5600 | 0.0000 | 1.0000 +fieldCapacity | 0.2000 | 0.0000 | 1.0000 +wettingFrontSuction | 0.3000 | 0.1000 | 1.5000 +theta_mp | 0.3500 | 0.3000 | 0.6000 +theta_sat | 0.4500 | 0.3500 | 0.6500 +theta_res | 0.0500 | 0.0010 | 0.0800 +vGn_alpha | -0.8400 | -1.0000 | -0.0100 +vGn_n | 1.5000 | 1.2000 | 4.0000 +mpExp | 5.0000 | 1.0000 | 10.0000 +k_soil | 7.5d-06 | 1.d-08 | 1.d-02 +k_macropore | 1.0d-03 | 1.d-08 | 1.d-02 +kAnisotropic | 1.0000 | 0.0001 | 10.0000 +zScale_TOPMODEL | 2.5000 | 1.0000 | 10.0000 +compactedDepth | 1.0000 | 0.0000 | 1.0000 +aquiferBaseflowRate | 1.0d-7 | 1.0d-9 | 1.0d-5 +aquiferScaleFactor | 0.3500 | 0.1000 | 0.5000 +aquiferBaseflowExp | 2.0000 | 1.0000 | 5.0000 +qSurfScale | 50.0000 | 1.0000 | 100.0000 +specificYield | 0.2000 | 0.1000 | 0.3000 +specificStorage | 1.d-06 | 1.d-07 | 1.d-05 +f_impede | 2.0000 | 1.0000 | 10.0000 +soilIceScale | 0.1300 | 0.0001 | 1.0000 +soilIceCV | 0.4500 | 0.1000 | 5.0000 +! ==================================================================== +! algorithmic control parameters +! ==================================================================== +minwind | 0.1000 | 0.0010 | 1.0000 +minstep | 1.0000 | 1.0000 | 1800.0000 +maxstep | 3600.0000 | 60.0000 | 1800.0000 +wimplicit | 0.0000 | 0.0000 | 1.0000 +maxiter | 100.0000 | 1.0000 | 100.0000 +relConvTol_liquid | 1.0d-3 | 1.0d-5 | 1.0d-1 +absConvTol_liquid | 1.0d-5 | 1.0d-8 | 1.0d-3 +relConvTol_matric | 1.0d-6 | 1.0d-7 | 1.0d-1 +absConvTol_matric | 1.0d-6 | 1.0d-8 | 1.0d-3 +relConvTol_energy | 1.0d-2 | 1.0d-5 | 1.0d-1 +absConvTol_energy | 1.0d-0 | 1.0d-2 | 1.0d+1 +relConvTol_aquifr | 1.0d-0 | 1.0d-2 | 1.0d+1 +absConvTol_aquifr | 1.0d-5 | 1.0d-5 | 1.0d-1 +zmin | 0.0100 | 0.0050 | 0.1000 +zmax | 0.0500 | 0.0100 | 0.5000 +! --- +zminLayer1 | 0.0075 | 0.0075 | 0.0075 +zminLayer2 | 0.0100 | 0.0100 | 0.0100 +zminLayer3 | 0.0500 | 0.0500 | 0.0500 +zminLayer4 | 0.1000 | 0.1000 | 0.1000 +zminLayer5 | 0.2500 | 0.2500 | 0.2500 +! --- +zmaxLayer1_lower | 0.0500 | 0.0500 | 0.0500 +zmaxLayer2_lower | 0.2000 | 0.2000 | 0.2000 +zmaxLayer3_lower | 0.5000 | 0.5000 | 0.5000 +zmaxLayer4_lower | 1.0000 | 1.0000 | 1.0000 +! --- +zmaxLayer1_upper | 0.0300 | 0.0300 | 0.0300 +zmaxLayer2_upper | 0.1500 | 0.1500 | 0.1500 +zmaxLayer3_upper | 0.3000 | 0.3000 | 0.3000 +zmaxLayer4_upper | 0.7500 | 0.7500 | 0.7500 +! ==================================================================== +minTempUnloading | 270.16 | 260.16 | 273.16 +minWindUnloading | 0.0000 | 0.0000 | 10.000 +rateTempUnloading | 1.87d+5 | 1.0d+5 | 3.0d+5 +rateWindUnloading | 1.56d+5 | 1.0d+5 | 3.0d+5 +! history Wed Jul 29 16:01:34 2020: /home/wknoben/summa/utils/convert_summa_config_v2_v3.py fileManager.txt \ No newline at end of file diff --git a/case_study/reynolds/site_settings/modelDecisions_reynoldsVariableDecayRate.txt b/test_ngen/domain_provo/settings/SUMMA/modelDecisions.txt old mode 100644 new mode 100755 similarity index 79% rename from case_study/reynolds/site_settings/modelDecisions_reynoldsVariableDecayRate.txt rename to test_ngen/domain_provo/settings/SUMMA/modelDecisions.txt index 483188e46..ba49e5e0d --- a/case_study/reynolds/site_settings/modelDecisions_reynoldsVariableDecayRate.txt +++ b/test_ngen/domain_provo/settings/SUMMA/modelDecisions.txt @@ -8,34 +8,38 @@ ! (3) the simulation start/end times must be within single quotes ! *********************************************************************************************************************** ! *********************************************************************************************************************** -soilCatTbl ROSETTA ! (03) soil-category dateset -vegeParTbl USGS ! (04) vegetation category dataset +soilCatTbl STAS ! (03) soil-category dataset +vegeParTbl USGS ! (04) vegetation category dataset soilStress NoahType ! (05) choice of function for the soil moisture control on stomatal resistance stomResist BallBerry ! (06) choice of function for stomatal resistance ! *********************************************************************************************************************** -num_method itertive ! (07) choice of numerical method +num_method homegrown ! (07) choice of numerical method fDerivMeth analytic ! (08) method used to calculate flux derivatives LAI_method monTable ! (09) method used to determine LAI and SAI f_Richards mixdform ! (10) form of Richard's equation -groundwatr noXplict ! (11) choice of groundwater parameterization +groundwatr bigBuckt ! (11) choice of groundwater parameterization hc_profile constant ! (12) choice of hydraulic conductivity profile bcUpprTdyn nrg_flux ! (13) type of upper boundary condition for thermodynamics bcLowrTdyn zeroFlux ! (14) type of lower boundary condition for thermodynamics bcUpprSoiH liq_flux ! (15) type of upper boundary condition for soil hydrology bcLowrSoiH drainage ! (16) type of lower boundary condition for soil hydrology -veg_traits CM_QJRMS1988 ! (17) choice of parameterization for vegetation roughness length and displacement height +veg_traits vegTypeTable ! (17) choice of parameterization for vegetation roughness length and displacement height canopyEmis difTrans ! (18) choice of parameterization for canopy emissivity snowIncept lightSnow ! (19) choice of parameterization for snow interception windPrfile logBelowCanopy ! (20) choice of wind profile through the canopy astability louisinv ! (21) choice of stability function -canopySrad CLM_2stream ! (22) choice of canopy shortwave radiation method +canopySrad noah_mp ! (22) choice of canopy shortwave radiation method alb_method varDecay ! (23) choice of albedo representation compaction anderson ! (24) choice of compaction routine -snowLayers CLM_2010 ! (25) choice of method to combine and sub-divide snow layers +snowLayers jrdn1991 ! (25) choice of method to combine and sub-divide snow layers thCondSnow jrdn1991 ! (26) choice of thermal conductivity representation for snow -thCondSoil mixConstit ! (27) choice of thermal conductivity representation for soil +thCondSoil funcSoilWet ! (27) choice of thermal conductivity representation for soil spatial_gw localColumn ! (28) choice of method for the spatial representation of groundwater subRouting timeDlay ! (29) choice of method for sub-grid routing +nrgConserv enthalpyForm ! (30) choice of variable in energy equations (BE residual or IDA state variable) +infRateMax GreenAmpt ! (31) choice of infiltration rate method +surfRun_IE homegrown_IE ! (32) infiltration excess surface runoff parameterization +surfRun_SE homegrown_SE ! (33) saturation excess surface runoff parameterization ! *********************************************************************************************** ! ***** description of the options available -- nothing below this point is read **************** ! *********************************************************************************************** @@ -43,13 +47,13 @@ subRouting timeDlay ! (29) choice of method for sub- ! (01) simulation start time ! (02) simulation end time ! ----------------------------------------------------------------------------------------------- -! (03) soil-category dateset +! (03) soil-category dataset ! STAS ! STATSGO dataset ! STAS-RUC ! ?? ! ROSETTA ! merged Rosetta table with STAS-RUC ! ----------------------------------------------------------------------------------------------- ! (04) vegetation category dataset -! USGS ! USGS 24/27 category dataset +! USGS ! USGS 24/27 category dataset ! MODIFIED_IGBP_MODIS_NOAH ! MODIS 20-category dataset ! ----------------------------------------------------------------------------------------------- ! (05) choice of function for the soil moisture control on stomatal resistance @@ -62,12 +66,12 @@ subRouting timeDlay ! (29) choice of method for sub- ! Jarvis ! Jarvis ! ----------------------------------------------------------------------------------------------- ! (07) choice of numerical method -! itertive ! iterative -! non_iter ! non-iterative -! itersurf ! iterate only on the surface energy balance +! homegrown ! home-grown backward Euler +! kinsol ! SUNDIALS backward Euler solution using Kinsol +! ida ! SUNDIALS solution using IDA ! ----------------------------------------------------------------------------------------------- ! (08) method used to calculate flux derivatives -! numericl ! numerical derivatives +! numericl ! numerical derivatives (only works with SUNDIALS) ! analytic ! analytical derivatives ! ----------------------------------------------------------------------------------------------- ! (09) method used to determine LAI and SAI @@ -115,11 +119,11 @@ subRouting timeDlay ! (29) choice of method for sub- ! difTrans ! parameterized as a function of diffuse transmissivity ! ----------------------------------------------------------------------------------------------- ! (19) choice of parameterization for snow interception -! stickySnow ! maximum interception capacity an increasing function of temerature +! stickySnow ! maximum interception capacity an increasing function of temperature ! lightSnow ! maximum interception capacity an inverse function of new snow density ! ----------------------------------------------------------------------------------------------- ! (20) choice of wind profile -! exponential ! exponential wind profile extends to the surface +! exponential ! exponential wind profile extends to the surface ! logBelowCanopy ! logarithmic profile below the vegetation canopy ! ----------------------------------------------------------------------------------------------- ! (21) choice of stability function @@ -164,5 +168,25 @@ subRouting timeDlay ! (29) choice of method for sub- ! (29) choice of method for sub-grid routing ! timeDlay ! time-delay histogram ! qInstant ! instantaneous routing +! ----------------------------------------------------------------------------------------------- +! (30) choice of variable in energy equations (BE residual or IDA state variable) +! closedForm ! use temperature with closed form heat capacity +! enthalpyFormLU ! use enthalpy with soil temperature-enthalpy lookup tables +! enthalpyForm ! use enthalpy with soil temperature-enthalpy analytical solutions +! ----------------------------------------------------------------------------------------------- +! (31) choice of infiltration rate method +! GreenAmpt ! Green-Ampt +! topmodel_GA ! Green-Ampt with TOPMODEL conductivity rate +! noInfExc ! no infiltration excess runoff (saturation excess may still occur) +! ----------------------------------------------------------------------------------------------- +! (32) choice of infiltration excess (IE) surface runoff parameterization +! zero_IE ! zero IE surface runoff +! homegrown_IE ! IE component of SUMMA's original liquid flux parameterization (default) +! ----------------------------------------------------------------------------------------------- +! (33) choice of saturation excess (SE) surface runoff parameterization +! zero_SE ! zero SE surface runoff +! homegrown_SE ! SE component of SUMMA's original liquid flux parameterization (default) +! FUSEPRMS ! FUSE PRMS surface runoff parameterization +! FUSEAVIC ! FUSE ARNO/VIC surface runoff parameterization +! FUSETOPM ! FUSE TOPMODEL surface runoff parameterization ! *********************************************************************************************** -! history Mon Jul 20 16:08:15 2020: /pool0/home/andrbenn/data/summa_3/utils/convert_summa_config_v2_v3.py ./wrrPaperTestCases/figure06/summa_fileManager_reynoldsVariableDecayRate.txt diff --git a/test_ngen/domain_provo/settings/SUMMA/outputControl.txt b/test_ngen/domain_provo/settings/SUMMA/outputControl.txt new file mode 100755 index 000000000..c76453e56 --- /dev/null +++ b/test_ngen/domain_provo/settings/SUMMA/outputControl.txt @@ -0,0 +1,33 @@ +! ------------- +! attributes +! ------------- +hruId +latitude +longitude +! +! ----------- +! forcings +! ----------- +pptrate | 1 +airtemp | 1 +! +! +! ------------------- +! model variables +! ------------------- +averageRoutedRunoff | 1 +scalarSWE | 24 +scalarGroundSnowFraction | 24 +scalarLatHeatTotal | 24 +scalarSenHeatTotal | 24 +scalarNetRadiation | 24 +scalarCanopyTranspiration | 24 +scalarCanopyEvaporation | 24 +scalarGroundEvaporation | 24 +scalarCanopySublimation | 24 +scalarSnowSublimation | 24 +mLayerDepth | 24 +mLayerVolFracLiq | 24 +scalarTotalET | 24 + + diff --git a/test_ngen/domain_provo/settings/SUMMA/trialParams.nc b/test_ngen/domain_provo/settings/SUMMA/trialParams.nc new file mode 100755 index 000000000..b6a0385dd Binary files /dev/null and b/test_ngen/domain_provo/settings/SUMMA/trialParams.nc differ diff --git a/test_ngen/domain_provo/settings/cat-2863621.input b/test_ngen/domain_provo/settings/cat-2863621.input new file mode 100644 index 000000000..7f72979c3 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863621.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 7 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863622.input b/test_ngen/domain_provo/settings/cat-2863622.input new file mode 100644 index 000000000..f90bae471 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863622.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 42 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863623.input b/test_ngen/domain_provo/settings/cat-2863623.input new file mode 100644 index 000000000..e90329933 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863623.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 43 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863624.input b/test_ngen/domain_provo/settings/cat-2863624.input new file mode 100644 index 000000000..bdd7325b4 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863624.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 44 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863625.input b/test_ngen/domain_provo/settings/cat-2863625.input new file mode 100644 index 000000000..e8b468794 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863625.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 1 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863626.input b/test_ngen/domain_provo/settings/cat-2863626.input new file mode 100644 index 000000000..538a5948f --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863626.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 8 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863627.input b/test_ngen/domain_provo/settings/cat-2863627.input new file mode 100644 index 000000000..8ffd1a571 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863627.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 47 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863628.input b/test_ngen/domain_provo/settings/cat-2863628.input new file mode 100644 index 000000000..23c09009e --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863628.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 49 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863629.input b/test_ngen/domain_provo/settings/cat-2863629.input new file mode 100644 index 000000000..d9a768e16 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863629.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 52 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863630.input b/test_ngen/domain_provo/settings/cat-2863630.input new file mode 100644 index 000000000..66ec3ac7e --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863630.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 53 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863631.input b/test_ngen/domain_provo/settings/cat-2863631.input new file mode 100644 index 000000000..6365e0e0c --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863631.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 9 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863808.input b/test_ngen/domain_provo/settings/cat-2863808.input new file mode 100644 index 000000000..55b5da732 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863808.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 10 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863809.input b/test_ngen/domain_provo/settings/cat-2863809.input new file mode 100644 index 000000000..a95d7d822 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863809.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 50 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863810.input b/test_ngen/domain_provo/settings/cat-2863810.input new file mode 100644 index 000000000..14d11d94a --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863810.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 2 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863811.input b/test_ngen/domain_provo/settings/cat-2863811.input new file mode 100644 index 000000000..8cc97150a --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863811.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 51 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863812.input b/test_ngen/domain_provo/settings/cat-2863812.input new file mode 100644 index 000000000..c975b349f --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863812.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 11 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863813.input b/test_ngen/domain_provo/settings/cat-2863813.input new file mode 100644 index 000000000..228b2255e --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863813.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 48 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863814.input b/test_ngen/domain_provo/settings/cat-2863814.input new file mode 100644 index 000000000..9fbbc670a --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863814.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 3 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863815.input b/test_ngen/domain_provo/settings/cat-2863815.input new file mode 100644 index 000000000..455c866b4 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863815.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 45 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863816.input b/test_ngen/domain_provo/settings/cat-2863816.input new file mode 100644 index 000000000..58b625097 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863816.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 46 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863817.input b/test_ngen/domain_provo/settings/cat-2863817.input new file mode 100644 index 000000000..d7a55dd35 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863817.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 41 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863818.input b/test_ngen/domain_provo/settings/cat-2863818.input new file mode 100644 index 000000000..f73f9abc9 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863818.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 40 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863819.input b/test_ngen/domain_provo/settings/cat-2863819.input new file mode 100644 index 000000000..877aede16 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863819.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 39 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863820.input b/test_ngen/domain_provo/settings/cat-2863820.input new file mode 100644 index 000000000..da555c6db --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863820.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 38 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863821.input b/test_ngen/domain_provo/settings/cat-2863821.input new file mode 100644 index 000000000..9fb529914 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863821.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 33 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863822.input b/test_ngen/domain_provo/settings/cat-2863822.input new file mode 100644 index 000000000..ea39e0fbe --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863822.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 4 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863823.input b/test_ngen/domain_provo/settings/cat-2863823.input new file mode 100644 index 000000000..70da3fe8f --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863823.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 37 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863824.input b/test_ngen/domain_provo/settings/cat-2863824.input new file mode 100644 index 000000000..7098931f4 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863824.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 12 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863825.input b/test_ngen/domain_provo/settings/cat-2863825.input new file mode 100644 index 000000000..a922937b1 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863825.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 34 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863826.input b/test_ngen/domain_provo/settings/cat-2863826.input new file mode 100644 index 000000000..7ff784997 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863826.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 36 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863827.input b/test_ngen/domain_provo/settings/cat-2863827.input new file mode 100644 index 000000000..6ff49d6b9 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863827.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 35 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863828.input b/test_ngen/domain_provo/settings/cat-2863828.input new file mode 100644 index 000000000..c27cb8dc9 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863828.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 13 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863829.input b/test_ngen/domain_provo/settings/cat-2863829.input new file mode 100644 index 000000000..223ed3324 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863829.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 27 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863830.input b/test_ngen/domain_provo/settings/cat-2863830.input new file mode 100644 index 000000000..30cf57b74 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863830.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 14 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863831.input b/test_ngen/domain_provo/settings/cat-2863831.input new file mode 100644 index 000000000..e6f0b71f1 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863831.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 31 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863832.input b/test_ngen/domain_provo/settings/cat-2863832.input new file mode 100644 index 000000000..7f22b30dc --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863832.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 32 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863833.input b/test_ngen/domain_provo/settings/cat-2863833.input new file mode 100644 index 000000000..3276c3344 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863833.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 30 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863834.input b/test_ngen/domain_provo/settings/cat-2863834.input new file mode 100644 index 000000000..db4c1bf59 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863834.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 29 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863835.input b/test_ngen/domain_provo/settings/cat-2863835.input new file mode 100644 index 000000000..759b9bc56 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863835.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 28 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863836.input b/test_ngen/domain_provo/settings/cat-2863836.input new file mode 100644 index 000000000..d7d7e6bed --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863836.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 5 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863837.input b/test_ngen/domain_provo/settings/cat-2863837.input new file mode 100644 index 000000000..4f7fb03c3 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863837.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 6 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863838.input b/test_ngen/domain_provo/settings/cat-2863838.input new file mode 100644 index 000000000..b7dd7bcf0 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863838.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 25 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863839.input b/test_ngen/domain_provo/settings/cat-2863839.input new file mode 100644 index 000000000..31403206f --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863839.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 26 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863840.input b/test_ngen/domain_provo/settings/cat-2863840.input new file mode 100644 index 000000000..25fe04d1a --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863840.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 15 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863841.input b/test_ngen/domain_provo/settings/cat-2863841.input new file mode 100644 index 000000000..be01e097d --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863841.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 16 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863842.input b/test_ngen/domain_provo/settings/cat-2863842.input new file mode 100644 index 000000000..a371f38ca --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863842.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 17 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863843.input b/test_ngen/domain_provo/settings/cat-2863843.input new file mode 100644 index 000000000..45dd55b80 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863843.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 18 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863844.input b/test_ngen/domain_provo/settings/cat-2863844.input new file mode 100644 index 000000000..1fd93fd2a --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863844.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 24 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863845.input b/test_ngen/domain_provo/settings/cat-2863845.input new file mode 100644 index 000000000..0f5de0093 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863845.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 23 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863846.input b/test_ngen/domain_provo/settings/cat-2863846.input new file mode 100644 index 000000000..516ade020 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863846.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 19 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863847.input b/test_ngen/domain_provo/settings/cat-2863847.input new file mode 100644 index 000000000..e997280dc --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863847.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 20 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863848.input b/test_ngen/domain_provo/settings/cat-2863848.input new file mode 100644 index 000000000..bcfbe719d --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863848.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 22 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/cat-2863849.input b/test_ngen/domain_provo/settings/cat-2863849.input new file mode 100644 index 000000000..ecd8e8639 --- /dev/null +++ b/test_ngen/domain_provo/settings/cat-2863849.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/domain_provo/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 21 + restart_print_freq = "e" +/ diff --git a/test_ngen/domain_provo/settings/gage-10154200_subset.gpkg b/test_ngen/domain_provo/settings/gage-10154200_subset.gpkg new file mode 100644 index 000000000..8041b76ff Binary files /dev/null and b/test_ngen/domain_provo/settings/gage-10154200_subset.gpkg differ diff --git a/test_ngen/domain_provo/settings/provo_realization_config_w_summa_bmi.json b/test_ngen/domain_provo/settings/provo_realization_config_w_summa_bmi.json new file mode 100644 index 000000000..4324665c2 --- /dev/null +++ b/test_ngen/domain_provo/settings/provo_realization_config_w_summa_bmi.json @@ -0,0 +1,51 @@ +{ + "global": { + "formulations": [ + { + "name": "bmi_multi", + "params": { + "model_type_name": "bmi_multi_summa", + "forcing_file": "", + "init_config": "", + "allow_exceed_end_time": true, + "main_output_variable": "land_surface_water__runoff_volume_flux", + "modules": [ + { + "name": "bmi_fortran", + "params": { + "model_type_name": "bmi_fortran_summa", + "library_file": "./extern/summa/cmake_build/libsummabmi", + "forcing_file": "", + "init_config": "./extern/summa/summa/test_ngen/domain_provo/settings/{{id}}.input", + "allow_exceed_end_time": true, + "main_output_variable": "land_surface_water__runoff_volume_flux", + "variables_names_map": { + "atmosphere_water__precipitation_mass_flux": "precip_rate", + "land_surface_air__temperature": "TMP_2maboveground", + "atmosphere_air_water~vapor__relative_saturation": "SPFH_2maboveground", + "land_surface_wind__x_component_of_velocity": "UGRD_10maboveground", + "land_surface_wind__y_component_of_velocity": "VGRD_10maboveground", + "land_surface_radiation~incoming~shortwave__energy_flux": "DSWRF_surface", + "land_surface_radiation~incoming~longwave__energy_flux": "DLWRF_surface", + "land_surface_air__pressure": "PRES_surface" + }, + "uses_forcing_file": false + } + } + ], + "uses_forcing_file": false + } + } + ], + "forcing": { + "path": "./extern/summa/summa/test_ngen/domain_provo/forcing/forcings.nc", + "provider": "NetCDF" + } + }, + "time": { + "start_time": "2017-10-01 1:00:00", + "end_time": "2022-09-30 23:00:00", + "output_interval": 3600 + }, + "output_root": "./extern/summa/summa/test_ngen/domain_provo/simulations/" +} diff --git a/test_ngen/domain_provo/settings/provo_realization_config_w_summa_bmi_routing.json b/test_ngen/domain_provo/settings/provo_realization_config_w_summa_bmi_routing.json new file mode 100644 index 000000000..1e8e7359c --- /dev/null +++ b/test_ngen/domain_provo/settings/provo_realization_config_w_summa_bmi_routing.json @@ -0,0 +1,54 @@ +{ + "global": { + "formulations": [ + { + "name": "bmi_multi", + "params": { + "model_type_name": "bmi_multi_summa", + "forcing_file": "", + "init_config": "", + "allow_exceed_end_time": true, + "main_output_variable": "land_surface_water__runoff_volume_flux", + "modules": [ + { + "name": "bmi_fortran", + "params": { + "model_type_name": "bmi_fortran_summa", + "library_file": "./extern/summa/cmake_build/libsummabmi", + "forcing_file": "", + "init_config": "./extern/summa/summa/test_ngen/domain_provo/settings/{{id}}.input", + "allow_exceed_end_time": true, + "main_output_variable": "land_surface_water__runoff_volume_flux", + "variables_names_map": { + "atmosphere_water__precipitation_mass_flux": "precip_rate", + "land_surface_air__temperature": "TMP_2maboveground", + "atmosphere_air_water~vapor__relative_saturation": "SPFH_2maboveground", + "land_surface_wind__x_component_of_velocity": "UGRD_10maboveground", + "land_surface_wind__y_component_of_velocity": "VGRD_10maboveground", + "land_surface_radiation~incoming~shortwave__energy_flux": "DSWRF_surface", + "land_surface_radiation~incoming~longwave__energy_flux": "DLWRF_surface", + "land_surface_air__pressure": "PRES_surface" + }, + "uses_forcing_file": false + } + } + ], + "uses_forcing_file": false + } + } + ], + "forcing": { + "path": "./extern/summa/summa/test_ngen/domain_provo/forcing/forcings.nc", + "provider": "NetCDF" + } + }, + "time": { + "start_time": "2017-10-01 1:00:00", + "end_time": "2022-09-30 23:00:00", + "output_interval": 3600 + }, + "output_root": "./extern/summa/summa/test_ngen/domain_provo/simulations/", + "routing": { + "t_route_config_file_with_path": "./extern/summa/summa/test_ngen/provo_routing.yaml" + } +} diff --git a/test_ngen/domain_provo/settings/provo_routing.yaml b/test_ngen/domain_provo/settings/provo_routing.yaml new file mode 100644 index 000000000..f7884f27b --- /dev/null +++ b/test_ngen/domain_provo/settings/provo_routing.yaml @@ -0,0 +1,79 @@ +#-------------------------------------------------------------------------------- +log_parameters: + #---------- + showtiming: True + log_level : DEBUG +#-------------------------------------------------------------------------------- +network_topology_parameters: + #---------- + supernetwork_parameters: + #---------- + network_type: HYFeaturesNetwork + geo_file_path: ./extern/summa/summa/test_ngen/domain_provo/settings/gage-10154200_subset.gpkg + columns: + key: 'id' + downstream: 'toid' + dx : 'lengthkm' + n : 'n' + ncc : 'nCC' + s0 : 'So' + bw : 'BtmWdth' + waterbody : 'rl_NHDWaterbodyComID' + gages : 'rl_gages' + tw : 'TopWdth' + twcc : 'TopWdthCC' + musk : 'MusK' + musx : 'MusX' + cs : 'ChSlp' + alt: 'alt' + mainstem: 'mainstem' + #duplicate_wb_segments: None + waterbody_parameters: + #---------- + break_network_at_waterbodies: False +#-------------------------------------------------------------------------------- +compute_parameters: + #---------- + parallel_compute_method: by-subnetwork-jit-clustered #serial + compute_kernel : V02-structured + assume_short_ts : True + subnetwork_target_size : 10000 + cpu_pool : 1 + restart_parameters: + #---------- + start_datetime: "2017-10-01_01:00:00" + forcing_parameters: + #---------- + qts_subdivisions : 12 + dt : 300 # [sec] + qlat_input_folder : ./extern/summa/summa/test_ngen/domain_provo/simulations/ + qlat_file_pattern_filter : "nex-*" + binary_nexus_file_folder : #./ #NOTE: If memory issues arise while preprocessing forcing data, use this to create hourly binary files for forcing data. + nts : 2880 #288 for 1day + max_loop_size : 240 # [hr] + data_assimilation_parameters: + #---------- + #usgs_timeslices_folder : ./usgs_TimeSlice/ + #usace_timeslices_folder : usace_TimeSlice/ + #timeslice_lookback_hours : 48 + #qc_threshold : 1 + streamflow_da: + #---------- + streamflow_nudging: False + reservoir_da: + #---------- + reservoir_persistence_da: + #---------- + reservoir_persistence_usgs : False + reservoir_persistence_usace: False + reservoir_rfc_da: + #---------- + reservoir_rfc_forecasts: False +#-------------------------------------------------------------------------------- +output_parameters: + #---------- + stream_output : + stream_output_directory: ./extern/summa/summa/test_ngen/domain_provo/simulations/ + stream_output_time: 1 #[hr] + stream_output_type: '.nc' #please select only between netcdf '.nc' or '.csv' or '.pkl' + stream_output_internal_frequency: 60 #[min] it should be order of 5 minutes. For instance if you want to output every hour put 60 diff --git a/test_ngen/example_run.sh b/test_ngen/example_run.sh new file mode 100755 index 000000000..02ac9fd81 --- /dev/null +++ b/test_ngen/example_run.sh @@ -0,0 +1,8 @@ +#./cmake_build/ngen ./test/data/routing/gauge_01073000.gpkg '' ./test/data/routing/gauge_01073000.gpkg '' ./extern/summa/summa/test_ngen/gauge_01073000/settings/example_realization_config_w_summa_bmi_routing.json + +./cmake_build/ngen ./test/data/routing/gauge_01073000.gpkg '' ./test/data/routing/gauge_01073000.gpkg '' ./extern/summa/summa/test_ngen/gauge_01073000/settings/example_realization_config_w_summa_bmi.json +python -m nwm_routing -V4 -f ./test/data/routing/ngen_routing_config_unit_test.yaml + +#./cmake_build/ngen ./test/data/routing/gauge_01073000.gpkg '' ./test/data/routing/gauge_01073000.gpkg '' ./data/gauge_01073000/example_bmi_multi_realization_config_w_routing.json + +rm test/data/routing/*.parquet diff --git a/test_ngen/gauge_01073000/forcing/SUMMA_input/summa_forcing.nc b/test_ngen/gauge_01073000/forcing/SUMMA_input/summa_forcing.nc new file mode 100644 index 000000000..275432861 Binary files /dev/null and b/test_ngen/gauge_01073000/forcing/SUMMA_input/summa_forcing.nc differ diff --git a/test_ngen/gauge_01073000/forcing/SUMMA_input/summa_forcing_from_ngen.nc b/test_ngen/gauge_01073000/forcing/SUMMA_input/summa_forcing_from_ngen.nc new file mode 100644 index 000000000..0b52fd8f6 Binary files /dev/null and b/test_ngen/gauge_01073000/forcing/SUMMA_input/summa_forcing_from_ngen.nc differ diff --git a/test_ngen/gauge_01073000/forcing/SUMMA_input/summa_forcing_tiled_by_hru.nc b/test_ngen/gauge_01073000/forcing/SUMMA_input/summa_forcing_tiled_by_hru.nc new file mode 100644 index 000000000..d7f1fad46 Binary files /dev/null and b/test_ngen/gauge_01073000/forcing/SUMMA_input/summa_forcing_tiled_by_hru.nc differ diff --git a/test_ngen/gauge_01073000/forcing/ngen_forcing_from_summa.nc b/test_ngen/gauge_01073000/forcing/ngen_forcing_from_summa.nc new file mode 100644 index 000000000..3070f1de7 Binary files /dev/null and b/test_ngen/gauge_01073000/forcing/ngen_forcing_from_summa.nc differ diff --git a/test_ngen/gauge_01073000/settings/SUMMA/README.md b/test_ngen/gauge_01073000/settings/SUMMA/README.md new file mode 100644 index 000000000..aa8c149d4 --- /dev/null +++ b/test_ngen/gauge_01073000/settings/SUMMA/README.md @@ -0,0 +1,22 @@ +# SUMMA base settings +Recall that a SUMMA Grouped Response Unit (GRU) contains at least one but possibly more Hydrologic Response Units (HRUs). + +#### basinParamInfo.txt +GRU-level parameters. These control the properties of the aquifer that the HRUs share in certain model setups and the settings for within-GRU routing. The shared aquifer is disabled if all HRUs are modeled as independent soil columns; see setting "settings_summa_connect_HRUs" in the control file. Within-GRU routing is controlled by the model decision `subRouting`. In the default setup in this workflow, this decision is set to `timeDlay` which means that within-GRU routing is active. Note that this means that the mizuRoute setting `doesBasinRoute` should be set to `0` to avoid the water inside a given GRU being routed twice. See: +- https://summa.readthedocs.io/en/latest/input_output/SUMMA_input/#attribute-and-parameter-files + +#### localParamInfo.txt +HRU-level parameters. First column is the default value. Second and third columns provide plausible ranges that are currently not used by SUMMA (but must be provided regardless). These columns may be used in the future for built-in parameter sampling or sensitivity analysis. See: +- https://summa.readthedocs.io/en/latest/input_output/SUMMA_input/#attribute-and-parameter-files + +#### modelDecisions.txt +Controls the modeling options active within SUMMA. Note that with the current workflow, modeling option `qTopmodl` for decision `groundwatr` should not be used, because the required geospatial parameters are not defined. To use the `qTopmodl` option parameters `tan_slope` and `contourLength` must be set to appropriate values for each HRU in the attributes `.nc` file. As mentioned above, option `timeDlay` for decision `subRouting` should not be used at the same time as mizuRoute's `doesBasinRoute` option. See: +- https://summa.readthedocs.io/en/latest/input_output/SUMMA_input/#model-decisions-file + +#### outputControl.txt +Controls which variables SUMMA writes to the output files. See: +- https://summa.readthedocs.io/en/latest/input_output/SUMMA_input/#output-control-file +- https://summa.readthedocs.io/en/latest/input_output/SUMMA_output/ + +#### `*.TBL` +Contain the lookup tables used for soil parameters (`TBL_SOIL_PARM.TBL`) and vegetation parameters (`TBL_VEGPARM.TBL`). Files `TBL_GENPARM.TBL` and `TBL_MPTABLE.TBL` are legacy files that are no longer used but still need to be provided. \ No newline at end of file diff --git a/test_ngen/gauge_01073000/settings/SUMMA/TBL_GENPARM.TBL b/test_ngen/gauge_01073000/settings/SUMMA/TBL_GENPARM.TBL new file mode 100644 index 000000000..17fc9172b --- /dev/null +++ b/test_ngen/gauge_01073000/settings/SUMMA/TBL_GENPARM.TBL @@ -0,0 +1,36 @@ +General Parameters +SLOPE_DATA +9 +0.1 +0.6 +1.0 +0.35 +0.55 +0.8 +0.63 +0.0 +0.0 +SBETA_DATA +-2.0 +FXEXP_DATA +2.0 +CSOIL_DATA +2.00E+6 +SALP_DATA +2.6 +REFDK_DATA +2.0E-6 +REFKDT_DATA +3.0 +FRZK_DATA +0.15 +ZBOT_DATA +-8.0 +CZIL_DATA +0.1 +SMLOW_DATA +0.5 +SMHIGH_DATA +3.0 +LVCOEF_DATA +0.5 diff --git a/test_ngen/gauge_01073000/settings/SUMMA/TBL_MPTABLE.TBL b/test_ngen/gauge_01073000/settings/SUMMA/TBL_MPTABLE.TBL new file mode 100644 index 000000000..cbafef9bb --- /dev/null +++ b/test_ngen/gauge_01073000/settings/SUMMA/TBL_MPTABLE.TBL @@ -0,0 +1,411 @@ +&noah_mp_usgs_veg_categories + VEG_DATASET_DESCRIPTION = "USGS" + NVEG = 27 +/ +&noah_mp_usgs_parameters + ! NVEG = 27 + ! 1: Urban and Built-Up Land + ! 2: Dryland Cropland and Pasture + ! 3: Irrigated Cropland and Pasture + ! 4: Mixed Dryland/Irrigated Cropland and Pasture + ! 5: Cropland/Grassland Mosaic + ! 6: Cropland/Woodland Mosaic + ! 7: Grassland + ! 8: Shrubland + ! 9: Mixed Shrubland/Grassland + ! 10: Savanna + ! 11: Deciduous Broadleaf Forest + ! 12: Deciduous Needleleaf Forest + ! 13: Evergreen Broadleaf Forest + ! 14: Evergreen Needleleaf Forest + ! 15: Mixed Forest + ! 16: Water Bodies + ! 17: Herbaceous Wetland + ! 18: Wooded Wetland + ! 19: Barren or Sparsely Vegetated + ! 20: Herbaceous Tundra + ! 21: Wooded Tundra + ! 22: Mixed Tundra + ! 23: Bare Ground Tundra + ! 24: Snow or Ice + ! 25: Playa + ! 26: Lava + ! 27: White Sand + + ISURBAN = 1 + ISWATER = 16 + ISBARREN = 19 + ISSNOW = 24 + EBLFOREST = 13 + + !--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- + ! 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 + !--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- + CH2OP = 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, + DLEAF = 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, + Z0MVT = 1.00, 0.15, 0.15, 0.15, 0.14, 0.50, 0.12, 0.06, 0.09, 0.50, 0.80, 0.85, 1.10, 1.09, 0.80, 0.00, 0.12, 0.50, 0.00, 0.10, 0.30, 0.20, 0.03, 0.00, 0.01, 0.00, 0.00, + HVT = 15.0, 2.00, 2.00, 2.00, 1.50, 8.00, 1.00, 1.10, 1.10, 10.0, 16.0, 18.0, 20.0, 20.0, 16.0, 0.00, 0.50, 10.0, 0.00, 0.50, 4.00, 2.00, 0.50, 0.00, 0.10, 0.00, 0.00, + HVB = 1.00, 0.10, 0.10, 0.10, 0.10, 0.15, 0.05, 0.10, 0.10, 0.10, 11.5, 7.00, 8.00, 8.50, 10.0, 0.00, 0.05, 0.10, 0.00, 0.10, 0.10, 0.10, 0.10, 0.00, 0.10, 0.00, 0.00, + DEN = 0.01, 25.0, 25.0, 25.0, 25.0, 25.0, 100., 10.0, 10.0, 0.02, 0.10, 0.28, 0.02, 0.28, 0.10, 0.01, 10.0, 0.10, 0.01, 1.00, 1.00, 1.00, 1.00, 0.00, 0.01, 0.01, 0.01, + RC = 1.00, 0.08, 0.08, 0.08, 0.08, 0.08, 0.03, 0.12, 0.12, 3.00, 1.40, 1.20, 3.60, 1.20, 1.40, 0.01, 0.10, 1.40, 0.01, 0.30, 0.30, 0.30, 0.30, 0.00, 0.01, 0.01, 0.01, + + ! Row 1: Vis + ! Row 2: Near IR + RHOL = 0.00, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.07, 0.10, 0.10, 0.10, 0.07, 0.10, 0.07, 0.10, 0.00, 0.11, 0.10, 0.00, 0.10, 0.10, 0.10, 0.10, 0.00, 0.10, 0.00, 0.00, + 0.00, 0.58, 0.58, 0.58, 0.58, 0.58, 0.58, 0.35, 0.45, 0.45, 0.45, 0.35, 0.45, 0.35, 0.45, 0.00, 0.58, 0.45, 0.00, 0.45, 0.45, 0.45, 0.45, 0.00, 0.45, 0.00, 0.00, + + ! Row 1: Vis + ! Row 2: Near IR + RHOS = 0.00, 0.36, 0.36, 0.36, 0.36, 0.36, 0.36, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.00, 0.36, 0.16, 0.00, 0.16, 0.16, 0.16, 0.16, 0.00, 0.16, 0.00, 0.00, + 0.00, 0.58, 0.58, 0.58, 0.58, 0.58, 0.58, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.00, 0.58, 0.39, 0.00, 0.39, 0.39, 0.39, 0.39, 0.00, 0.39, 0.00, 0.00, + + ! Row 1: Vis + ! Row 2: Near IR + TAUL = 0.00, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.00, 0.07, 0.05, 0.00, 0.05, 0.05, 0.05, 0.05, 0.00, 0.05, 0.00, 0.00, + 0.00, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.10, 0.10, 0.25, 0.25, 0.10, 0.25, 0.10, 0.25, 0.00, 0.25, 0.25, 0.00, 0.25, 0.25, 0.25, 0.25, 0.00, 0.25, 0.00, 0.00, + + ! Row 1: Vis + ! Row 2: Near IR + TAUS = 0.000, 0.220, 0.220, 0.220, 0.220, 0.220, 0.220, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.000, 0.220, 0.001, 0.000, 0.220, 0.001, 0.001, 0.001, 0.000, 0.001, 0.000, 0.000, + 0.000, 0.380, 0.380, 0.380, 0.380, 0.380, 0.380, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.000, 0.380, 0.001, 0.000, 0.380, 0.001, 0.001, 0.001, 0.000, 0.001, 0.000, 0.000, + + XL = 0.000, -0.30, -0.30, -0.30, -0.30, -0.30, -0.30, 0.010, 0.250, 0.010, 0.250, 0.010, 0.010, 0.010, 0.250, 0.000, -0.30, 0.250, 0.000, -0.30, 0.250, 0.250, 0.250, 0.000, 0.250, 0.000, 0.000, +! CWPVT = 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, + CWPVT = 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, + C3PSN = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, + KC25 = 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, + AKC = 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, + KO25 = 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, + AKO = 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, + AVCMX = 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, + AQE = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, + + LTOVRC= 0.0, 1.2, 1.2, 1.2, 1.2, 1.30, 0.50, 0.65, 0.70, 0.65, 0.55, 0.2, 0.55, 0.5, 0.5, 0.0, 1.4, 1.4, 0.0, 1.2, 1.3, 1.4, 1.0, 0.0, 1.0, 0.0, 0.0, + DILEFC= 0.00, 0.50, 0.50, 0.50, 0.35, 0.20, 0.20, 0.20, 0.50, 0.50, 0.60, 1.80, 0.50, 1.20, 0.80, 0.00, 0.40, 0.40, 0.00, 0.40, 0.30, 0.40, 0.30, 0.00, 0.30, 0.00, 0.00, + DILEFW= 0.00, 0.20, 0.20, 0.20, 0.20, 0.20, 0.10, 0.20, 0.20, 0.50, 0.20, 0.20, 4.00, 0.20, 0.20, 0.00, 0.20, 0.20, 0.00, 0.20, 0.20, 0.20, 0.20, 0.00, 0.20, 0.00, 0.00, + RMF25 = 0.00, 1.00, 1.40, 1.45, 1.45, 1.45, 1.80, 0.26, 0.26, 0.80, 3.00, 4.00, 0.65, 3.00, 3.00, 0.00, 3.20, 3.20, 0.00, 3.20, 3.00, 3.00, 3.00, 0.00, 3.00, 0.00, 0.00, + SLA = 60, 80, 80, 80, 80, 80, 60, 60, 60, 50, 80, 80, 80, 80, 80, 0, 80, 80, 0, 80, 80, 80, 80, 0, 80, 0, 0, + FRAGR = 0.00, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.10, 0.20, 0.10, 0.10, 0.00, 0.10, 0.10, 0.10, 0.10, 0.10, 0.10, 0.10, 0.00, 0.10, 0.00, 0.00, + TMIN = 0, 273, 273, 273, 273, 273, 273, 273, 273, 273, 273, 268, 273, 265, 268, 0, 268, 268, 0, 268, 268, 268, 268, 0, 268, 0, 0, + VCMX25= 0.00, 80.0, 80.0, 80.0, 60.0, 70.0, 40.0, 40.0, 40.0, 40.0, 60.0, 60.0, 60.0, 50.0, 55.0, 0.00, 50.0, 50.0, 0.00, 50.0, 50.0, 50.0, 50.0, 0.00, 50.0, 0.00, 0.00, + TDLEF = 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 268, 278, 278, 268, 0, 268, 268, 0, 268, 268, 268, 268, 0, 268, 0, 0, + BP = 1.E15, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 1.E15, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 1.E15, 2.E3, 1.E15, 1.E15, + MP = 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 6., 9., 6., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., + QE25 = 0., 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.00, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.00, 0.06, 0.00, 0.00, + RMS25 = 0.00, 0.10, 0.10, 0.10, 0.10, 0.10, 0.10, 0.10, 0.10, 0.32, 0.10, 0.64, 0.30, 0.90, 0.80, 0.00, 0.10, 0.10, 0.00, 0.10, 0.10, 0.10, 0.00, 0.00, 0.00, 0.00, 0.00, + RMR25 = 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 1.20, 0.00, 0.00, 0.01, 0.01, 0.05, 0.05, 0.36, 0.03, 0.00, 0.00, 0.00, 0.00, 2.11, 2.11, 2.11, 0.00, 0.00, 0.00, 0.00, 0.00, + ARM = 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, + FOLNMX= 0.00, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 0.00, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 0.00, 1.5, 0.00, 0.00, + WDPOOL= 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 0.00, 0.00, 1.00, 0.00, 0.00, 1.00, 1.00, 0.00, 0.00, 0.00, 0.00, 0.00, + WRRAT = 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 3.00, 3.00, 3.00, 30.0, 30.0, 30.0, 30.0, 30.0, 0.00, 0.00, 30.0, 0.00, 0.00, 3.00, 3.00, 0.00, 0.00, 0.00, 0.00, 0.00, + MRP = 0.00, 0.23, 0.23, 0.23, 0.23, 0.23, 0.17, 0.19, 0.19, 0.40, 0.40, 0.37, 0.23, 0.37, 0.30, 0.00, 0.17, 0.40, 0.00, 0.17, 0.23, 0.20, 0.00, 0.00, 0.20, 0.00, 0.00, + +! Monthly values, one row for each month: + SAIM = 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.3, 0.5, 0.4, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.3, 0.5, 0.4, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.3, 0.5, 0.4, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.4, 0.5, 0.3, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 0.2, 0.2, 0.2, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.4, 0.5, 0.4, 0.4, 0.0, 0.3, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 0.3, 0.3, 0.3, 0.4, 0.4, 0.4, 0.2, 0.3, 0.4, 0.4, 0.7, 0.5, 0.5, 0.4, 0.0, 0.4, 0.4, 0.0, 0.2, 0.2, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 0.4, 0.4, 0.4, 0.6, 0.6, 0.8, 0.4, 0.6, 0.8, 0.9, 1.3, 0.5, 0.5, 0.7, 0.0, 0.6, 0.6, 0.0, 0.4, 0.4, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 0.5, 0.5, 0.5, 0.9, 0.9, 1.3, 0.6, 0.9, 1.2, 1.2, 1.2, 0.5, 0.6, 0.8, 0.0, 0.9, 0.9, 0.0, 0.6, 0.6, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 0.4, 0.4, 0.4, 0.7, 1.0, 1.1, 0.8, 1.0, 1.3, 1.6, 1.0, 0.5, 0.6, 1.0, 0.0, 0.7, 1.0, 0.0, 0.7, 0.8, 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 0.3, 0.3, 0.3, 0.3, 0.8, 0.4, 0.7, 0.6, 0.7, 1.4, 0.8, 0.5, 0.7, 1.0, 0.0, 0.3, 0.8, 0.0, 0.5, 0.7, 0.5, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 0.3, 0.3, 0.3, 0.3, 0.4, 0.4, 0.3, 0.3, 0.4, 0.6, 0.6, 0.5, 0.6, 0.5, 0.0, 0.3, 0.4, 0.0, 0.3, 0.3, 0.3, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.4, 0.2, 0.3, 0.4, 0.4, 0.5, 0.5, 0.5, 0.4, 0.0, 0.3, 0.4, 0.0, 0.2, 0.2, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, + + LAIM = 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.4, 0.0, 0.2, 0.3, 0.0, 0.0, 4.5, 4.0, 2.0, 0.0, 0.2, 0.2, 0.0, 0.2, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.5, 0.0, 0.3, 0.3, 0.0, 0.0, 4.5, 4.0, 2.0, 0.0, 0.3, 0.3, 0.0, 0.3, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 0.0, 0.0, 0.0, 0.3, 0.2, 0.6, 0.2, 0.4, 0.5, 0.3, 0.0, 4.5, 4.0, 2.2, 0.0, 0.3, 0.3, 0.0, 0.3, 1.1, 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 0.0, 0.0, 0.0, 0.4, 0.6, 0.7, 0.6, 0.7, 0.8, 1.2, 0.6, 4.5, 4.0, 2.6, 0.0, 0.4, 0.6, 0.0, 0.4, 1.3, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 1.0, 1.0, 1.0, 1.1, 2.0, 1.2, 1.5, 1.4, 1.8, 3.0, 1.2, 4.5, 4.0, 3.5, 0.0, 1.1, 2.0, 0.0, 0.6, 1.7, 1.2, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 2.0, 2.0, 2.0, 2.5, 3.3, 3.0, 2.3, 2.6, 3.6, 4.7, 2.0, 4.5, 4.0, 4.3, 0.0, 2.5, 3.3, 0.0, 1.5, 2.1, 1.8, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 3.0, 3.0, 3.0, 3.2, 3.7, 3.5, 2.3, 2.9, 3.8, 4.5, 2.6, 4.5, 4.0, 4.3, 0.0, 3.2, 3.7, 0.0, 1.7, 2.1, 1.8, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 3.0, 3.0, 3.0, 2.2, 3.2, 1.5, 1.7, 1.6, 2.1, 3.4, 1.7, 4.5, 4.0, 3.7, 0.0, 2.2, 3.2, 0.0, 0.8, 1.8, 1.3, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 1.5, 1.5, 1.5, 1.1, 1.3, 0.7, 0.6, 0.7, 0.9, 1.2, 1.0, 4.5, 4.0, 2.6, 0.0, 1.1, 1.3, 0.0, 0.4, 1.3, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 0.0, 0.0, 0.0, 0.3, 0.2, 0.6, 0.2, 0.4, 0.5, 0.3, 0.5, 4.5, 4.0, 2.2, 0.0, 0.3, 0.3, 0.0, 0.3, 1.1, 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.5, 0.0, 0.3, 0.3, 0.0, 0.2, 4.5, 4.0, 2.0, 0.0, 0.3, 0.3, 0.0, 0.2, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.4, 0.0, 0.2, 0.3, 0.0, 0.0, 4.5, 4.0, 2.0, 0.0, 0.2, 0.2, 0.0, 0.2, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + + SLAREA=0.0228,0.0200,0.0200,0.0295,0.0223,0.0277,0.0060,0.0227,0.0188,0.0236,0.0258,0.0200,0.0200,0.0090,0.0223,0.0422,0.0390, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, + +! Five types, one row for each type. + EPS = 41.87, 0.00, 0.00, 2.52, 0.04, 17.11, 0.02, 21.62, 0.11, 22.80, 46.86, 0.00, 0.00, 0.46, 30.98, 2.31, 1.63, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.98, 0.00, 0.00, 0.16, 0.09, 0.28, 0.05, 0.92, 0.22, 0.59, 0.38, 0.00, 0.00, 3.34, 0.96, 1.47, 1.07, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + 1.82, 0.00, 0.00, 0.23, 0.05, 0.81, 0.03, 1.73, 1.26, 1.37, 1.84, 0.00, 0.00, 1.85, 1.84, 1.70, 1.21, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, +/ + +&noah_mp_modis_veg_categories + VEG_DATASET_DESCRIPTION = "modified igbp modis noah" + NVEG = 20 +/ + +&noah_mp_modis_veg_categories + VEG_DATASET_DESCRIPTION = "modified igbp modis noah" + NVEG = 20 +/ + +&noah_mp_modis_parameters +! 1 'Evergreen Needleleaf Forest' -> USGS 14 +! 2, 'Evergreen Broadleaf Forest' -> USGS 13 +! 3, 'Deciduous Needleleaf Forest' -> USGS 12 +! 4, 'Deciduous Broadleaf Forest' -> USGS 11 +! 5, 'Mixed Forests' -> USGS 15 +! 6, 'Closed Shrublands' -> USGS 8 "shrubland" +! 7, 'Open Shrublands' -> USGS 9 "shrubland/grassland" +! 8, 'Woody Savannas' -> USGS 8 "shrubland" +! 9, 'Savannas' -> USGS 10 +! 10, 'Grasslands' -> USGS 7 +! 11 'Permanent wetlands' -> avg of USGS 17 and 18 (herb. wooded wetland) +! 12, 'Croplands' -> USGS 2 "dryland cropland" +! 13, 'Urban and Built-Up' -> USGS 1 +! 14 'cropland/natural vegetation mosaic' -> USGS 5 "cropland/grassland" +! 15, 'Snow and Ice' -> USGS 24 +! 16, 'Barren or Sparsely Vegetated' -> USGS 19 +! 17, 'Water' -> USGS 16 +! 18, 'Wooded Tundra' -> USGS 21 +! 19, 'Mixed Tundra' -> USGS 22 +! 20, 'Barren Tundra' -> USGS 23 + + ISURBAN = 13 + ISWATER = 17 + ISBARREN = 16 + ISSNOW = 15 + EBLFOREST = 2 + + !--------------------------------------------------------------------------------------------------------------------------------------------------------------------- + ! 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + !--------------------------------------------------------------------------------------------------------------------------------------------------------------------- + CH2OP = 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, + DLEAF = 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, + Z0MVT = 1.09, 1.10, 0.85, 0.80, 0.80, 0.20, 0.06, 0.60, 0.50, 0.12, 0.30, 0.15, 1.00, 0.14, 0.00, 0.00, 0.00, 0.30, 0.20, 0.03, + HVT = 20.0, 20.0, 18.0, 16.0, 16.0, 1.10, 1.10, 13.0, 10.0, 1.00, 5.00, 2.00, 15.0, 1.50, 0.00, 0.00, 0.00, 4.00, 2.00, 0.50, + HVB = 8.50, 8.00, 7.00, 11.5, 10.0, 0.10, 0.10, 0.10, 0.10, 0.05, 0.10, 0.10, 1.00, 0.10, 0.00, 0.00, 0.00, 0.30, 0.20, 0.10, + DEN = 0.28, 0.02, 0.28, 0.10, 0.10, 10.0, 10.0, 10.0, 0.02, 100., 5.05, 25.0, 0.01, 25.0, 0.00, 0.01, 0.01, 1.00, 1.00, 1.00, + RC = 1.20, 3.60, 1.20, 1.40, 1.40, 0.12, 0.12, 0.12, 3.00, 0.03, 0.75, 0.08, 1.00, 0.08, 0.00, 0.01, 0.01, 0.30, 0.30, 0.30, + + ! Row 1: Vis + ! Row 2: Near IR + RHOL = 0.07, 0.10, 0.07, 0.10, 0.10, 0.07, 0.07, 0.07, 0.10, 0.11, 0.105, 0.11, 0.00, 0.11, 0.00, 0.00, 0.00, 0.10, 0.10, 0.10, + 0.35, 0.45, 0.35, 0.45, 0.45, 0.35, 0.35, 0.35, 0.45, 0.58, 0.515, 0.58, 0.00, 0.58, 0.00, 0.00, 0.00, 0.45, 0.45, 0.45, + + ! Row 1: Vis + ! Row 2: Near IR + RHOS = 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.36, 0.26, 0.36, 0.00, 0.36, 0.00, 0.00, 0.00, 0.16, 0.16, 0.16, + 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.58, 0.485, 0.58, 0.00, 0.58, 0.00, 0.00, 0.00, 0.39, 0.39, 0.39, + + ! Row 1: Vis + ! Row 2: Near IR + TAUL = 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.07, 0.06, 0.07, 0.00, 0.07, 0.00, 0.00, 0.00, 0.05, 0.05, 0.05, + 0.10, 0.25, 0.10, 0.25, 0.25, 0.10, 0.10, 0.10, 0.25, 0.25, 0.25, 0.25, 0.00, 0.25, 0.00, 0.00, 0.00, 0.25, 0.25, 0.25, + + ! Row 1: Vis + ! Row 2: Near IR + TAUS = 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.220, 0.1105, 0.220, 0.000, 0.220, 0.000, 0.000, 0.000, 0.001, 0.001, 0.001, + 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.380, 0.1905, 0.380, 0.000, 0.380, 0.000, 0.000, 0.000, 0.001, 0.001, 0.001, + + XL = 0.010, 0.010, 0.010, 0.250, 0.250, 0.010, 0.010, 0.010, 0.010, -0.30, -0.025, -0.30, 0.000, -0.30, 0.000, 0.000, 0.000, 0.250, 0.250, 0.250, +! CWPVT = 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, + CWPVT = 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, + C3PSN = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, + KC25 = 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, + AKC = 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, + KO25 = 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, + AKO = 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, + AVCMX = 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, + AQE = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, + + LTOVRC= 0.5, 0.55, 0.2, 0.55, 0.5, 0.65, 0.65, 0.65, 0.65, 0.50, 1.4, 1.6, 0.0, 1.2, 0.0, 0.0, 0.0, 1.3, 1.4, 1.0, + DILEFC= 1.20, 0.50, 1.80, 0.60, 0.80, 0.20, 0.20, 0.20, 0.50, 0.20, 0.4, 0.50, 0.00, 0.35, 0.00, 0.00, 0.00, 0.30, 0.40, 0.30, + DILEFW= 0.20, 4.00, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.50, 0.10, 0.2, 0.20, 0.00, 0.20, 0.00, 0.00, 0.00, 0.20, 0.20, 0.20, + RMF25 = 3.00, 0.65, 4.00, 3.00, 3.00, 0.26, 0.26, 0.26, 0.80, 1.80, 3.2, 1.00, 0.00, 1.45, 0.00, 0.00, 0.00, 3.00, 3.00, 3.00, + SLA = 80, 80, 80, 80, 80, 60, 60, 60, 50, 60, 80, 80, 60, 80, 0, 0, 0, 80, 80, 80, + FRAGR = 0.10, 0.20, 0.10, 0.20, 0.10, 0.20, 0.20, 0.20, 0.20, 0.20, 0.1, 0.20, 0.00, 0.20, 0.00, 0.10, 0.00, 0.10, 0.10, 0.10, + TMIN = 265, 273, 268, 273, 268, 273, 273, 273, 273, 273, 268, 273, 0, 273, 0, 0, 0, 268, 268, 268, + VCMX25= 50.0, 60.0, 60.0, 60.0, 55.0, 40.0, 40.0, 40.0, 40.0, 40.0, 50.0, 80.0, 0.00, 60.0, 0.00, 0.00, 0.00, 50.0, 50.0, 50.0, + TDLEF = 278, 278, 268, 278, 268, 278, 278, 278, 278, 278, 268, 278, 278, 278, 0, 0, 0, 268, 268, 268, + BP = 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 1.E15, 2.E3, 1.E15, 2.E3, 1.E15, 2.E3, 2.E3, 2.E3, + MP = 6., 9., 6., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., 9., + QE25 = 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.00, 0.06, 0.00, 0.06, 0.00, 0.06, 0.06, 0.06, + RMS25 = 0.90, 0.30, 0.64, 0.10, 0.80, 0.10, 0.10, 0.10, 0.32, 0.10, 0.10, 0.10, 0.00, 0.10, 0.00, 0.00, 0.00, 0.10, 0.10, 0.00, + RMR25 = 0.36, 0.05, 0.05, 0.01, 0.03, 0.00, 0.00, 0.00, 0.01, 1.20, 0.0, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 2.11, 2.11, 0.00, + ARM = 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, + FOLNMX= 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 0.00, 1.5, 0.00, 1.5, 0.00, 1.5, 1.5, 1.5, + WDPOOL= 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 0.00, 0.5, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 1.00, 1.00, 0.00, + WRRAT = 30.0, 30.0, 30.0, 30.0, 30.0, 3.00, 3.00, 3.00, 3.00, 0.00, 15.0, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 3.00, 3.00, 0.00, + MRP = 0.37, 0.23, 0.37, 0.40, 0.30, 0.19, 0.19, 0.19, 0.40, 0.17, 0.285, 0.23, 0.00, 0.23, 0.00, 0.00, 0.00, 0.23, 0.20, 0.00, + +! Monthly values, one row for each month: + SAIM = 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, + 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, + 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, + 0.3, 0.5, 0.4, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, + 0.4, 0.5, 0.4, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, + 0.5, 0.5, 0.7, 0.4, 0.4, 0.3, 0.2, 0.4, 0.4, 0.4, 0.4, 0.3, 0.0, 0.4, 0.0, 0.0, 0.0, 0.2, 0.2, 0.0, + 0.5, 0.5, 1.3, 0.9, 0.7, 0.6, 0.4, 0.7, 0.8, 0.8, 0.6, 0.4, 0.0, 0.6, 0.0, 0.0, 0.0, 0.4, 0.4, 0.0, + 0.6, 0.5, 1.2, 1.2, 0.8, 0.9, 0.6, 1.2, 1.2, 1.3, 0.9, 0.5, 0.0, 0.9, 0.0, 0.0, 0.0, 0.6, 0.6, 0.0, + 0.6, 0.5, 1.0, 1.6, 1.0, 1.2, 0.8, 1.4, 1.3, 1.1, 0.9, 0.4, 0.0, 0.7, 0.0, 0.0, 0.0, 0.8, 0.7, 0.0, + 0.7, 0.5, 0.8, 1.4, 1.0, 0.9, 0.7, 1.1, 0.7, 0.4, 0.6, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.7, 0.5, 0.0, + 0.6, 0.5, 0.6, 0.6, 0.5, 0.4, 0.3, 0.5, 0.4, 0.4, 0.4, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.3, 0.3, 0.0, + 0.5, 0.5, 0.5, 0.4, 0.4, 0.3, 0.2, 0.4, 0.4, 0.4, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.2, 0.0, + + LAIM = 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.4, 0.2, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, + 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.5, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, + 4.0, 4.5, 0.0, 0.3, 2.2, 0.3, 0.2, 0.4, 0.5, 0.6, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.1, 0.7, 0.0, + 4.0, 4.5, 0.6, 1.2, 2.6, 0.9, 0.6, 1.0, 0.8, 0.7, 0.5, 0.0, 0.0, 0.4, 0.0, 0.0, 0.0, 1.3, 0.8, 0.0, + 4.0, 4.5, 1.2, 3.0, 3.5, 2.2, 1.5, 2.4, 1.8, 1.2, 1.5, 1.0, 0.0, 1.1, 0.0, 0.0, 0.0, 1.7, 1.2, 0.0, + 4.0, 4.5, 2.0, 4.7, 4.3, 3.5, 2.3, 4.1, 3.6, 3.0, 2.9, 2.0, 0.0, 2.5, 0.0, 0.0, 0.0, 2.1, 1.8, 0.0, + 4.0, 4.5, 2.6, 4.5, 4.3, 3.5, 2.3, 4.1, 3.8, 3.5, 3.5, 3.0, 0.0, 3.2, 0.0, 0.0, 0.0, 2.1, 1.8, 0.0, + 4.0, 4.5, 1.7, 3.4, 3.7, 2.5, 1.7, 2.7, 2.1, 1.5, 2.7, 3.0, 0.0, 2.2, 0.0, 0.0, 0.0, 1.8, 1.3, 0.0, + 4.0, 4.5, 1.0, 1.2, 2.6, 0.9, 0.6, 1.0, 0.9, 0.7, 1.2, 1.5, 0.0, 1.1, 0.0, 0.0, 0.0, 1.3, 0.8, 0.0, + 4.0, 4.5, 0.5, 0.3, 2.2, 0.3, 0.2, 0.4, 0.5, 0.6, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.1, 0.7, 0.0, + 4.0, 4.5, 0.2, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.5, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, + 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.4, 0.2, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, + +! LAIM = 5.1, 3.3, 0.0, 1.9, 3.0, 1.0, 0.8, 0.5, 0.5, 0.7, 0.3, 1.8, 0.0, 2.4, 0.0, 0.0, 0.0, 0.6, 0.7, 0.0, +! 5.0, 3.6, 0.0, 1.9, 2.9, 1.0, 0.6, 1.0, 1.0, 0.7, 0.45, 1.9, 0.0, 2.6, 0.0, 0.0, 0.0, 0.4, 0.4, 0.0, +! 5.1, 4.4, 0.0, 2.1, 3.3, 1.0, 0.8, 1.8, 1.7, 1.1, 0.5, 2.6, 0.0, 2.9, 0.0, 0.0, 0.0, 0.4, 0.4, 0.0, +! 5.3, 5.4, 0.6, 2.5, 4.0, 1.0, 0.9, 2.6, 2.9, 1.7, 0.55, 3.9, 0.0, 3.4, 0.0, 0.0, 0.0, 0.4, 0.4, 0.0, +! 5.9, 6.2, 1.2, 3.1, 5.0, 1.0, 1.5, 3.4, 3.6, 2.5, 0.85, 5.2, 0.0, 4.0, 0.0, 0.0, 0.0, 0.8, 1.0, 0.0, +! 6.3, 6.4, 2.0, 3.3, 5.4, 1.0, 2.1, 3.6, 3.5, 2.7, 1.85, 5.6, 0.0, 4.2, 0.0, 0.0, 0.0, 2.0, 2.3, 0.0, +! 6.4, 5.9, 2.6, 3.3, 5.4, 1.0, 2.6, 3.4, 2.9, 2.8, 2.6, 5.3, 0.0, 4.1, 0.0, 0.0, 0.0, 3.3, 3.3, 0.0, +! 6.1, 5.6, 1.7, 3.1, 5.0, 1.0, 2.4, 3.2, 2.7, 2.4, 2.25, 4.5, 0.0, 3.8, 0.0, 0.0, 0.0, 3.3, 3.0, 0.0, +! 6.0, 5.3, 1.0, 2.9, 4.8, 1.0, 2.2, 2.9, 2.4, 2.1, 1.6, 4.1, 0.0, 3.7, 0.0, 0.0, 0.0, 2.8, 3.0, 0.0, +! 5.5, 4.7, 0.5, 2.6, 4.1, 1.0, 1.6, 2.3, 1.8, 1.7, 1.1, 3.2, 0.0, 3.2, 0.0, 0.0, 0.0, 1.4, 1.4, 0.0, +! 5.2, 4.0, 0.2, 2.2, 3.4, 1.0, 1.0, 1.5, 1.4, 1.3, 0.65, 2.3, 0.0, 2.7, 0.0, 0.0, 0.0, 0.5, 0.7, 0.0, +! 5.1, 3.2, 0.0, 1.9, 3.0, 1.0, 0.9, 0.7, 0.7, 0.8, 0.4, 1.7, 0.0, 2.4, 0.0, 0.0, 0.0, 0.8, 0.7, 0.0, + + SLAREA=0.0090, 0.0200, 0.0200, 0.0258, 0.0223, 0.0227, 0.0188, 0.0227, 0.0236, 0.0060, 0.0295, 0.0200, 0.0228, 0.0223, 0.02, 0.02, 0.0422, 0.02, 0.02, 0.02, + +! Five types, one row for each type. + EPS = 0.46, 0.00, 0.00, 46.86, 30.98, 21.62, 0.11, 21.62, 22.80, 0.02, 0.815, 0.00, 41.87, 0.04, 0.0, 0.0, 2.31, 0.0, 0.0, 0.0, + 3.34, 0.00, 0.00, 0.38, 0.96, 0.92, 0.22, 0.92, 0.59, 0.05, 0.535, 0.00, 0.98, 0.09, 0.0, 0.0, 1.47, 0.0, 0.0, 0.0, + 1.85, 0.00, 0.00, 1.84, 1.84, 1.73, 1.26, 1.73, 1.37, 0.03, 0.605, 0.00, 1.82, 0.05, 0.0, 0.0, 1.70, 0.0, 0.0, 0.0, + 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, +/ +&noah_mp_umd_veg_categories + VEG_DATASET_DESCRIPTION = "UMD" + NVEG = 13 +/ +&noah_mp_umd_parameters + ! NVEG = 13 + ! 1: Evergreen Needleleaf Forest + ! 2: Evergreen Broadleaf Forest + ! 3: Deciduous Needleleaf Forest + ! 4: Deciduous Broadleaf Forest + ! 5: Mixed Forests + ! 6: Woodlands + ! 7: Wooded Grassland + ! 8: Closed Shrublands + ! 9: Open Shrublands + ! 10: Grasslands + ! 11: Croplands + ! 12: Bare Soil + ! 13: Urban + + ISURBAN = 13 + ISWATER = 14 + ISBARREN = 12 + ISSNOW = 0 + EBLFOREST = 2 + + !------------------------------------------------------------------------------------------------------------- + ! 1 2 3 4 5 6 7 8 9 10 11 12 13 + !------------------------------------------------------------------------------------------------------------- + CH2OP = 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, + DLEAF = 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, + Z0MVT = 1.09, 1.10, 0.85, 0.80, 0.80, 1.09, 0.60, 0.20, 0.06, 0.12, 0.15, 0.00, 1.00, + HVT = 20.0, 20.0, 18.0, 16.0, 16.0, 20.0, 13.0, 1.1, 1.1, 1.0, 2.0, 0.0, 15.0, + HVB = 8.50, 8.00, 7.00, 11.50, 10.00, 8.50, 0.10, 0.10, 0.10, 0.05, 0.10, 0.00, 1.00, + DEN = 0.28, 0.02, 0.28, 0.10, 0.10, 0.28, 10.00, 10.00, 10.00, 100.00, 25.00, 0.01, 0.01, + RC = 1.20, 3.60, 1.20, 1.40, 1.40, 1.20, 0.12, 0.12, 0.12, 0.03, 0.08, 0.01, 1.00, + + ! Row 1: Vis + ! Row 2: Near IR + RHOL = 0.07, 0.10, 0.07, 0.10, 0.10, 0.07, 0.07, 0.07, 0.07, 0.11, 0.11, 0.00, 0.00, + 0.35, 0.45, 0.35, 0.45, 0.45, 0.35, 0.35, 0.35, 0.35, 0.58, 0.58, 0.00, 0.00, + + ! Row 1: Vis + ! Row 2: Near IR + RHOS = 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.36, 0.36, 0.00, 0.00, + 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.58, 0.58, 0.00, 0.00, + + ! Row 1: Vis + ! Row 2: Near IR + TAUL = 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.07, 0.07, 0.00, 0.00, + 0.10, 0.25, 0.10, 0.25, 0.25, 0.10, 0.10, 0.10, 0.10, 0.25, 0.25, 0.00, 0.00, + + ! Row 1: Vis + ! Row 2: Near IR + TAUS = 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.220, 0.220, 0.000, 0.000, + 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.380, 0.380, 0.000, 0.000, + + XL = 0.010, 0.010, 0.010, 0.250, 0.250, 0.010, 0.010, 0.010, 0.010, -0.300, -0.300, 0.000, 0.000, + CWPVT = 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, + C3PSN = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, + KC25 = 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, + AKC = 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, + KO25 = 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, + AKO = 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, + AVCMX = 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, + AQE = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, + + LTOVRC= 0.50, 0.55, 0.20, 0.55, 0.50, 0.50, 0.65, 0.65, 0.65, 0.50, 1.60, 0.00, 0.00, + DILEFC= 1.20, 0.50, 1.80, 0.60, 0.80, 1.20, 0.20, 0.20, 0.20, 0.20, 0.50, 0.00, 0.00, + DILEFW= 0.20, 4.00, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.10, 0.20, 0.00, 0.00, + RMF25 = 3.00, 0.65, 4.00, 3.00, 3.00, 3.00, 0.26, 0.26, 0.26, 1.80, 1.00, 0.00, 0.00, + SLA = 80, 80, 80, 80, 80, 80, 60, 60, 60, 60, 80, 0, 60, + FRAGR = 0.10, 0.20, 0.10, 0.20, 0.10, 0.10, 0.20, 0.20, 0.20, 0.20, 0.20, 0.10, 0.00, + TMIN = 265, 273, 268, 273, 268, 265, 273, 273, 273, 273, 273, 0, 0, + VCMX25= 50.0, 60.0, 60.0, 60.0, 55.0, 50.0, 40.0, 40.0, 40.0, 40.0, 80.0, 0.0, 0.0, + TDLEF = 278, 278, 268, 278, 268, 278, 278, 278, 278, 278, 278, 0, 278, + BP = 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3,0.1E+16, + MP = 6., 9., 6., 9., 9., 6., 9., 9., 9., 9., 9., 9., 9., + QE25 = 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.00, + RMS25 = 0.90, 0.30, 0.64, 0.10, 0.80, 0.90, 0.10, 0.10, 0.10, 0.10, 0.10, 0.00, 0.00, + RMR25 = 0.36, 0.05, 0.05, 0.01, 0.03, 0.36, 0.00, 0.00, 0.00, 1.20, 0.00, 0.00, 0.00, + ARM = 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, + FOLNMX= 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 0.0, + WDPOOL= 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 0.00, 0.00, 0.00, 0.00, + WRRAT = 30.00, 30.00, 30.00, 30.00, 30.00, 30.00, 3.00, 3.00, 3.00, 0.00, 0.00, 0.00, 0.00, + MRP = 0.37, 0.23, 0.37, 0.40, 0.30, 0.37, 0.19, 0.19, 0.19, 0.17, 0.23, 0.00, 0.00, + +! Monthly values, one row for each month: + SAIM = 0.4, 0.5, 0.3, 0.4, 0.4, 0.4, 0.4, 0.3, 0.2, 0.3, 0.3, 0.0, 0.0, + 0.4, 0.5, 0.3, 0.4, 0.4, 0.4, 0.4, 0.3, 0.2, 0.3, 0.3, 0.0, 0.0, + 0.4, 0.5, 0.3, 0.4, 0.4, 0.4, 0.4, 0.3, 0.2, 0.3, 0.3, 0.0, 0.0, + 0.3, 0.5, 0.4, 0.4, 0.4, 0.3, 0.4, 0.3, 0.2, 0.3, 0.3, 0.0, 0.0, + 0.4, 0.5, 0.4, 0.4, 0.4, 0.4, 0.4, 0.3, 0.2, 0.3, 0.3, 0.0, 0.0, + 0.5, 0.5, 0.7, 0.4, 0.4, 0.5, 0.4, 0.3, 0.2, 0.4, 0.3, 0.0, 0.0, + 0.5, 0.5, 1.3, 0.9, 0.7, 0.5, 0.7, 0.6, 0.4, 0.8, 0.4, 0.0, 0.0, + 0.6, 0.5, 1.2, 1.2, 0.8, 0.6, 1.2, 0.9, 0.6, 1.3, 0.5, 0.0, 0.0, + 0.6, 0.5, 1.0, 1.6, 1.0, 0.6, 1.4, 1.2, 0.8, 1.1, 0.4, 0.0, 0.0, + 0.7, 0.5, 0.8, 1.4, 1.0, 0.7, 1.1, 0.9, 0.7, 0.4, 0.3, 0.0, 0.0, + 0.6, 0.5, 0.6, 0.6, 0.5, 0.6, 0.5, 0.4, 0.3, 0.4, 0.3, 0.0, 0.0, + 0.5, 0.5, 0.5, 0.4, 0.4, 0.5, 0.4, 0.3, 0.2, 0.4, 0.3, 0.0, 0.0, + + LAIM = 4.0, 4.5, 0.0, 0.0, 2.0, 4.0, 0.2, 0.0, 0.0, 0.4, 0.0, 0.0, 0.0, + 4.0, 4.5, 0.0, 0.0, 2.0, 4.0, 0.2, 0.0, 0.0, 0.5, 0.0, 0.0, 0.0, + 4.0, 4.5, 0.0, 0.3, 2.2, 4.0, 0.4, 0.3, 0.2, 0.6, 0.0, 0.0, 0.0, + 4.0, 4.5, 0.6, 1.2, 2.6, 4.0, 1.0, 0.9, 0.6, 0.7, 0.0, 0.0, 0.0, + 4.0, 4.5, 1.2, 3.0, 3.5, 4.0, 2.4, 2.2, 1.5, 1.2, 1.0, 0.0, 0.0, + 4.0, 4.5, 2.0, 4.7, 4.3, 4.0, 4.1, 3.5, 2.3, 3.0, 2.0, 0.0, 0.0, + 4.0, 4.5, 2.6, 4.5, 4.3, 4.0, 4.1, 3.5, 2.3, 3.5, 3.0, 0.0, 0.0, + 4.0, 4.5, 1.7, 3.4, 3.7, 4.0, 2.7, 2.5, 1.7, 1.5, 3.0, 0.0, 0.0, + 4.0, 4.5, 1.0, 1.2, 2.6, 4.0, 1.0, 0.9, 0.6, 0.7, 1.5, 0.0, 0.0, + 4.0, 4.5, 0.5, 0.3, 2.2, 4.0, 0.4, 0.3, 0.2, 0.6, 0.0, 0.0, 0.0, + 4.0, 4.5, 0.2, 0.0, 2.0, 4.0, 0.2, 0.0, 0.0, 0.5, 0.0, 0.0, 0.0, + 4.0, 4.5, 0.0, 0.0, 2.0, 4.0, 0.2, 0.0, 0.0, 0.4, 0.0, 0.0, 0.0, + + SLAREA=0.0090, 0.0200, 0.0200, 0.0258, 0.0223, 0.0090, 0.0227, 0.0227, 0.0188, 0.0060, 0.0200, 0.0200, 0.0228, + +! Five types, one row for each type. + EPS = 0.46, 0.00, 0.00, 46.86, 30.98, 0.46, 21.62, 21.62, 0.11, 0.02, 0.00, 0.00, 41.87, + 3.34, 0.00, 0.00, 0.38, 0.96, 3.34, 0.92, 0.92, 0.22, 0.05, 0.00, 0.00, 0.98, + 1.85, 0.00, 0.00, 1.84, 1.84, 1.85, 1.73, 1.73, 1.26, 0.03, 0.00, 0.00, 1.82, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, +/ diff --git a/test_ngen/gauge_01073000/settings/SUMMA/TBL_SOILPARM.TBL b/test_ngen/gauge_01073000/settings/SUMMA/TBL_SOILPARM.TBL new file mode 100644 index 000000000..b87d1bae5 --- /dev/null +++ b/test_ngen/gauge_01073000/settings/SUMMA/TBL_SOILPARM.TBL @@ -0,0 +1,59 @@ +Soil Parameters +STAS +19,1 'BB DRYSMC F11 MAXSMC REFSMC SATPSI SATDK SATDW WLTSMC QTZ ' +1, 2.79, 0.010, -0.472, 0.339, 0.236, 0.069, 1.07E-6, 0.608E-6, 0.010, 0.92, 'SAND' +2, 4.26, 0.028, -1.044, 0.421, 0.383, 0.036, 1.41E-5, 0.514E-5, 0.028, 0.82, 'LOAMY SAND' +3, 4.74, 0.047, -0.569, 0.434, 0.383, 0.141, 5.23E-6, 0.805E-5, 0.047, 0.60, 'SANDY LOAM' +4, 5.33, 0.084, 0.162, 0.476, 0.360, 0.759, 2.81E-6, 0.239E-4, 0.084, 0.25, 'SILT LOAM' +5, 5.33, 0.084, 0.162, 0.476, 0.383, 0.759, 2.81E-6, 0.239E-4, 0.084, 0.10, 'SILT' +6, 5.25, 0.066, -0.327, 0.439, 0.329, 0.355, 3.38E-6, 0.143E-4, 0.066, 0.40, 'LOAM' +7, 6.66, 0.067, -1.491, 0.404, 0.314, 0.135, 4.45E-6, 0.990E-5, 0.067, 0.60, 'SANDY CLAY LOAM' +8, 8.72, 0.120, -1.118, 0.464, 0.387, 0.617, 2.04E-6, 0.237E-4, 0.120, 0.10, 'SILTY CLAY LOAM' +9, 8.17, 0.103, -1.297, 0.465, 0.382, 0.263, 2.45E-6, 0.113E-4, 0.103, 0.35, 'CLAY LOAM' +10, 10.73, 0.100, -3.209, 0.406, 0.338, 0.098, 7.22E-6, 0.187E-4, 0.100, 0.52, 'SANDY CLAY' +11, 10.39, 0.126, -1.916, 0.468, 0.404, 0.324, 1.34E-6, 0.964E-5, 0.126, 0.10, 'SILTY CLAY' +12, 11.55, 0.138, -2.138, 0.468, 0.412, 0.468, 9.74E-7, 0.112E-4, 0.138, 0.25, 'CLAY' +13, 5.25, 0.066, -0.327, 0.439, 0.329, 0.355, 3.38E-6, 0.143E-4, 0.066, 0.05, 'ORGANIC MATERIAL' +14, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.60, 'WATER' +15, 2.79, 0.006, -1.111, 0.20, 0.17, 0.069, 1.41E-4, 0.136E-3, 0.006, 0.07, 'BEDROCK' +16, 4.26, 0.028, -1.044, 0.421, 0.283, 0.036, 1.41E-5, 0.514E-5, 0.028, 0.25, 'OTHER(land-ice)' +17, 11.55, 0.030, -10.472, 0.468, 0.454, 0.468, 9.74E-7, 0.112E-4, 0.030, 0.60, 'PLAYA' +18, 2.79, 0.006, -0.472, 0.200, 0.17, 0.069, 1.41E-4, 0.136E-3, 0.006, 0.52, 'LAVA' +19, 2.79, 0.01, -0.472, 0.339, 0.236, 0.069, 1.07E-6, 0.608E-6, 0.01, 0.92, 'WHITE SAND' +Soil Parameters +STAS-RUC +19,1 'BB DRYSMC HC MAXSMC REFSMC SATPSI SATDK SATDW WLTSMC QTZ ' +1, 4.05, 0.045, 1.47, 0.395, 0.236, 0.121, 1.76E-4, 0.608E-6, 0.068, 0.92, 'SAND' +2, 4.38, 0.057, 1.41, 0.410, 0.383, 0.090, 1.56E-4, 0.514E-5, 0.075, 0.82, 'LOAMY SAND' +3, 4.90, 0.065, 1.34, 0.435, 0.383, 0.218, 3.47E-5, 0.805E-5, 0.114, 0.60, 'SANDY LOAM' +4, 5.30, 0.067, 1.27, 0.485, 0.360, 0.786, 7.20E-6, 0.239E-4, 0.179, 0.25, 'SILT LOAM' +5, 5.30, 0.034, 1.27, 0.485, 0.383, 0.786, 7.20E-6, 0.239E-4, 0.179, 0.10, 'SILT' +6, 5.39, 0.078, 1.21, 0.451, 0.329, 0.478, 6.95E-6, 0.143E-4, 0.155, 0.40, 'LOAM' +7, 7.12, 0.100, 1.18, 0.420, 0.314, 0.299, 6.30E-6, 0.990E-5, 0.175, 0.60, 'SANDY CLAY LOAM' +8, 7.75, 0.089, 1.32, 0.477, 0.387, 0.356, 1.70E-6, 0.237E-4, 0.218, 0.10, 'SILTY CLAY LOAM' +9, 8.52, 0.095, 1.23, 0.476, 0.382, 0.630, 2.45E-6, 0.113E-4, 0.250, 0.35, 'CLAY LOAM' +10, 10.40, 0.100, 1.18, 0.426, 0.338, 0.153, 2.17E-6, 0.187E-4, 0.219, 0.52, 'SANDY CLAY' +11, 10.40, 0.070, 1.15, 0.492, 0.404, 0.490, 1.03E-6, 0.964E-5, 0.283, 0.10, 'SILTY CLAY' +12, 11.40, 0.068, 1.09, 0.482, 0.412, 0.405, 1.28E-6, 0.112E-4, 0.286, 0.25, 'CLAY' +13, 5.39, 0.078, 1.21, 0.451, 0.329, 0.478, 6.95E-6, 0.143E-4, 0.155, 0.05, 'ORGANIC MATERIAL' +14, 0.0, 0.0, 4.18, 1.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.00, 'WATER' +15, 4.05, 0.004, 2.03, 0.200, 0.17, 0.121, 1.41E-4, 0.136E-3, 0.006, 0.60, 'BEDROCK' +16, 4.90, 0.065, 2.10, 0.435, 0.283, 0.218, 3.47E-5, 0.514E-5, 0.114, 0.05, 'OTHER(land-ice)' +17, 11.40, 0.030, 1.41, 0.468, 0.454, 0.468, 9.74E-7, 0.112E-4, 0.030, 0.60, 'PLAYA' +18, 4.05, 0.006, 1.41, 0.200, 0.17, 0.069, 1.41E-4, 0.136E-3, 0.060, 0.52, 'LAVA' +19, 4.05, 0.01, 1.47, 0.339, 0.236, 0.069, 1.76E-4, 0.608E-6, 0.060, 0.92, 'WHITE SAND' +Soil Parameters +ROSETTA +12,1 'theta_res theta_sat vGn_alpha vGn_n k_soil BB DRYSMC HC MAXSMC REFSMC SATPSI SATDK SATDW WLTSMC QTZ ' +1 0.098 0.459 -1.496 1.253 1.70799e-06 1.40 0.068 1.09 0.482 0.412 0.405 1.28E-6 0.112E-4 0.286 0.25 'CLAY' +2 0.079 0.442 -1.581 1.416 9.47297e-07 8.52 0.095 1.23 0.476 0.382 0.630 2.45E-6 0.113E-4 0.250 0.35 'CLAY LOAM' +3 0.061 0.399 -1.112 1.472 1.39472e-06 5.39 0.078 1.21 0.451 0.329 0.478 6.95E-6 0.143E-4 0.155 0.40 'LOAM' +4 0.049 0.390 -3.475 1.746 1.21755e-05 4.38 0.057 1.41 0.410 0.383 0.090 1.56E-4 0.514E-5 0.075 0.82 'LOAMY SAND' +5 0.053 0.375 -3.524 3.177 7.43852e-05 4.05 0.045 1.47 0.395 0.236 0.121 1.76E-4 0.608E-6 0.068 0.92 'SAND' +6 0.117 0.385 -3.342 1.208 1.31367e-06 0.40 0.100 1.18 0.426 0.338 0.153 2.17E-6 0.187E-4 0.219 0.52 'SANDY CLAY' +7 0.063 0.384 -2.109 1.330 1.52576e-06 7.12 0.100 1.18 0.420 0.314 0.299 6.30E-6 0.990E-5 0.175 0.60 'SANDY CLAY LOAM' +8 0.039 0.387 -2.667 1.449 4.43084e-06 4.90 0.065 1.34 0.435 0.383 0.218 3.47E-5 0.805E-5 0.114 0.60 'SANDY LOAM' +9 0.050 0.489 -0.658 1.679 5.06391e-06 5.30 0.034 1.27 0.485 0.383 0.786 7.20E-6 0.239E-4 0.179 0.10 'SILT' +10 0.111 0.481 -1.622 1.321 1.11298e-06 0.40 0.070 1.15 0.492 0.404 0.490 1.03E-6 0.964E-5 0.283 0.10 'SILTY CLAY' +11 0.090 0.482 -0.839 1.521 1.28673e-06 7.75 0.089 1.32 0.477 0.387 0.356 1.70E-6 0.237E-4 0.218 0.10 'SILTY CLAY LOAM' +12 0.065 0.439 -0.506 1.663 2.11099e-06 5.30 0.067 1.27 0.485 0.360 0.786 7.20E-6 0.239E-4 0.179 0.25 'SILT LOAM' diff --git a/test_ngen/gauge_01073000/settings/SUMMA/TBL_VEGPARM.TBL b/test_ngen/gauge_01073000/settings/SUMMA/TBL_VEGPARM.TBL new file mode 100644 index 000000000..293a0463b --- /dev/null +++ b/test_ngen/gauge_01073000/settings/SUMMA/TBL_VEGPARM.TBL @@ -0,0 +1,239 @@ +Vegetation Parameters +USGS +27,1, 'SHDFAC NROOT RS RGL HS SNUP MAXALB LAIMIN LAIMAX EMISSMIN EMISSMAX ALBEDOMIN ALBEDOMAX Z0MIN Z0MAX ZTOPV ZBOTV' +1, .10, 1, 200., 999., 999.0, 0.04, 46., 1.00, 1.00, .880, .880, .15, .15, .50, .50, 0.00, 0.00, 'Urban and Built-Up Land' +2, .80, 3, 40., 100., 36.25, 0.04, 66., 1.56, 5.68, .920, .985, .17, .23, .05, .15, 0.50, 0.01, 'Dryland Cropland and Pasture' +3, .80, 3, 40., 100., 36.25, 0.04, 66., 1.56, 5.68, .930, .985, .20, .25, .02, .10, 0.50, 0.01, 'Irrigated Cropland and Pasture' +4, .80, 3, 40., 100., 36.25, 0.04, 66., 1.00, 4.50, .920, .985, .18, .23, .05, .15, 0.50, 0.01, 'Mixed Dryland/Irrigated Cropland and Pasture' +5, .80, 3, 40., 100., 36.25, 0.04, 68., 2.29, 4.29, .920, .980, .18, .23, .05, .14, 0.50, 0.01, 'Cropland/Grassland Mosaic' +6, .80, 3, 70., 65., 44.14, 0.04, 60., 2.00, 4.00, .930, .985, .16, .20, .20, .20, 0.50, 0.01, 'Cropland/Woodland Mosaic' +7, .80, 3, 40., 100., 36.35, 0.04, 70., 0.52, 2.90, .920, .960, .19, .23, .10, .12, 0.50, 0.01, 'Grassland' +8, .70, 3, 300., 100., 42.00, 0.03, 60., 0.50, 3.66, .930, .930, .25, .30, .01, .05, 0.50, 0.10, 'Shrubland' +9, .70, 3, 170., 100., 39.18, 0.035, 65., 0.60, 2.60, .930, .950, .22, .30, .01, .06, 0.50, 0.10, 'Mixed Shrubland/Grassland' +10, .50, 3, 70., 65., 54.53, 0.04, 50., 0.50, 3.66, .920, .920, .20, .20, .15, .15, 5.00, 0.10, 'Savanna' +11, .80, 4, 100., 30., 54.53, 0.08, 58., 1.85, 3.31, .930, .930, .16, .17, .50, .50, 20.0, 11.5, 'Deciduous Broadleaf Forest' +12, .70, 4, 150., 30., 47.35, 0.08, 54., 1.00, 5.16, .930, .940, .14, .15, .50, .50, 14.0, 7.0, 'Deciduous Needleleaf Forest' +13, .95, 4, 150., 30., 41.69, 0.08, 35., 3.08, 6.48, .950, .950, .12, .12, .50, .50, 35.0, 1.0, 'Evergreen Broadleaf Forest' +14, .70, 4, 125., 30., 47.35, 0.08, 52., 5.00, 6.40, .950, .950, .12, .12, .50, .50, 17.0, 8.5, 'Evergreen Needleleaf Forest' +15, .80, 4, 125., 30., 51.93, 0.08, 53., 2.80, 5.50, .930, .970, .17, .25, .20, .50, 18.0, 10.0, 'Mixed Forest' +16, .00, 0, 100., 30., 51.75, 0.01, 70., 0.01, 0.01, .980, .980, .08, .08, 0.0001, 0.0001, 0.00, 0.00, 'Water Bodies' +17, .60, 2, 40., 100., 60.00, 0.01, 68., 1.50, 5.65, .950, .950, .14, .14, .20, .20, 0.50, 0.01, 'Herbaceous Wetland' +18, .60, 2, 100., 30., 51.93, 0.02, 50., 2.00, 5.80, .950, .950, .14, .14, .40, .40, 20.0, 11.5, 'Wooded Wetland' +19, .01, 1, 999., 999., 999.0, 0.02, 75., 0.10, 0.75, .900, .900, .38, .38, .01, .01, 0.02, 0.01, 'Barren or Sparsely Vegetated' +20, .60, 3, 150., 100., 42.00, 0.025, 68., 0.41, 3.35, .920, .920, .15, .20, .10, .10, 0.50, 0.01, 'Herbaceous Tundra' +21, .60, 3, 150., 100., 42.00, 0.025, 55., 0.41, 3.35, .930, .930, .15, .20, .30, .30, 10.0, 0.10, 'Wooded Tundra' +22, .60, 3, 150., 100., 42.00, 0.025, 60., 0.41, 3.35, .920, .920, .15, .20, .15, .15, 5.00, 0.10, 'Mixed Tundra' +23, .30, 2, 200., 100., 42.00, 0.02, 75., 0.41, 3.35, .900, .900, .25, .25, .05, .10, 0.02, 0.01, 'Bare Ground Tundra' +24, .00, 1, 999., 999., 999.0, 0.02, 82., 0.01, 0.01, .950, .950, .55, .70, 0.001, 0.001, 0.00, 0.00, 'Snow or Ice' +25, .50, 1, 40., 100., 36.25, 0.02, 75., 0.01, 0.01, .890, .890, .30, .30, .01, .01, 0.00, 0.00, 'Playa' +26, .00, 0, 999., 999., 999.0, 0.02, 75., 0.01, 0.01, .880, .880, .16, .16, .15, .15, 0.00, 0.00, 'Lava' +27, .00, 0, 999., 999., 999.0, 0.02, 75., 0.01, 0.01, .830, .830, .60, .60, .01, .01, 0.00, 0.00, 'White Sand' +TOPT_DATA +298.0 +CMCMAX_DATA +0.5E-3 +CFACTR_DATA +0.5 +RSMAX_DATA +5000.0 +BARE +19 +NATURAL +5 +Vegetation Parameters +MODIFIED_IGBP_MODIS_NOAH +20,1, 'SHDFAC NROOT RS RGL HS SNUP MAXALB LAIMIN LAIMAX EMISSMIN EMISSMAX ALBEDOMIN ALBEDOMAX Z0MIN Z0MAX ZTOPV ZBOTV' +1 .70, 4, 125., 30., 47.35, 0.08, 52., 5.00, 6.40, .950, .950, .12, .12, .50, .50, 17.0, 8.5, 'Evergreen Needleleaf Forest' +2, .95, 4, 150., 30., 41.69, 0.08, 35., 3.08, 6.48, .950, .950, .12, .12, .50, .50, 35.0, 1.0, 'Evergreen Broadleaf Forest' +3, .70, 4, 150., 30., 47.35, 0.08, 54., 1.00, 5.16, .930, .940, .14, .15, .50, .50, 14.0, 7.0, 'Deciduous Needleleaf Forest' +4, .80, 4, 100., 30., 54.53, 0.08, 58., 1.85, 3.31, .930, .930, .16, .17, .50, .50, 20.0, 11.5, 'Deciduous Broadleaf Forest' +5, .80, 4, 125., 30., 51.93, 0.08, 53., 2.80, 5.50, .930, .970, .17, .25, .20, .50, 18.0, 10.0, 'Mixed Forests' +6, .70, 3, 300., 100., 42.00, 0.03, 60., 0.50, 3.66, .930, .930, .25, .30, .01, .05, 0.50, 0.10, 'Closed Shrublands' +7, .70, 3, 170., 100., 39.18, 0.035, 65., 0.60, 2.60, .930, .950, .22, .30, .01, .06, 0.50, 0.10, 'Open Shrublands' +8, .70, 3, 300., 100., 42.00, 0.03, 60., 0.50, 3.66, .930, .930, .25, .30, .01, .05, 0.50, 0.10, 'Woody Savannas' +9, .50, 3, 70., 65., 54.53, 0.04, 50., 0.50, 3.66, .920, .920, .20, .20, .15, .15, 0.50, 0.10, 'Savannas' +10, .80, 3, 40., 100., 36.35, 0.04, 70., 0.52, 2.90, .920, .960, .19, .23, .10, .12, 0.50, 0.01, 'Grasslands' +11 .60, 2, 70., 65., 55.97 0.015 59., 1.75, 5.72, .950, .950, .14, .14, .30, .30, 0.00, 0.00, 'Permanent wetlands' +12, .80, 3, 40., 100., 36.25, 0.04, 66., 1.56, 5.68, .920, .985, .17, .23, .05, .15, 0.50, 0.01, 'Croplands' +13, .10, 1, 200., 999., 999.0, 0.04, 46., 1.00, 1.00, .880, .880, .15, .15, .50, .50, 0.00, 0.00, 'Urban and Built-Up' +14 .80, 3, 40., 100., 36.25, 0.04, 68., 2.29, 4.29, .920, .980, .18, .23, .05, .14, 0.50, 0.01, 'cropland/natural vegetation mosaic' +15, .00, 1, 999., 999., 999.0, 0.02, 82., 0.01, 0.01, .950, .950, .55, .70, 0.001, 0.001, 0.00, 0.00, 'Snow and Ice' +16, .01, 1, 999., 999., 999.0, 0.02, 75., 0.10, 0.75, .900, .900, .38, .38, .01, .01, 0.02, 0.01, 'Barren or Sparsely Vegetated' +17, .00, 0, 100., 30., 51.75, 0.01, 70., 0.01, 0.01, .980, .980, .08, .08, 0.0001, 0.0001, 0.00, 0.00, 'Water' +18, .60, 3, 150., 100., 42.00, 0.025, 55., 0.41, 3.35, .930, .930, .15, .20, .30, .30, 10.0, 0.10, 'Wooded Tundra' +19, .60, 3, 150., 100., 42.00, 0.025, 60., 0.41, 3.35, .920, .920, .15, .20, .15, .15, 5.00, 0.10, 'Mixed Tundra' +20, .30, 2, 200., 100., 42.00, 0.02, 75., 0.41, 3.35, .900, .900, .25, .25, .05, .10, 0.02, 0.01, 'Barren Tundra' +TOPT_DATA +298.0 +CMCMAX_DATA +0.5E-3 +CFACTR_DATA +0.5 +RSMAX_DATA +5000.0 +BARE +16 +NATURAL +14 +Vegetation Parameters +USGS-RUC +28,1, 'ALBEDO Z0 LEMI PC SHDFAC IFOR RS RGL HS SNUP LAI MAXALB' +1, .18, 2.0, .88, .40, .10, 9, 200., 999., 999.0, 0.04, 1.00, 40., 'Urban and Built-Up Land' +2, .17, .06, .92, .30, .80, 7, 40., 100., 36.25, 0.04, 5.68, 64., 'Dryland Cropland and Pasture' +3, .18, .075, .92, .40, .80, 7, 40., 100., 36.25, 0.04, 5.68, 64., 'Irrigated Cropland and Pasture' +4, .18, .125, .92, .40, .80, 7, 40., 100., 36.25, 0.04, 4.50, 64., 'Mixed Dryland/Irrigated Cropland and Pasture' +5, .18, .15, .92, .40, .80, 3, 40., 100., 36.25, 0.04, 4.29, 64., 'Cropland/Grassland Mosaic' +6, .16, .20, .93, .40, .80, 3, 70., 65., 44.14, 0.04, 4.00, 60., 'Cropland/Woodland Mosaic' +7, .19, .075 .92, .40, .80, 5, 40., 100., 36.35, 0.04, 2.90, 64., 'Grassland' +8, .22, .10, .88, .40, .70, 4, 300., 100., 42.00, 0.03, 3.66, 69., 'Shrubland' +9, .20, .11, .90, .40, .70, 4, 170., 100., 39.18, 0.035, 2.60, 67., 'Mixed Shrubland/Grassland' +10, .20, .15, .92, .40, .50, 5, 70., 65., 54.53, 0.04, 3.66, 45., 'Savanna' +11, .16, .70, .93, .55, .80, 3, 100., 30., 54.53, 0.08, 3.31, 58., 'Deciduous Broadleaf Forest' +12, .14, .70, .94, .55, .70, 4, 150., 30., 47.35, 0.08, 5.16, 54., 'Deciduous Needleleaf Forest' +13, .12, .70, .95, .55, .95, 2, 150., 30., 41.69, 0.08, 6.48, 32., 'Evergreen Broadleaf Forest' +14, .12, .70, .95, .55, .70, 1, 125., 30., 47.35, 0.08, 6.40, 52., 'Evergreen Needleleaf Forest' +15, .13, .70, .94, .55, .80, 2, 125., 30., 51.93, 0.08, 5.50, 53., 'Mixed Forest' +16, .08, .0001, .98, .00, .00, 9, 100., 30., 51.75, 0.01, 0.01, 70., 'Water Bodies' +17, .14, .20, .95, .55, .60, 4, 40., 100., 60.00, 0.01, 5.65, 35., 'Herbaceous Wetland' +18, .14, .40, .95, .55, .60, 4, 100., 30., 51.93, 0.02, 5.80, 30., 'Wooded Wetland' +19, .25, .05, .85, .30, .01, 5, 999., 999., 999.0, 0.02, 0.75, 69., 'Barren or Sparsely Vegetated' +20, .15, .10, .92, .30, .60, 5, 150., 100., 42.00, 0.025, 3.35, 58., 'Herbaceous Tundra' +21, .15, .15, .93, .40, .60, 5, 150., 100., 42.00, 0.025, 3.35, 55., 'Wooded Tundra' +22, .15, .10, .92, .40, .60, 5, 150., 100., 42.00, 0.025, 3.35, 55., 'Mixed Tundra' +23, .25, .065, .85, .30, .30, 5, 200., 100., 42.00, 0.02, 3.35, 65., 'Bare Ground Tundra' +24, .55, .0024, .98, .00, .00, 9, 999., 999., 999.0, 0.02, 0.01, 75., 'Snow or Ice' +25, .30, .01, .85, .30, .50, 9, 40., 100., 36.25, 0.02, 0.01, 69., 'Playa' +26, .16, .15, .85, .00, .00, 9, 999., 999., 999.0, 0.02, 0.01, 69., 'Lava' +27, .60, .01, .90, .00, .00, 9, 999., 999., 999.0, 0.02, 0.01, 69., 'White Sand' +28, .08, .0001, .98, .00, .00, 9, 100., 30., 51.75, 0.01, 0.01, 70., 'Lakes' +TOPT_DATA +298.0 +CMCMAX_DATA +0.2E-3 +CFACTR_DATA +0.5 +RSMAX_DATA +5000.0 +BARE +19 +NATURAL +5 +Vegetation Parameters +MODI-RUC +21,1, 'ALBEDO Z0 LEMI PC SHDFAC IFOR RS RGL HS SNUP LAI MAXALB' +1 .12, .70, .950, .55, .70, 1, 125., 30., 47.35, 0.08, 6.40, 52., 'Evergreen Needleleaf Forest' +2, .12, .70, .950, .55, .95, 2, 150., 30., 41.69, 0.08, 6.48, 35., 'Evergreen Broadleaf Forest' +3, .14, .70, .940, .55, .70, 4, 150., 30., 47.35, 0.08, 5.16, 54., 'Deciduous Needleleaf Forest' +4, .16, .70, .930, .55, .80, 3, 100., 30., 54.53, 0.08, 3.31, 58., 'Deciduous Broadleaf Forest' +5, .13, .70, .940, .55, .80, 2, 125., 30., 51.93, 0.08, 5.50, 53., 'Mixed Forests' +6, .22, .10, .930, .40, .70, 4, 300., 100., 42.00, 0.03, 3.66, 60., 'Closed Shrublands' +7, .20, .10, .880, .40, .70, 4, 170., 100., 39.18, 0.035, 2.60, 65., 'Open Shrublands' +8, .20, .15, .930, .40, .70, 5, 300., 100., 42.00, 0.03, 3.66, 60., 'Woody Savannas' +9, .20, .15, .920, .40, .50, 5, 70., 65., 54.53, 0.04, 3.66, 50., 'Savannas' +10, .19, .075, .920, .40, .80, 5, 40., 100., 36.35, 0.04, 2.90, 70., 'Grasslands' +11 .14, .30, .950, .40, .60, 4, 70., 65., 55.97 0.015 5.72, 59., 'Permanent wetlands' +12, .18, .15, .935, .40, .80, 7, 40., 100., 36.25, 0.04, 5.68, 66., 'Croplands' +13, .18, 2.0, .880, .40, .10, 9, 200., 999., 999.0, 0.04, 1.00, 46., 'Urban and Built-Up' +14 .16, .14, .920, .40, .80, 7, 40., 100., 36.25, 0.04, 4.29, 68., 'cropland/natural vegetation mosaic' +15, .55, .011, .980, .00, .00, 9, 999., 999., 999.0, 0.02, 0.01, 82., 'Snow and Ice' +16, .25, .065, .850, .30, .01, 5, 999., 999., 999.0, 0.02, 0.75, 75., 'Barren or Sparsely Vegetated' +17, .08, .0001, .980, .00, .00, 9, 100., 30., 51.75, 0.01, 0.01, 70., 'Water' +18, .15, .15, .930, .40, .60, 5, 150., 100., 42.00, 0.025, 3.35, 55., 'Wooded Tundra' +19, .15, .10, .920, .40, .60, 5, 150., 100., 42.00, 0.025, 3.35, 60., 'Mixed Tundra' +20, .15, .06, .900, .30, .30, 5, 200., 100., 42.00, 0.02, 3.35, 75., 'Barren Tundra' +21, .08, .0001, .980, .00, .00, 9, 100., 30., 51.75, 0.01, 0.01, 70., 'Lakes' +TOPT_DATA +298.0 +CMCMAX_DATA +0.2E-3 +CFACTR_DATA +0.5 +RSMAX_DATA +5000.0 +BARE +16 +NATURAL +14 +Vegetation Parameters +NLCD40 +40,1, 'SHDFAC NROOT RS RGL HS SNUP MAXALB LAIMIN LAIMAX EMISSMIN EMISSMAX ALBEDOMIN ALBEDOMAX Z0MIN Z0MAX ZTOPV ZBOTV' +1, .70, 4, 125., 30., 47.35, 0.08, 52., 5.00, 6.40, .950, .950, .12, .12, .50, .50, 17.00, 8.50, 'Evergreen Needleleaf Forest' +2, .95, 4, 150., 30., 41.69, 0.08, 35., 3.08, 6.48, .950, .950, .12, .12, .50, .50, 35.00, 1.00, 'Evergreen Broadleaf Forest' +3, .70, 4, 150., 30., 47.35, 0.08, 54., 1.00, 5.16, .930, .940, .14, .15, .50, .50, 14.00, 7.00, 'Deciduous Needleleaf Forest' +4, .80, 4, 100., 30., 54.53, 0.08, 58., 1.85, 3.31, .930, .930, .16, .17, .50, .50, 20.00, 11.50, 'Deciduous Broadleaf Forest' +5, .80, 4, 125., 30., 51.93, 0.08, 53., 2.80, 5.50, .930, .970, .17, .25, .20, .50, 18.00, 10.00, 'Mixed Forest' +6, .70, 3, 300., 100., 42.00, 0.03, 60., 0.50, 3.66, .930, .930, .25, .30, .01, .05, 0.50, 0.10, 'Closed Shrubland' +7, .70, 3, 170., 100., 39.18, 0.035, 65., 0.60, 2.60, .930, .950, .22, .30, .01, .06, 0.50, 0.10, 'Open Shrubland' +8, .50, 3, 70., 65., 54.53, 0.04, 50., 0.50, 3.66, .930, .930, .25, .30, .01, .05, 0.00, 0.00, 'Woody Savanna' +9, .50, 3, 70., 65., 54.53, 0.04, 50., 0.50, 3.66, .920, .920, .20, .20, .15, .15, 0.50, 0.10, 'Savanna' +10, .80, 3, 40., 100., 36.35, 0.04, 70., 0.52, 2.90, .920, .960, .19, .23, .10, .12, 0.50, 0.10, 'Grassland' +11, .60, 2, 100., 30., 51.93, 0.02, 50., 1.75, 5.72, .950, .950, .14, .14, .30, .30, 0.50, 0.10, 'Permanent Wetland' +12, .80, 3, 40., 100., 36.25, 0.04, 66., 1.50, 5.68, .920, .985, .15, .23, .05, .15, 0.50, 0.10, 'Cropland' +13, .10, 1, 200., 999., 999.0, 0.04, 46., 1.00, 1.00, .880, .880, .15, .15, .50, .50, 0.00, 0.00, 'Urban and Built-Up' +14, .80, 3, 40., 100., 36.25, 0.04, 66., 2.29, 4.29, .920, .980, .18, .23, .05, .14, 0.50, 0.10, 'Cropland / Natural Veg. Mosaic' +15, .00, 1, 999., 999., 999.0, 0.02, 82., 0.01, 0.01, .950, .950, .55, .70, 0.001, 0.001, 0.00, 0.00, 'Permanent Snow' +16, .01, 1, 999., 999., 999.0, 0.02, 75., 0.10, 0.75, .900, .900, .38, .38, .01, .01, 0.02, 0.01, 'Barren / Sparsely Vegetated' +17, .00, 0, 100., 30., 51.75, 0.01, 70., 0.01, 0.01, .980, .980, .08, .08, 0.0001, 0.0001, 0.00, 0.00, 'IGBP Water' +18, .00, 0, 999., 999., 999.0, 999., 999., 999.0, 999.0, 999., 999.0, 999.0, 999.0, 999.0, 999.0, 0.00, 0.00, 'Unclassified' +19, .00, 0, 999., 999., 999.0, 999., 999., 999.0, 999.0, 999., 999.0, 999.0, 999.0, 999.0, 999.0, 0.00, 0.00, 'Fill Value' +20, .00, 0, 999., 999., 999.0, 999., 999., 999.0, 999.0, 999., 999.0, 999.0, 999.0, 999.0, 999.0, 0.00, 0.00, 'Unclassified' +21, .00, 0, 100., 30., 51.75, 0.01, 70., 0.01, 0.01, .980, .980, .08, .08, 0.0001, 0.0001, 0.00, 0.00, 'Open Water' +22, .00, 1, 999., 999., 999.0, 0.02, 82., 0.01, 0.01, .950, .950, .55, .70, 0.001, 0.001, 0.00, 0.00, 'Perennial Ice/Snow' +23, .30, 1, 200., 999., 999.0, 0.04, 46., 1.00, 1.00, .880, .880, .20, .20, .50, .50, 0.00, 0.00, 'Developed Open Space' +24, .27, 1, 200., 999., 999.0, 0.04, 46., 1.00, 1.00, .880, .880, .20, .20, .70, .70, 0.00, 0.00, 'Developed Low Intensity' +25, .02, 1, 200., 999., 999.0, 0.04, 46., 1.00, 1.00, .880, .880, .20, .20, 1.5, 1.5, 0.00, 0.00, 'Developed Medium Intensity' +26, .11, 1, 200., 999., 999.0, 0.04, 46., 1.00, 1.00, .880, .880, .20, .20, 2.0, 2.0, 0.00, 0.00, 'Developed High Intensity' +27, .01, 1, 999., 999., 999.0, 0.02, 75., 0.10, 0.75, .900, .900, .38, .38, .01, .01, 0.02, 0.01, 'Barren Land' +28, .80, 4, 125., 30., 54.70, 0.08, 56., 1.00, 5.16, .930, .940, .14, .17, .50, .50, 20.00, 11.50, 'Deciduous Forest' +29, .95, 4, 140., 30., 44.00, 0.08, 42., 3.08, 6.48, .950, .950, .12, .12, .50, .50, 17.00, 8.50, 'Evergreen Forest' +30, .80, 4, 125., 30., 51.93, 0.08, 53., 2.80, 5.50, .930, .970, .17, .25, .20, .50, 18.00, 10.00, 'Mixed Forest' +31, .70, 3, 170., 100., 39.18, 0.035, 65., 1.00, 4.00, .930, .950, .16, .30, .01, .04, 0.50, 0.10, 'Dwarf Scrub' +32, .70, 3, 300., 100., 42.00, 0.03, 60., 0.50, 3.66, .930, .930, .22, .30, .01, .05, 0.50, 0.10, 'Shrub/Scrub' +33, .80, 3, 40., 100., 36.35, 0.04, 70., 0.52, 2.90, .920, .960, .19, .23, .10, .12, 0.50, 0.10, 'Grassland/Herbaceous' +34, .60, 2, 40., 100., 60.00, 0.01, 68., 1.50, 5.65, .950, .950, .14, .14, .20, .20, 0.50, 0.10, 'Sedge/Herbaceous' +35, .60, 2, 40., 100., 60.00, 0.01, 68., 1.00, 2.00, .950, .950, .31, .31, .01, .01, 0.00, 0.00, 'Lichens' +36, .60, 2, 40., 100., 60.00, 0.01, 68., 1.00, 2.00, .950, .950, .24, .24, .01, .01, 0.00, 0.00, 'Moss' +37, .80, 3, 40., 100., 36.25, 0.04, 66., 1.56, 5.68, .920, .985, .17, .23, .05, .15, 0.50, 0.10, 'Pasture/Hay' +38, .80, 3, 40., 100., 36.25, 0.04, 66., 1.56, 5.68, .930, .985, .20, .25, .02, .10, 0.50, 0.10, 'Cultivated Crops' +39, .60, 2, 100., 30., 51.93, 0.02, 50., 0.70, 3.50, .950, .950, .14, .14, .40, .40, 20.00, 11.50, 'Woody Wetland' +40, .60, 2, 40., 100., 60.00, 0.01, 68., 0.70, 3.50, .950, .950, .12, .12, .20, .20, 0.50, 0.10, 'Emergent Herbaceous Wetland' +TOPT_DATA +298.0 +CMCMAX_DATA +0.5E-3 +CFACTR_DATA +0.5 +RSMAX_DATA +5000.0 +BARE +16 +NATURAL +14 +Vegetation Parameters +UMD +13,1, 'SHDFAC NROOT RS RGL HS SNUP MAXALB LAIMIN LAIMAX EMISSMIN EMISSMAX ALBEDOMIN ALBEDOMAX Z0MIN Z0MAX ZTOPV ZBOTV' +1 .70, 4, 125., 30., 47.35, 0.08, 52., 5.00, 6.40, .950, .950, .12, .12, .50, .50, 17.0, 8.5, 'Evergreen Needleleaf Forest' +2, .95, 4, 150., 30., 41.69, 0.08, 35., 3.08, 6.48, .950, .950, .12, .12, .50, .50, 35.0, 1.0, 'Evergreen Broadleaf Forest' +3, .70, 4, 150., 30., 47.35, 0.08, 54., 1.00, 5.16, .930, .940, .14, .15, .50, .50, 14.0, 7.0, 'Deciduous Needleleaf Forest' +4, .80, 4, 100., 30., 54.53, 0.08, 58., 1.85, 3.31, .930, .930, .16, .17, .50, .50, 20.0, 11.5, 'Deciduous Broadleaf Forest' +5, .80, 4, 125., 30., 51.93, 0.08, 53., 2.80, 5.50, .930, .970, .17, .25, .20, .50, 18.0, 10.0, 'Mixed Forests' +6, .70, 4, 125., 30., 47.35, 0.08, 52., 5.00, 6.40, .950, .950, .12, .12, .50, .50, 17.0, 8.5, 'Woodlands' +7, .70, 3, 300., 100., 42.00, 0.03, 60., 0.50, 3.66, .930, .930, .25, .30, .01, .05, 0.50, 0.01, 'Wooded Grassland' +8, .70, 3, 300., 100., 42.00, 0.03, 60., 0.50, 3.66, .930, .930, .25, .30, .01, .05, 0.50, 0.01, 'Closed Shrublands' +9, .70, 3, 170., 100., 39.18, 0.035, 65., 0.60, 2.60, .930, .950, .22, .30, .01, .06, 0.50, 0.01, 'Open Shrublands' +10, .80, 3, 40., 100., 36.35, 0.04, 70., 0.52, 2.90, .920, .960, .19, .23, .10, .12, 0.50, 0.01, 'Grasslands' +11, .80, 3, 40., 100., 36.25, 0.04, 66., 1.56, 5.68, .920, .985, .17, .23, .05, .15, 0.50, 0.01, 'Croplands' +12, .01, 1, 999., 999., 999.0, 0.02, 75., 0.10, 0.75, .900, .900, .38, .38, .01, .01, 0.02, 0.01, 'Bare Soil' +13, .10, 1, 200., 999., 999.0, 0.04, 46., 1.00, 1.00, .880, .880, .15, .15, .50, .50, 0.00, 0.00, 'Urban' +TOPT_DATA +298.0 +CMCMAX_DATA +0.5E-3 +CFACTR_DATA +0.5 +RSMAX_DATA +5000.0 +BARE +12 +NATURAL +5 diff --git a/test_ngen/gauge_01073000/settings/SUMMA/attributes_tiled_by_hru.nc b/test_ngen/gauge_01073000/settings/SUMMA/attributes_tiled_by_hru.nc new file mode 100644 index 000000000..4a0b42c90 Binary files /dev/null and b/test_ngen/gauge_01073000/settings/SUMMA/attributes_tiled_by_hru.nc differ diff --git a/case_study/base_settings/basinParamInfo.txt b/test_ngen/gauge_01073000/settings/SUMMA/basinParamInfo.txt similarity index 88% rename from case_study/base_settings/basinParamInfo.txt rename to test_ngen/gauge_01073000/settings/SUMMA/basinParamInfo.txt index 96b28c1f9..bb986d41c 100644 --- a/case_study/base_settings/basinParamInfo.txt +++ b/test_ngen/gauge_01073000/settings/SUMMA/basinParamInfo.txt @@ -1,8 +1,3 @@ -! File provenance -! --------------- -! 2021-08-10: taken from the SUMMA test cases v3 distribution (WRR figures) and included as case study default file -! -! ! *********************************************************************************************************************** ! *********************************************************************************************************************** ! ***** DEFINITION OF BASIN PARAMETERS ********************************************************************************** @@ -30,11 +25,11 @@ ! baseflow ! ******************************************************************** basin__aquiferHydCond | 0.0100 | 0.0001 | 10.0000 -basin__aquiferScaleFactor | 3.5000 | 0.1000 | 100.0000 +basin__aquiferScaleFactor | 3.5000 | 0.1000 | 10.0000 basin__aquiferBaseflowExp | 5.0000 | 1.0000 | 10.0000 ! ******************************************************************** ! within-grid routing ! ******************************************************************** -routingGammaShape | 2.5000 | 2.0000 | 3.0000 -routingGammaScale | 20000.0000 | 1.0000 | 5000000.0000 +routingGammaShape | 2.5000 | 2.0000 | 5.0000 +routingGammaScale | 20000.0000 | 1.0000 | 100000.0000 ! ******************************************************************** diff --git a/test_ngen/gauge_01073000/settings/SUMMA/coldstate_tiled_by_hru.nc b/test_ngen/gauge_01073000/settings/SUMMA/coldstate_tiled_by_hru.nc new file mode 100644 index 000000000..349b3a6a3 Binary files /dev/null and b/test_ngen/gauge_01073000/settings/SUMMA/coldstate_tiled_by_hru.nc differ diff --git a/test_ngen/gauge_01073000/settings/SUMMA/fileManager.txt b/test_ngen/gauge_01073000/settings/SUMMA/fileManager.txt new file mode 100644 index 000000000..998895012 --- /dev/null +++ b/test_ngen/gauge_01073000/settings/SUMMA/fileManager.txt @@ -0,0 +1,20 @@ +controlVersion 'SUMMA_FILE_MANAGER_V3.0.0' +simStartTime '2015-12-01 00:00' +simEndTime '2015-12-30 23:00' +tmZoneInfo 'utcTime' +outFilePrefix 'run_1' +settingsPath './extern/summa/summa/test_ngen/gauge_01073000/settings/SUMMA/' +forcingPath './extern/summa/summa/test_ngen/gauge_01073000/forcing/SUMMA_input/' +outputPath './extern/summa/summa/test_ngen/gauge_01073000/simulations/run_1/SUMMA/' +initConditionFile 'coldstate_tiled_by_hru.nc' +attributeFile 'attributes_tiled_by_hru.nc' +trialParamFile 'trialParams_default_tiled_by_hru.nc' +forcingListFile 'forcingFileList.txt' +decisionsFile 'modelDecisions.txt' +outputControlFile 'outputControl.txt' +globalHruParamFile 'localParamInfo.txt' +globalGruParamFile 'basinParamInfo.txt' +vegTableFile 'TBL_VEGPARM.TBL' +soilTableFile 'TBL_SOILPARM.TBL' +generalTableFile 'TBL_GENPARM.TBL' +noahmpTableFile 'TBL_MPTABLE.TBL' diff --git a/test_ngen/gauge_01073000/settings/SUMMA/forcingFileList.txt b/test_ngen/gauge_01073000/settings/SUMMA/forcingFileList.txt new file mode 100644 index 000000000..396e6cbbc --- /dev/null +++ b/test_ngen/gauge_01073000/settings/SUMMA/forcingFileList.txt @@ -0,0 +1 @@ +summa_forcing_from_ngen.nc \ No newline at end of file diff --git a/case_study/base_settings/localParamInfo.txt b/test_ngen/gauge_01073000/settings/SUMMA/localParamInfo.txt similarity index 89% rename from case_study/base_settings/localParamInfo.txt rename to test_ngen/gauge_01073000/settings/SUMMA/localParamInfo.txt index 505343039..0b6481037 100644 --- a/case_study/base_settings/localParamInfo.txt +++ b/test_ngen/gauge_01073000/settings/SUMMA/localParamInfo.txt @@ -1,8 +1,3 @@ -! File provenance -! --------------- -! 2021-08-10: taken from the SUMMA test cases v3 distribution (WRR figures) and included as case study default file -! -! ! ======================================================================================================================= ! ======================================================================================================================= ! ===== DEFINITION OF MODEL PARAMETERS ================================================================================== @@ -29,12 +24,12 @@ ! ==================================================================== ! boundary conditions ! ==================================================================== -upperBoundHead | -0.7500 | -100.0000 | -0.0100 -lowerBoundHead | 0.0000 | -100.0000 | -0.0100 +upperBoundHead | 0.0000 | -10.0000 | 1.0000 +lowerBoundHead | -10.000 | -50.0000 | -1.0000 upperBoundTheta | 0.2004 | 0.1020 | 0.3680 lowerBoundTheta | 0.1100 | 0.1020 | 0.3680 -upperBoundTemp | 272.1600 | 270.1600 | 280.1600 -lowerBoundTemp | 274.1600 | 270.1600 | 280.1600 +upperBoundTemp | 274.1600 | 270.1600 | 280.1600 +lowerBoundTemp | 272.1600 | 270.1600 | 280.1600 ! ==================================================================== ! precipitation partitioning ! ==================================================================== @@ -44,13 +39,13 @@ frozenPrecipMultip | 1.0000 | 0.5000 | 1.5000 ! ==================================================================== ! snow properties ! ==================================================================== -snowfrz_scale | 50.0000 | 10.0000 | 1000.0000 +snowfrz_scale | 50.0000 | 10.0000 | 100.0000 fixedThermalCond_snow | 0.3500 | 0.1000 | 1.0000 ! ==================================================================== ! snow albedo ! ==================================================================== -albedoMax | 0.8400 | 0.7000 | 0.9500 -albedoMinWinter | 0.5500 | 0.6000 | 1.0000 +albedoMax | 0.8400 | 0.7000 | 0.9000 +albedoMinWinter | 0.6500 | 0.5500 | 1.0000 albedoMinSpring | 0.5500 | 0.3000 | 1.0000 albedoMaxVisible | 0.9500 | 0.7000 | 0.9500 albedoMinVisible | 0.7500 | 0.5000 | 0.7500 @@ -90,7 +85,7 @@ baseViscosity | 9.0d+5 | 5.0d+5 | 1.5d+6 ! ==================================================================== ! water flow through snow ! ==================================================================== -Fcapil | 0.0600 | 0.0100 | 0.1000 +Fcapil | 0.0600 | 0.0050 | 0.2000 k_snow | 0.0150 | 0.0050 | 0.0500 mw_exp | 3.0000 | 1.0000 | 5.0000 ! ==================================================================== @@ -104,8 +99,8 @@ critRichNumber | 0.2000 | 0.1000 | 1.0000 Louis79_bparam | 9.4000 | 9.2000 | 9.6000 Louis79_cStar | 5.3000 | 5.1000 | 5.5000 Mahrt87_eScale | 1.0000 | 0.5000 | 2.0000 -leafExchangeCoeff | 0.0100 | 0.0010 | 0.1000 -windReductionParam | 0.2800 | 0.0000 | 1.0000 +leafExchangeCoeff | 0.0100 | 0.0010 | 0.0100 +windReductionParam | 0.2800 | 0.2500 | 1.0000 ! ==================================================================== ! stomatal conductance ! ==================================================================== @@ -137,7 +132,7 @@ winterSAI | 1.0000 | 0.0100 | 3.0000 summerLAI | 3.0000 | 0.0100 | 10.0000 rootScaleFactor1 | 2.0000 | 1.0000 | 10.0000 rootScaleFactor2 | 5.0000 | 1.0000 | 10.0000 -rootingDepth | 2.0000 | 0.0100 | 10.0000 +rootingDepth | 2.0000 | 0.1000 | 6.0000 rootDistExp | 1.0000 | 0.0100 | 1.0000 plantWiltPsi | -150.0000 | -500.0000 | 0.0000 soilStressParam | 5.8000 | 4.3600 | 6.3700 @@ -158,7 +153,7 @@ snowUnloadingCoeff | 0.0000 | 0.0000 | 1.5d-6 canopyDrainageCoeff | 0.0050 | 0.0010 | 0.0100 ratioDrip2Unloading | 0.4000 | 0.0000 | 1.0000 canopyWettingFactor | 0.7000 | 0.0000 | 1.0000 -canopyWettingExp | 1.0000 | 0.0000 | 1.0000 +canopyWettingExp | 1.0000 | 0.4000 | 1.0000 ! ==================================================================== ! soil properties ! ==================================================================== @@ -169,23 +164,23 @@ frac_silt | 0.2800 | 0.0000 | 1.0000 frac_clay | 0.5600 | 0.0000 | 1.0000 fieldCapacity | 0.2000 | 0.0000 | 1.0000 wettingFrontSuction | 0.3000 | 0.1000 | 1.5000 -theta_mp | 0.4010 | 0.3000 | 0.6000 -theta_sat | 0.5500 | 0.3000 | 0.6000 -theta_res | 0.1390 | 0.0010 | 0.1000 +theta_mp | 0.3500 | 0.3000 | 0.6000 +theta_sat | 0.4500 | 0.3500 | 0.6500 +theta_res | 0.0500 | 0.0010 | 0.0800 vGn_alpha | -0.8400 | -1.0000 | -0.0100 -vGn_n | 1.3000 | 1.0000 | 3.0000 +vGn_n | 1.5000 | 1.2000 | 4.0000 mpExp | 5.0000 | 1.0000 | 10.0000 -k_soil | 7.5d-06 | 1.d-07 | 100.d-07 -k_macropore | 1.0d-03 | 1.d-07 | 100.d-07 +k_soil | 7.5d-06 | 1.d-08 | 1.d-02 +k_macropore | 1.0d-03 | 1.d-08 | 1.d-02 kAnisotropic | 1.0000 | 0.0001 | 10.0000 -zScale_TOPMODEL | 2.5000 | 0.1000 | 100.0000 +zScale_TOPMODEL | 2.5000 | 1.0000 | 10.0000 compactedDepth | 1.0000 | 0.0000 | 1.0000 -aquiferScaleFactor | 0.3500 | 0.1000 | 100.0000 +aquiferBaseflowRate | 0.1000 | 0.0000 | 0.1000 +aquiferScaleFactor | 0.3500 | 0.1000 | 10.0000 aquiferBaseflowExp | 2.0000 | 1.0000 | 10.0000 -aquiferBaseflowRate | 2.0000 | 1.0000 | 10.0000 qSurfScale | 50.0000 | 1.0000 | 100.0000 specificYield | 0.2000 | 0.1000 | 0.3000 -specificStorage | 1.d-09 | 1.d-05 | 1.d-07 +specificStorage | 1.d-06 | 1.d-07 | 1.d-05 f_impede | 2.0000 | 1.0000 | 10.0000 soilIceScale | 0.1300 | 0.0001 | 1.0000 soilIceCV | 0.4500 | 0.1000 | 5.0000 @@ -198,8 +193,8 @@ maxstep | 3600.0000 | 60.0000 | 1800.0000 wimplicit | 0.0000 | 0.0000 | 1.0000 maxiter | 100.0000 | 1.0000 | 100.0000 relConvTol_liquid | 1.0d-3 | 1.0d-5 | 1.0d-1 -absConvTol_liquid | 1.0d-6 | 1.0d-8 | 1.0d-3 -relConvTol_matric | 1.0d-6 | 1.0d-5 | 1.0d-1 +absConvTol_liquid | 1.0d-5 | 1.0d-8 | 1.0d-3 +relConvTol_matric | 1.0d-6 | 1.0d-7 | 1.0d-1 absConvTol_matric | 1.0d-6 | 1.0d-8 | 1.0d-3 relConvTol_energy | 1.0d-2 | 1.0d-5 | 1.0d-1 absConvTol_energy | 1.0d-0 | 1.0d-2 | 1.0d+1 @@ -227,4 +222,4 @@ zmaxLayer4_upper | 0.7500 | 0.7500 | 0.7500 minTempUnloading | 270.16 | 260.16 | 273.16 minWindUnloading | 0.0000 | 0.0000 | 10.000 rateTempUnloading | 1.87d+5 | 1.0d+5 | 3.0d+5 -rateWindUnloading | 1.56d+5 | 1.0d+5 | 3.0d+5 \ No newline at end of file +rateWindUnloading | 1.56d+5 | 1.0d+5 | 3.0d+5 diff --git a/case_study/reynolds/site_settings/modelDecisions_reynoldsConstantDecayRate.txt b/test_ngen/gauge_01073000/settings/SUMMA/modelDecisions.txt similarity index 79% rename from case_study/reynolds/site_settings/modelDecisions_reynoldsConstantDecayRate.txt rename to test_ngen/gauge_01073000/settings/SUMMA/modelDecisions.txt index 744eea32f..ba49e5e0d 100644 --- a/case_study/reynolds/site_settings/modelDecisions_reynoldsConstantDecayRate.txt +++ b/test_ngen/gauge_01073000/settings/SUMMA/modelDecisions.txt @@ -8,34 +8,38 @@ ! (3) the simulation start/end times must be within single quotes ! *********************************************************************************************************************** ! *********************************************************************************************************************** -soilCatTbl ROSETTA ! (03) soil-category dateset -vegeParTbl USGS ! (04) vegetation category dataset +soilCatTbl STAS ! (03) soil-category dataset +vegeParTbl USGS ! (04) vegetation category dataset soilStress NoahType ! (05) choice of function for the soil moisture control on stomatal resistance stomResist BallBerry ! (06) choice of function for stomatal resistance ! *********************************************************************************************************************** -num_method itertive ! (07) choice of numerical method +num_method homegrown ! (07) choice of numerical method fDerivMeth analytic ! (08) method used to calculate flux derivatives LAI_method monTable ! (09) method used to determine LAI and SAI f_Richards mixdform ! (10) form of Richard's equation -groundwatr noXplict ! (11) choice of groundwater parameterization +groundwatr bigBuckt ! (11) choice of groundwater parameterization hc_profile constant ! (12) choice of hydraulic conductivity profile bcUpprTdyn nrg_flux ! (13) type of upper boundary condition for thermodynamics bcLowrTdyn zeroFlux ! (14) type of lower boundary condition for thermodynamics bcUpprSoiH liq_flux ! (15) type of upper boundary condition for soil hydrology bcLowrSoiH drainage ! (16) type of lower boundary condition for soil hydrology -veg_traits CM_QJRMS1988 ! (17) choice of parameterization for vegetation roughness length and displacement height +veg_traits vegTypeTable ! (17) choice of parameterization for vegetation roughness length and displacement height canopyEmis difTrans ! (18) choice of parameterization for canopy emissivity snowIncept lightSnow ! (19) choice of parameterization for snow interception windPrfile logBelowCanopy ! (20) choice of wind profile through the canopy astability louisinv ! (21) choice of stability function -canopySrad CLM_2stream ! (22) choice of canopy shortwave radiation method -alb_method conDecay ! (23) choice of albedo representation +canopySrad noah_mp ! (22) choice of canopy shortwave radiation method +alb_method varDecay ! (23) choice of albedo representation compaction anderson ! (24) choice of compaction routine -snowLayers CLM_2010 ! (25) choice of method to combine and sub-divide snow layers +snowLayers jrdn1991 ! (25) choice of method to combine and sub-divide snow layers thCondSnow jrdn1991 ! (26) choice of thermal conductivity representation for snow -thCondSoil mixConstit ! (27) choice of thermal conductivity representation for soil +thCondSoil funcSoilWet ! (27) choice of thermal conductivity representation for soil spatial_gw localColumn ! (28) choice of method for the spatial representation of groundwater subRouting timeDlay ! (29) choice of method for sub-grid routing +nrgConserv enthalpyForm ! (30) choice of variable in energy equations (BE residual or IDA state variable) +infRateMax GreenAmpt ! (31) choice of infiltration rate method +surfRun_IE homegrown_IE ! (32) infiltration excess surface runoff parameterization +surfRun_SE homegrown_SE ! (33) saturation excess surface runoff parameterization ! *********************************************************************************************** ! ***** description of the options available -- nothing below this point is read **************** ! *********************************************************************************************** @@ -43,13 +47,13 @@ subRouting timeDlay ! (29) choice of method for sub- ! (01) simulation start time ! (02) simulation end time ! ----------------------------------------------------------------------------------------------- -! (03) soil-category dateset +! (03) soil-category dataset ! STAS ! STATSGO dataset ! STAS-RUC ! ?? ! ROSETTA ! merged Rosetta table with STAS-RUC ! ----------------------------------------------------------------------------------------------- ! (04) vegetation category dataset -! USGS ! USGS 24/27 category dataset +! USGS ! USGS 24/27 category dataset ! MODIFIED_IGBP_MODIS_NOAH ! MODIS 20-category dataset ! ----------------------------------------------------------------------------------------------- ! (05) choice of function for the soil moisture control on stomatal resistance @@ -62,12 +66,12 @@ subRouting timeDlay ! (29) choice of method for sub- ! Jarvis ! Jarvis ! ----------------------------------------------------------------------------------------------- ! (07) choice of numerical method -! itertive ! iterative -! non_iter ! non-iterative -! itersurf ! iterate only on the surface energy balance +! homegrown ! home-grown backward Euler +! kinsol ! SUNDIALS backward Euler solution using Kinsol +! ida ! SUNDIALS solution using IDA ! ----------------------------------------------------------------------------------------------- ! (08) method used to calculate flux derivatives -! numericl ! numerical derivatives +! numericl ! numerical derivatives (only works with SUNDIALS) ! analytic ! analytical derivatives ! ----------------------------------------------------------------------------------------------- ! (09) method used to determine LAI and SAI @@ -115,11 +119,11 @@ subRouting timeDlay ! (29) choice of method for sub- ! difTrans ! parameterized as a function of diffuse transmissivity ! ----------------------------------------------------------------------------------------------- ! (19) choice of parameterization for snow interception -! stickySnow ! maximum interception capacity an increasing function of temerature +! stickySnow ! maximum interception capacity an increasing function of temperature ! lightSnow ! maximum interception capacity an inverse function of new snow density ! ----------------------------------------------------------------------------------------------- ! (20) choice of wind profile -! exponential ! exponential wind profile extends to the surface +! exponential ! exponential wind profile extends to the surface ! logBelowCanopy ! logarithmic profile below the vegetation canopy ! ----------------------------------------------------------------------------------------------- ! (21) choice of stability function @@ -164,5 +168,25 @@ subRouting timeDlay ! (29) choice of method for sub- ! (29) choice of method for sub-grid routing ! timeDlay ! time-delay histogram ! qInstant ! instantaneous routing +! ----------------------------------------------------------------------------------------------- +! (30) choice of variable in energy equations (BE residual or IDA state variable) +! closedForm ! use temperature with closed form heat capacity +! enthalpyFormLU ! use enthalpy with soil temperature-enthalpy lookup tables +! enthalpyForm ! use enthalpy with soil temperature-enthalpy analytical solutions +! ----------------------------------------------------------------------------------------------- +! (31) choice of infiltration rate method +! GreenAmpt ! Green-Ampt +! topmodel_GA ! Green-Ampt with TOPMODEL conductivity rate +! noInfExc ! no infiltration excess runoff (saturation excess may still occur) +! ----------------------------------------------------------------------------------------------- +! (32) choice of infiltration excess (IE) surface runoff parameterization +! zero_IE ! zero IE surface runoff +! homegrown_IE ! IE component of SUMMA's original liquid flux parameterization (default) +! ----------------------------------------------------------------------------------------------- +! (33) choice of saturation excess (SE) surface runoff parameterization +! zero_SE ! zero SE surface runoff +! homegrown_SE ! SE component of SUMMA's original liquid flux parameterization (default) +! FUSEPRMS ! FUSE PRMS surface runoff parameterization +! FUSEAVIC ! FUSE ARNO/VIC surface runoff parameterization +! FUSETOPM ! FUSE TOPMODEL surface runoff parameterization ! *********************************************************************************************** -! history Mon Jul 20 16:08:16 2020: /pool0/home/andrbenn/data/summa_3/utils/convert_summa_config_v2_v3.py ./wrrPaperTestCases/figure06/summa_fileManager_reynoldsConstantDecayRate.txt diff --git a/test_ngen/gauge_01073000/settings/SUMMA/outputControl.txt b/test_ngen/gauge_01073000/settings/SUMMA/outputControl.txt new file mode 100644 index 000000000..9c234c8dd --- /dev/null +++ b/test_ngen/gauge_01073000/settings/SUMMA/outputControl.txt @@ -0,0 +1,28 @@ +! ------------- +! attributes +! ------------- +!hruId +!latitude +!longitude +! +! ----------- +! forcings +! ----------- +pptrate | 1 +airtemp | 1 +SWRadAtm | 24 +! +! +! ------------------- +! model variables +! ------------------- +averageRoutedRunoff | 1 +scalarTotalRunoff | 24 +scalarSWE | 24 +scalarGroundSnowFraction | 24 +! +SWRadAtm | 1 +scalarSWE | 1 + + + diff --git a/test_ngen/gauge_01073000/settings/SUMMA/trialParams_default.nc b/test_ngen/gauge_01073000/settings/SUMMA/trialParams_default.nc new file mode 100644 index 000000000..0ecb3bdb7 Binary files /dev/null and b/test_ngen/gauge_01073000/settings/SUMMA/trialParams_default.nc differ diff --git a/test_ngen/gauge_01073000/settings/SUMMA/trialParams_default_tiled_by_hru.nc b/test_ngen/gauge_01073000/settings/SUMMA/trialParams_default_tiled_by_hru.nc new file mode 100644 index 000000000..1ff5e04cc Binary files /dev/null and b/test_ngen/gauge_01073000/settings/SUMMA/trialParams_default_tiled_by_hru.nc differ diff --git a/test_ngen/gauge_01073000/settings/cat-11223.input b/test_ngen/gauge_01073000/settings/cat-11223.input new file mode 100644 index 000000000..4c31490d2 --- /dev/null +++ b/test_ngen/gauge_01073000/settings/cat-11223.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/gauge_01073000/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 4 + restart_print_freq = "e" +/ diff --git a/test_ngen/gauge_01073000/settings/cat-11224.input b/test_ngen/gauge_01073000/settings/cat-11224.input new file mode 100644 index 000000000..8b937ed7f --- /dev/null +++ b/test_ngen/gauge_01073000/settings/cat-11224.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/gauge_01073000/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 5 + restart_print_freq = "e" +/ diff --git a/test_ngen/gauge_01073000/settings/cat-11371.input b/test_ngen/gauge_01073000/settings/cat-11371.input new file mode 100644 index 000000000..0af666949 --- /dev/null +++ b/test_ngen/gauge_01073000/settings/cat-11371.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/gauge_01073000/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 2 + restart_print_freq = "e" +/ diff --git a/test_ngen/gauge_01073000/settings/cat-11410.input b/test_ngen/gauge_01073000/settings/cat-11410.input new file mode 100644 index 000000000..c021505c5 --- /dev/null +++ b/test_ngen/gauge_01073000/settings/cat-11410.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/gauge_01073000/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 1 + restart_print_freq = "e" +/ diff --git a/test_ngen/gauge_01073000/settings/cat-11509.input b/test_ngen/gauge_01073000/settings/cat-11509.input new file mode 100644 index 000000000..476b5a66e --- /dev/null +++ b/test_ngen/gauge_01073000/settings/cat-11509.input @@ -0,0 +1,5 @@ +¶meters + file_manager = "./extern/summa/summa/test_ngen/gauge_01073000/settings/SUMMA/fileManager.txt" + attrib_file_HRU_order = 3 + restart_print_freq = "e" +/ diff --git a/test_ngen/gauge_01073000/settings/example_realization_config_w_summa_bmi.json b/test_ngen/gauge_01073000/settings/example_realization_config_w_summa_bmi.json new file mode 100644 index 000000000..e17e64af1 --- /dev/null +++ b/test_ngen/gauge_01073000/settings/example_realization_config_w_summa_bmi.json @@ -0,0 +1,51 @@ +{ + "global": { + "formulations": [ + { + "name": "bmi_multi", + "params": { + "model_type_name": "bmi_multi_summa", + "forcing_file": "", + "init_config": "", + "allow_exceed_end_time": true, + "main_output_variable": "land_surface_water__runoff_volume_flux", + "modules": [ + { + "name": "bmi_fortran", + "params": { + "model_type_name": "bmi_fortran_summa", + "library_file": "./extern/summa/cmake_build/libsummabmi", + "forcing_file": "", + "init_config": "./extern/summa/summa/test_ngen/gauge_01073000/settings/{{id}}.input", + "allow_exceed_end_time": true, + "main_output_variable": "land_surface_water__runoff_volume_flux", + "variables_names_map": { + "atmosphere_water__precipitation_mass_flux": "precip_rate", + "land_surface_air__temperature": "TMP_2maboveground", + "atmosphere_air_water~vapor__relative_saturation": "SPFH_2maboveground", + "land_surface_wind__x_component_of_velocity": "UGRD_10maboveground", + "land_surface_wind__y_component_of_velocity": "VGRD_10maboveground", + "land_surface_radiation~incoming~shortwave__energy_flux": "DSWRF_surface", + "land_surface_radiation~incoming~longwave__energy_flux": "DLWRF_surface", + "land_surface_air__pressure": "PRES_surface" + }, + "uses_forcing_file": false + } + } + ], + "uses_forcing_file": false + } + } + ], + "forcing": { + "path": "./data/gauge_01073000/forcing.nc", + "provider": "NetCDF" + } + }, + "time": { + "start_time": "2015-12-01 0:00:00", + "end_time": "2015-12-30 23:00:00", + "output_interval": 3600 + }, + "output_root": "./test/data/routing/" +} diff --git a/test_ngen/gauge_01073000/settings/example_realization_config_w_summa_bmi_routing.json b/test_ngen/gauge_01073000/settings/example_realization_config_w_summa_bmi_routing.json new file mode 100644 index 000000000..2bb9a903f --- /dev/null +++ b/test_ngen/gauge_01073000/settings/example_realization_config_w_summa_bmi_routing.json @@ -0,0 +1,54 @@ +{ + "global": { + "formulations": [ + { + "name": "bmi_multi", + "params": { + "model_type_name": "bmi_multi_summa", + "forcing_file": "", + "init_config": "", + "allow_exceed_end_time": true, + "main_output_variable": "land_surface_water__runoff_volume_flux", + "modules": [ + { + "name": "bmi_fortran", + "params": { + "model_type_name": "bmi_fortran_summa", + "library_file": "./extern/summa/cmake_build/libsummabmi", + "forcing_file": "", + "init_config": "./extern/summa/summa/test_ngen/gauge_01073000/settings/{{id}}.input", + "allow_exceed_end_time": true, + "main_output_variable": "land_surface_water__runoff_volume_flux", + "variables_names_map": { + "atmosphere_water__precipitation_mass_flux": "precip_rate", + "land_surface_air__temperature": "TMP_2maboveground", + "atmosphere_air_water~vapor__relative_saturation": "SPFH_2maboveground", + "land_surface_wind__x_component_of_velocity": "UGRD_10maboveground", + "land_surface_wind__y_component_of_velocity": "VGRD_10maboveground", + "land_surface_radiation~incoming~shortwave__energy_flux": "DSWRF_surface", + "land_surface_radiation~incoming~longwave__energy_flux": "DLWRF_surface", + "land_surface_air__pressure": "PRES_surface" + }, + "uses_forcing_file": false + } + } + ], + "uses_forcing_file": false + } + } + ], + "forcing": { + "path": "./data/gauge_01073000/forcing.nc", + "provider": "NetCDF" + } + }, + "time": { + "start_time": "2015-12-01 0:00:00", + "end_time": "2015-12-30 23:00:00", + "output_interval": 3600 + }, + "output_root": "./test/data/routing/", + "routing": { + "t_route_config_file_with_path": "./test/data/routing/ngen_routing_config_unit_test.yaml" + } +} diff --git a/test_ngen/gauge_01073000/simulations/run_1/SUMMA/.gitkeep b/test_ngen/gauge_01073000/simulations/run_1/SUMMA/.gitkeep new file mode 100644 index 000000000..e69de29bb diff --git a/test_ngen/io_scripts/convert_forcing.py b/test_ngen/io_scripts/convert_forcing.py new file mode 100644 index 000000000..0926086b6 --- /dev/null +++ b/test_ngen/io_scripts/convert_forcing.py @@ -0,0 +1,180 @@ +#!/usr/bin/env python3 +""" +Convert SUMMA forcing files to NGen forcing format or vice versa. +Usage: + python3 convert_forcing.py input_file.nc output_file.nc typeOfConversion attributes_file.nc(optional) +""" +import argparse +import xarray as xr +import numpy as np +import re + +def _parse_id(fid): + # try direct int, else extract trailing digits, else first digits, else return original string + try: + return int(fid) + except Exception: + s = str(fid).strip() + m = re.search(r'(\d+)$', s) or re.search(r'(\d+)', s) + return int(m.group(1)) if m else s + +def main(): + p = argparse.ArgumentParser() + p.add_argument("input_file", help="input_file.nc (SUMMA or NGen forcing file)") + p.add_argument("output_file", help="output_file.nc (converted forcing file)") + p.add_argument("typeOfConversion", help="type of conversion: summa_to_ngen or ngen_to_summa") + p.add_argument("attributes_file", nargs='?', help="attributes_file.nc (optional, for lat/lon info)", default=None) + args = p.parse_args() + + # open input file + f_ds = xr.open_dataset(args.input_file) + + # do conversion + if args.typeOfConversion == "ngen_to_summa": + f_var = "ids" + if f_var not in f_ds: + raise RuntimeError(f"NGen forcing file missing '{f_var}' variable") + f_ids_raw = np.array([str(x) for x in f_ds[f_var].values]) + f_ids = np.array([_parse_id(fid) for fid in f_ids_raw]) + + # make hru dimension name consistent with SUMMA and replace ids with parsed integer ids + f_ds = f_ds.rename_dims({"catchment-id": "hru"}) + f_ds[f_var] = (("hru",), f_ids) + + # rename other variables to match SUMMA conventions + f_ds = f_ds.rename_vars({ + "ids": "hruId", + "precip_rate": "pptrate", + "TMP_2maboveground": "airtemp", + "SPFH_2maboveground": "spechum", + "PRES_surface": "airpres", + "DSWRF_surface": "SWRadAtm", + "DLWRF_surface": "LWRadAtm", + }) + + # make time a coordinate instead of variable and set values to Time values as datetime64[ns] + time_da = f_ds['Time'] + if time_da.ndim == 1: + tvals = time_da.values.astype('datetime64[ns]') + elif time_da.ndim == 2: + # if Time is repeated per hru, take the first hru column (assumes identical) + other_dims = [d for d in time_da.dims if d != 'time'] + if other_dims: + tvals = time_da.isel({other_dims[0]: 0}).values.astype('datetime64[ns]') + else: + # fallback: assume shape (time, N) and take first column + tvals = time_da.values[:, 0].astype('datetime64[ns]') + else: + raise RuntimeError(f"Unsupported Time ndim: {time_da.ndim}") + f_ds = f_ds.assign_coords(time=('time', tvals)) + f_ds = f_ds.drop_vars('Time') + + # make windspd UV components into speed + u = f_ds["UGRD_10maboveground"] + v = f_ds["VGRD_10maboveground"] + f_ds["windspd"] = np.sqrt(u**2 + v**2) + f_ds = f_ds.drop_vars("UGRD_10maboveground") + f_ds = f_ds.drop_vars("VGRD_10maboveground") + + # add data_step variable + f_ds["data_step"] = ((), np.int64(3600)) + + # add lat/lon variables as read from attributes (if attributes_file provided) + if args.attributes_file: + f_attr = xr.open_dataset(args.attributes_file) + f_ds["latitude"] = f_attr["latitude"] + f_ds["longitude"] = f_attr["longitude"] + + # ensure data variables use dims ('time','hru') not ('hru','time') + for name, var in list(f_ds.data_vars.items()): + dims = tuple(var.dims) + if dims == ("hru", "time"): + f_ds[name] = var.transpose("time", "hru") + elif set(dims) >= {"time", "hru"} and dims.index("hru") < dims.index("time"): + # generic reorder if hru appears before time + new_order = tuple(d for d in dims if d != "hru") + ("hru",) if "time" not in dims else ("time","hru") + try: + f_ds[name] = var.transpose(*new_order) + except Exception: + pass + + # write output file + f_ds.to_netcdf(args.output_file) + print(f"Wrote converted SUMMA forcing file to {args.output_file}") + + elif args.typeOfConversion == "summa_to_ngen": + f_var = "hruId" + if f_var not in f_ds: + raise RuntimeError(f"SUMMA forcing file missing '{f_var}' variable") + f_ids_raw = f_ds[f_var].values + f_ids = np.array([f"cat-{str(fid)}" for fid in f_ids_raw]) + + # make hru dimension name consistent with NGen and replace hruId with string ids + f_ds = f_ds.rename_dims({"hru": "catchment-id"}) + f_ds[f_var] = (("catchment-id"), f_ids) + + # rename other variables to match NGen conventions + f_ds = f_ds.rename_vars({ + "hruId": "ids", + "pptrate": "precip_rate", + "airtemp": "TMP_2maboveground", + "spechum": "SPFH_2maboveground", + "airpres": "PRES_surface", + "SWRadAtm": "DSWRF_surface", + "LWRadAtm": "DLWRF_surface", + }) + + # make Time a variable from time coordinate tiled by catchment and drop time coordinate + time_vals = f_ds.coords["time"].values.astype("datetime64[ns]") + time_vals = np.asarray(time_vals, dtype="datetime64[ns]") + ntime = time_vals.shape[0] + n = f_ds.sizes.get("catchment-id", f_ds.sizes.get("hru", 1)) + + # build 2-D Time in nanoseconds as float64 to match other files + time_ns = time_vals.astype("datetime64[ns]").astype("int64").astype(np.float64) + tiled = np.broadcast_to(time_ns[None, :], (n, ntime)) # shape (catchment-id, time) + f_ds["Time"] = (("catchment-id", "time"), tiled) + f_ds["Time"].attrs["units"] = "ns" + # clear problematic encoding/attrs that can trigger packing/valid_range errors + f_ds["Time"].encoding.clear() + for bad in ("valid_range", "_FillValue", "missing_value", "scale_factor", "add_offset"): + f_ds["Time"].attrs.pop(bad, None) + + # make windspd into UV components, all north wind for now + windspd = f_ds["windspd"] + f_ds["UGRD_10maboveground"] = windspd + f_ds["VGRD_10maboveground"] = xr.zeros_like(windspd) + f_ds = f_ds.drop_vars("windspd") + + # remove SUMMA-only variables (if present) + for maybe in ("latitude", "longitude", "data_step"): + if maybe in f_ds: + f_ds = f_ds.drop_vars(maybe) + + # ensure data variables use dims ('catchment-id','time') not ('time','catchment-id') + for name, var in list(f_ds.data_vars.items()): + dims = tuple(var.dims) + if dims == ("time", "catchment-id"): + f_ds[name] = var.transpose("catchment-id", "time") + elif set(dims) >= {"time", "catchment-id"} and dims.index("time") < dims.index("catchment-id"): + # generic reorder if time appears before catchment-id + new_order = tuple(d for d in dims if d != "time") + ("time",) if "catchment-id" not in dims else ("catchment-id","time") + try: + f_ds[name] = var.transpose(*new_order) + except Exception: + pass + + # write output file + f_ds.to_netcdf(args.output_file) + print(f"Wrote NGen forcing to {args.output_file}") + + else: + raise RuntimeError("typeOfConversion must be either 'summa_to_ngen' or 'ngen_to_summa'") + + + + + + +if __name__ == "__main__": + main() \ No newline at end of file diff --git a/test_ngen/io_scripts/merge_restarts.py b/test_ngen/io_scripts/merge_restarts.py new file mode 100644 index 000000000..df45b22af --- /dev/null +++ b/test_ngen/io_scripts/merge_restarts.py @@ -0,0 +1,115 @@ +#!/usr/bin/env python3 +""" +Merge NGEN restart files from multiple GRUs into a single SUMMA restart file with same GRU order as a given (old) restart file. +Usage: + python3 merge_restarts.py init_cond.nc restart_pattern date_string +""" +import argparse +import xarray as xr +import os + +def drop_hru_if_has_gru(ds, strategy="first"): + """ + For every data variable that has both 'gru' and 'hru' dims, + collapse the 'hru' dim according to strategy and replace the var. + strategy: "first" | "mean" | "sum" + """ + for vn in list(ds.data_vars): + da = ds[vn] + dims = tuple(str(d) for d in da.dims) + if "gru" in dims and "hru" in dims: + if strategy == "first": + new = da.isel(hru=0) + elif strategy == "mean": + new = da.mean(dim="hru") + elif strategy == "sum": + new = da.sum(dim="hru") + else: + raise ValueError(f"unknown strategy {strategy}") + ds[vn] = new + # remove any leftover coordinate variables (optional) + ds = ds.reset_coords(drop=True) + return ds + + + +def main(): + p = argparse.ArgumentParser() + p.add_argument("init_cond", help="init_cond.nc (initial condition file with desired GRU order)") + p.add_argument("restart_pattern", help="pattern for GRU restart files, e.g. gauge_01073000/simulations/run_1/SUMMA/run_1_restart_{}_G{}-{}.nc") + p.add_argument("date_string", help="date string to identify restart files, e.g. 2015123023") + args = p.parse_args() + + + file_ds = xr.open_dataset(args.init_cond) + hru_ids = file_ds['hruId'].values.tolist() + + # create empty list to hold datasets + ds_list = [] + for i, hru_id in enumerate(hru_ids): + restart_file = args.restart_pattern.format(args.date_string,str(i+1),str(i+1)) + if not os.path.isfile(restart_file): + raise RuntimeError(f"Restart file {restart_file} for HRU ID {hru_id} not found.") + ds = xr.open_dataset(restart_file) + ds_list.append(ds) + + if not ds_list: + raise RuntimeError("No restart files found.") + + # union of variable names across all datasets + all_vars = sorted(set().union(*(set(ds.data_vars.keys()) for ds in ds_list))) + + out_vars = {} + for var in all_vars: + # choose concat dim for this variable + choose_dim = None + for ds in ds_list: + if var in ds and "hru" in ds[var].dims: + choose_dim = 'hru' + break + if choose_dim is None: + for ds in ds_list: + if var in ds and "gru" in ds[var].dims: + choose_dim = 'gru' + break + + # prepare per-file DataArray list, ensuring a length-1 concat dim and coord value from hru_ids + arrs = [] + for idx, ds in enumerate(ds_list): + this_id = hru_ids[idx] + if var in ds: + da = ds[var] + dims = tuple(str(d) for d in da.dims) + if choose_dim in dims: + da = da.expand_dims({}) if False else da # no-op; keep shape + # ensure coord for the dim is the desired id + try: + da = da.assign_coords({choose_dim: (choose_dim, [this_id])}) + except Exception: + # some variables may not allow assign_coords; construct new DataArray + da = xr.DataArray(da.values, dims=da.dims, coords={choose_dim: [this_id]}, attrs=da.attrs) + else: + # add leading concat dim + da = da.expand_dims({choose_dim: [this_id]}) + da = da.assign_coords({choose_dim: (choose_dim, [this_id])}) + else: + raise RuntimeError(f"Variable {var} not found in restart file for HRU ID {this_id}") + + arrs.append(da) + + # concat for this variable + try: + conc = xr.concat(arrs, dim=choose_dim, combine_attrs='override') + except Exception: + # fallback: try concat by building numpy stack then DataArray + conc = xr.concat(arrs, dim=choose_dim, combine_attrs='override') + out_vars[var] = conc + + # assemble final dataset from per-variable DataArrays + merged_ds = xr.Dataset(data_vars=out_vars) + out_path = args.restart_pattern.replace("{}_G{}-{}.nc", f"merged_{args.date_string}.nc") + merged_ds.to_netcdf(out_path) + print(f"Wrote merged restart to {out_path}") + +if __name__ == "__main__": + main() \ No newline at end of file diff --git a/test_ngen/io_scripts/processInput.sh b/test_ngen/io_scripts/processInput.sh new file mode 100644 index 000000000..d138238af --- /dev/null +++ b/test_ngen/io_scripts/processInput.sh @@ -0,0 +1,14 @@ +python3 io_scripts/tile_files_by_hru.py gauge_01073000/settings/SUMMA/attributes.nc ../../../../data/gauge_01073000/forcing.nc attrib ../../../../data/gauge_01073000 + +python3 io_scripts/tile_files_by_hru.py gauge_01073000/settings/SUMMA/trialParams_default.nc ../../../../data/gauge_01073000/forcing.nc param ../../../../data/gauge_01073000 + +python3 io_scripts/tile_files_by_hru.py gauge_01073000/settings/SUMMA/coldstate.nc ../../../../data/gauge_01073000/forcing.nc init ../../../../data/gauge_01073000 + +#python3 scripts/tile_files_by_hru.py gauge_01073000/forcing/SUMMA_input/summa_forcing.nc ../../../../data/gauge_01073000/forcing.nc force ../../../../data/gauge_01073000 + +python3 io_scripts/write_input.py gauge_01073000/settings/SUMMA/fileManager.txt ../../../../data/gauge_01073000/forcing.nc e gauge_01073000/settings + +python3 io_scripts/convert_forcing.py ../../../../data/gauge_01073000/forcing.nc gauge_01073000/forcing/SUMMA_input/summa_forcing_from_ngen.nc ngen_to_summa gauge_01073000/settings/SUMMA/attributes_tiled_by_hru.nc + +#python3 io_scripts/convert_forcing.py gauge_01073000/forcing/SUMMA_input/summa_forcing_tiled_by_hru.nc gauge_01073000/forcing/ngen_forcing_from_summa.nc summa_to_ngen + diff --git a/test_ngen/io_scripts/processOutput.sh b/test_ngen/io_scripts/processOutput.sh new file mode 100644 index 000000000..0195d8ab9 --- /dev/null +++ b/test_ngen/io_scripts/processOutput.sh @@ -0,0 +1 @@ +python3 io_scripts/merge_restarts.py gauge_01073000/settings/SUMMA/coldstate_tiled_by_hru.nc gauge_01073000/simulations/run_1/SUMMA/run_1_restart_{}_G{}-{}.nc 2015123023 \ No newline at end of file diff --git a/test_ngen/io_scripts/tile_files_by_hru.py b/test_ngen/io_scripts/tile_files_by_hru.py new file mode 100644 index 000000000..52a0cb5b6 --- /dev/null +++ b/test_ngen/io_scripts/tile_files_by_hru.py @@ -0,0 +1,287 @@ +#!/usr/bin/env python3 +""" +Tile/reindex SUMMA file with one HRU by hruId to match ids/order in NGEN forcing.nc. +Usage: + python3 tile_files_by_hru.py old_file.nc forcing.nc typeOfInput folder_to_other_attribs (optional) +""" +import argparse +import xarray as xr +import numpy as np +import re +import os +from ast import literal_eval + +def _parse_id(fid): + # try direct int, else extract trailing digits, else first digits, else return original string + try: + return int(fid) + except Exception: + s = str(fid).strip() + m = re.search(r'(\d+)$', s) or re.search(r'(\d+)', s) + return int(m.group(1)) if m else s + +def _parse_namelist(text): + groups = {} + for m in re.finditer(r'&(\w+)(.*?)/', text, re.S): + name, body = m.group(1), m.group(2) + vals = {} + for line in re.split(r'[\r\n]+', body): + line = re.sub(r'!.*$', '', line).strip() # drop comments + if not line: + continue + for kv in line.split(','): + if '=' not in kv: + continue + k, v = map(str.strip, kv.split('=', 1)) + # try to convert to number/list/string + try: + parsed = literal_eval(v) + except Exception: + parsed = v.strip().strip('"').strip("'") + vals[k] = parsed + groups[name] = vals + return groups + +def _parse_kv_text(text): + from ast import literal_eval + import re + + out = {} + for line in text.splitlines(): + line = re.sub(r'#.*$', '', line).strip() # drop comments starting with # + line = re.sub(r'\[.*$', '', line).strip() # drop units starting with [ + if not line: + continue + if '=' not in line: + continue + k, v = map(str.strip, line.split('=', 1)) + # normalize booleans used in config files + vl = v.strip().strip('"').strip("'") + if vl.upper() in ("TRUE", "T", "YES", "Y", "ON"): + out[k] = True + continue + if vl.upper() in ("FALSE", "F", "NO", "N", "OFF"): + out[k] = False + continue + # try numeric / list parsing + try: + out[k] = literal_eval(vl) + except Exception: + # fallback: try int/float then raw string + try: + out[k] = int(vl) + except Exception: + try: + out[k] = float(vl) + except Exception: + out[k] = vl + return out + +def _ensure_hru_var(ds, name, n, fill=np.nan, dtype=float): + if name not in ds: + arr = np.full((n,), fill, dtype=dtype) + ds[name] = xr.DataArray(arr, dims=("hru",), attrs={}) + return ds + +def _fixSoilVar(ds,var_name): + """Fix soil variable to have midSoil dimension instead of midToto.""" + da = ds[var_name] + + if 'midToto' in da.dims: + # rename the existing dimension + ds['mLayerMatricHead'] = da.rename({'midToto': 'midSoil'}) + else: + # create a new midSoil dim of the same length as midToto (fallback to 1 if missing) + size = ds.dims.get('midToto', 1) + ds[var_name] = da.expand_dims({'midSoil': size}) + return ds + +def _fixWaterContentVar(ds): + """Fix water content variable to be small enough.""" + # if mLayerVolFracLiq is close to default value then lower it + default_water_content = 0.45 # assumed default + ds['mLayerVolFracLiq'].values[ds['mLayerVolFracLiq'].values > default_water_content-0.] = default_water_content - 0.15 + return ds + +def main(): + p = argparse.ArgumentParser() + p.add_argument("old_file", help="old_file.nc (with single HRU)") + p.add_argument("forcing", help="forcing.nc (contains target HRU ids/order)") + p.add_argument("typeOfInput", help="type of input files in other_folder: param or attrib ") + p.add_argument("other_folder", nargs='?', default=None, help="file folder containing other model old_file to search (optional)") + args = p.parse_args() + + file_ds = xr.open_dataset(args.old_file) + f_ds = xr.open_dataset(args.forcing) + typeOfInput = args.typeOfInput.lower() + if typeOfInput not in ("param", "attrib", "init", "force"): + raise RuntimeError(f"typeOfInput must be 'param' or 'attrib' or 'init' or 'force', got '{typeOfInput}'") + + if typeOfInput == "init": + file_ds = _fixSoilVar(file_ds, 'mLayerMatricHead') + file_ds = _fixWaterContentVar(file_ds) + + out_path = args.old_file.replace(".nc", f"_tiled_by_hru.nc") + + # forcing ids (use as labels for the new hru coordinate) + f_var = "ids" + if f_var not in f_ds: + raise RuntimeError(f"forcing file missing '{f_var}' variable") + f_ids_raw = np.array([str(x) for x in f_ds[f_var].values]) + f_ids = np.array([_parse_id(fid) for fid in f_ids_raw]) + n = f_ids.size + + # tile old_file to match forcing ids/order + data_vars = {} + for vn, var in file_ds.data_vars.items(): + var_dims = tuple(str(d) for d in var.dims) + vals = var.values + + # prefer expanding an existing 'hru' axis, otherwise 'gru', otherwise add leading 'hru' + if "hru" in var_dims: + axis = var_dims.index("hru") + size = var.sizes.get("hru", 1) + if size == n: + arr_vals = vals + else: + arr_vals = np.repeat(vals, n, axis=axis) + arr = xr.DataArray(arr_vals, dims=var_dims, attrs=var.attrs) + + elif "gru" in var_dims: + axis = var_dims.index("gru") + size = var.sizes.get("gru", 1) + if size == n: + arr_vals = vals + else: + arr_vals = np.repeat(vals, n, axis=axis) + arr = xr.DataArray(arr_vals, dims=var_dims, attrs=var.attrs) + + else: + # keep same, no additional dimensions + arr = xr.DataArray(var.values, dims=var_dims, attrs=var.attrs) + + data_vars[vn] = arr + + # preserve coordinate variables from original file_ds + coords = {} + for k, v in file_ds.coords.items(): + coords[k] = (tuple(str(d) for d in v.dims), v.values) + + tiled = xr.Dataset(data_vars=data_vars, coords=coords, attrs=file_ds.attrs) + + # remove all coordinate variables except 'time' (if any) + to_drop = [c for c in list(tiled.coords) if c != 'time'] + if to_drop: + tiled = tiled.drop_vars(to_drop) + + # make hruId and gruId be ids from forcing file + if "hruId" in tiled: + tiled['hruId'].values = f_ids + if "gruId" in tiled: + tiled['gruId'].values = f_ids + + # redo hru2gru mapping if present + if "hru2gruId" in tiled: + tiled['hru2gruId'].values = f_ids + + # set old_file from distributed files, all text files with matching hruId names + NOAH_folder = os.path.join(args.other_folder, "NOAH") + PET_folder = os.path.join(args.other_folder, "PET") + CFE_folder = os.path.join(args.other_folder, "CFE") + + # default NOAH decisions + # precip_phase_option = 1 # Jordan (1991) SNTHERM equation + # snow_albedo_option = 1 # 1 is BATS==varDecay + # dynamic_veg_option = 4 # use table LAI; use maximum vegetation fraction + # runoff_option = 3 # original surface and subsurface runoff (free drainage) + # drainage_option = 8 # original subsurface runoff (free drainage) with dynamic VIC runoff + # frozen_soil_option = 1 # linear effects, more permeable + # dynamic_vic_option = 1 # 1 is Philip scheme, 2 is Green-Ampt + # radiative_transfer_option = 3 # modified two-stream (gap = F(solar angle, 3D structure ...)<1-FVEG) + # sfc_drag_coeff_option = 1 # surface layer drag coeff M-O theory + # canopy_stom_resist_option = 1 # Ball-Berry + # snowsoil_temp_time_option = 3 # semi-implicit; flux top boundary condition, FSNO for TS calculation + # soil_temp_boundary_option = 2 # zero flux bottom boundary condition + # supercooled_water_option = 1 # no iteration for supercooled water + # stomatal_resistance_option = 1 # NOAH, thresholded linear function of volumetric liquid water content + # evap_srfc_resistance_option = 4 # Sakaguchi and Zeng (2009) for bare soil evaporation resistance, rsurf = rsurf_snow for snow + # subsurface_option = 2 # one-way coupled hydrostatic + for fn in os.listdir(NOAH_folder): + file_path = os.path.join(NOAH_folder, fn) + base_name, ext = os.path.splitext(fn) + # id should be number matching hruIds + try: + fid = _parse_id(base_name) + except Exception: + continue + if fid in f_ids: + idx = np.where(f_ids == fid)[0][0] + nml = _parse_namelist(open(file_path, 'r').read()) + if typeOfInput == "param": + # set parameters + tiled = _ensure_hru_var(tiled, 'tempCritRain', n, fill=np.nan) + tiled['tempCritRain'].values[idx] = nml['forcing']['rain_snow_thresh']+273.15 # convert C to K + elif typeOfInput == "attrib": + # NOTE: ideally would have HRUarea, but since GRU and HRU are 1-1, HRUarea is not needed in summa code + tiled['latitude'].values[idx] = nml['location']['lat'] + tiled['longitude'].values[idx] = nml['location']['lon'] + #tiled['aspect'].values[idx] = nml['location']['azimuth'] # seems to be always 0 + tiled['mHeight'].values[idx] = nml['forcing']['ZREF'] # reference height for wind + tiled['vegTypeIndex'].values[idx] = nml['structure']['vegtyp'] + tiled['soilTypeIndex'].values[idx] = nml['structure']['isltyp'] + #tiled['tan_slope'].values[idx] = np.tan(np.deg2rad(nml['location']['terrain_slope'])) # compute tan_slope from slope in degrees, seems to be always 0 + elif typeOfInput == "force": + tiled['latitude'].values[idx] = nml['location']['lat'] + tiled['longitude'].values[idx] = nml['location']['lon'] + + # PET + # uses logBelowCanopy wind decision + for fn in os.listdir(PET_folder): + file_path = os.path.join(PET_folder, fn) + base_name, ext = os.path.splitext(fn) + # id should be number matching hruIds + try: + fid = _parse_id(base_name) + except Exception: + continue + if fid in f_ids: + idx = np.where(f_ids == fid)[0][0] + kvs = _parse_kv_text(open(file_path, 'r').read()) + if typeOfInput == "param": + tiled = _ensure_hru_var(tiled, 'heightCanopyTop', n, fill=np.nan) + tiled['heightCanopyTop'].values[idx] = kvs['vegetation_height_m'] + #tiled['zpdFraction'].values[idx] = kvs['zero_plane_displacement_height_m']/kvs['vegetation_height'] # seems too small + elif typeOfInput == "attrib": + tiled['elevation'].values[idx] = kvs['site_elevation_m'] + + # CFE + for fn in os.listdir(CFE_folder): + file_path = os.path.join(CFE_folder, fn) + base_name, ext = os.path.splitext(fn) + # id should be number matching hruIds + try: + fid = _parse_id(base_name) + except Exception: + continue + if fid in f_ids: + idx = np.where(f_ids == fid)[0][0] + kvs = _parse_kv_text(open(file_path, 'r').read()) + if typeOfInput == "param": + continue # no parameters to set from CFE files, these available but contradict NOAH table values + #tiled = _ensure_hru_var(tiled, 'theta_sat', n, fill=np.nan) + #tiled = _ensure_hru_var(tiled, 'k_soil', n, fill=np.nan) + #tiled = _ensure_hru_var(tiled, 'critSoilWilting', n, fill=np.nan) + #tiled['theta_sat'].values[idx] = kvs['soil_params.smcmax'] # effective porosity [V/V] + #tiled['k_soil'].values[idx] = kvs['soil_params.satdk'] # saturated hydraulic conductivity [m s-1] + #tiled['critSoilWilting'].values[idx] = kvs['soil_params.wltsmc'] # wilting point soil moisture content [V/V] + + if typeOfInput == "init": + tiled['dt_init'].values = np.full(tiled['dt_init'].shape, 3600.0) # default 1 hour time step for initialization files + + # write result + tiled.to_netcdf(out_path) + print(f"Wrote tiled file to {out_path}") + + +if __name__ == "__main__": + main() \ No newline at end of file diff --git a/test_ngen/io_scripts/write_input.py b/test_ngen/io_scripts/write_input.py new file mode 100644 index 000000000..7fdba6e2e --- /dev/null +++ b/test_ngen/io_scripts/write_input.py @@ -0,0 +1,57 @@ +#!/usr/bin/env python3 +""" +Write input files for NGEN from SUMMA fileManager and NGEN forcing files. +Usage: + python3 write_input.py summa_fileManager.nc ngen_forcing.nc restart_freq output_folder +""" +import argparse +import xarray as xr +import numpy as np +import re +import os + +def _parse_id(fid): + # try direct int, else extract trailing digits, else first digits, else return original string + try: + return int(fid) + except Exception: + s = str(fid).strip() + m = re.search(r'(\d+)$', s) or re.search(r'(\d+)', s) + return int(m.group(1)) if m else s + +def main(): + p = argparse.ArgumentParser() + p.add_argument("fileManager", help="summa_fileManager.nc (SUMMA fileManager file)") + p.add_argument("ngen_forcing", help="ngen_forcing.nc (contains target HRU ids/order)") + p.add_argument("restart_freq", help="restart frequency string, y for every year, m for month, d for day, e for end, n for never") + p.add_argument("output_folder", help="output folder for NGEN input files") + args = p.parse_args() + + # forcing ids (use as labels for the new hru coordinate) + f_ds = xr.open_dataset(args.ngen_forcing) + f_var = "ids" + if f_var not in f_ds: + raise RuntimeError(f"forcing file missing '{f_var}' variable") + f_ids_raw = np.array([str(x) for x in f_ds[f_var].values]) + f_ids = np.array([_parse_id(fid) for fid in f_ids_raw]) + + # ensure output folder exists + os.makedirs(args.output_folder, exist_ok=True) + current_dir = os.getcwd() + # get directory starting from "extern" + idx = current_dir.find("extern") + extern_path = current_dir[idx:] if idx != -1 else current_dir + + # write a simple ¶meters namelist block for each HRU id (stub) + for i, id_ in enumerate(f_ids): + out_path = os.path.join(args.output_folder, f"cat-{id_}.input") + with open(out_path, "w") as fh: + fh.write("¶meters\n") + fh.write(f' file_manager = "./{extern_path}/{args.fileManager}"\n') + fh.write(f' attrib_file_HRU_order = {str(i+1)}\n') + fh.write(f' restart_print_freq = "{args.restart_freq}"\n') + fh.write("/\n") + print(f"Wrote {out_path}") + +if __name__ == "__main__": + main() \ No newline at end of file diff --git a/test_ngen/provo_run.sh b/test_ngen/provo_run.sh new file mode 100755 index 000000000..961c690b7 --- /dev/null +++ b/test_ngen/provo_run.sh @@ -0,0 +1,6 @@ +#./cmake_build/ngen ./extern/summa/summa/test_ngen/domain_provo/settings/gage-10154200_subset.gpkg '' ./extern/summa/summa/test_ngen/domain_provo/settings/gage-10154200_subset.gpkg'' ./extern/summa/summa/test_ngen/settings/provo_realization_config_w_summa_bmi_routing.json + +./cmake_build/ngen ./extern/summa/summa/test_ngen/domain_provo/settings/gage-10154200_subset.gpkg '' ./extern/summa/summa/test_ngen/domain_provo/settings/gage-10154200_subset.gpkg '' ./extern/summa/summa/test_ngen/domain_provo/settings/provo_realization_config_w_summa_bmi.json +python -m nwm_routing -V4 -f ./extern/summa/summa/test_ngen/domain_provo/settings/provo_routing.yaml + +rm extern/summa/summa/test_ngen/domain_provo/simulations/*.parquet \ No newline at end of file diff --git a/test_ngen/provo_summa_run.sh b/test_ngen/provo_summa_run.sh new file mode 100755 index 000000000..e3c2d5bd6 --- /dev/null +++ b/test_ngen/provo_summa_run.sh @@ -0,0 +1 @@ +/Users/amedin/Research/SummaSundials/summa/bin/summa_sundials.exe -p m -m /Users/amedin/Research/SummaBMI/ngen/extern/summa/summa/test_ngen/domain_Provo/settings/SUMMA/fileManager.txt diff --git a/test_ngen/python_env/environment.yml b/test_ngen/python_env/environment.yml new file mode 100644 index 000000000..9546e3fb2 --- /dev/null +++ b/test_ngen/python_env/environment.yml @@ -0,0 +1,25 @@ +name: pyngen +channels: + - conda-forge + - defaults +dependencies: + - numpy[version='<2.0'] + - ipykernel + - yaml + - pandas + - matplotlib + - bmipy + - Cython[version='>3,!=3.0.4'] + - pyyaml + - bmipy + - bokeh + - ruamel.yaml + - netCDF4 + - xarray + - joblib + - toolz + - geopandas + - pyarrow + - deprecated + - wheel +prefix: /Users/amedin/opt/anaconda3/envs/pyngen diff --git a/test_ngen/readme.md b/test_ngen/readme.md new file mode 100644 index 000000000..9f791b7ff --- /dev/null +++ b/test_ngen/readme.md @@ -0,0 +1,10 @@ +# SUMMA case studies +This folder contains a case study to show how a typical SUMMA setup looks in the NextGen setup.The folder serves a double purpose as a way to track default versions of certain input files, such as the Noah-MP tables and spatially constant parameter files. These files are in /settings/SUMMA. + + +## Settings +The SUMMA folder contains the setting some files that typically do not change for different model applications. Currently these include: +- `TBL_GENPARM.TBL`: lookup table for general parameters (legacy, currently unused) +- `TBL_MPTABLE.TBL`: lookup table for vegetation parameters +- `TBL_SOILPARM.TBL`: lookup table for soil parameters +- `TBL_VEGPARM.TBL`: lookup table for vegetation parameters diff --git a/test_ngen/summa_run.sh b/test_ngen/summa_run.sh new file mode 100755 index 000000000..da2e4b208 --- /dev/null +++ b/test_ngen/summa_run.sh @@ -0,0 +1 @@ +/Users/amedin/Research/SummaSundials/summa/bin/summa_sundials.exe -p m -m /Users/amedin/Research/SummaBMI/ngen/extern/summa/summa/test_ngen/gauge_01073000/settings/SUMMA/fileManager.txt diff --git a/utils/containers/Summa-OpenWQ/Dockerfile b/utils/containers/Summa-OpenWQ/Dockerfile new file mode 100644 index 000000000..564f56d94 --- /dev/null +++ b/utils/containers/Summa-OpenWQ/Dockerfile @@ -0,0 +1,50 @@ +FROM ubuntu:22.04 + +WORKDIR /code +RUN apt-get update -y && \ + apt-get upgrade -y && \ + DEBIAN_FRONTEND="noninteractive" apt-get install -y software-properties-common \ + libnetcdf-dev \ + libnetcdff-dev \ + liblapack-dev \ + libopenblas-dev \ + cmake \ + g++ \ + git \ + libssl-dev \ + make \ + gfortran \ + wget \ + python3-pip \ + valgrind \ + libboost-all-dev \ + hdf5-tools \ + gdb &&\ + apt-get autoclean + +# Install Sundials +WORKDIR /opt +RUN wget https://github.com/LLNL/sundials/archive/refs/tags/v7.1.1.tar.gz +RUN tar -xzf v7.1.1.tar.gz +WORKDIR /opt/sundials-7.1.1 +RUN mkdir build/ +WORKDIR /opt/sundials-7.1.1/build +RUN cmake ../ -DBUILD_FORTRAN_MODULE_INTERFACE=ON \ + -DCMAKE_Fortran_COMPILER=gfortran \ + -DCMAKE_INSTALL_PREFIX=/usr/local/sundials +RUN make -j 4 +RUN make install + +# Install Armadillo in conventional linux directory (/opt) +WORKDIR /opt +RUN wget https://sourceforge.net/projects/arma/files/armadillo-10.5.0.tar.xz +RUN tar -xf armadillo-10.5.0.tar.xz +WORKDIR /opt/armadillo-10.5.0 +RUN cmake . -D DETECT_HDF5=true -DCMAKE_C_FLAGS="-DH5_USE_110_API" +RUN make install +# Enable HDF5 Support +RUN sed -i '121s/^\/\/ #define ARMA_USE_HDF5/#define ARMA_USE_HDF5/' /usr/include/armadillo_bits/config.hpp + +# Set Entry Point +WORKDIR /code + diff --git a/utils/containers/Summa-OpenWQ/build_docker_container.sh b/utils/containers/Summa-OpenWQ/build_docker_container.sh new file mode 100755 index 000000000..360f55944 --- /dev/null +++ b/utils/containers/Summa-OpenWQ/build_docker_container.sh @@ -0,0 +1,3 @@ +#! /bin/bash + +docker build -t summa-openwq . \ No newline at end of file diff --git a/utils/containers/Summa-generic/Dockerfile b/utils/containers/Summa-generic/Dockerfile new file mode 100644 index 000000000..67025aae0 --- /dev/null +++ b/utils/containers/Summa-generic/Dockerfile @@ -0,0 +1,37 @@ +FROM ubuntu:latest + +WORKDIR /code +RUN apt-get update -y && \ + apt-get upgrade -y && \ + DEBIAN_FRONTEND="noninteractive" apt-get install -y software-properties-common \ + libnetcdf-dev \ + libnetcdff-dev \ + liblapack-dev \ + libopenblas-dev \ + cmake \ + g++ \ + git \ + libssl-dev \ + make \ + gfortran \ + wget \ + python3-pip \ + valgrind \ + gdb &&\ + apt-get autoclean + +# Install Sundials +WORKDIR /opt +RUN wget https://github.com/LLNL/sundials/archive/refs/tags/v7.1.1.tar.gz +RUN tar -xzf v7.1.1.tar.gz +WORKDIR /opt/sundials-7.1.1 +RUN mkdir build/ +WORKDIR /opt/sundials-7.1.1/build +RUN cmake ../ -DBUILD_FORTRAN_MODULE_INTERFACE=ON \ + -DCMAKE_Fortran_COMPILER=gfortran \ + -DCMAKE_INSTALL_PREFIX=/usr/local/sundials +RUN make -j 4 +RUN make install + + +WORKDIR /code diff --git a/utils/containers/Summa-generic/build_docker_container.sh b/utils/containers/Summa-generic/build_docker_container.sh new file mode 100755 index 000000000..115639227 --- /dev/null +++ b/utils/containers/Summa-generic/build_docker_container.sh @@ -0,0 +1,3 @@ +#! /bin/bash + +docker build -t summa-generic . \ No newline at end of file diff --git a/utils/post-processing/actorsSummary.py b/utils/post-processing/actorsSummary.py new file mode 100644 index 000000000..8231650a4 --- /dev/null +++ b/utils/post-processing/actorsSummary.py @@ -0,0 +1,67 @@ +import os +import re + +# Define the folder containing the log files +log_folder = os.path.expanduser('~/summaNorthAmerica_settings/logs') +output_file = 'summary.txt' + +# Define the patterns to search for +duration_pattern = re.compile(r'Total Duration = ([\d.]+) Hours') +failed_pattern = re.compile(r'Num Failed = (\d+)') +file_pattern = re.compile(r'File Manager Path: /home/x-avanb/summaNorthAmerica_settings/fileManager_([^/]+)\.txt') +gru_pattern = re.compile(r'Starting SUMMA Actor, start_gru (\d+), num_gru (\d+)') + +# Initialize lists to store the extracted values +durations = [] +failures = [] +file_names = [] +start_grus = [] +num_grus = [] + +# Initialize a list to store the results +results = [] + +# Iterate over all files in the folder +for filename in os.listdir(log_folder): + if filename.startswith('log'): + filepath = os.path.join(log_folder, filename) + with open(filepath, 'r') as file: + content = file.read() + # Search for the patterns in the file content + duration_match = duration_pattern.search(content) + failed_match = failed_pattern.search(content) + file_match = file_pattern.search(content) + gru_match = gru_pattern.search(content) + if duration_match and failed_match and file_match and gru_match: + durations.append(duration_match.group(1)) + failures.append(failed_match.group(1)) + file_names.append(file_match.group(1)) + start_grus.append(gru_match.group(1)) + num_grus.append(gru_match.group(2)) + start_gru = int(gru_match.group(1)) + num_gru = int(gru_match.group(2)) + array = (start_gru - 1) / num_gru + results.append((filename, f'{duration_match.group(1):>10} Hours', f'{failed_match.group(1):>3} failures', f'file {file_match.group(1):<8}', f'array {array:.2f}', f'start_gru {start_gru:>6}', f'num_gru {num_gru:>5}')) + elif file_match and gru_match: + # Print the filename if the patterns were not found, didn't finish + start_gru = int(gru_match.group(1)) + num_gru = int(gru_match.group(2)) + array = (start_gru - 1) / num_gru + results.append((filename, 'NOT FINISHED', '', f'file {file_match.group(1):<8}', f'array {array:.2f}', f'start_gru {start_gru:>6}', f'num_gru {num_gru:>5}')) + else: + # Print the filename if the patterns were not found + results.append((filename, 'NOT FOUND', '', '', '', '', '')) + +# Sort the results by logID +results.sort(key=lambda x: x[0]) + +# Print the sorted results +for result in results: + print(f'{result[0]:<15} | {result[1]:>10} | {result[2]:>3} | {result[3]:<8} | {result[4]:<8} | {result[5]:<12} | {result[6]:<8}') + +# Write the sorted results to the output file +with open(output_file, 'w') as file: + for result in results: + file.write(f'{result[0]:<15} | {result[1]:>10} | {result[2]:>3} | {result[3]:<8} | {result[4]:<8} | {result[5]:<12} | {result[6]:<8}\n') + +print(f'Summary written to {output_file}') \ No newline at end of file diff --git a/utils/post-processing/check_bit_4_bit_withTol.py b/utils/post-processing/check_bit_4_bit_withTol.py new file mode 100644 index 000000000..378eae7c6 --- /dev/null +++ b/utils/post-processing/check_bit_4_bit_withTol.py @@ -0,0 +1,132 @@ +#!/usr/bin/env python + +# python check_bit_4_bit_withTol.py [bench_dir] [test_dir] [tol] + +import sys +import numpy as np +import xarray as xr +from pathlib import Path + +PRINT_MESSAGE = 'Test {0: >3} - Filename: {1: <64} - Variable: {2: <64} - Mean and Max difference: {3: <8}, {4: <8}' +FINAL_MESSAGE = 'Variable: {0: >20} - HRU: {1: <8} - Max: {2: <25} - Time: {3: <30}' +ERROR_MESSAGE = 'Found differences in test cases: {}' +SUCCESS_MESSAGE = 'SUCCESSFUL TEST RUN: All files match within tolerence!' +USAGE = 'USAGE: python check_bit_4_bit_withTol.py BENCHMARK_DIRECTORY TEST_DIRECTORY TOLERENCE' + +#if len(sys.argv) != 4: +# print(USAGE) +# exit(1) + +testing = False +if testing: + bench_dir = 'summa_be' #sys.argv[1] + test_dir = 'summa-sundials_be' #sys.argv[2] + tol = 0.1 #sys.argv[3] +else: + bench_dir = sys.argv[1] + test_dir = sys.argv[2] + tol = sys.argv[3] + +bench_files = sorted(list(Path(bench_dir).glob('**/*.nc'))) +test_files = sorted(list(Path(test_dir).glob('**/*.nc'))) + + +assert len(bench_files) == len(test_files), \ + 'Found {} files but need {}!'.format(len(test_files), len(bench_files)) + + +def rem(li1, li2): + return list(set(li1) - set(li2)) + + +def compute_diffs(bench_files, test_files): + all_diffs_mean = [] + all_times_max = [] + all_diffs_max = [] + all_tots_mean = [] + all_tots_max = [] + for i, (f1, f2) in enumerate(zip(bench_files, test_files)): + ds1, ds2 = xr.open_dataset(str(f1)), xr.open_dataset(str(f2)) + #m = (ds1['scalarSWE'].sel(hru = 71003766)- ds2['scalarSWE'].sel(hru = 71003766)) + m = (ds1['scalarSWE'].sel(time = '1981-05-02T14:00:00.000013408')- ds2['scalarSWE'].sel(time = '1981-05-02T14:00:00.000013408')) + m.plot() + diff = (np.fabs(ds1 - ds2)) + # get rid of gru dimension, assuming they are same as the often are + diff = diff.drop_vars(['hruId','gruId','wallClockTime']) + m = diff.drop_dims('hru') + m = m.rename({'gru': 'hru'}) + diff = diff.drop_dims('gru') + diff = xr.merge([diff,m]) + # take means and maxes + diff_mean = diff.mean(dim='time') + time_max = diff.idxmax(dim='time') + #for v in rem(list(diff.variables.keys()), list(diff.dims.keys())): + # m = diff[v].sel(hru = np.int(diff[v].idxmax(dim="hru").values[0])) + # print(v, m.idxmax().values,np.int(diff[v].idxmax(dim="hru").values[0]),diff[v].max(dim="hru").values[0]) + diff_max = diff.max(dim='time') + tot_mean = diff_mean.mean(dim='hru') + tot_max = diff_max.max(dim='hru') + #for v in rem(list(diff_mean.variables.keys()), list(diff_mean.dims.keys())): + #print(PRINT_MESSAGE.format(i, str(f1).split('/')[-1], v, tot_mean[v].values, tot_max[v].values)) + all_diffs_mean.append(diff_mean) + all_times_max.append(time_max) + all_diffs_max.append(diff_max) + all_tots_mean.append(tot_mean) + all_tots_max.append(tot_max) + return all_diffs_mean, all_times_max, all_diffs_max, all_tots_mean, all_tots_max,i + + +all_diffs_mean, all_times_max, all_diffs_max, all_tots_mean, all_tots_max,i = compute_diffs(bench_files, test_files) + +combined_mean = xr.concat(all_diffs_mean, dim='hru') +combined_mean.to_netcdf("all_diffs_mean.nc") + +combined_time = xr.concat(all_times_max, dim='hru') +combined_max = xr.concat(all_diffs_max, dim='hru') +combined_max.to_netcdf("all_diffs_max.nc") +max_ind = combined_max.idxmax(dim='hru') + +combined_tmean = xr.concat(all_tots_mean, dim='hru') +combined_tmax = xr.concat(all_tots_max, dim='hru') + +#assert np.fabs(combined_tmean).max(dim='hru') - tol*(i-1) <= 0.0, \ +# ERROR_MESSAGE.format(np.argwhere(np.asarray(combined_tmean)-tol*(i-1)> 0.0)) + +#print(SUCCESS_MESSAGE) +print(combined_tmean) + + +# HRU - 71000000 is the GRU if a 71* HRU, gruId, hruId is the first HRU, if value is first HRU then all values same +for v in rem(list(combined_max.variables.keys()), list(combined_time.dims.keys())): + print(FINAL_MESSAGE.format(v, np.int(max_ind[v].values), combined_max[v].sel(hru = np.int(max_ind[v].values)).values, combined_time[v].sel(hru = np.int(max_ind[v].values)).values)) + +if testing: + bench_files = "run_3766_summa_be.nc" + f1 = bench_files + + #test_files = ["run_3766_summa_be_conv.nc","run_3766_summa-sundials_beclosed_new.nc","run_3766_summa-sundials_closed_new.nc","run_3766_summa-sundials_closed.nc","run_3766_summa-sundials_enthal_new.nc","run_3766_summa-sundials_enthal_new_noderiv.nc","run_3766_summa-sundials_enthal.nc","run_3766_summa-sundials_beclosed_new_noCp.nc","run_3766_summa-sundials_closed_new_noCp.nc"] + #test_files = ["run_3766_summa-sundials_beclosed_new.nc","run_3766_summa-sundials_beclosed_new_noCp.nc","run_3766_summa-sundials_beclosed_new_noCp_oldJac.nc"] + test_files = ["run_3766_sun_updateCp_withDeriv.nc","run_3766_be_updateCp_withDeriv.nc","run_3766_be_original_withDeriv.nc","run_3766_be_orginal.nc"] + vars = ['averageRoutedRunoff','scalarTotalET','scalarTotalSoilWat','scalarSWE','scalarCanopyWat'] + + for j, v in enumerate(vars): + for i, f2 in enumerate(test_files): + ds1, ds2 = xr.open_dataset(f1), xr.open_dataset(f2) + m = ds1[v]- ds2[v] + m.plot() + + plt.gca().legend(test_files) + plt.show() + + test_files = ["run_3766_nrgWatTermOrderSwitch_commita2c16c8c.nc","run_3766_nrgWatTermOrderSame_commitec1f42b4.nc"] + vars = ['averageRoutedRunoff','scalarTotalET','scalarTotalSoilWat','scalarSWE','scalarCanopyWat'] + + for j, v in enumerate(vars): + for i, f2 in enumerate(test_files): + ds1, ds2 = xr.open_dataset(f1), xr.open_dataset(f2) + m = ds1[v]- ds2[v] + m.plot() + + plt.gca().legend(test_files) + plt.show() + diff --git a/utils/post-processing/concat_groups_split_summa.py b/utils/post-processing/concat_groups_split_summa.py new file mode 100644 index 000000000..e51c02fa4 --- /dev/null +++ b/utils/post-processing/concat_groups_split_summa.py @@ -0,0 +1,154 @@ +# concatenate the outputs of a split domain summa run into fewer groups +# written originally by Manab Saharia, updated by Hongli Liu and Andy Wood, and W. Knoben +# modified by A. Van Beusekom (2023) +# Best to comment out parallel processing lines and run that way on Graham or for full dataset + +# Run: +# python concat_groups_split_summa.py sundials_1en8 + +import os +from glob import glob +import netCDF4 as nc +import numpy as np + +catby_num = 2 #number of files to cat into one, if had to divide runs from regular batches into sub-batches to finish in 7 days + +missing = False # if appending nan hrus to batch because failed +missgru = 72055933 # batch 205 summa-be32 value +misshru = missgru # could be different + +run_local = False +if run_local: + top_fold = '/Users/amedin/Research/USask/test_py/' + method_name = 'sundials_1en8' +else: + import multiprocessing as mp + import sys + top_fold = '/home/avanb/scratch/' + method_name = sys.argv[1] # sys.argv values are strings by default so this is fine (sundials_1en8 or be64) + +ncdir = top_fold + 'summa-' + method_name + '_nocat' +file_pattern = 'run1_G*_timestep.nc' +ctdir = top_fold + 'summa-' + method_name + +# get list of split summa output files (hardwired pattern) +outfilelist0 = glob((ncdir+'/'+file_pattern)) +outfilelist0.sort() + +# -- functions +def get_stat(g,catby_num,outfilelist0,ctdir): + outfilelist = outfilelist0[(catby_num*g):(catby_num*(g+1))] + gru_num = 0 + hru_num = 0 + subset0 = outfilelist[0].split('/')[-1].split('_')[1] + subset1 = outfilelist[-1].split('/')[-1].split('_')[1] + out_name = 'run1_'+subset0[0:7]+subset1[7:14]+'_timestep.nc' # will fail if GRU numbers are more than 6 digits + + for file in outfilelist: + f = nc.Dataset(file) + gru_num = gru_num+len(f.dimensions['gru']) + hru_num = hru_num+len(f.dimensions['hru']) + # extract the subset IDs + + # write output + with nc.Dataset(outfilelist[0]) as src: + with nc.Dataset(ctdir+'/'+out_name, "w") as dst: + # copy dimensions + for name, dimension in src.dimensions.items(): + if name == 'gru': + dst.createDimension(name, gru_num) + elif name == 'hru': + dst.createDimension(name, hru_num) + else: + dst.createDimension(name, (len(dimension) if not dimension.isunlimited() else None)) + + # copy variable attributes all at once via dictionary + gru_vars = [] # variable name, gru axis in variable dimension for concatenation. + hru_vars = [] + for name, variable in src.variables.items(): + x = dst.createVariable(name, variable.datatype, variable.dimensions) + dst[name].setncatts(src[name].__dict__) + # Note here the variable dimension name is the same, but size has been updated for gru and hru. + + # Assign different values depending on dimension + dims = variable.dimensions + if 'gru' in dims: + gru_vars.append([name,dims.index('gru')]) + elif 'hru' in dims: + hru_vars.append([name,dims.index('hru')]) + else: + dst[name][:]=src[name][:] + + # read values for gru and hru dimensioned variables + Dict = {} + gru_vars_num = len(gru_vars) + hru_vars_num = len(hru_vars) + for i,file in enumerate(outfilelist): + + print("combining file %d %s" % (i,file)) + # f = nc.Dataset(os.path.join(ncdir, file)) + f = nc.Dataset(file) + for j in range(gru_vars_num): + gru_var_name = gru_vars[j][0] + dim_index = gru_vars[j][1] + data=f[gru_var_name][:] + if i == 0: + Dict[gru_var_name]=data + else: + Dict[gru_var_name]=np.concatenate((Dict[gru_var_name],data),axis=dim_index) + + for j in range(hru_vars_num): + hru_var_name = hru_vars[j][0] + dim_index = hru_vars[j][1] + data=f[hru_var_name][:] + if i == 0: + Dict[hru_var_name]=data + else: + Dict[hru_var_name]=np.concatenate((Dict[hru_var_name],data),axis=dim_index) + + # assign values for gru and hru dimensioned variables + for j in range(gru_vars_num): + dst.variables[gru_vars[j][0]][:] = Dict[gru_vars[j][0]] + for j in range(hru_vars_num): + dst.variables[hru_vars[j][0]][:] = Dict[hru_vars[j][0]] + + #if missing HRUs, this is slow or broken + if missing: + new_index = np.append(dst["gru"].values,missgru) + dst.reindex({"gru": new_index}) + dst.sel(gru=missgru)["gruId"] = missgru + + new_index = np.append(dst["hru"].values,misshru) + dst.reindex({"hru": new_index}) + dst.sel(gru=misshru)["hruId"] = misshru + + # Temporarily create gruId from hruId + #if gru_num == hru_num: + # gruId = dst.createVariable('gruId', dst['hruId'].datatype, ('gru',)) + # gruId.long_name = "ID of group of response unit (GRU)" + # gruId.units = dst['hruId'].units + # dst.variables['gruId'][:] = dst.variables['hruId'][:] + #else: + # print('Warning: gruId variable cannot be created since it has different size from hruId') + + print("wrote output: %s" % (ctdir+'/'+out_name)) + + return #nothing +# -- end functions + + +if run_local: + # -- no parallel processing + for g in range(0,int(len(outfilelist0)/catby_num)): + get_stat(g,catby_num,outfilelist0,ctdir) +else: + # -- start parallel processing + ncpus = int(os.environ.get('SLURM_CPUS_PER_TASK',default=1)) + if __name__ == "__main__": + pool = mp.Pool(processes=ncpus) + results = [pool.apply_async(get_stat, args=(g,catby_num,outfilelist0,ctdir)) for g in range(0,int(len(outfilelist0)/catby_num))] + dojob = [p.get() for p in results] + pool.close() + # -- end parallel processing + + diff --git a/utils/post-processing/hist_per_GRU.py b/utils/post-processing/hist_per_GRU.py new file mode 100644 index 000000000..49b46d2d5 --- /dev/null +++ b/utils/post-processing/hist_per_GRU.py @@ -0,0 +1,634 @@ +# written by A. Van Beusekom (2023) + +## Visualize statistics per GRU +## Needs: +# SUMMA output statistics + +## Special note +# SUMMA simulations have been preprocessed into single value statistics per model element, using auxiliary scripts in ~/utils +# Run: +# python hist_per_GRU.py [stat] +# where stat is rmse or maxe or kgem or rmnz or avge + +# modules +import os +import matplotlib +import numpy as np +import xarray as xr +from pathlib import Path +import matplotlib.pyplot as plt +import copy +import pandas as pd + +do_box = True # true is plot boxplot instead of CDF/histogram +do_rel = False # true is plot relative to the benchmark simulation +do_hist = False # true is plot histogram instead of CDF +run_local = True # true is run on local machine, false is run on cluster +fix_units_soil = False # true is convert to storage units, only works for soil because of known and constant depth in default setup +fix_wall_actors = False # true then scale reference solution for wall clock time +comp_wall_actors_plot = False # true then plot the wall clock time comparison +comp_wall_event_plot = False # true then plot the event detection time comparison +no_snow = False # true is only plot snow free simulations +# these options are for the boxplot only +showfliers = False # true is show outliers in boxplot +do_violin = False # true is plot violin plot instead of boxplot +vio_points = 10000 # number of points to consider in kernel estimation of violin plot, bigger is better but slow (100 default, 10000 is good for all of N.America) + +if run_local: + stat = 'avge' + viz_dir = Path('/Users/amedin/Research/USask/test_py/statistics_en') +else: + import sys + stat = sys.argv[1] + viz_dir = Path(os.path.expanduser('~/statistics')) + + +#method_name=['be1','be16','be32','sun6'] #maybe make this an argument +#plt_name=['BE1','BE16','BE32','SUNDIALS'] #maybe make this an argument +#method_name=['sun5cm_noev','sun5cm_ev','sun5en_noev','sun5en_ev','sun8en_noev'] +#plt_name=['SUNDIALS temp no ev','SUNDIALS temp', 'SUNDIALS enth no ev', 'SUNDIALS enth','reference soln no ev'] +method_name=['be8','be8cm','be8en','sun5cm','sun5en'] +plt_name=['BE8 common','BE8 temp','BE8 mixed','SUNDIALS temp', 'SUNDIALS enth'] +#method_name2=method_name +#plt_name2=plt_name +#method_name2=method_name +['sun8en_ev'] +#method_name2=method_name +['sun8enOrigWall'] +method_name2=method_name +['sun8en'] +plt_name2=plt_name +['reference soln'] +method_name3=method_name[0:3] +plt_name3=plt_name[0:3] + +num_bins = 1000 +auto_col = plt.rcParams['axes.prop_cycle'].by_key()['color'] + +if stat == 'kgem': do_rel = False # don't plot relative to the benchmark simulation for KGE + +# Define the power transformation function +def power_transform(x): + return x ** 0.5 # Adjust the exponent as needed + +# Simulation statistics file locations +use_vars = [] +rep = [] # mark the repeats +#use_vars = [4,4,1,1] +#rep = [1,2,1,2] # mark the repeats +settings0= ['scalarSWE','scalarTotalSoilWat','scalarTotalET','scalarCanopyWat','scalarRootZoneTemp'] +settings = [settings0[i] for i in use_vars] + +use_vars2 = [3,3] +rep2 = [1,2] # mark the repeats +use_vars2 = [8] +rep2 = [0] # mark the repeats +#use_vars2 = [3,3] +#rep2 = [1,2] # mark the repeats +#use_vars2 = [1,1,2,2,3,3] +#rep2 = [1,2,1,2,1,2] # mark the repeats +settings20= ['balanceCasNrg','balanceVegNrg','balanceSnowNrg','balanceSoilNrg','balanceVegMass','balanceSnowMass','balanceSoilMass','balanceAqMass','wallClockTime'] +settings2 = [settings20[i] for i in use_vars2] + +use_vars3 = [] +rep3 = [] # mark the repeats +#use_vars3 = [0,1,2,3,0,1,2,3] +#rep3 = [1,1,1,1,2,2,2,2] # mark the repeats +settings30= ['numberStateSplit','numberDomainSplitNrg','numberDomainSplitMass','numberScalarSolutions','meanStepSize'] +settings3 = [settings30[i] for i in use_vars3] + +viz_fil = method_name.copy() +viz_fl2 = method_name2.copy() +viz_fl3 = method_name3.copy() +for i, m in enumerate(method_name): + viz_fil[i] = m + '_hrly_diff_stats_accuracy.nc' +for i, m in enumerate(method_name2): + viz_fl2[i] = m + '_hrly_diff_bals_balance.nc' +for i, m in enumerate(method_name3): + viz_fl3[i] = m + '_hrly_diff_steps_split.nc' + +# Specify variables of interest +plot_vars = settings.copy() +plt_titl = ['snow water equivalent','total soil water content','total evapotranspiration', 'total water on the vegetation canopy','top 3m soil temperature'] +leg_titl = ['$kg~m^{-2}$', '$kg~m^{-2}$','mm~y^{-1}$','$kg~m^{-2}$','$K$'] +if (len(use_vars)>1): + plt_titl = [f"({chr(97+n)}) {plt_titl[i]}" for n,i in enumerate(use_vars)] +else: + plt_titl = [f"{plt_titl[i]}" for n,i in enumerate(use_vars)] +leg_titl = [leg_titl[i] for i in use_vars] + +plot_vars2 = settings2.copy() +plt_titl2 = ['canopy air space enthalpy balance','vegetation enthalpy balance','snow enthalpy balance','soil enthalpy balance','vegetation mass balance','snow mass balance','soil mass balance','aquifer mass balance', 'wall clock time'] +leg_titl2 = ['$W~m^{-3}$'] * 4 + ['$kg~m^{-3}~s^{-1}$'] * 3 + ['$kg~m^{-2}~s^{-1}$']+ ['$s$'] +if fix_units_soil: + leg_titl2[3] = ['$kJ~m^{-2}$'] + leg_titl2[6] = ['$kg~m^{-2}'] +if (len(use_vars)+len(use_vars2)>1): + plt_titl2 = [f"({chr(97+n + len(use_vars))}) {plt_titl2[i]}" for n,i in enumerate(use_vars2)] +else: + plt_titl2 = [f"{plt_titl2[i]}" for n,i in enumerate(use_vars2)] +leg_titl2 = [leg_titl2[i] for i in use_vars2] + +plot_vars3 = settings3.copy() +plt_titl3 = ['number of state splits','number of energy domain splits','number of mass domain splits','number of scalar solutions','mean step size'] +leg_titl3 = [''] * 4 + ['$s$'] +if (len(use_vars)+len(use_vars2)+len(use_vars3)>1): + plt_titl3 = [f"({chr(97+n + len(use_vars)+len(use_vars2))}) {plt_titl3[i]}" for n,i in enumerate(use_vars3)] +else: + plt_titl3 = [f"{plt_titl3[i]}" for n,i in enumerate(use_vars3)] +leg_titl3 = [leg_titl3[i] for i in use_vars3] + +if do_box: + fig_fil = 'Hrly_diff_box_{}_{}_zoom' +else: + if do_hist: + fig_fil = 'Hrly_diff_hist_{}_{}_zoom' + else: + fig_fil = 'Hrly_diff_cdf_{}_{}_zoom' + #if len(use_vars3)>0: fig_fil = 'Hrly_diff_cdf_{}_{}' +if do_rel: fig_fil = fig_fil+'_rel' +if no_snow: fig_fil = fig_fil + '_nosnow' +fig_fil = fig_fil +'_compressed.png' +if len(use_vars)>0: + fig_fil = fig_fil.format('accuracy',stat) +elif len(use_vars2)>0: # and len(use_vars)==0: + fig_fil = fig_fil.format('wallclock','mean') +elif len(use_vars3)>0: + fig_fil = fig_fil.format('split','mean') + +maxes_m = [99,15,99,99,6] +if do_rel: maxes_m = [0.4,0.007,0.6,0.15,0.0015] +if stat == 'avge': + stat2 = 'mean' + maxes = [99,7,99,99,0.28] + if do_rel: maxes = [0.4,0.007,0.6,0.15,0.0015] +if stat == 'rmse' or stat=='rmnz': + stat2 = 'mean' + maxes = [2,15,250,0.08,200] + if do_rel: maxes = [0.4,0.007,0.6,0.15,0.0015] +if stat == 'maxe': + stat2 = 'amax' + if stat == 'maxe': maxes = maxes_m +if stat == 'kgem': + stat2 = 'mean' + maxes = [0.9,0.9,0.9,0.9,0.9] +maxes = [maxes[i] for i in use_vars] +for i in range(len(maxes)): + #if rep[i]==2: maxes[i] = maxes[i]*2.5 #clunky way to increase the plot_range for the second repeat + if rep[i]==2: maxes[i] = maxes_m[use_vars[i]] #clunky way to increase the plot_range for the second repeat + +if stat2 == 'mean': + maxes2 = [5e1,5e1,5e1,5e1]+[1e-7,1e-5,1e-7,1e-8] + [2e-2] +if stat2 == 'amax': + maxes2 = [5e3,5e3,5e3,5e3]+[1e-5,1e-3,1e-5,1e-6] + [2.0] +maxes2 = [maxes2[i] for i in use_vars2] +for i in range(len(maxes2)): + if rep2[i]==2: maxes2[i] = maxes2[i]*1e2 #clunky way to increase the plot_range for the second repeat + +stat3 = 'mean' +maxes3 = [1e2,1e2,1e2,1e2,1e-7] +maxes3 = [maxes3[i] for i in use_vars3] + +summa = {} +summa1 = {} +summa2 = {} +if len(use_vars)>0: + for i, m in enumerate(method_name): + # Get the aggregated statistics of SUMMA simulations + summa[m] = xr.open_dataset(viz_dir/viz_fil[i]) +if len(use_vars2)>0: + for i, m in enumerate(method_name2): + summa1[m] = xr.open_dataset(viz_dir/viz_fl2[i]) + if (fix_wall_actors or comp_wall_actors_plot) and 'wallClockTime' in settings2: + summa1['be8Old'] = xr.open_dataset(viz_dir/'be8NrgOld_hrly_diff_bals_balance.nc') + summa1['sun5enOld'] = xr.open_dataset(viz_dir/'sun5enNrgOld_hrly_diff_bals_balance.nc') + +if len(use_vars3)>0: + for i, m in enumerate(method_name3): + summa2[m] = xr.open_dataset(viz_dir/viz_fl3[i]) + +if no_snow: + summa[method_name[0]] = xr.open_dataset(viz_dir/viz_fil[0]) # will be a problem if this does not exist + if len(use_vars)>0: + for m in method_name: + summa[m] = summa[m].where(summa[method_name[0]]['scalarSWE'].sel(stat='mean_ben') == 0) + if len(use_vars2)>0: + for m in method_name2: + summa1[m] = summa1[m].where(summa[method_name[0]]['scalarSWE'].sel(stat='mean_ben') == 0) + + if len(use_vars3)>0: + for m in method_name3: + summa2[m] = summa2[m].where(summa[method_name[0]]['scalarSWE'].sel(stat='mean_ben') == 0) + + +##Figure + +plt.rcParams['xtick.color'] = 'black' +plt.rcParams['xtick.major.width'] = 2 +plt.rcParams['ytick.color'] = 'black' +plt.rcParams['ytick.major.width'] = 2 +# fix size for now +ncol = 2 +nrow = 3 + +if 'compressed' in fig_fil: + plt.rcParams.update({'font.size': 27}) +else: + plt.rcParams.update({'font.size': 100}) + +if 'compressed' in fig_fil: + fig,axs = plt.subplots(nrow,ncol,figsize=(17*ncol,17*nrow)) +else: + fig,axs = plt.subplots(nrow,ncol,figsize=(70*ncol,80*nrow)) +fig.subplots_adjust(hspace=0.2, wspace=0.12) # Adjust the bottom margin, vertical space, and horizontal space +#fig.suptitle('Histograms of Hourly Statistics for each GRU', fontsize=40,y=1.0) + +def run_loop(i,var,mx,rep,stat): + r = i//ncol + c = i-r*ncol + if rep == 1: stat = 'avge' + if rep == 2: stat = 'maxe' + stat0 = stat + if stat == 'rmse' or stat == 'kgem' or stat == 'avge': + if var == 'wallClockTime': stat0 = 'mean' + statr = 'mean_ben' + if stat == 'rmnz': + if var == 'wallClockTime': stat0 = 'mnnz' + statr = 'mnnz_ben' + if stat == 'maxe': + if var == 'wallClockTime': stat0 = 'amax' + statr = 'amax_ben' + + if 'zoom' in fig_fil: + mx = mx + mn = mx + else: + mx = 0.0 + mn = 1.0 + s_rel = summa[method_name[0]][var].sel(stat=statr) + for m in method_name: + s = summa[m][var].sel(stat=stat0) + if do_rel and var != 'wallClockTime': s = s/s_rel + if stat == 'maxe': s = np.fabs(s) # make absolute value norm + mx = max(s.max(),mx) + if stat == 'kgem': mn = min(s.min(),mn) + + # Data + s_rel = summa[method_name[0]][var].sel(stat=statr) + for m in method_name: + s = summa[m][var].sel(stat=stat0) + if do_rel and var != 'wallClockTime': s = s/s_rel + if var == 'scalarTotalET' and not do_rel: + if stat =='rmse' or stat =='rmnz' or stat=='mean': s = s*31557600 # make annual total + if stat =='maxe': s = s*3600 # make hourly max + if var == 'averageRoutedRunoff' and not do_rel: + if stat =='rmse' or stat =='rmnz' or stat=='mean': s = s*31557600*1000 # make annual total + if stat =='maxe': s = s*3600*1000 # make hourly max + if stat == 'maxe': s = np.fabs(s) # make absolute value norm + plot_range = (0,mx) + if stat=='kgem' and var!='wallClockTime': + plot_range = (mn,1) + elif var=='wallClockTime': + plot_range = (0.0008,mx) + if do_box: + data = np.fabs(s.values) + data = data[~np.isnan(data)] + if do_violin: + vplot = axs[r, c].violinplot(dataset=[data],positions=[len(method_name) - method_name.index(m)],vert=False,showextrema=showfliers,points=vio_points) + for pc in vplot['bodies']: + pc.set_facecolor(auto_col[method_name.index(m)]) + pc.set_edgecolor('black') + pc.set_alpha(1) + else: + axs[r, c].boxplot(data,vert=False, positions=[len(method_name) - method_name.index(m)], widths=0.6,patch_artist=True,medianprops=dict(color='black'),boxprops=dict(facecolor=auto_col[method_name.index(m)]),showfliers=showfliers) + + else: + if do_hist: + np.fabs(s).plot.hist(ax=axs[r,c], bins=num_bins,histtype='step',zorder=0,label=m,linewidth=3.0,range=plot_range) + else: #cdf + sorted_data = np.sort(np.fabs(s)) + valid_data = sorted_data[~np.isnan(sorted_data)] + yvals = np.arange(len(valid_data)) / float(len(valid_data) - 1) + axs[r,c].plot(valid_data, yvals, zorder=0, label=m, linewidth=3.0) + print("max, min, mean without nans", s.where(lambda x: ~np.isnan(x)).max().values, s.where(lambda x: ~np.isnan(x)).min().values, s.where(lambda x: ~np.isnan(x)).mean().values, m, var) + + if stat0 == 'rmse': stat_word = 'RMSE' + if stat0 == 'rmnz': stat_word = 'RMSE' # no 0s' + if stat0 == 'maxe': stat_word = 'max abs error' + if stat0 == 'kgem': stat_word = 'KGE"' + if stat0 == 'mean': stat_word = 'mean' + if stat0 == 'mnnz': stat_word = 'mean' # no 0s' + if stat0 == 'amax': stat_word = 'max' + if stat0 == 'avge': stat_word = 'mean abs error' + + if statr == 'mean_ben': statr_word = 'mean' + if statr == 'mnnz_ben': statr_word = 'mean' # no 0s' + if statr == 'amax_ben': statr_word = 'max' + + if c==0 and not do_box: axs[r,c].legend(plt_name) + titl = plt_titl[i] + if no_snow: titl = titl + ' (snow-free GRUs)' + if rep>0: titl = titl #+ ' '+ stat_word + axs[r,c].set_title(titl) + if stat=='rmse' or stat=='rmnz' or stat=='maxe' or stat=='mean' or stat=='avge': axs[r,c].set_xlabel(stat_word + ' [{}]'.format(leg_titl[i])) + if stat=='kgem': axs[r,c].set_xlabel(stat_word) + if do_rel and var!='wallClockTime': axs[r,c].set_xlabel('relative '+ stat_word) + + if do_box: + axs[r,c].set_xlim(plot_range) + axs[r, c].set_ylabel('') + axs[r, c].set_yticklabels('') + axs[r,c].set_xscale('function', functions=(power_transform, np.power)) #log x axis + if mx<1: # Rotate x-axis labels + axs[r, c].tick_params(axis='x', rotation=45) # Rotate x-axis labels for subplot + axs[r, c].set_yticks(range(1, len(method_name) + 1)) + if(c==0): axs[r, c].set_yticklabels(plt_name[::-1]) + else: + if do_hist: + axs[r,c].set_ylabel('GRU count') + if var != 'wallClockTime' and not run_local: axs[r,c].set_ylim([0, 25000]) + else: + axs[r,c].set_xlim(plot_range) + axs[r,c].set_ylabel('cumulative distribution') + if(c>=1): axs[r, c].set_ylabel('') + axs[r,c].set_ylim([0.0, 1.0]) + axs[r,c].set_xscale('function', functions=(power_transform, np.power)) #log x axis + if mx<1: # Rotate x-axis labels + axs[r,c].tick_params(axis='x', rotation=45) + + +def run_loopb(i,var,mx,rep,stat2): + r = (i+len(use_vars))//ncol + c = (i+len(use_vars))-r*ncol + stat0 = np.copy(stat2) + if rep == 1: stat0 = 'mean' + if rep == 2: stat0 = 'amax' + + if 'zoom' in fig_fil: + mx = mx + mn = mx*1e-9 + if any(substring in var for substring in ['VegNrg', 'SnowNrg', 'SoilNrg']): + mn = mx*1e-9 + if var=='wallClockTime': mn = 0.0008 + if fix_units_soil and 'Soil' in var: + mn = mn*3600*3.0 # mult by time step and depth to get storage + mx = mx*3600*3.0 + if 'Nrg' in var: + mn=mn*1e-3 + mx=mx*1e-3 + else: + mx = 0.0 + mn = 1.0 + for m in method_name2: + # Get the statistics, remove 9999 (should be nan, but just in case) + s = summa1[m][var].sel(stat=stat0).where(lambda x: x != 9999) + if var=='wallClockTime': s = s.where(lambda x: x != 0) # Actors simulations may have 0 + mx = max(s.max(),mx) + mn = min(s.min(),mn) + # Data + combined_s2 = [] + combined_s_saved = [] + for m in method_name2: + s = summa1[m][var].sel(stat=stat0).where(lambda x: x != 9999) + if var=='wallClockTime': s = s.where(lambda x: x != 0) # water bodies should be 0 + if fix_units_soil and 'Soil' in var: + s = s*3600*3.0 # mult by time step and depth to get storage + if 'Nrg' in var: s = s*1e-3 + + plot_range = (mn,mx) + + if (fix_wall_actors or comp_wall_actors_plot) and 'wallClockTime' in var: + from scipy.stats import linregress + if m in ['be8', 'sun5en']: + s_saved = s + s2 = summa1[f'{m}Old'][var].sel(stat=stat0).where(lambda x: x != 9999) + s2 = s2.where(lambda x: x != 0) # water bodies should be 0 + mask = ~np.isnan(s2.values) & ~np.isnan(s_saved.values) + s2 = s2[mask] + s_saved = s_saved[mask] + combined_s2.append(s2.values) + combined_s_saved.append(s_saved.values) + first_len = len(s2) + + if m=='sun8en': # assumes sun8en is the last one + combined_s2 = np.concatenate(combined_s2) + combined_s_saved = np.concatenate(combined_s_saved) + # Least squares fit + A = combined_s2[:, np.newaxis] + fac, _, _, _ = np.linalg.lstsq(A, combined_s_saved, rcond=None) + fac = fac[0] + print(f'Best fit least squares ratio (slope={fac:.4f})') + slope, intercept, r_value, p_value, std_err = linregress(combined_s2, combined_s_saved) + print(f'Best fit regression line (slope={slope:.4f}, intercept={intercept:.4f}, corr coeff={r_value:.2e})') + # slope = 0.8731 + # intercept = -0.0003 + # corr coeff = 0.880 + # x is s2, non-actors Graham way (Anvil is faster) + s = s * slope + intercept + + if comp_wall_event_plot and 'wallClockTime' in var: + from scipy.stats import linregress + if m in ['sun5cm_ev','sun5en_ev','sun8en_ev']: + s_saved = s + s2 = summa1[f'{m[:-3]}_noev'][var].sel(stat=stat0).where(lambda x: x != 9999) + s2 = s2.where(lambda x: x != 0) # water bodies should be 0 + mask = ~np.isnan(s2.values) & ~np.isnan(s_saved.values) + s2 = s2[mask] + s_saved = s_saved[mask] + combined_s2.append(s2.values) + combined_s_saved.append(s_saved.values) + first_len = len(s2) + + if m=='sun8en_ev': # assumes sun8en is the last one + combined_s2 = np.concatenate(combined_s2) + combined_s_saved = np.concatenate(combined_s_saved) + # Least squares fit + A = combined_s2[:, np.newaxis] + fac, _, _, _ = np.linalg.lstsq(A, combined_s_saved, rcond=None) + fac = fac[0] + print(f'Best fit least squares ratio (slope={fac:.4f})') + slope, intercept, r_value, p_value, std_err = linregress(combined_s2, combined_s_saved) + print(f'Best fit regression line (slope={slope:.4f}, intercept={intercept:.4f}, corr coeff={r_value:.2e})') + # slope = 1.0423 + # intercept = -0.0001 + # corr coeff = 0.987 + # x is s2, no_ev way (with event detection is slower) + # note, do not apply the fit to the event detection time + + if do_box: + data = np.fabs(s.values) + data = data[~np.isnan(data)] + if do_violin: + vplot = axs[r, c].violinplot(dataset=[data],positions=[len(method_name2) - method_name2.index(m)],vert=False,showextrema=showfliers,points=vio_points) + for pc in vplot['bodies']: + pc.set_facecolor(auto_col[method_name2.index(m)]) + pc.set_edgecolor('black') + pc.set_alpha(1) + else: + axs[r, c].boxplot(data,vert=False, positions=[len(method_name2) - method_name2.index(m)], widths=0.6,patch_artist=True,medianprops=dict(color='black'),boxprops=dict(facecolor=auto_col[method_name2.index(m)]),showfliers=showfliers) + else: + if do_hist: + np.fabs(s).plot.hist(ax=axs[r,c], bins=num_bins,histtype='step',zorder=0,label=m,linewidth=3.0,range=plot_range) + else: #cdf + sorted_data = np.sort(np.fabs(s)) + valid_data = sorted_data[~np.isnan(sorted_data)] + yvals = np.arange(len(valid_data)) / float(len(valid_data) - 1) + axs[r,c].plot(valid_data, yvals, zorder=0, label=m, linewidth=3.0) + print("max, min, mean without nans", s.where(lambda x: ~np.isnan(x)).max().values, s.where(lambda x: ~np.isnan(x)).min().values, s.where(lambda x: ~np.isnan(x)).mean().values, m, var) + + if stat0 == 'mean': + if var == 'wallClockTime': + stat_word = 'mean' + else: + stat_word = 'mean abs balance' + if stat0 == 'amax': + if var == 'wallClockTime': + stat_word = 'max' + else: + stat_word = 'max abs balance' + + if c==0 and not do_box: axs[r,c].legend(plt_name2) + titl = plt_titl2[i] + if no_snow: titl = titl + ' (snow-free GRUs)' + if rep>0: titl = titl #+ ' '+ stat_word + axs[r,c].set_title(titl) + axs[r,c].set_xlabel(stat_word + ' [{}]'.format(leg_titl2[i])) + + if do_box: + axs[r,c].set_xlim(plot_range) + axs[r, c].set_ylabel('') + axs[r, c].set_yticklabels('') + axs[r,c].set_xscale('log') #log x axis + if var=='wallClockTime': + axs[r,c].set_xscale('function', functions=(power_transform, np.power)) #log x axis + axs[r, c].tick_params(axis='x', rotation=45) # Rotate x-axis labels for subplot + axs[r, c].set_yticks(range(1, len(method_name2) + 1)) + if(c==0): axs[r, c].set_yticklabels(plt_name2[::-1]) + else: + if do_hist: + axs[r,c].set_ylabel('GRU count') + if(c==1): axs[r, c].set_ylabel('') + if var != 'wallClockTime' and not run_local: axs[r,c].set_ylim([0, 25000]) + else: + axs[r,c].set_xlim(plot_range) + axs[r,c].set_ylabel('cumulative distribution') + if(c>=1): axs[r, c].set_ylabel('') + axs[r,c].set_ylim([0.0, 1.0]) + axs[r,c].set_xscale('log') #log x axis + if var=='wallClockTime': + axs[r,c].set_xscale('function', functions=(power_transform, np.power)) #log x axis + axs[r, c].tick_params(axis='x', rotation=45) # Rotate x-axis labels for subplot + + if comp_wall_actors_plot: + fig.subplots_adjust(hspace=0.2, wspace=0.2) # Adjust the bottom margin, vertical space, and horizontal space + axs[r, c + 1].scatter(combined_s2[first_len:], combined_s_saved[first_len:], alpha=0.5, color=auto_col[4], label='SUNDIALS enth') + axs[r, c + 1].scatter(combined_s2[:first_len], combined_s_saved[:first_len], alpha=0.5, color=auto_col[0], label='BE8 common') + axs[r, c+1].set_xlabel('Graham time [s]') + axs[r, c+1].set_ylabel('Anvil Actors time [s]') + axs[r, c+1].set_title('wall clock time comparison') + axs[r, c+1].set_xlim(combined_s_saved.min(),combined_s2.max()) + axs[r, c+1].set_ylim(combined_s_saved.min(),combined_s2.max()) + axs[r, c+1].plot(combined_s2, intercept + slope * combined_s2, color='black',linewidth=3.0) + axs[r, c+1].tick_params(axis='x', rotation=45) # Rotate x-axis labels for subplot + + if comp_wall_event_plot: + fig.subplots_adjust(hspace=0.2, wspace=0.2) # Adjust the bottom margin, vertical space, and horizontal space + axs[r, c + 1].scatter(combined_s2[first_len:], combined_s_saved[first_len:], alpha=0.5, color=auto_col[5], label='reference soln') + axs[r, c + 1].scatter(combined_s2[:first_len], combined_s_saved[:first_len], alpha=0.5, color=auto_col[3], label='SUNDIALS enth') + axs[r, c+1].set_xlabel('no event detection time [s]') + axs[r, c+1].set_ylabel('event detection time time [s]') + axs[r, c+1].set_title('wall clock time comparison') + axs[r, c+1].set_xlim(combined_s_saved.min(),combined_s2.max()) + axs[r, c+1].set_ylim(combined_s_saved.min(),combined_s2.max()) + axs[r, c+1].plot(combined_s2, intercept + slope * combined_s2, color='black',linewidth=3.0) + axs[r, c+1].tick_params(axis='x', rotation=45) # Rotate x-axis labels for subplot + + +def run_loop3(i,var,mx,rep,stat3): + r = (i+len(use_vars)+len(use_vars2))//ncol + c = (i+len(use_vars)+len(use_vars2))-r*ncol + stat0 = np.copy(stat3) + if rep == 1: stat0 = 'mean' + if rep == 2: stat0 = 'amax' + + mx = 0.0 + mn = 1.0 + for m in method_name3: + s = summa2[m][var].sel(stat=stat0) + mx = max(s.max(),mx) + mn = min(s.min(),mn) + + # Data + for m in method_name3: + s = summa2[m][var].sel(stat=stat0) + plot_range = (0,mx) + if do_box: + data = np.fabs(s.values) + data = data[~np.isnan(data)] + if do_violin: + vplot = axs[r, c].violinplot(dataset=[data],positions=[len(method_name3) - method_name3.index(m)],vert=False,showextrema=showfliers,points=vio_points) + for pc in vplot['bodies']: + pc.set_facecolor(auto_col[method_name3.index(m)]) + pc.set_edgecolor('black') + pc.set_alpha(1) + else: + axs[r, c].boxplot(data,vert=False, positions=[len(method_name3) - method_name3.index(m)], widths=0.6,patch_artist=True,medianprops=dict(color='black'),boxprops=dict(facecolor=auto_col[method_name3.index(m)]),showfliers=showfliers) + else: + if do_hist: + np.fabs(s).plot.hist(ax=axs[r,c], bins=num_bins,histtype='step',zorder=0,label=m,linewidth=3.0,range=plot_range) + else: #cdf + sorted_data = np.sort(np.fabs(s)) + valid_data = sorted_data[~np.isnan(sorted_data)] + yvals = np.arange(len(valid_data)) / float(len(valid_data) - 1) + axs[r,c].plot(valid_data, yvals, zorder=0, label=m, linewidth=3.0) + print("max, min, mean without nans", s.where(lambda x: ~np.isnan(x)).max().values, s.where(lambda x: ~np.isnan(x)).min().values, s.where(lambda x: ~np.isnan(x)).mean().values, m, var) + + if stat0 == 'mean': stat_word = 'mean per data window' + if stat0 == 'amax': stat_word = 'max per data window' + + if c==0 and not do_box: axs[r,c].legend(plt_name3) + titl = plt_titl3[i] + if no_snow: titl = titl + ' (snow-free GRUs)' + if rep>0: titl = titl #+ ' '+ stat_word + axs[r,c].set_title(titl) + axs[r,c].set_xlabel(stat_word + ' [{}]'.format(leg_titl3[i])) + + if do_box: + axs[r,c].set_xlim(plot_range) + axs[r, c].set_ylabel('') + axs[r, c].set_yticklabels('') + #axs[r,c].set_xscale('log') #log x axis + axs[r, c].set_yticks(range(1, len(method_name3) + 1)) + if(c==0): axs[r, c].set_yticklabels(plt_name3[::-1]) + else: + if do_hist: + axs[r,c].set_ylabel('GRU count') + if(c==1): axs[r, c].set_ylabel('') + else: + axs[r,c].set_xlim(plot_range) + axs[r,c].set_ylabel('cumulative distribution') + if(c>=1): axs[r, c].set_ylabel('') + axs[r,c].set_ylim([0.0, 1.0]) + #axs[r,c].set_xscale('log') #log x axis + if 'zoom' in fig_fil: + axs[r,c].set_ylim([0.98, 1.0]) + + +if len(use_vars) > 0: + for i,(var,mx,rep) in enumerate(zip(plot_vars,maxes,rep)): + run_loop(i,var,mx,rep,stat) +if len(use_vars2) > 0: + for i,(var,mx,rep) in enumerate(zip(plot_vars2,maxes2,rep2)): + run_loopb(i,var,mx,rep,stat2) +if len(use_vars3) > 0: + for i,(var,mx,rep) in enumerate(zip(plot_vars3,maxes3,rep3)): + run_loop3(i,var,mx,rep,stat3) + + +# Remove the extra subplots +if (len(plot_vars)+len(plot_vars2)+len(plot_vars3)) < ncol*nrow: + for i in range((len(plot_vars)+len(plot_vars2)+len(plot_vars3)),ncol*nrow): + r = i//ncol + c = i-r*ncol + if (r==0 and c==1 and comp_wall_actors_plot): continue + if (r==0 and c==1 and comp_wall_event_plot): continue + fig.delaxes(axs[r, c]) + +# Save +plt.savefig(viz_dir/fig_fil, bbox_inches='tight', transparent=False) diff --git a/utils/post-processing/largest_error_attrib.py b/utils/post-processing/largest_error_attrib.py new file mode 100644 index 000000000..6ee874d61 --- /dev/null +++ b/utils/post-processing/largest_error_attrib.py @@ -0,0 +1,137 @@ +#!/usr/bin/env python + +# python largest_error_attrib.py [method_name] [stat] + +import numpy as np +import xarray as xr +from pathlib import Path + +nBig = 10 +do_rel = True # stat relative to the benchmark simulation +do_var = False # do vars, if False do bals + +run_local = True +if run_local: + top_fold = '/Users/amedin/Research/USask/test_py/' + attr_fold = '/Users/amedin/Research/USask/test_py/settings/' + method_name= 'sundials_1en6cm' + stat = 'mean' +else: + import sys + top_fold = '/home/avanb/scratch/' + attr_fold = '/home/avanb/TestScripts/settings/' + method_name = sys.argv[1] + stat = sys.argv[2] + +des_dir = top_fold + 'statistics_en' +des_dir = Path(des_dir) + +if do_var: + settings= ['scalarSWE','scalarTotalSoilWat','scalarTotalET','scalarCanopyWat','averageRoutedRunoff','wallClockTime'] + viz_fil = method_name + '_hrly_diff_stats_{}.nc' + viz_fil = viz_fil.format(','.join(settings)) + src_file = des_dir / viz_fil + plot_vars = settings.copy() + short_name= ['SWE ', + 'soilWat ', + 'ET ', + 'canWat ', + 'runoff '] +else: + do_rel = False + settings= ['balanceCasNrg','balanceVegNrg','balanceSnowNrg','balanceSoilNrg','balanceVegMass','balanceSnowMass','balanceSoilMass','balanceAqMass','wallClockTime'] + viz_fil = method_name + '_hrly_diff_bals_balance.nc' + src_file = des_dir / viz_fil + plot_vars = settings.copy() + short_name= ['casNrg ', + 'vegNrg ', + 'snowNrg ', + 'soilNrg ', + 'vegMass ', + 'snowMass', + 'soilMass', + 'aqMass '] + +attr_fil = Path(attr_fold) / 'attributes.nc' + +# Open the netCDF file with RMSE data +summa = xr.open_dataset(src_file) +if stat == 'rmse' or stat == 'kgem' or stat == 'mean': statr = 'mean_ben' +if stat == 'rmnz' or stat == 'mnnz': statr = 'mnnz_ben' +if stat == 'maxe' or stat == 'amax': statr = 'amax_ben' + +for var in plot_vars: + + # Get the variable from the netCDF file + stat0 = stat + if var == 'wallClockTime': + if stat == 'rmse' or stat == 'kgem' or stat == 'mean': stat0 = 'mean' + if stat == 'rmnz' or stat == 'mnnz': stat0 = 'mnnz' + if stat == 'maxe' or stat == 'amax': stat0 = 'amax' + s = summa[var].sel(stat=stat0) + if do_rel: + s_rel = summa[var].sel(stat=statr) + if var != 'wallClockTime': s = s/s_rel + + # Mask the finite values of the variable + mask = np.isfinite(s) + s = s[mask] + + # Get the indices of the largest nBig values + big_indices = abs(s).argsort()[-nBig:] + + # Get the largest nBig values + val_big = s[big_indices.values] + + # Get the hru coordinate of the largest nBig values + hru_big = s[big_indices.values].hru.values + + # Get the largest nBig bench values + if do_rel: ben_big = s_rel.sel(hru=hru_big) + + # Print all the values of the biggest rmse hru + if do_rel: + print(f"\n{var} raw error values of largest relative {stat} values:") + else: + print(f"\n{var} raw error values of largest {stat} values:") + # Print all the raw values of the largest nBig values + raw_vals = summa.sel(stat=stat0, hru=hru_big) + for i,var0 in enumerate(plot_vars[:-1]): + print(f"{short_name[i]}: [{' '.join(f'{val:8.1e}' for val in raw_vals[var0].values)}]") + var0 = 'wallClockTime' + if stat == 'rmse' or stat == 'kgem' or stat == 'mean': stat00 = 'mean' + if stat == 'rmnz' or stat == 'mnnz': stat00 = 'mnnz' + if stat == 'maxe' or stat == 'amax': stat00 = 'amax' + raw_vals = summa.sel(stat=stat00, hru=hru_big) + print("wall"f"{stat00}: [{' '.join(f'{val:8.1e}' for val in raw_vals[var0].values)}]") + + # Open the netCDF file with local attributes + attr = xr.open_dataset(attr_fil) + + # Mask the HRU variable from the netCDF file + mask = attr['hruId'].isin(hru_big) + + # Filtered HRU IDs + filtered_hru_ids = attr['hruId'][mask] + + # Determine the indices that would sort filtered_hru_ids to match the order of hru_big + h_ind = [filtered_hru_ids.values.tolist().index(hru_id) for hru_id in hru_big if hru_id in filtered_hru_ids.values] + h = attr['hruId'][mask].values[h_ind] + + # Get the vegTypeIndex, lat, lon variables from the netCDF file + vegType_big = attr['vegTypeIndex'][mask].values[h_ind] + lat_big = attr['latitude'][mask].values[h_ind] + lon_big = attr['longitude'][mask].values[h_ind] + + # Print the attributes of the largest nBig values + print("HRU vals: [", " ".join([f"{val:8d}" for val in hru_big]), "]", sep="") + print("vegType : [", " ".join([f"{val:8d}" for val in vegType_big]), "]", sep="") + print("latitude: [", " ".join([f"{val:8.2f}" for val in lat_big]), "]", sep="") + print("longitud: [", " ".join([f"{val:8.2f}" for val in lon_big]), "]", sep="") + + # Print the values of the largest nBig values, bench will be the mean, mnnz, or amax and err will be the rmse, rmnz, or maxe + if do_rel: + #print(summa[var].sel(stat=stat0, hru=hru_big)) + print("Ben vals: [", " ".join([f"{val:8.1e}" for val in ben_big.values]), "]", sep="") + print("Err vals: [", " ".join([f"{val:8.1e}" for val in val_big.values]), "]", sep="") + \ No newline at end of file diff --git a/utils/post-processing/plot_per_GRUMult.py b/utils/post-processing/plot_per_GRUMult.py new file mode 100644 index 000000000..d297b47fa --- /dev/null +++ b/utils/post-processing/plot_per_GRUMult.py @@ -0,0 +1,709 @@ +# written originally by W. Knoben, modified by A. Van Beusekom (2023) + +## Visualize statistics per GRU +## Needs: +# Catchment shapefile with GRU delineation +# SUMMA output statistics + +## Special note +# SUMMA simulations have been preprocessed into single value statistics per model element, using auxiliary scripts in ~/utils +# To improve visualization of large lakes, HydroLAKES lake delineations are plotted on top of the catchment GRUs and river segments. +# Dealing with HydroLAKES inputs is not considered within scope of the workflow and therefore requires some manual downloading and preprocessing of this data for those who wish to reproduce this step. +# The relevant code is easily disabled by switching the plot_lakes = True flag to False. + +# Run: +# python plot_per_GRUMult.py [stat] +# where stat is rmse or maxe or kgem or mean or amax or avge + +# modules +import sys +import os +import matplotlib +import numpy as np +import xarray as xr +from pathlib import Path +import matplotlib.pyplot as plt +import copy +import pyproj +import fiona +import geopandas as gpd +import pandas as pd +import matplotlib.ticker as ticker +import matplotlib.colors as mcolors +from matplotlib.ticker import ScalarFormatter + + +do_rel = False # true is plot relative to the benchmark simulation +one_plot = True # true is one plot, false is multiple plots (one per variable) +run_local = False # true is run on local machine (only does testing), false is run on cluster +more_mean = False # true is plot mean/amax extra variables in a balance file +two_stat = True # true is run both mean and amax, false is run one stat +fix_hruid = True # true is only have hru index for hru, false is have hruid for hru + +if run_local: + stat = 'avge' + viz_dir = Path('/Users/amedin/Research/USask/test_py/statistics_en') +else: + import sys + stat = sys.argv[1] + viz_dir = Path(os.path.expanduser('~/statistics')) + #viz_dir = Path('/project/k/kshook/avanb/enthalpy_paper/runs/statistics') + + +# NOTE: method_name 'ref' will plot the reference solution, 'diff' will plot the difference between two simulations +# method_name 'diff' requires the specification of the two simulations to subtract in the variables from_meth and sub_meth + +method_name=['be1','be16','be32','sun6','ref'] +plt_name0=['SUMMA-BE1','SUMMA-BE16','SUMMA-BE32','SUMMA-SUNDIALS','reference solution'] +plt_nameshort=plt_name0 +method_name=['be8','be8cm','be8en','sun5cm','sun5en','diff','ref'] +plt_name0=['BE8 common','SUMMA-BE8 temperature','SUMMA-BE8 mixed','SUMMA-SUNDIALS temperature','SUMMA-SUNDIALS enthalpy','SUMMA-BE8 common - mixed','reference solution'] +plt_nameshort=['BE8 common','BE8 temp','BE8 mixed','SUNDIALS temp','SUNDIALS enth','BE8 common - mixed','reference soln'] +#method_name=['sun8en'] +#plt_name0=['reference solution'] +#plt_nameshort=[''] + +if one_plot: plt_name0 = plt_nameshort + +from_meth = method_name[0] # name of the first simulation in the difference simulation, only used if a method_name is 'diff' +sub_meth = method_name[0] # name of the simulation to subtract in the difference simulation, only used if a method_name is 'diff' + +# Simulation statistics file locations +settings= ['scalarSWE','scalarTotalSoilWat','scalarTotalET','scalarCanopyWat','scalarRootZoneTemp'] + +viz_fil = method_name.copy() +for i, m in enumerate(method_name): + viz_fil[i] = m + '_hrly_diff_stats_accuracy.nc' +nbatch_hrus = 518 # number of HRUs per batch +if stat == 'kgem': do_rel = False # don't plot relative to the benchmark simulation for KGE + +if more_mean: # extra vars in a balance file + plt_titl_exVar = ['rain plus melt into soil','top 3m soil temperature','air temperature','snow water equivalent'] + plot_vars_exVar = ['scalarRainPlusMelt','scalarRootZoneTemp','airtemp','scalarSWE'] + #plot_vars_exVar = ['balanceAqMass','balanceSoilNrg','balanceSoilMass','balanceVegMass'] + viz_file_exVar = 'exVar_hrly_diff_bals_balance.nc' + plt_name0_exVar = 'SUMMA-BE1 temperature' + plt_nameshort_exVar = 'BE1 temp' # identify method here + leg_titl_exVar = ['$mm~y^{-1}$','$K$','$K$','$kg~m^{-2}$'] + maxes_exVar = [3000,295,295,100] + if one_plot: plt_name0_exVar = plt_nameshort_exVar + +# Specify variables in files +plot_vars = settings.copy() + ['scalarSWE'] +plt_titl = ['snow water equivalent','total soil water content','total evapotranspiration', 'total water on the vegetation canopy','top 3m soil temperature','melt with seasonal snow'] +leg_titl = ['$kg~m^{-2}$', '$kg~m^{-2}$','$mm~y^{-1}$','$kg~m^{-2}$','$K$','$kg~m^{-2}$'] +calc = [0,0,0,0,0,0,1] # 1 if variable needs to be calculated from other variables +melt_thresh = 1/(0.75) # threshold for melt water calculation (divisor is percentage of year no snow, if only melts once) + +# adjust for vars actually computed +plot_vars_computed = ['scalarTotalSoilWat','scalarRootZoneTemp'] + +fig_fil= '_hrly_diff_stats_{}_compressed.png' +if do_rel: fig_fil = '_hrly_diff_stats_{}_rel_compressed.png' + +if stat == 'avge': + maxes = [99,7,99,99,0.28,99] + if do_rel: maxes = [0.4,0.007,0.6,0.15,0.0015] +if stat == 'rmse' or stat == 'rmnz': + maxes = [2,15,250,0.08,200,2] + if do_rel: maxes = [0.4,0.007,0.6,0.15,0.0015,0.2,0.6] +if stat == 'maxe' or (stat=='avge' and two_stat): + maxes2 = [99,15,99,99,6,99] #[15,25,25e-5,2,1e-7,0.2] + if do_rel: maxes2 = [0.4,0.007,0.6,0.15,0.0015,0.2,0.6] + if not two_stat: + maxes = maxes2 +if stat == 'kgem': + maxes = [0.9,0.9,0.9,0.9,0.9,10e-3,0.9] +if stat == 'mean' or stat == 'mnnz': + maxes = [100,1700,2000,8,295,3000,100] #[80,1500,5e-5,8,1e-7,10e-3] + if do_rel: maxes = [1.1,1.1,1.1,1.1,1.1,1.1] +if stat == 'amax' or (stat=='mean' and two_stat): + maxes2 = [240,1800,3.5,25,6,0.2,240] #[240,1800,1e-3,25,2e-6,0.2] + if do_rel: maxes2 = [1.1,1.1,1.1,1.1,1.1,1.1] + if not two_stat: + maxes = maxes2 + +# Get simulation statistics +summa = {} +for i, m in enumerate(method_name): + # Get the aggregated statistics of SUMMA simulations + if m!='diff' and m!='ref': summa[m] = xr.open_dataset(viz_dir/viz_fil[i]) + +if more_mean: summa['exVar'] = xr.open_dataset(viz_dir/viz_file_exVar) + +if fix_hruid: + hruid_file = xr.open_dataset(viz_dir/'sun8en_hrly_diff_bals_balance.nc') + hruid = hruid_file['hru'] + for m in method_name: + if m!='diff' and m!='ref': summa[m]['hru'] = hruid + +# Function to extract a given setting from the control file +def read_from_control( file, setting ): + + # Open controlFile and ... + with open(file) as contents: + for line in contents: + + # ... find the line with the requested setting + if setting in line and not line.startswith('#'): + break + + # Extract the setting's value + substring = line.split('|',1)[1] # Remove the setting's name (split into 2 based on '|', keep only 2nd part) + substring = substring.split('#',1)[0] # Remove comments, does nothing if no '#' is found + substring = substring.strip() # Remove leading and trailing whitespace, tabs, newlines + + # Return this value + return substring + +# Function to specify a default path +def make_default_path(suffix): + + # Get the root path + rootPath = Path( read_from_control(controlFile,'root_path') ) + + # Get the domain folder + domainName = read_from_control(controlFile,'domain_name') + domainFolder = 'domain_' + domainName + + # Specify the forcing path + defaultPath = rootPath / domainFolder / suffix + + return defaultPath + +if run_local: + # Make stubs to check if the plots set up properly + plot_lakes = False + plot_rivers = False + + # Create a mock DataFrame + from shapely.geometry import Point + s = summa[method_name[0]][plot_vars_computed[0]].sel(stat=stat) + mock_data = { + 'hm_hruid': np.concatenate(([81029662], s.hru.values[-100:])), #s.hru.values[-100:], # Example HRU IDs + 'geometry': [Point(x, y) for x, y in zip(range(101), range(101))] # Simple geometries + } + bas_albers = gpd.GeoDataFrame(mock_data, geometry='geometry') + hm_hruid = 'hm_hruid' # Correctly define the variable name in the shapefile + xmin, ymin, xmax, ymax = bas_albers.total_bounds + +else: + # Get the albers shapes + main = Path(os.path.expanduser('~/albers_projection')) + plot_lakes = True + plot_rivers = False + + # Control file handling + controlFile = main / 'plot_control_NorthAmerica.txt' + + # HM catchment shapefile path & name + hm_catchment_path = read_from_control(controlFile,'catchment_shp_path') + hm_catchment_name = read_from_control(controlFile,'catchment_shp_name') + # Specify default path if needed + if hm_catchment_path == 'default': + hm_catchment_path = make_default_path('shapefiles/catchment') # outputs a Path() + else: + hm_catchment_path = Path(hm_catchment_path) # make sure a user-specified path is a Path() + + # Find the GRU and HRU identifiers + hm_hruid = read_from_control(controlFile,'catchment_shp_hruid') + + ## River network shapefile location and variable names + river_network_path = read_from_control(controlFile,'river_network_shp_path') + river_network_name = read_from_control(controlFile,'river_network_shp_name') + # Specify default path if needed + if river_network_path == 'default': + river_network_path = make_default_path('shapefiles/river_network') # outputs a Path() + else: + river_network_path = Path(river_network_path) # make sure a user-specified path is a Path() + + # Find the segment ID + seg_id = read_from_control(controlFile,'river_network_shp_segid') + + ## Load all shapefiles and project to Albers Conformal Conic and reproject + acc = 'ESRI:102008' # Set the target CRS + + bas_albers = gpd.read_file(main/'basin.shp') + xmin, ymin, xmax, ymax = bas_albers.total_bounds + + if plot_rivers: riv_albers = gpd.read_file(main/'river.shp') + if plot_lakes: lak_albers = gpd.read_file(main/'lakes.shp') + + +# Match the accummulated values to the correct HRU IDs in the shapefile +hru_ids_shp = bas_albers[hm_hruid].astype(int) # hru order in shapefile +# Define a list of stat0 values to loop over +if two_stat: + if stat=='avge': + stat_values = [stat, 'maxe'] + else: + stat_values = [stat, 'amax'] +else: + stat_values = [stat] + +for i,plot_var in enumerate(plot_vars_computed): + for stat_use in stat_values: + stat0 = stat_use + if stat_use == 'rmse' or stat_use == 'kgem' or stat_use == 'mean' or stat_use == 'avge': + if plot_var == 'wallClockTime': stat0 = 'mean' + statr = 'mean_ben' + if stat_use == 'rmnz' or stat_use == 'mnnz': + if plot_var == 'wallClockTime': stat0 = 'mnnz' + statr = 'mnnz_ben' + if stat_use == 'maxe' or stat_use == 'amax': + if plot_var == 'wallClockTime': stat0 = 'amax' + statr = 'amax_ben' + + s_rel = np.fabs(summa[method_name[0]][plot_var].sel(stat=statr)) + + if calc[i]: + if do_rel: s_rel = s_rel.where(summa[method_name[0]][plot_var].sel(stat='mnnz_ben') > melt_thresh*summa[method_name[0]][plot_var].sel(stat='mean_ben')) + + + for m in method_name: + if m=='diff': + s = summa[from_meth][plot_var].sel(stat=stat0) - summa[sub_meth][plot_var].sel(stat=stat0) + elif m=='ref': + s = np.fabs(summa[method_name[0]][plot_var].sel(stat=statr)) + else: + s = np.fabs(summa[m][plot_var].sel(stat=stat0)) + if calc[i]: + if m=='diff': + s_from = summa[from_meth][plot_var].sel(stat=stat0) + s_from = s_from.where(summa[from_meth][plot_var].sel(stat='mnnz') > melt_thresh*summa[from_meth][plot_var].sel(stat='mean')) + s_sub = summa[sub_meth][plot_var].sel(stat=stat0) + s_sub = s_sub.where(summa[sub_meth][plot_var].sel(stat='mnnz') > melt_thresh*summa[sub_meth][plot_var].sel(stat='mean')) + s = s_from - s_sub + elif m=='ref': + s =s.where(summa[method_name[0]][plot_var].sel(stat='mnnz_ben') > melt_thresh*summa[method_name[0]][plot_var].sel(stat='mean_ben')) + else: + s = s.where(summa[m][plot_var].sel(stat='mnnz') > melt_thresh*summa[m][plot_var].sel(stat='mean')) + if do_rel and plot_var != 'wallClockTime': s = s/s_rel + + # Replace inf and 9999 values with NaN in the s DataArray + s = s.where(~np.isinf(s), np.nan).where(lambda x: x != 9999, np.nan) + + if plot_var == 'scalarTotalET' and not do_rel: + if stat_use =='rmse' or stat_use =='rmnz' or stat_use=='mnnz' or stat_use=='mean': s = s*31557600 # make annual total + if stat_use =='maxe' or stat_use=='amax': s = s*3600 # make hourly max + if plot_var == 'averageRoutedRunoff' and not do_rel: + if stat_use =='rmse' or stat_use =='rmnz' or stat_use=='mnnz' or stat_use=='mean': s = s*31557600*1000 # make annual total + if stat_use =='maxe' or stat_use=='amax': s = s*3600*1000 # make hourly max + if plot_var == 'scalarRainPlusMelt' and not do_rel: + if stat_use =='rmse' or stat_use =='rmnz' or stat_use=='mnnz' or stat_use=='mean': s = s*31557600*1000 # make annual total + if stat_use =='maxe' or stat_use=='amax': s = s*3600*1000 # make hourly max + + # Create a new column in the shapefile for each method, and fill it with the statistics + if calc[i]: + plot_var1 = plot_var + '_calc' + else: + plot_var1 = plot_var + bas_albers[plot_var1+m+stat0] = np.nan + hru_ind = [i for i, hru_id in enumerate(hru_ids_shp.values) if hru_id in s.hru.values] # if some missing + bas_albers.loc[hru_ind, plot_var1+m+stat0] = s.sel(hru=hru_ids_shp.values[hru_ind]).values + +if more_mean: # extra mean/amax variables + for i,plot_var in enumerate(plot_vars_exVar): + for stat_use in stat_values: + stat0 = stat_use + + if stat_use != 'mean' and stat_use != 'amax': + print('Only mean and amax are supported for extra variables') + sys.exit() + + m = 'exVar' + s = np.fabs(summa[m][plot_var].sel(stat=stat0)) + + # Replace inf and 9999 values with NaN in the s DataArray + s = s.where(~np.isinf(s), np.nan).where(lambda x: x != 9999, np.nan) + + if plot_var == 'scalarRainPlusMelt': + if stat_use=='mean': s = s*31557600*1000 # make annual total + if stat_use=='amax': s = s*3600*1000 # make hourly max + + # Create a new column in the shapefile for each method, and fill it with the statistics + plot_var1 = plot_var + bas_albers[plot_var1+m+stat0] = np.nan + hru_ind = [i for i, hru_id in enumerate(hru_ids_shp.values) if hru_id in s.hru.values] # if some missing + bas_albers.loc[hru_ind, plot_var1+m+stat0] = s.sel(hru=hru_ids_shp.values[hru_ind]).values + + + +# Select lakes of a certain size for plotting +if plot_lakes: + minSize = 1000 # km2 + in_domain = (lak_albers['Country'] == 'Canada') | \ + (lak_albers['Country'] == 'United States of America') | \ + (lak_albers['Country'] == 'Mexico') + out_domain = (lak_albers['Pour_long'] > -80) & (lak_albers['Pour_lat'] > 65) # Exclude Baffin Island + large_lakes_albers = lak_albers.loc[(lak_albers['Lake_area'] > minSize) & in_domain & (~out_domain) ] + lake_col = (8/255,81/255,156/255) + + + +# Figure +def run_loop(j,var,the_max,stat,row_fill): + stat0 = stat + if stat == 'rmse' or stat == 'kgem' or stat == 'mean': + if var == 'wallClockTime': stat0 = 'mean' + statr = 'mean_ben' + if stat == 'rmnz' or stat == 'mnnz': + if var == 'wallClockTime': stat0 = 'mnnz' + statr = 'mnnz_ben' + if stat == 'maxe' or stat == 'amax': + if var == 'wallClockTime': stat0 = 'amax' + statr = 'amax_ben' + + + if stat0 == 'rmse': stat_word = 'RMSE' + if stat0 == 'rmnz': stat_word = 'RMSE' # no 0s' + if stat0 == 'maxe': stat_word = 'max abs error' + if stat0 == 'kgem': stat_word = 'KGE"' + if stat0 == 'mean': stat_word = 'mean' + if stat0 == 'mnnz': stat_word = 'mean' # no 0s' + if stat0 == 'amax': stat_word = 'max' + if stat0 == 'avge': stat_word = 'mean abs error' + + if do_rel: + if statr == 'mean_ben': statr_word = 'mean' + if statr == 'mnnz_ben': statr_word = 'mean' # no 0s' + if statr == 'amax_ben': statr_word = 'max' + + my_cmap = copy.copy(matplotlib.cm.get_cmap('inferno_r')) # copy the default cmap + my_cmap.set_bad(color='white') #nan color white + + if var!='exVar': + vmin,vmax = 0, the_max + if (stat =='mean' or stat=='mnnz') and var=='scalarTotalSoilWat' and not do_rel: vmin,vmax = 600, the_max + if stat =='amax' and var=='scalarTotalSoilWat' and not do_rel: vmin,vmax = 1000, the_max + if (stat == 'mean' or stat == 'mnnz' or stat == 'amax') and var!='wallClockTime' and do_rel: vmin,vmax = 0.9, the_max + norm=matplotlib.colors.PowerNorm(vmin=vmin,vmax=vmax,gamma=0.5) + + if stat =='kgem' and var!='wallClockTime': + my_cmap = copy.copy(matplotlib.cm.get_cmap('inferno')) # copy the default cmap + my_cmap.set_bad(color='white') #nan color white + vmin,vmax = the_max, 1.0 + norm=matplotlib.colors.PowerNorm(vmin=vmin,vmax=vmax,gamma=1.5) + + my_cmap2 = copy.copy(matplotlib.cm.get_cmap('inferno_r')) # copy the default cmap + my_cmap2.set_bad(color='white') #nan color white + vmin,vmax = -the_max/250,the_max/250 + norm2 = matplotlib.colors.TwoSlopeNorm(vmin=vmin, vcenter=0, vmax=vmax) + #norm2 = matplotlib.colors.SymLogNorm(vmin=vmin,vmax=vmax,linthresh=0.01,base=1.1) + + if stat == 'mean' and var== 'scalarRootZoneTemp': + my_cmap = copy.copy(matplotlib.cm.get_cmap('inferno_r')) # copy the default cmap + my_cmap.set_bad(color='white') #nan color white + vmin,vmax = (280-(the_max-280)),the_max + norm = matplotlib.colors.TwoSlopeNorm(vmin=vmin, vcenter=273.16, vmax=vmax) + + for i,m in enumerate(method_name): + if len(method_name)==1: + if row_fill: + r = base_row//ncol + c = base_row-r*ncol + else: + c = base_row//nrow + r = base_row-c*nrow + else: + if row_fill: + r = i//ncol + base_row + c = i - (r-base_row)*ncol + else: + c = i//nrow + base_row + r = i - (c-base_row)*nrow + + # Plot the data with the full extent of the bas_albers shape + if m=='diff': + bas_albers.plot(ax=axs[r,c], column=var+m+stat0, edgecolor='none', legend=False, cmap=my_cmap2, norm=norm2,zorder=0) + stat_word0 = stat_word+' difference' + stat_word2 = stat_word + plt_nm = plt_name[i] + elif m=='ref' and var != 'wallClockTime': + # only plot wallClockTime for the reference solution + plt_nm ='' + else: + bas_albers.plot(ax=axs[r,c], column=var+m+stat0, edgecolor='none', legend=False, cmap=my_cmap, norm=norm,zorder=0) + stat_word0 = stat_word + plt_nm = plt_name[i] + print(f"{'all HRU mean for '}{var+m+stat0:<35}{np.nanmean(bas_albers[var+m+stat0].values):<10.5f}{' max: '}{np.nanmax(bas_albers[var+m+stat0].values):<10.5f}") + axs[r,c].set_title(plt_nm) + axs[r,c].axis('off') + axs[r,c].set_xlim(xmin, xmax) + axs[r,c].set_ylim(ymin, ymax) + + # Custom colorbar + if i==len(method_name)-1: + if m=='diff': + sm = matplotlib.cm.ScalarMappable(cmap=my_cmap2, norm=norm2) + sm2 = matplotlib.cm.ScalarMappable(cmap=my_cmap, norm=norm) + else: + sm = matplotlib.cm.ScalarMappable(cmap=my_cmap, norm=norm) + sm.set_array([]) + if not row_fill: + axs_list = np.array(axs).T.ravel().tolist() + else: + axs_list = axs.ravel().tolist() + if one_plot: + if m=='diff': # only works if diff is last on list + if not row_fill: + cbr = fig.colorbar(sm, ax=axs_list[c*len(method_name):(c+1)*len(method_name)],aspect=27/nrow,location='right') + cbr2 = fig.colorbar(sm2, ax=axs_list[(c+1)*len(method_name)-1:(c+1)*len(method_name)],aspect=27/nrow,location='left') + else: + cbr = fig.colorbar(sm, ax=axs_list[r*len(method_name):(r+1)*len(method_name)],aspect=27/nrow,location='right') + cbr2 = fig.colorbar(sm2, ax=axs_list[(r+1)*len(method_name)-1:(r+1)*len(method_name)],aspect=27/nrow,location='left') + cbr2.ax.yaxis.set_ticks_position('right') + cbr2.ax.yaxis.set_label_position('right') + else: + if len(method_name)==1: + if not row_fill: + cbr = fig.colorbar(sm, ax=axs_list[base_row:base_row+1],aspect=27/1) + else: + cbr = fig.colorbar(sm, ax=axs_list[base_row:base_row+1],aspect=27/1,location='right') + else: + if not row_fill: + cbr = fig.colorbar(sm, ax=axs_list[c*len(method_name):(c+1)*len(method_name)],aspect=27/1.1*nrow,location='right') + else: + cbr = fig.colorbar(sm, ax=axs_list[r*len(method_name):(r+1)*len(method_name)],aspect=27/1.1*nrow,location='right') + else: + # will be wonky with m=='diff' choice + if not row_fill: + cbr = fig.colorbar(sm, ax=axs_list[c*len(method_name):(c+1)*len(method_name)],aspect=27/3*nrow) + if m=='diff': cbr2 = fig.colorbar(sm2, ax=axs_list[c*len(method_name):(c+1)*len(method_name)],aspect=27/3*nrow) + else: + cbr = fig.colorbar(sm, ax=axs_list,aspect=27/3*nrow) + if m=='diff': cbr2 = fig.colorbar(sm2, ax=axs_list,aspect=27/3*nrow) + if stat == 'kgem': + cbr.ax.set_ylabel(stat_word0) + else: + if do_rel and var!='wallClockTime': + cbr.ax.set_ylabel('relative '+ stat_word0) + if m=='diff': cbr2.ax.set_ylabel('relative '+ stat_word2) + else: + cbr.ax.set_ylabel(stat_word0 + ' [{}]'.format(leg_titl[j])) + if m=='diff': cbr2.ax.set_ylabel(stat_word2 + ' [{}]'.format(leg_titl[j])) + + if var=='scalarTotalET' and (stat =='mean' or stat =='mnnz') and m!='diff': + # Customizing the tick labels to include negative signs + def format_tick(value, tick_number): + rounded_value = int(round(value,-2)) + return f"-{rounded_value}" + cbr.ax.yaxis.set_major_formatter(ticker.FuncFormatter(format_tick)) + if m=='diff': + # Customizing the tick labels + cbr.ax.yaxis.set_major_formatter(ScalarFormatter()) + + # lakes + if m=='ref' and var != 'wallClockTime': + # only plot wallClockTime for the reference solution + plt_nm ='' + else: + if plot_lakes: large_lakes_albers.plot(ax=axs[r,c], color=lake_col, zorder=1) + + else: # extra mean/amax variables + for i,v in enumerate(plot_vars_exVar): + vmin,vmax = 0, maxes_exVar[i] + if (v=='airtemp' or v== 'scalarRootZoneTemp'): + #vmin,vmax = 260, maxes_exVar[i] + my_cmap2 = copy.copy(matplotlib.cm.get_cmap('inferno_r')) # copy the default cmap + my_cmap2.set_bad(color='white') #nan color white + vmin,vmax = (273.16-(maxes_exVar[i]-273.16)),maxes_exVar[i], + norm2 = matplotlib.colors.TwoSlopeNorm(vmin=vmin, vcenter=273.16, vmax=vmax) + else: + norm=matplotlib.colors.PowerNorm(vmin=vmin,vmax=vmax,gamma=0.5) + + r = i//ncol + base_row + c = i - (r-base_row)*ncol + m = 'exVar' + + # Plot the data with the full extent of the bas_albers shape + if (v=='airtemp' or v== 'scalarRootZoneTemp' or v=='balanceSoilNrg'): + bas_albers.plot(ax=axs[r,c], column=v+m, edgecolor='none', legend=False, cmap=my_cmap2, norm=norm2,zorder=0) + else: + bas_albers.plot(ax=axs[r,c], column=v+m, edgecolor='none', legend=False, cmap=my_cmap, norm=norm,zorder=0) + stat_word0 = stat_word + print(f"{'all HRU mean for '}{v+m:<35}{np.nanmean(bas_albers[v+m].values):<10.5f}{' max: '}{np.nanmax(bas_albers[v+m].values):<10.5f}") + axs[r,c].set_title(plt_name[i]) + axs[r,c].axis('off') + axs[r,c].set_xlim(xmin, xmax) + axs[r,c].set_ylim(ymin, ymax) + + if (v=='airtemp' or v== 'scalarRootZoneTemp' or v=='balanceSoilNrg'): + sm = matplotlib.cm.ScalarMappable(cmap=my_cmap2, norm=norm2) + else: + sm = matplotlib.cm.ScalarMappable(cmap=my_cmap, norm=norm) + sm.set_array([]) + if i==len(plot_vars_exVar)-1: + pad = 0.05 + elif i==len(plot_vars_exVar)-2: + pad = -0.05 + else: + pad = -0.5 + if one_plot: # will be wrong with two_stat, but ex_var shouldn't have 2 stat at the moment + if len(method_name)==1: + cbr = fig.colorbar(sm,ax=axs_list[r*ncol:r*ncol+c+1],aspect=27/1, pad=pad) + else: + cbr = fig.colorbar(sm,ax=axs_list[r*ncol:r*ncol+c+1],aspect=27/nrow, pad=pad) + else: + cbr = fig.colorbar(sm,ax=axs_list[r*ncol:r*ncol+c+1],aspect=27/nrow, pad=pad) + cbr.ax.set_ylabel(stat_word0 + ' [{}]'.format(leg_titl_exVar[i])) + + # lakes + if plot_lakes: large_lakes_albers.plot(ax=axs[r,c], color=lake_col, zorder=1) + + + +# Specify plotting options +if one_plot: + #use_vars = [0,5,4,1] + #use_meth = [0] + #use_vars_exVar = [0] + use_vars = [4,1] + use_meth = [0,1,2,3,4] +else: + #use_vars = [0,1,2,3,4,5] + use_vars = [4,1] + use_meth = [0,1,2,3,4] + use_vars_exVar = [3,0,2] +if more_mean: + use_vars = ['exVar'] + use_vars # 'exVar' is the extra variables in a balance file, all same method + if len(use_meth) < len(use_vars_exVar): use_vars_exVar = use_vars_exVar[:len(use_meth)] # chop if longer + plot_vars_exVar = [plot_vars_exVar[i] for i in use_vars_exVar] + leg_titl_exVar = [leg_titl_exVar[i] for i in use_vars_exVar] + maxes_exVar = [maxes_exVar[i] for i in use_vars_exVar] + #plt_name_exVar = [f"({chr(97+n)}) {plt_titl_exVar[i]+ ' ' + plt_name0_exVar}" for n,i in enumerate(use_vars_exVar)] + plt_name_exVar = [f"({chr(97+n)}) {plt_titl_exVar[i]}" for n,i in enumerate(use_vars_exVar)] + +plot_vars = [var + '_calc' if c == 1 else var for var, c in zip(plot_vars, calc)] +plot_vars = [plot_vars[i] if i != 'exVar' else 'exVar' for i in use_vars] +plt_titl = [plt_titl[i] if i != 'exVar' else 'exVar' for i in use_vars] +leg_titl = [leg_titl[i] if i != 'exVar' else 'exVar' for i in use_vars] +maxes = [maxes[i] if i != 'exVar' else 'exVar' for i in use_vars] +if two_stat: + maxes2 = [maxes2[i] for i in use_vars] +else: + maxes2 = maxes # dummy +method_name = [method_name[i] for i in use_meth] + +if one_plot: + if two_stat: + ncol = 2*len(use_vars) + nrow = len(use_meth) + else: + ncol = len(use_meth) + nrow = len(use_vars) + if len(use_meth)==1: + ncol = len(use_vars) + nrow = 2 + + # Set the font size: we need this to be huge so we can also make our plotting area huge, to avoid a gnarly plotting bug + if 'compressed' in fig_fil: + plt.rcParams.update({'font.size': 33}) + if more_mean and len(use_meth)>1: + fig,axs = plt.subplots(nrow,ncol,figsize=(16.9*ncol,13*nrow),constrained_layout=True) + else: + fig,axs = plt.subplots(nrow,ncol,figsize=(15*ncol,13*nrow),constrained_layout=True) + + else: + plt.rcParams.update({'font.size': 120}) + if more_mean and len(use_meth)>1: + fig,axs = plt.subplots(nrow,ncol,figsize=(80*ncol,58*nrow),constrained_layout=True) + else: + fig,axs = plt.subplots(nrow,ncol,figsize=(67*ncol,58*nrow),constrained_layout=True) + + fig.suptitle('hourly statistics', fontsize=40,y=1.05) + plt.rcParams['patch.antialiased'] = False # Prevents an issue with plotting distortion along the 0 degree latitude and longitude lines + +else: + if two_stat: + ncol = 2 + nrow = len(use_meth) + else: + #size hardwired to 2x3 for now + ncol = 3 + nrow = 2 + if len(method_name)>6: + print('Too many methods for 3x2 plot') + sys.exit() + plt_name_orig = [f"({chr(97+n)}) {plt_name0[i]}" for n,i in enumerate(use_meth)] + +for i,(var,the_max,the_max2) in enumerate(zip(plot_vars,maxes,maxes2)): + + if one_plot: + # Reset the names + base_row = i + if not two_stat: + if (len(use_vars)>1): plt_name = [f"({chr(97+n+i*len(use_meth))}) {plt_titl[i] + ' ' + plt_name0[j]}" for n,j in enumerate(use_meth)] + if (len(use_vars)==1): plt_name = [f"({chr(97+n+i*len(use_meth))}) {plt_name0[j]}" for n,j in enumerate(use_meth)] + if(var=='exVar'): plt_name = plt_name_exVar + else: + base_row = 0 + if not two_stat: + plt_name = plt_name_orig + if(var=='exVar'): plt_name = plt_name_exVar + # Set the font size: we need this to be huge so we can also make our plotting area huge, to avoid a gnarly plotting bug + if 'compressed' in fig_fil: + plt.rcParams.update({'font.size': 33}) + fig,axs = plt.subplots(nrow,ncol,figsize=(15*ncol,13*nrow),constrained_layout=True) + else: + plt.rcParams.update({'font.size': 120}) + fig,axs = plt.subplots(nrow,ncol,figsize=(67*ncol,58*nrow),constrained_layout=True) + + if not two_stat: + # Remove the extra subplots + if len(method_name) < nrow*ncol: + for j in range(len(method_name),nrow*ncol): + r = j//ncol + c = j-r*ncol + fig.delaxes(axs[r, c]) + + fig.suptitle('{} hourly statistics'.format(plt_titl[i]), fontsize=40,y=1.05) + plt.rcParams['patch.antialiased'] = False # Prevents an issue with plotting distortion along the 0 degree latitude and longitude lines + + if two_stat: + row_fill=False + + base_row = base_row*2 + if one_plot: + plt_name = [f"({chr(97+2*n+base_row)}) {plt_titl[i] + ' ' + plt_name0[j]}" for n,j in enumerate(use_meth)] + else: + plt_name = [f"({chr(97+2*n+base_row)}) {plt_name0[j]}" for n,j in enumerate(use_meth)] + run_loop(i,var,the_max,stat, row_fill) + + base_row = base_row+1 + if one_plot: + plt_name = [f"({chr(97+2*n+base_row)}) {plt_titl[i] + ' ' + plt_name0[j]}" for n,j in enumerate(use_meth)] + else: + plt_name = [f"({chr(97+2*n+base_row)}) {plt_name0[j]}" for n,j in enumerate(use_meth)] + if stat=='avge': + stat2 = 'maxe' + else: + stat2 = 'amax' + run_loop(i,var,the_max2,stat2,row_fill) + else: + row_fill=True + run_loop(i,var,the_max,stat,row_fill) + + if not one_plot: + # Save the figure + if not two_stat: + fig_fil1 = (var+fig_fil).format(stat) + else: + fig_fil1 = (var+fig_fil).format(stat+','+stat2) + plt.savefig(viz_dir/fig_fil1, bbox_inches='tight', transparent=True) + +if one_plot: + if not two_stat: + # Remove the extra subplots + if len(method_name)*len(plot_vars) < nrow*ncol: + for j in range(len(method_name)*len(plot_vars),nrow*ncol): + r = j//ncol + c = j-r*ncol + fig.delaxes(axs[r, c]) + + # Save the figure + if not two_stat: + fig_fil1 = ('all'+fig_fil).format(stat) + else: + fig_fil1 = ('all'+fig_fil).format(stat+','+stat2) + plt.savefig(viz_dir/fig_fil1, bbox_inches='tight', transparent=True) diff --git a/utils/post-processing/plot_per_GRUMultBal.py b/utils/post-processing/plot_per_GRUMultBal.py new file mode 100644 index 000000000..100a8a676 --- /dev/null +++ b/utils/post-processing/plot_per_GRUMultBal.py @@ -0,0 +1,405 @@ +# written originally by W. Knoben, modified by A. Van Beusekom (2023) + +## Visualize statistics per GRU +## Needs: +# Catchment shapefile with GRU delineation +# SUMMA output statistics + +## Special note +# SUMMA simulations have been preprocessed into single value statistics per model element, using auxiliary scripts in ~/utils +# To improve visualization of large lakes, HydroLAKES lake delineations are plotted on top of the catchment GRUs and river segments. +# Dealing with HydroLAKES inputs is not considered within scope of the workflow and therefore requires some manual downloading and preprocessing of this data for those who wish to reproduce this step. +# The relevant code is easily disabled by switching the plot_lakes = True flag to False. + +# Run: +# python plot_per_GRUMult.py [stat] +# where stat is mean or amax + + +# modules +import sys +import os +import matplotlib +import numpy as np +import xarray as xr +from pathlib import Path +import matplotlib.pyplot as plt +import copy +import pyproj +import fiona +import geopandas as gpd +import pandas as pd + + +one_plot = False # true is one plot, false is multiple plots (one per variable) +run_local = False # true is run on local machine (only does testing), false is run on cluster +fix_units_soil = True # true is convert to storage units, only works for Soil +two_stat = False # true is run both mean and amax, false is run one stat +fix_hruid = True # true is only have hru index for hru, false is have hruid for hru + +if run_local: + stat = 'mean' + viz_dir = Path('/Users/amedin/Research/USask/test_py/statistics_en') +else: + import sys + stat = sys.argv[1] + viz_dir = Path(os.path.expanduser('~/statistics')) + #viz_dir = Path('/project/k/kshook/avanb/enthalpy_paper/runs/statistics') + + +method_name=['be8','be8cm','be8en','sun5cm','sun5en','sun8en'] #maybe make this an argument +plt_name0=['SUMMA-BE8 common','SUMMA-BE8 temperature','SUMMA-BE8 mixed','SUMMA-SUNDIALS temperature','SUMMA-SUNDIALS enthalpy','reference solution'] +plt_nameshort=['BE8 common','BE8 temp','BE8 mixed','SUNDIALS temp','SUNDIALS enth','reference soln'] + +if one_plot: plt_name0 = plt_nameshort + +# Simulation statistics file locations +settings= ['balanceCasNrg','balanceVegNrg','balanceSnowNrg','balanceSoilNrg','balanceVegMass','balanceSnowMass','balanceSoilMass','balanceAqMass','wallClockTime'] + +viz_fil = method_name.copy() +for i, m in enumerate(method_name): + viz_fil[i] = m + '_hrly_diff_bals_balance.nc' +nbatch_hrus = 518 # number of HRUs per batch + +# Specify variables in files +plt_titl = ['canopy air space enthalpy balance','vegetation enthalpy balance','snow enthalpy balance','soil enthalpy balance','vegetation mass balance','snow mass balance','soil mass balance','aquifer mass balance', 'wall clock time'] +leg_titl = ['$W~m^{-3}$'] * 4 + ['$kg~m^{-3}~s^{-1}$'] * 3 + ['$kg~m^{-2}~s^{-1}$']+ ['$s$'] +if fix_units_soil: leg_titl = ['$kJ~m^{-2}$'] * 4 + ['$kg~m^{-2}'] * 4 + ['$s$'] + +fig_fil= '_hrly_balance_{}_compressed.png' +plot_vars = settings.copy() + +# adjust for vars actually computed +plot_vars_computed = ['balanceSoilNrg','wallClockTime'] + +if stat == 'mean': + maxes = [1e2,1e2,1e2,1e2]+[1e-7,1e-5,1e-7,1e-8] + [1e-2] +if stat == 'amax' or two_stat: + maxes2 = [1e4,1e4,1e4,1e4]+[1e-5,1e-3,1e-5,1e-6] + [2.0] + if not two_stat: + maxes = maxes2 + +# Get simulation statistics +summa = {} +for i, m in enumerate(method_name): + # Get the aggregated statistics of SUMMA simulations + summa[m] = xr.open_dataset(viz_dir/viz_fil[i]) + +if fix_hruid: + hruid_file = xr.open_dataset(viz_dir/'sun8en_hrly_diff_bals_balance.nc') + hruid = hruid_file['hru'] + for m in method_name: + summa[m]['hru'] = hruid + +# Function to extract a given setting from the control file +def read_from_control( file, setting ): + + # Open controlFile and ... + with open(file) as contents: + for line in contents: + + # ... find the line with the requested setting + if setting in line and not line.startswith('#'): + break + + # Extract the setting's value + substring = line.split('|',1)[1] # Remove the setting's name (split into 2 based on '|', keep only 2nd part) + substring = substring.split('#',1)[0] # Remove comments, does nothing if no '#' is found + substring = substring.strip() # Remove leading and trailing whitespace, tabs, newlines + + # Return this value + return substring + +# Function to specify a default path +def make_default_path(suffix): + + # Get the root path + rootPath = Path( read_from_control(controlFile,'root_path') ) + + # Get the domain folder + domainName = read_from_control(controlFile,'domain_name') + domainFolder = 'domain_' + domainName + + # Specify the forcing path + defaultPath = rootPath / domainFolder / suffix + + return defaultPath + +if run_local: + # Make stubs to check if the plots set up properly + plot_lakes = False + plot_rivers = False + + # Create a mock DataFrame + from shapely.geometry import Point + + s = summa[method_name[0]][plot_vars_computed[0]].sel(stat=stat) + mock_data = { + 'hm_hruid': s.hru.values[range(100)], # Example HRU IDs + 'geometry': [Point(x, y) for x, y in zip(range(100), range(100))] # Simple geometries + } + bas_albers = gpd.GeoDataFrame(mock_data, geometry='geometry') + hm_hruid = 'hm_hruid' # Correctly define the variable name in the shapefile + xmin, ymin, xmax, ymax = bas_albers.total_bounds + +else: + # Get the albers shapes + main = Path(os.path.expanduser('~/albers_projection')) + plot_lakes = True + plot_rivers = False + + # Control file handling + controlFile = main / 'plot_control_NorthAmerica.txt' + + # HM catchment shapefile path & name + hm_catchment_path = read_from_control(controlFile,'catchment_shp_path') + hm_catchment_name = read_from_control(controlFile,'catchment_shp_name') + # Specify default path if needed + if hm_catchment_path == 'default': + hm_catchment_path = make_default_path('shapefiles/catchment') # outputs a Path() + else: + hm_catchment_path = Path(hm_catchment_path) # make sure a user-specified path is a Path() + + # Find the GRU and HRU identifiers + hm_hruid = read_from_control(controlFile,'catchment_shp_hruid') + + ## River network shapefile location and variable names + river_network_path = read_from_control(controlFile,'river_network_shp_path') + river_network_name = read_from_control(controlFile,'river_network_shp_name') + # Specify default path if needed + if river_network_path == 'default': + river_network_path = make_default_path('shapefiles/river_network') # outputs a Path() + else: + river_network_path = Path(river_network_path) # make sure a user-specified path is a Path() + + # Find the segment ID + seg_id = read_from_control(controlFile,'river_network_shp_segid') + + ## Load all shapefiles and project to Albers Conformal Conic and reproject + acc = 'ESRI:102008' # Set the target CRS + + bas_albers = gpd.read_file(main/'basin.shp') + xmin, ymin, xmax, ymax = bas_albers.total_bounds + + if plot_rivers: riv_albers = gpd.read_file(main/'river.shp') + if plot_lakes: lak_albers = gpd.read_file(main/'lakes.shp') + + +# Match the accummulated values to the correct HRU IDs in the shapefile +hru_ids_shp = bas_albers[hm_hruid].astype(int) # hru order in shapefile +# Define a list of stat0 values to loop over +if two_stat: + stat_values = [stat, 'amax'] +else: + stat_values = [stat] +for plot_var in plot_vars_computed: + for stat_use in stat_values: + stat0 = stat_use + for m in method_name: + s = summa[m][plot_var].sel(stat=stat0) + if fix_units_soil and 'Soil' in plot_var: + s = s * 3600 * 3.0 # Multiply by time step and depth to get storage + if 'Nrg' in plot_var: + s = s * 1e-3 + + # Make absolute value norm, not all positive + s = np.fabs(s) + + # Replace inf and 9999 values with NaN in the s DataArray + s = s.where(~np.isinf(s), np.nan).where(lambda x: x != 9999, np.nan) + + # Create a new column in the shapefile for each method, and fill it with the statistics + bas_albers[plot_var+m+stat0] = np.nan + hru_ind = [i for i, hru_id in enumerate(hru_ids_shp.values) if hru_id in s.hru.values] # if some missing + bas_albers.loc[hru_ind, plot_var+m+stat0] = s.sel(hru=hru_ids_shp.values[hru_ind]).values + +# Select lakes of a certain size for plotting +if plot_lakes: + minSize = 1000 # km2 + in_domain = (lak_albers['Country'] == 'Canada') | \ + (lak_albers['Country'] == 'United States of America') | \ + (lak_albers['Country'] == 'Mexico') + out_domain = (lak_albers['Pour_long'] > -80) & (lak_albers['Pour_lat'] > 65) # Exclude Baffin Island + large_lakes_albers = lak_albers.loc[(lak_albers['Lake_area'] > minSize) & in_domain & (~out_domain) ] + lake_col = (8/255,81/255,156/255) + + + +# Figure +def run_loop(j,var,the_max,stat,row_fill): + stat0 = stat + + my_cmap = copy.copy(matplotlib.cm.get_cmap('inferno_r')) # copy the default cmap + my_cmap.set_bad(color='white') #nan color white + vmin,vmax = the_max*1e-9, the_max + if any(substring in var for substring in ['VegNrg', 'SnowNrg', 'SoilNrg']): + vmin, vmax = the_max * 1e-9, the_max + if var in ['wallClockTime',]: vmin,vmax = the_max*1e-1, the_max + if fix_units_soil and 'Soil' in var: + vmin = vmin*3600*3.0 # mult by time step and depth to get storage + vmax = vmax*3600*3.0 + if 'Nrg' in var: + vmin = vmin*1e-3 + vmax = vmax*1e-3 + + norm = matplotlib.colors.LogNorm(vmin=vmin, vmax=vmax) + + if stat0 == 'mean': stat_word = 'mean abs balance' + if stat0 == 'amax': stat_word = 'max abs balance' + + for i,m in enumerate(method_name): + if row_fill: + r = i//ncol + base_row + c = i - (r-base_row)*ncol + else: + c = i//nrow + base_row + r = i - (c-base_row)*nrow + # Plot the data with the full extent of the bas_albers shape + bas_albers.plot(ax=axs[r,c], column=var+m+stat0, edgecolor='none', legend=False, cmap=my_cmap, norm=norm,zorder=0) + print(f"{'all HRU mean for '}{var+m+stat0:<35}{np.nanmean(bas_albers[var+m+stat0].values):<10.5f}{' max: '}{np.nanmax(bas_albers[var+m+stat0].values):<10.5f}") + axs[r,c].set_title(plt_name[i]) + axs[r,c].axis('off') + axs[r,c].set_xlim(xmin, xmax) + axs[r,c].set_ylim(ymin, ymax) + + # Custom colorbar + if i==len(method_name)-1: + sm = matplotlib.cm.ScalarMappable(cmap=my_cmap, norm=norm) + sm.set_array([]) + if not row_fill: + axs_list = np.array(axs).T.ravel().tolist() + else: + axs_list = axs.ravel().tolist() + if one_plot: + if not row_fill: + cbr = fig.colorbar(sm, ax=axs_list[c*len(method_name):(c+1)*len(method_name)],aspect=27/1.1*nrow) + else: + cbr = fig.colorbar(sm, ax=axs_list[r*len(method_name):(r+1)*len(method_name)],aspect=27/1.1*nrow) + else: + if not row_fill: + cbr = fig.colorbar(sm, ax=axs_list[c*len(method_name):(c+1)*len(method_name)],aspect=27/1.2*nrow) + else: + cbr = fig.colorbar(sm, ax=axs_list,aspect=27/1.2*nrow) + cbr.ax.set_ylabel(stat_word + ' [{}]'.format(leg_titl[j])) + + # lakes + if plot_lakes: large_lakes_albers.plot(ax=axs[r,c], color=lake_col, zorder=1) + + + +# Specify plotting options +if one_plot: + #use_vars = [1,2,3] + #use_meth = [0,2,4] + use_vars = [3] + use_meth = [0,1,2,3,4,5] +else: + use_vars = [0,1,2,3,4,5,6,7] + use_vars = [3] #[3,8] + use_meth = [0,1,2,3,4,5] +plot_vars = [plot_vars[i] for i in use_vars] +plt_titl = [plt_titl[i] for i in use_vars] +leg_titl = [leg_titl[i] for i in use_vars] +if two_stat: + maxes2 = [maxes2[i] for i in use_vars] +else: + maxes2 = [maxes[i] for i in use_vars] # dummy, not used +maxes = [maxes[i] for i in use_vars] +method_name = [method_name[i] for i in use_meth] + +if one_plot: + if two_stat: + ncol = 2*len(use_vars) + nrow = len(use_meth) + else: + ncol = len(use_meth) + nrow = len(use_vars) + + # Set the font size: we need this to be huge so we can also make our plotting area huge, to avoid a gnarly plotting bug + if 'compressed' in fig_fil: + plt.rcParams.update({'font.size': 33}) + fig,axs = plt.subplots(nrow,ncol,figsize=(15*ncol,13*nrow),constrained_layout=True) + else: + plt.rcParams.update({'font.size': 120}) + fig,axs = plt.subplots(nrow,ncol,figsize=(67*ncol,58*nrow),constrained_layout=True) + + fig.suptitle('hourly statistics', fontsize=40,y=1.05) + plt.rcParams['patch.antialiased'] = False # Prevents an issue with plotting distortion along the 0 degree latitude and longitude lines + +else: + if two_stat: + ncol = 2 + nrow = len(use_meth) + else: + #size hardwired to 2x3 for now + ncol = 3 + nrow = 2 + if len(method_name)>ncol*nrow: + print('Too many methods for '+ nrow + 'x' + ncol + 'plotting') + sys.exit() + plt_name = [f"({chr(97+n)}) {plt_name0[i]}" for n,i in enumerate(use_meth)] + +for i,(var,the_max,the_max2) in enumerate(zip(plot_vars,maxes,maxes2)): + + if one_plot: + # Reset the names + base_row = i + if not two_stat: + plt_name = [f"({chr(97+n+i*len(use_meth))}) {plt_titl[i] + ' ' + plt_name0[j]}" for n,j in enumerate(use_meth)] + else: + base_row = 0 + # Set the font size: we need this to be huge so we can also make our plotting area huge, to avoid a gnarly plotting bug + if 'compressed' in fig_fil: + plt.rcParams.update({'font.size': 33}) + fig,axs = plt.subplots(nrow,ncol,figsize=(15*ncol,13*nrow),constrained_layout=True) + else: + plt.rcParams.update({'font.size': 120}) + fig,axs = plt.subplots(nrow,ncol,figsize=(67*ncol,58*nrow),constrained_layout=True) + + if not two_stat: + # Remove the extra subplots + if len(method_name) < nrow*ncol: + for j in range(len(method_name),nrow*ncol): + r = j//ncol + c = j-r*ncol + fig.delaxes(axs[r, c]) + + fig.suptitle('{} hourly statistics'.format(plt_titl[i]), fontsize=40,y=1.05) + plt.rcParams['patch.antialiased'] = False # Prevents an issue with plotting distortion along the 0 degree latitude and longitude lines + + if two_stat: + row_fill=False + + base_row = base_row*2 + if one_plot: + plt_name = [f"({chr(97+2*n+base_row)}) {plt_titl[i] + ' ' + plt_name0[j]}" for n,j in enumerate(use_meth)] + else: + plt_name = [f"({chr(97+2*n+base_row)}) {plt_name0[j]}" for n,j in enumerate(use_meth)] + run_loop(i,var,the_max,stat, row_fill) + + base_row = base_row+1 + if one_plot: + plt_name = [f"({chr(97+2*n+base_row)}) {plt_titl[i] + ' ' + plt_name0[j]}" for n,j in enumerate(use_meth)] + else: + plt_name = [f"({chr(97+2*n+base_row)}) {plt_name0[j]}" for n,j in enumerate(use_meth)] + stat2 = 'amax' + run_loop(i,var,the_max2,stat2,row_fill) + else: + row_fill=True + run_loop(i,var,the_max,stat,row_fill) + + if not one_plot: + # Save the figure + if not two_stat: + fig_fil1 = (var+fig_fil).format(stat) + else: + fig_fil1 = (var+fig_fil).format(stat+','+stat2) + plt.savefig(viz_dir/fig_fil1, bbox_inches='tight', transparent=True) + +if one_plot: + # Save the figure + if not two_stat: + fig_fil1 = ('all'+fig_fil).format(stat) + else: + fig_fil1 = ('all'+fig_fil).format(stat+','+stat2) + plt.savefig(viz_dir/fig_fil1, bbox_inches='tight', transparent=True) diff --git a/utils/post-processing/readme.md b/utils/post-processing/readme.md new file mode 100644 index 000000000..aab2815e1 --- /dev/null +++ b/utils/post-processing/readme.md @@ -0,0 +1,3 @@ +# post-processing folder +Helpful scripts for a variety of post-processing purposes: +- `check_bit_4_bit_withTol.py`: checks for differences in output files to a tolerance - `concat_groups_split_summa.py`: concatenate the outputs of a split domain summa run into fewer groups - `hist_per_GRU.py`: visualize statistics per GRU as a CDF or histogram - `largest_error_attrib.py`: find GRUs with largest errors - `plot_per_GRUMult.py`: visualize statistics per GRU as a geographical map - `plot_per_GRUMultBal.py`: visualize conservation balances per GRU as a geographical map - `scat_per_GRU.py`: visualize statistics or balances per GRU as a scatter plot or heat plot - `summarize_logs.py`: summarize all SUMMA logs in a folder to see if batch runs finished - `timeseries_to_statistics.py`: loads timeseries of simulated variables and computes a variety of statistics \ No newline at end of file diff --git a/utils/post-processing/scat_per_GRU.py b/utils/post-processing/scat_per_GRU.py new file mode 100644 index 000000000..f5537869b --- /dev/null +++ b/utils/post-processing/scat_per_GRU.py @@ -0,0 +1,616 @@ +# written by A. Van Beusekom (2023) + +## Visualize statistics per GRU +## Needs: +# SUMMA output statistics + +## Special note +# SUMMA simulations have been preprocessed into single value statistics per model element, using auxiliary scripts in ~/utils +# Run: +# python scat_per_GRU.py [stat] +# where stat is rmse or maxe or kgem + +# modules +import os +import matplotlib +import numpy as np +import xarray as xr +from pathlib import Path +import matplotlib.pyplot as plt +import copy +import pandas as pd +from matplotlib.colors import LogNorm +from matplotlib.colors import ListedColormap + +do_rel = False # true is plot relative to the benchmark simulation +do_heat = False # true is plot heatmaps instead of scatterplots +run_local = True # true is run on local machine, false is run on cluster +inferno_col= True # Set to True if want to match geographic plots, False if want rainbow colormap (does not matter if do_heat is False) +fixed_Mass_units = False # true is convert mass balance units to kg m-2 s-1, if ran new code with depth in calculation + +# which statistics to plot, can do both +do_vars = False +do_balance = True + +if run_local: + stat = 'mnnz' + viz_dir = Path('/Users/amedin/Research/USask/test_py/statistics_en') +else: + import sys + stat = sys.argv[1] + viz_dir = Path('/home/avanb/scratch/statistics') + + +#method_name=['be1','sundials_1en4','be4','be8','be16','be32','sundials_1en6'] +#plt_name=['BE1','IDAe-4','BE4','BE8','BE16','BE32','IDAe-6'] +method_name=['be1','be16','be32','sundials_1en6'] +plt_name=['BE1','BE16','BE32','SUNDIALS'] +method_name=['be1','be1cm','be1en','sundials_1en6cm','sundials_1en6en'] +plt_name=['BE1 common','BE1 temp','BE1 mixed','SUNDIALS temp','SUNDIALS enth'] +method_name2=method_name+['sundials_1en8cm'] +plt_name2=plt_name+['reference solution'] + +if inferno_col: + custom_cmap = copy.copy(matplotlib.cm.get_cmap('inferno_r')) # copy the default cmap + custom_cmap.set_bad(color='white') #nan color white +else: # use rainbow colormap, I think looks better + rainbow_cmap = plt.cm.get_cmap('rainbow', 256) # Get the rainbow colormap + rainbow_colors = rainbow_cmap(np.linspace(0, 1, 256)) + rainbow_colors_with_white = np.vstack((rainbow_colors, [1, 1, 1, 1])) + custom_cmap = ListedColormap(rainbow_colors_with_white, name='rainbow_white') + custom_cmap.set_under('white') # Ensure that values under the lower bound are white + +if stat == 'kgem': do_rel = False # don't plot relative to the benchmark simulation for KGE + +# Simulation statistics file locations +settings= ['scalarSWE','scalarTotalSoilWat','scalarTotalET','scalarCanopyWat','averageRoutedRunoff','wallClockTime'] +viz_fil = method_name.copy() +viz_fl2 = method_name2.copy() +for i, m in enumerate(method_name): + viz_fil[i] = m + '_hrly_diff_stats_{}.nc' + viz_fil[i] = viz_fil[i].format(','.join(settings)) +for i, m in enumerate(method_name2): + viz_fl2[i] = m + '_hrly_diff_bals_{}.nc' + viz_fl2[i] = viz_fl2[i].format(','.join(['balance'])) + +summa = {} +summa1 = {} +if do_vars: + for i, m in enumerate(method_name): + # Get the aggregated statistics of SUMMA simulations + summa[m] = xr.open_dataset(viz_dir/viz_fil[i]) + hru_size = summa[m].sizes['hru'] +if do_balance: + for i, m in enumerate(method_name2): + summa1[m] = xr.open_dataset(viz_dir/viz_fl2[i]) + hru_size = summa1[m].sizes['hru'] + +numbin = int(np.sqrt(hru_size/10)) +maxcolor = numbin**2/75 +do_clip = True # choose if want the heat values clipped (True) or plotted as white if over maxcolor (False) + +def run_loop(i,var,lx,ly,plt_t,leg_t,leg_t0,leg_tm,rep,mx): + r = i//ncol + c = i-r*ncol + global method_name # Declare method_name as global to modify its global value + global plt_name # Declare plt_name as global to modify its global value + method_name = np.copy(method_name0) + plt_name = np.copy(plt_name0) + + if stat == 'rmse' or stat == 'kgem': + stat0 = 'mean' + stat0_word = 'mean' + statr = 'mean_ben' + stat_word = 'RMSE' + if stat == 'kgem': stat_word = 'KGE"' + + if stat == 'rmnz': + stat0 = 'mnnz' + stat0_word = 'mean' # no 0s' + statr = 'mnnz_ben' + stat_word = 'RMSE' # no 0s' + + if stat == 'maxe': + stat0 = 'amax' + stat0_word = 'max' + statr = 'amax_ben' + stat_word = 'max abs error' + + if stat == 'mnnz': + stat0 = 'mnnz_ben' + stat0_word = 'mean - mean reference' # no 0s' + statr = 'mnnz_ben' + stat_word = 'mean' # no 0s' + + if stat == 'mean': + stat0 = 'mean_ben' + stat0_word = 'mean - mean reference' # no 0s' + statr = 'mean_ben' + stat_word = 'mean' # no 0s' + + if stat == 'amax': + stat0 = 'amax_ben' + stat0_word = 'max abs - max abs reference' + statr = 'amax_ben' + stat_word = 'max abs error' + + # Data + if do_rel: s_rel = summa[method_name[0]][var].sel(stat=statr) + # make the axes the same + do_same = False + if do_heat and len(method_name)>1: + do_same = True + mxx = 0.0 + mnx = 1.0 + for m in method_name: + # Get the statistics, remove 9999 (should be nan, but just in case) + s0 = summa[m][var].sel(stat=stat).where(lambda x: x != 9999) + if do_rel: s0=s0/s_rel + if stat=='mnnz' or stat=='mean' or stat=='amax': + s = s0 + else: + s = np.fabs(s0) + mxx = max(s.max(),mxx) + mnx = min(s.min(),mnx) + mxy = 0.0 + mny = 1.0 + for m in method_name: + # Get the statistics, remove 9999 (should be nan, but just in case) + s0 = summa[m][var].sel(stat=[stat,stat0]).where(lambda x: x != 9999) + if stat=='mnnz' or stat=='mean' or stat=='amax': + s = s0.sel(stat=stat) - s0.sel(stat=stat0) + else: + s = s0.sel(stat=stat0) + mxy = max(s.max(),mxy) + mny = min(s.min(),mny) + method_name = [method_name0[rep]] + plt_name = [plt_name0[rep]] + else: # only one method + mxx = 0.0 + mnx = 1.0 + mxy = 0.0 + mny = 1.0 + for j, m in enumerate(method_name): + s = summa[m][var].sel(stat=[stat,stat0]) + if var == 'scalarTotalET': + if stat =='rmse' or stat =='rmnz' or stat=='mnnz' or stat=='mean': + s = s*31557600 # make annual total + if do_rel: + s_rel = s_rel*31557600 + else: + mnx = mnx*31557600 + mxx = mxx*31557600 + mny = mny*31557600 + mxy = mxy*31557600 + if stat =='maxe' or stat=='amax': + s = s*3600 # make hourly max + if do_rel: + s_rel = s_rel*3600 + else: + mnx = mnx*3600 + mxx = mxx*3600 + mny = mny*3600 + mxy = mxy*3600 + if var == 'averageRoutedRunoff': + if stat =='rmse' or stat =='rmnz' or stat=='mnnz'or stat=='mean': + s = s*31557600*1000 # make annual total + if do_rel: + s_rel = s_rel*31557600*1000 + else: + mnx = mnx*31557600*1000 + mxx = mxx*31557600*1000 + mny = mny*31557600*1000 + mxy = mxy*31557600*1000 + if stat =='maxe' or stat=='amax': + s = s*3600*1000 # make hourly max + if do_rel: + s_rel = s_rel*3600*1000 + else: + mnx = mnx*3600*1000 + mxx = mxx*3600*1000 + mny = mny*3600*1000 + mxy = mxy*3600*1000 + if stat == 'maxe': s.loc[dict(stat='maxe')] = np.fabs(s.loc[dict(stat='maxe')]) # make absolute value norm + + if do_rel and var != 'wallClockTime': + s.loc[dict(stat=stat)] = s.loc[dict(stat=stat)]/s_rel + stat_word = 'relative '+ stat_word + + if do_heat: + x_points = [] + y_points = [] + if stat=='mnnz' or stat=='mean' or stat=='amax': + x = s.sel(stat=stat).values + y = s.sel(stat=stat).values-s.sel(stat=stat0).values + else: + x = np.fabs(s.sel(stat=stat).values) + y = s.sel(stat=stat0).values + if lx: + x = np.where(x > 0, np.log10(x), np.nan) + mnx = np.log10(np.where(mnx <= 0, 1e-30, mnx)) + mxx = np.log10(np.where(mxx <= 0, 1e-30, mxx)) + if ly: + if stat!='mnnz' and stat!='mean': + if var == 'scalarTotalET': + y = np.where(-y > 0, np.log10(-y), np.nan) + mny = np.log10(np.where(-mny <= 0, 1e-30, -mny)) + mxy = np.log10(np.where(-mxy <= 0, 1e-30, -mxy)) + else: + y = np.where(y > 0, np.log10(y), np.nan) + mny = np.log10(np.where(mny <= 0, 1e-30, mny)) + mxy = np.log10(np.where(mxy <= 0, 1e-30, mxy)) + x_points.extend(x) + y_points.extend(y) + x_points = np.array(x_points) # Convert lists to numpy arrays + y_points = np.array(y_points) + + # Ensure no NaNs or infs before proceeding + is_valid = ~np.isnan(x_points) & ~np.isnan(y_points) & ~np.isinf(x_points) & ~np.isinf(y_points) + x_points = x_points[is_valid] + y_points = y_points[is_valid] + if not is_valid.any(): + print('no valid values') + continue + + # Define the bins for the histogram and calculate + if not do_same: + mnx = x_points.min() + mxx = x_points.max() + mny = y_points.min() + mxy = y_points.max() + else: + if mx: + mnx = 0.0 + mxx = mx + x_edges = np.linspace(mnx,mxx, num=numbin) + y_edges = np.linspace(mny,mxy, num=numbin) + zi, _, _ = np.histogram2d(x_points, y_points, bins=[x_edges, y_edges]) + zi = zi.T # Transpose the histogram to match the pcolormesh orientation + if do_clip: + zi_clipped = np.where(zi > 0.95*maxcolor, 0.95*maxcolor, zi) # Clip zi.T so that max values are maxcolor with a little buffer + else: + zi_clipped = zi # don't clip + + # Calculate bin centers from edges for X and Y + x_centers = (x_edges[:-1] + x_edges[1:]) / 2 + y_centers = (y_edges[:-1] + y_edges[1:]) / 2 + X, Y = np.meshgrid(x_centers, y_centers) + if lx: X = 10**X + if ly: + if stat!='mnnz' and stat!='mean': + if var == 'scalarTotalET': + Y = -10**Y + else: + Y = 10**Y + + # Adjust the pcolormesh call to use the centers and compatible shading + norm = LogNorm(vmin=1, vmax=maxcolor) + mesh = axs[r, c].pcolormesh(X, Y, zi_clipped, shading='gouraud', cmap=custom_cmap, zorder=0,norm=norm) + if r==1 and c==len(method_name)-1: fig.colorbar(mesh, ax=axs.ravel().tolist(), label='GRU count',aspect=20/3*nrow) + + elif not do_heat: + if stat=='mnnz' or stat=='mean' or stat=='amax': + axs[r,c].scatter(x=s.sel(stat=stat).values,y=s.sel(stat=stat).values-s.sel(stat=stat0).values,s=1,zorder=0,label=m) + else: + axs[r,c].scatter(x=np.fabs(s.sel(stat=stat).values),y=s.sel(stat=stat0).values,s=1,zorder=0,label=m) + + if do_heat: + axs[r,c].set_title(plt_t + ' '+ plt_name[0] + ' heatmap') + elif not(do_heat): + lgnd = axs[r,c].legend(plt_name) + for j, m in enumerate(plt_name): + lgnd.legendHandles[j]._sizes = [80] + axs[r,c].set_title(plt_t) + if lx: axs[r,c].set_xscale('log') + if ly: axs[r,c].set_yscale('log') + if do_rel: + axs[r,c].set_xlabel(stat_word) + else: + if stat == 'rmse' or stat == 'rmnz' or stat=='mnnz' or stat=='mean': + axs[r,c].set_xlabel(stat_word + ' [{}]'.format(leg_t)) + if stat == 'maxe' or stat=='amax': + axs[r,c].set_xlabel(stat_word + ' [{}]'.format(leg_tm)) + if stat == 'kgem': axs[r,c].set_xlabel(stat_word) + axs[r,c].set_ylabel(stat0_word + ' [{}]'.format(leg_t0)) + if do_heat and c>0: axs[r, c].set_ylabel('') + +def run_loopb(i,var,comp,lx,ly,leg_t,leg_t0,plt_t,repy): + r = i//ncol + c = i-r*ncol + global method_name2 # Declare method_name as global to modify its global value + global plt_name2 # Declare plt_name as global to modify its global value + method_name2 = np.copy(method_name20) + plt_name2 = np.copy(plt_name20) + + if stat == 'rmse' or stat == 'kgem' or stat == 'mean': + stat0 = 'mean' + wordx = ' mean' + if stat == 'rmnz' or stat == 'mnnz': + stat0 = 'mean' + wordx = ' mean' # no 0s' + if stat == 'maxe': + stat0 = 'amax' + wordx = ' max' + wordy = wordx + + # Data + do_same = False + if do_heat and len(method_name2)>1: + if len(method_name2)>1: + do_same = True + mxx = 0.0 + mnx = 1.0 + for m in method_name2: + # Get the statistics, remove 9999 (should be nan, but just in case) + s = summa1[m][var].sel(stat=stat0).where(lambda x: x != 9999) + mxx = max(s.max(),mxx) + mnx = min(s.min(),mnx) + mxy = 0.0 + mny = 1.0 + for m in method_name2: + # Get the statistics, remove 9999 (should be nan, but just in case) + s = summa1[m][comp].sel(stat=stat0).where(lambda x: x != 9999) + mxy = max(s.max(),mxy) + mny = min(s.min(),mny) + method_name2 = [method_name20[rep]] + plt_name2 = [plt_name20[rep]] + else: # only one method + mxx = 0.0 + mnx = 1.0 + mxy = 0.0 + mny = 1.0 + for j, m in enumerate(method_name2): + # Get the statistics, remove 9999 (should be nan, but just in case) + s = np.fabs(summa1[m][var].sel(stat=stat0)).where(lambda x: x != 9999, np.nan) + s0 = np.fabs(summa1[m][comp].sel(stat=stat0)).where(lambda x: x != 9999, np.nan) + if fixed_Mass_units and 'Mass' in comp: s0 = s0/1000 # / density for mass balance + + if do_heat: + x_points = [] + y_points = [] + x = s.values + y = s0.values + if lx: + x = np.where(x > 0, np.log10(x), np.nan) + mxx = np.log10(np.where(mxx <= 0, 1e-30, mxx)) + mnx = np.log10(np.where(mnx <= 0, 1e-30, mnx)) + if ly: + y = np.where(y > 0, np.log10(y), np.nan) + mxy = np.log10(np.where(mxy <= 0, 1e-30, mxy)) + mny = np.log10(np.where(mny <= 0, 1e-30, mny)) + x_points.extend(x) + y_points.extend(y) + x_points = np.array(x_points) # Convert lists to numpy arrays + y_points = np.array(y_points) + + # Ensure no NaNs or infs before proceeding + is_valid = ~np.isnan(x_points) & ~np.isnan(y_points) & ~np.isinf(x_points) & ~np.isinf(y_points) + x_points = x_points[is_valid] + y_points = y_points[is_valid] + + # Define the bins for the histogram and calculate + if not do_same: + mnx = x_points.min() + mxx = x_points.max() + mny = y_points.min() + mxy = y_points.max() + x_edges = np.linspace(mnx,mxx, num=numbin) + y_edges = np.linspace(mny,mxy, num=numbin) + zi, _, _ = np.histogram2d(x_points, y_points, bins=[x_edges, y_edges]) + zi = zi.T # Transpose the histogram to match the pcolormesh orientation + if do_clip: + zi_clipped = np.where(zi > 0.95*maxcolor, 0.95*maxcolor, zi) # Clip zi.T so that max values are maxcolor with a little buffer + else: + zi_clipped = zi # don't clip + # Calculate bin centers from edges for X and Y + x_centers = (x_edges[:-1] + x_edges[1:]) / 2 + y_centers = (y_edges[:-1] + y_edges[1:]) / 2 + X, Y = np.meshgrid(x_centers, y_centers) + if lx: X = 10**X + if ly: Y = 10**Y + + # Adjust the pcolormesh call to use the centers and compatible shading + norm = LogNorm(vmin=1, vmax=maxcolor) + mesh = axs[r, c].pcolormesh(X, Y, zi_clipped, shading='gouraud', cmap=custom_cmap, zorder=0,norm=norm) + if r==1 and c==len(method_name2)-1: fig.colorbar(mesh, ax=axs.ravel().tolist(), label='GRU count',aspect=20/3*nrow) + elif not do_heat: + axs[r,c].scatter(x=s.values,y=s0.values,s=10,zorder=0,label=m) + + if comp == 'numberFluxCalc': + stat0_word = 'number flux calculations' + stat_word = 'wall clock time' + else: + stat0_word = 'balance abs value' + stat_word = 'balance abs value' + + if do_heat: + axs[r,c].set_title(plt_t + ' '+ plt_name[0] + ' heatmap') + elif not(do_heat): + lgnd = axs[r,c].legend(plt_name2) + for j, m in enumerate(plt_name2): + lgnd.legendHandles[j]._sizes = [80] + axs[r,c].set_title(plt_t) + if lx: axs[r,c].set_xscale('log') + if ly: axs[r,c].set_yscale('log') + axs[r,c].set_xlabel(stat_word + wordx + ' [{}]'.format(leg_t)) + axs[r,c].set_ylabel(stat0_word + wordy + ' [{}]'.format(leg_t0)) + if do_heat and c>0: axs[r, c].set_ylabel('') + +plt.rcParams['xtick.color'] = 'black' +plt.rcParams['xtick.major.width'] = 2 +plt.rcParams['ytick.color'] = 'black' +plt.rcParams['ytick.major.width'] = 2 +if do_vars: + # Specify variables of interest + if do_heat: + use_vars = [0,1,2,3,4] + use_meth = [0,2] + logx = np.zeros(len(use_vars)) # no log scale x axis + logy = np.zeros(len(use_vars)) # log scale y axis + else: + use_vars = [0,1,2,3,4] + use_meth = [0,1,2,3] + logx = np.ones(len(use_vars)) # log scale x axis + logy = np.ones(len(use_vars)) # log scale y axis + + rep = np.zeros(len(use_vars)) + if do_heat: + use_vars = [val for val in use_vars for _ in range(len(use_meth))] + logy = [val for val in logy for _ in range(len(use_meth))] + logx = [val for val in logx for _ in range(len(use_meth))] + rep = [int(val+_) for val in rep for _ in range(len(use_meth))] + + plot_vars = settings + plt_titl = ['snow water equivalent','total soil water content','total evapotranspiration', 'total water on the vegetation canopy','average routed runoff'] + leg_titl = ['$kg~m^{-2}$', '$kg~m^{-2}$','$mm~y^{-1}$','$kg~m^{-2}$','$mm~y^{-1}$','$mm~y^{-1}$'] + leg_titl0 = ['$kg~m^{-2}$', '$kg~m^{-2}$','$mm~y^{-1}$','$kg~m^{-2}$','$mm~y^{-1}$','$mm~y^{-1}$'] + leg_titlm= ['$kg~m^{-2}$', '$kg~m^{-2}$','$mm~h^{-1}$','$kg~m^{-2}$','$mm~h^{-1}$','$mm~h^{-1}$'] + + #to zoom the heat x axis set these + maxes = [0.0,0.0,0.0,0.0,0.0,0.0] #initialize + if stat == 'rmse' or stat=='rmnz': + maxes = [60,15,250,0.5,200,20e-3] + if do_rel: maxes = [0.6,0.02,0.6,0.3,0.6,20e-3] + if stat == 'maxe': + maxes = [60,20,250,0.5,200,2.0] + if do_rel: maxesx = [0.6,0.02,0.6,0.3,0.6,2.0] + if stat == 'kgem': + maxes = [0.9,0.9,0.9,0.9,0.9,20e-3] + #maxes = [0.0,0.0,0.0,0.0,0.0,0.0] # turn off zoom + + plot_vars = [plot_vars[i] for i in use_vars] + plt_titl = [f"({chr(97+n)}) {plt_titl[i]}" for n,i in enumerate(use_vars)] + leg_titl = [leg_titl[i] for i in use_vars] + leg_titl0 = [leg_titl0[i] for i in use_vars] + leg_titlm = [leg_titlm[i] for i in use_vars] + maxes = [maxes[i] for i in use_vars] + + method_name = [method_name[i] for i in use_meth] + plt_name = [plt_name[i] for i in use_meth] + method_name0 = np.copy(method_name) + plt_name0 = np.copy(plt_name) + + if do_heat: + ncol = len(use_meth) + nrow = len(plot_vars)//ncol + else: + ncol = 2 + nrow = len(plot_vars)//ncol + 1 + + fig_fil = 'Hrly_diff_scat_{}_{}' + if do_rel: fig_fil = fig_fil + '_rel' + if do_heat: + fig_fil = '{}'+fig_fil + '_heat' + if sum(maxes)>0: fig_fil = fig_fil + '_zoom' + fig_fil = fig_fil.format(','.join(method_name),','.join(plot_vars),stat) + else: + fig_fil = fig_fil.format(','.join(plot_vars),stat) + fig_fil = fig_fil + '_compressed.png' + + if 'compressed' in fig_fil: + if do_heat: + plt.rcParams.update({'font.size': 33}) + else: + plt.rcParams.update({'font.size': 27}) + fig,axs = plt.subplots(nrow,ncol,figsize=(17*ncol,13*nrow),constrained_layout=do_heat) + else: + if do_heat: + plt.rcParams.update({'font.size': 120}) + else: + plt.rcParams.update({'font.size': 100}) + if not do_heat: fig.subplots_adjust(hspace=0.33, wspace=0.17) # Adjust the bottom margin, vertical space, and horizontal space + + for i,(var,lx,ly,plt_t,leg_t,leg_t0,leg_tm,rep,mx) in enumerate(zip(plot_vars,logx,logy,plt_titl,leg_titl,leg_titl0,leg_titlm,rep,maxes)): + run_loop(i,var,lx,ly,plt_t,leg_t,leg_t0,leg_tm,rep,mx) + + # Remove the extra subplots + if not do_heat and (len(plot_vars)) < nrow*ncol: + for i in range(len(plot_vars),nrow*ncol): + r = i//ncol + c = i-r*ncol + fig.delaxes(axs[r, c]) + + # Save + plt.savefig(viz_dir/fig_fil, bbox_inches='tight', transparent=False) + + +if do_balance: + + # Specify variables of interest + if do_heat: + use_vars = [0,1,2] + use_meth = [0,1,3] + logx = np.ones(len(use_vars)) # log scale x axis + logy = np.ones(len(use_vars)) # log scale y axis + else: + use_vars = [0,1,2,3] + use_meth = [0,1,2,3,4,5] + logx = np.zeros(len(use_vars)) # no log scale x axis + logx = np.ones(len(use_vars)) # log scale x axis + logy = np.ones(len(use_vars)) # log scale y axis + + rep = np.zeros(len(use_vars)) + if do_heat: + use_vars = [val for val in use_vars for _ in range(len(use_meth))] + logy = [val for val in logy for _ in range(len(use_meth))] + logx = [val for val in logx for _ in range(len(use_meth))] + rep = [int(val+_) for val in rep for _ in range(len(use_meth))] + + plot_vars = ['balanceVegNrg','balanceSnowNrg','balanceSoilNrg','balanceCasNrg','wallClockTime'] + comp_vars = ['balanceVegMass','balanceSnowMass','balanceSoilMass','balanceAqMass','numberFluxCalc'] + plt_titl = ['vegetation balance','snow balance','soil balance', 'canopy air space and aquifer balance', 'wall clock time'] + leg_titl = ['$W~m^{-3}$'] * 4 + ['$s$'] + leg_titl0 =['$kg~m^{-3}~s^{-1}$'] * 4 + ['$num$'] + if fixed_Mass_units: leg_titl0 = ['s^{-1}$'] * 3 + ['m~s^{-1}$'] + ['$num$'] + + plot_vars = [plot_vars[i] for i in use_vars] + comp_vars = [comp_vars[i] for i in use_vars] + plt_titl = [f"({chr(97+n)}) {plt_titl[i]}" for n,i in enumerate(use_vars)] + leg_titl = [leg_titl[i] for i in use_vars] + leg_titl0 = [leg_titl0[i] for i in use_vars] + method_name2 = [method_name2[i] for i in use_meth] + plt_name2 = [plt_name2[i] for i in use_meth] + + method_name20 = np.copy(method_name2) + plt_name20 = np.copy(plt_name2) + + if do_heat: + ncol = len(use_meth) + nrow = len(plot_vars)//ncol + else: + ncol = 2 + nrow = len(plot_vars)//ncol + 1 + + fig_fil = 'Hrly_balance_scat_{}' + if do_heat: + fig_fil = '{}'+fig_fil + '_heat' + fig_fil = fig_fil.format(','.join(method_name2),','.join(plot_vars),stat) + else: + fig_fil = fig_fil.format(','.join(plot_vars),stat) + fig_fil = fig_fil + '_compressed.png' + + if 'compressed' in fig_fil: + if do_heat: + plt.rcParams.update({'font.size': 33}) + else: + plt.rcParams.update({'font.size': 27}) + fig,axs = plt.subplots(nrow,ncol,figsize=(17*ncol,13*nrow),constrained_layout=do_heat) + else: + if do_heat: + plt.rcParams.update({'font.size': 120}) + else: + plt.rcParams.update({'font.size': 100}) + fig,axs = plt.subplots(nrow,ncol,figsize=(70*ncol,54*nrow),constrained_layout=do_heat) + if not do_heat: fig.subplots_adjust(hspace=0.33, wspace=0.17) # Adjust the bottom margin, vertical space, and horizontal space + + for i,(var,comp,lx,ly,leg_t,leg_t0,plt_t,rep) in enumerate(zip(plot_vars,comp_vars,logx,logy,leg_titl,leg_titl0,plt_titl,rep)): + run_loopb(i,var,comp,lx,ly,leg_t,leg_t0,plt_t,rep) + + # Remove the extra subplots + if not do_heat and (len(plot_vars)) < nrow*ncol: + for i in range(len(plot_vars),nrow*ncol): + r = i//ncol + c = i-r*ncol + fig.delaxes(axs[r, c]) + # Save + plt.savefig(viz_dir/fig_fil, bbox_inches='tight', transparent=False) diff --git a/utils/post-processing/summarize_logs.py b/utils/post-processing/summarize_logs.py new file mode 100644 index 000000000..5ec62d657 --- /dev/null +++ b/utils/post-processing/summarize_logs.py @@ -0,0 +1,197 @@ +'''Summarize all SUMMA logs in a folder. Assumes all .txt files in folder are SUMMA logs. +Summary file is placed inside the log folder. Specifying a summary file name is optional. +Usage: python summarize_logs.py [log_folder] [name_of_summary_file.txt] [log file extension]''' + +# Modules +import os +import re +import sys +import statistics as sts + +# ---------------------- +# Set defaults +summaryFile = '_log_summary.txt' # default, placed at the top of the log folder +ext = '.txt' + +# Handle input arguments +if len(sys.argv) == 1: # sys.argv only contains the script name + sys.exit('Error: no input folder specified') + +else: # at least 2 elements in sys.argv; len(sys.argv) cannot be zero or we wouldn't be in this script + + # The first input argument specifies the folder where the log files are + folder = sys.argv[1] # sys.argv values are strings by default so this is fine + + # Check if there are more arguments + if len(sys.argv) == 3: + + # Assume the second argument is the name for the log file + summaryFile = sys.argv[2] # string + + # No extra argument so no summary file name is specified + elif len(sys.argv) == 4: + + # Assume the second argument is the name for the log file and the third is the file extension + summaryFile = sys.argv[2] # string + ext = sys.argv[3] # string + +# End of input arguments +# ---------------------- + +# ------------- +# Sub functions + +# Define a function to grab the last line in a file +# See: https://stackoverflow.com/questions/136168/get-last-n-lines-of-a-file-similar-to-tail +def tail(folder, file, lines=1, _buffer=4098): + + """Tail a file and get X lines from the end""" + + # open the file + with open(folder + '/' + file,'r') as f: + + # place holder for the lines found + lines_found = [] + + # block counter will be multiplied by buffer to get the block size from the end + block_counter = -1 + + # loop until we find X lines + while len(lines_found) < lines: + try: + f.seek(block_counter * _buffer, os.SEEK_END) + except IOError: # either file is too small, or too many lines requested + f.seek(0) + lines_found = f.readlines() + break + + lines_found = f.readlines() + + # decrement the block counter to get the next X bytes + block_counter -= 1 + + return lines_found[-lines:] + +# Define a function to handle the three types of log results: success, SUMMA error, non-SUMMA error +def determine_output(folder,file,nLines=2): + + # initialize outputs + success, summa, other = [0,0,0] # error flags + time = -1 # times are only extracted for successful simulations - a default negative time allows filtering outside this function + + # get the file contents + log_txt = tail(folder,file,nLines) + + # loop over the lines in the log text to find what happened + msg = 'no line read' # initialize output + for line in log_txt: + + # determine if the log contains a SUMMA statement + if 'successfully' in line: + + # determine time taken + more_lines = tail(folder,file,6) # extracting bottom 6 lines includes time in [h] + time = float(re.sub("[^\d\.]", "", more_lines[0])) # hours should be in top entry; store as float + + # process output flags + success = 1 + msg = 'success after ' + '{:.2f}'.format(time) + ' h \n' # message string + return success, summa, other, msg, time # we know what happened, stop function call + + elif 'FATAL ERROR' in line: + summa = 1 + msg = line + return success, summa, other, msg, time # we know what happened, stop function call + + # if we reach this, no SUMMA termination statement was found + other = 1 + msg = 'check SLURM logs - simulation terminated early at: ' + line + + return success, summa, other, msg, time + +# End of sub functions +# -------------------- + +# ------------------- +# Start of processing + +# Remove the summar file if it exists +try: + os.remove(folder + '/' + summaryFile) +except OSError: + pass + +# Find the .txt files in the folder +files = [] +for file in os.listdir(folder): + #if file.endswith(".txt"): + if file.endswith(ext): + files.append(file) + +# Sort the list +files.sort() + +# Initialize case counters +total_success, total_summa, total_other = [0,0,0] + +# Initialize time list +computation_time = [] + +# Open the summary file +with open(folder + '/' + summaryFile, 'w') as sf: + + # Add a header + sf.write('Summarizing log files in ' + folder + '\n \n') + sf.write('Log files' + '\n') + + # Loop over the log files + for file in files: + + size = os.path.getsize(folder + '/' + file) + if (size==0): continue + + # Find the result contained in each log file + success, summa, other, msg, time = determine_output(folder,file) # default of using last 2 lines should suffice to catch all success/error cases + + # Increment the counters + total_success += success + total_summa += summa + total_other += other + + # Save the computation time (time == -1 if error encountered) + computation_time.append(time) + + # Add the file name and error message to the summary file + sf.write(file + '\t' + msg) + + # Calculate percentages + total = total_success + total_summa + total_other + pct_success = total_success / total * 100 + pct_summa = total_summa / total * 100 + pct_other = total_other / total * 100 + + # Calculate computation time stats + computation_time = [time for time in computation_time if time >= 0] # remove negative times that are associated with simulations that return an error + st_min = min(computation_time) + st_max = max(computation_time) + st_mean = sts.mean(computation_time) + st_median = sts.median(computation_time) + + # add a statistical summary + sf.write('\nSuccess stats' + '\n') + sf.write('Success' + '\t \t \t \t {:.2f}% \n'.format(pct_success)) + sf.write('SUMMA error' + '\t \t \t {:.2f}% \n'.format(pct_summa)) + sf.write('Early termination' + '\t {:.2f}% \n'.format(pct_other)) + sf.write('\nTime needed for successful computations' + '\n') + sf.write('Min time ' + '\t \t \t {:.2f} h \n'.format(st_min)) + sf.write('Median time ' + '\t \t {:.2f} h \n'.format(st_median)) + sf.write('Mean time ' + '\t \t \t {:.2f} h \n'.format(st_mean)) + sf.write('Max time ' + '\t \t \t {:.2f} h \n'.format(st_max)) + + + #sf.write('Min time ' + '\t \t \t \t' + str(min(computation_time)) +'h \n') + #sf.write('Median time ' + '\t \t \t' + str(sts.median(computation_time)) +'h \n') + #sf.write('Mean time ' + '\t \t \t \t' + str(sts.mean(computation_time)) +'h \n') + #sf.write('Max time ' + '\t \t \t \t' + str(max(computation_time)) +'h \n') +# done, summary file is closed +# ---------------------------- diff --git a/utils/post-processing/timeseries_to_statistics.py b/utils/post-processing/timeseries_to_statistics.py new file mode 100644 index 000000000..4c5b44a69 --- /dev/null +++ b/utils/post-processing/timeseries_to_statistics.py @@ -0,0 +1,405 @@ +'''Loads timeseries of simulated variables and computes a variety of statistics.''' + +# This script analyzes the resulting files and summarizes the timeseries of a (set of) variable(s) into a statistical value. +# Currently implemented are finding the maximum and mean value across the entire time series. +# Outputs are stored in a single file that covers the full spatial extent of the domain. +# written originally by W. Knoben, modified by A. Van Beusekom (2023) +# Best to comment out parallel processing lines and run that way on Graham or for full dataset + +# Uses modified KGEm calculation avoids the amplified values when mean is small +# and avoids the KGE value dependence on the units of measurement (as discussed by Santos et al. 2018; Clark et al. 2021). +# The KGEm values range from -∞ to 1, with 1 being a perfect match with the benchmark results. +# Similar to Beck et al.(2020), we scaled KGEm values to avoid the heavy influence of large negative values. +# This results in KGE values that range between -1 and 1, with lower KGE values indicating larger differences from bench. + +# Run: +# python timeseries_to_statistics.py sundials_1en6 [1-101] 100 +# and run 100 times with different batch numbers 1-100, and then merge the files with 101 + +import os +import glob +import xarray as xr +from pathlib import Path +import numpy as np + +import warnings +warnings.simplefilter("ignore") #deal with correlation warnings from variance 0 in kgem, both have no snow + +# Settings +bench_name = 'sundials_1en8cm' + +not_parallel = True # run as true with batch mode, or false, with `python timeseries_to_statistics.py sundials_1en6 1 1` for single batch, and `python timeseries_to_statistics.py sundials_1en6 2 1` to merge +run_local = False + +# which statistics to compute +do_vars = False +do_steps = False +do_balance = True +do_wall = False + +if run_local: + not_parallel = True + method_name ='be1en' + ibatch = 1 # Run as 1, 2, and then 3 to fully test + nbatch = 2 + top_fold = '/Users/amedin/Research/USask/test_py/' +else: + import sys + # The first input argument specifies the run where the files are + method_name = sys.argv[1] # sys.argv values are strings by default so this is fine (sundials_1en6 or be1) + ibatch = int(sys.argv[2]) + nbatch = int(sys.argv[3]) + top_fold = '/home/avanb/scratch/' + +des_dir = top_fold + 'statistics_temp_' + method_name +# Check if the directory exists +if not os.path.exists(des_dir): + # If not, create the directory + os.mkdir(des_dir) + +fnl_dir = top_fold + 'statistics' +src_dir = top_fold + 'summa-' + method_name +ben_dir = top_fold + 'summa-' + bench_name +src_pat = 'run1_G*_timestep.nc' +des_fil = method_name + '_hrly_diff_stats_{}_{}.nc' +des_fl2 = method_name + '_hrly_diff_steps_{}_{}.nc' +des_fl3 = method_name + '_hrly_diff_bals_{}_{}.nc' +des_fl4 = method_name + '_hrly_diff_wall_{}_{}.nc' +settings= ['scalarSWE','scalarTotalSoilWat','scalarTotalET','scalarCanopyWat','averageRoutedRunoff','wallClockTime'] +stepsets= ['numberStateSplit','numberDomainSplitNrg','numberDomainSplitMass','numberScalarSolutions','meanStepSize'] +balssets= ['balanceCasNrg','balanceVegNrg','balanceSnowNrg','balanceSoilNrg','balanceVegMass','balanceSnowMass','balanceSoilMass','balanceAqMass','wallClockTime', 'numberFluxCalc'] +#balssets= ['scalarRainPlusMelt','scalarRootZoneTemp','airtemp','scalarSWE'] +wallsets= ['wallClockTime'] + +viz_fil = method_name + '_hrly_diff_stats_{}.nc' +viz_fil = viz_fil.format(','.join(settings)) +viz_fl2 = method_name + '_hrly_diff_steps_{}.nc' +viz_fl2 = viz_fl2.format(','.join(stepsets)) +viz_fl3 = method_name + '_hrly_diff_bals_{}.nc' +viz_fl3 = viz_fl3.format(','.join(['balance'])) +viz_fl4 = method_name + '_hrly_diff_wals_{}.nc' +viz_fl4 = viz_fl4.format(','.join(['wallclock'])) + +# Make sure we're dealing with the right kind of inputs +src_dir = Path(src_dir) +fnl_dir = Path(fnl_dir) +ben_dir = Path(ben_dir) +des_dir = Path(des_dir) + +# Ensure the output path exists +des_dir.mkdir(parents=True, exist_ok=True) + +# Construct the path to the processed_files.txt file +processed_files_path = os.path.join(des_dir, 'processed_files.txt') +processed_files_path0 = os.path.join(des_dir, 'processed_files' + str(ibatch) + '.txt') + +# Get the names of all inputs, assuming folders have same splits of domains and same file names +src_files = glob.glob(str( src_dir / src_pat )) +src_files.sort() +if do_vars: + ben_files = glob.glob(str( ben_dir / src_pat )) + ben_files.sort() + +# Load the list of files that have already been processed +if os.path.exists(processed_files_path): + with open(processed_files_path, 'r') as f: + processed_files = f.read().splitlines() +else: + processed_files = [] + +# Filter out the files that have already been processed +src_files = [f for f in src_files if f not in processed_files] +if do_vars: ben_files = [f for f in ben_files if f not in processed_files] + +if do_vars: + assert len(ben_files) == len(src_files), \ + 'Found {} files but need {}!'.format(len(src_files), len(ben_files)) + + # -- test for corruption + #for (file, bench) in zip(src_files,ben_files): + # # open file + # try: + # with xr.open_dataset(file), xr.open_dataset(bench) as ds: + # # Do nothing if the file is successfully opened + # pass + # except: + # # Log the file name or take other appropriate action if the file is corrupted + # print('Error opening file:', file, bench) + +# -- functions + +# definitions for KGE computation +def covariance(x,y,dims=None): + return xr.dot(x-x.mean(dims), y-y.mean(dims), dims=dims) / x.count(dims) + +def correlation(x,y,dims=None): + return (covariance(x,y,dims)) / (x.std(dims) * y.std(dims)) + +def run_loop(file,bench,processed_files_path0): + + # extract the subset IDs + subset = file.split('/')[-1].split('_')[1] + + # acquire the lock before opening the file + if not_parallel: + dat = xr.open_dataset(file) + if do_vars: ben = xr.open_dataset(bench) + else: + import multiprocessing as mp + lock = mp.Lock() + with lock: + dat = xr.open_dataset(file) + if do_vars: ben = xr.open_dataset(bench) + + # sometimes gives -9999 the whole run (non-compute), make these nan and plot as lowest value 0 in geographic + dat = dat.where(dat!=-9999) + # some weird negative values in runoff if not routed + if do_vars: dat['averageRoutedRunoff'] = dat['averageRoutedRunoff'].where(dat['averageRoutedRunoff']>=0) + # get rid of gru dimension, assuming hru and gru are one to one (everything now as hruId) + dat = dat.drop_vars(['hruId','gruId']) + m = dat.drop_dims('hru') + m = m.rename({'gru': 'hru'}) + dat = dat.drop_dims('gru') + dat = xr.merge([dat,m]) + dat = dat.where(dat.time!=dat.time[0],drop=True) #first timestep weird + + if do_vars: + ben = ben.where(ben!=-9999) + ben['averageRoutedRunoff'] = ben['averageRoutedRunoff'].where(ben['averageRoutedRunoff']>=0) + ben = ben.drop_vars(['hruId','gruId']) + m = ben.drop_dims('hru') + m = m.rename({'gru': 'hru'}) + ben = ben.drop_dims('gru') + ben = xr.merge([ben,m]) + ben = ben.where(ben.time!=ben.time[0],drop=True) #first timestep weird + + diff = dat - ben + the_hru = np.array(ben['hru']) + + # -- compute statistics + if do_vars: + for var in settings: + mean = dat[var].mean(dim='time') + mean = mean.expand_dims("stat").assign_coords(stat=("stat",["mean"])) + + datnz = dat[var].where(np.logical_and(ben[var] != 0,dat[var] != 0)) # don't include both 0 + mnnz = datnz.mean(dim='time') + mnnz = mnnz.expand_dims("stat").assign_coords(stat=("stat",["mnnz"])) + + mean_ben = ben[var].mean(dim='time') + mean_ben = mean_ben.expand_dims("stat").assign_coords(stat=("stat",["mean_ben"])) + + datnz = ben[var].where(np.logical_and(ben[var] != 0,dat[var] != 0)) # don't include both 0 + mnnz_ben = datnz.mean(dim='time') + mnnz_ben = mnnz_ben.expand_dims("stat").assign_coords(stat=("stat",["mnnz_ben"])) + + amx = np.fabs(dat[var]).fillna(-1).argmax(dim=['time']) # fill nan with neg value so will not choose + amax = dat[var].isel(amx).drop_vars('time') + amax = amax.expand_dims("stat").assign_coords(stat=("stat",["amax"])) + + amx = np.fabs(ben[var]).fillna(-1).argmax(dim=['time']) # fill nan with neg value so will not choose + amax_ben = ben[var].isel(amx).drop_vars('time') + amax_ben = amax_ben.expand_dims("stat").assign_coords(stat=("stat",["amax_ben"])) + + rmse = (np.square(diff[var]).mean(dim='time'))**(1/2) #RMSE SHOULD THIS BE NORMALIZED? colorbar will normalize + rmse = rmse.expand_dims("stat").assign_coords(stat=("stat",["rmse"])) + + diffnz = diff[var].where(np.logical_and(ben[var] != 0,dat[var] != 0)) # don't include both 0 + rmnz = (np.square(diffnz).mean(dim='time'))**(1/2) + rmnz = rmnz.expand_dims("stat").assign_coords(stat=("stat",["rmnz"])) + + amx = np.fabs(diff[var]).fillna(-1).argmax(dim=['time']) # fill nan with neg value so will not choose + maxe = diff[var].isel(amx).drop_vars('time') + maxe = maxe.expand_dims("stat").assign_coords(stat=("stat",["maxe"])) + + r = correlation(dat[var],ben[var],dims='time') + kgem = 1 - np.sqrt( np.square(r-1) + + np.square( dat[var].std(dim='time')/ben[var].std(dim='time') - 1) + + np.square( (dat[var].mean(dim='time')-ben[var].mean(dim='time'))/ben[var].std(dim='time') ) ) + + #if constant and identical, want this as 1.0 -- correlation with a constant = 0 and std dev = 0\n", + for h in the_hru: + ss = dat[var].sel(hru=h) + tt = ben[var].sel(hru=h) + kgem.loc[h] =kgem.sel(hru=h).where(np.allclose(ss,tt, atol = 1e-10)==False, other=1.0) + kgem = kgem/(2.0-kgem) + kgem = kgem.expand_dims("stat").assign_coords(stat=("stat",["kgem"])) + + new = xr.merge([mean,mnnz,amax, mean_ben,mnnz_ben,amax_ben, rmse,rmnz, maxe, kgem]) + new.to_netcdf(des_dir / des_fil.format(var,subset)) + + if do_steps: + for var in stepsets: + mean = dat[var].mean(dim='time') + mean = mean.expand_dims("stat").assign_coords(stat=("stat",["mean"])) + + amx = np.fabs(dat[var]).fillna(-1).argmax(dim=['time']) # fill nan with neg value so will not choose + amax = dat[var].isel(amx).drop_vars('time') + amax = amax.expand_dims("stat").assign_coords(stat=("stat",["amax"])) + + new = xr.merge([mean,amax]) + new.to_netcdf(des_dir / des_fl2.format(var,subset)) + + if do_balance: + for var in balssets: + mean = np.fabs(dat[var]).mean(dim='time') # this is actually absolute value mean + mean = mean.expand_dims("stat").assign_coords(stat=("stat",["mean"])) + + amx = np.fabs(dat[var]).fillna(-1).argmax(dim=['time']) # fill nan with neg value so will not choose + amax = dat[var].isel(amx).drop_vars('time') + amax = amax.expand_dims("stat").assign_coords(stat=("stat",["amax"])) + + new = xr.merge([mean,amax]) + new.to_netcdf(des_dir / des_fl3.format(var,subset)) + + if do_wall: + for var in wallsets: + mean = dat[var].mean(dim='time') + mean = mean.expand_dims("stat").assign_coords(stat=("stat",["mean"])) + + amx = np.fabs(dat[var]).fillna(-1).argmax(dim=['time']) # fill nan with neg value so will not choose + amax = dat[var].isel(amx).drop_vars('time') + amax = amax.expand_dims("stat").assign_coords(stat=("stat",["amax"])) + + std = dat[var].std(dim='time') + std = std.expand_dims("stat").assign_coords(stat=("stat",["std"])) + + new = xr.merge([mean,amax,std]) + new.to_netcdf(des_dir / des_fl4.format(var,subset)) + + # write the name of the processed file to the file list, acquire the lock before opening the file + if not_parallel: + with open(processed_files_path0, 'a') as filew: + filew.write(file + '\n') + if do_vars: filew.write(bench + '\n') + else: + import multiprocessing as mp + lock = mp.Lock() + with lock: + with open(processed_files_path0, 'a') as filew: + filew.write(file + '\n') + if do_vars: filew.write(bench + '\n') + + return #nothing + +def merge_subsets_into_one(src,pattern,des,name): + + '''Merges all files in {src} that match {pattern} into one file stored in /{des}/{name.nc}''' + + # this runs out of memory sometimes + # Find all files + #src_files = glob.glob(str( src / pattern )) + # Merge into one + #out = xr.merge([xr.open_dataset(file) for file in src_files]) + + out = xr.open_mfdataset(str( src / pattern )) + + # save to file + out.to_netcdf(des / name) + + return #nothing +# -- end functions + +# do batches +nf = len(src_files) +start = min((int(ibatch)-1)*np.ceil(nf/nbatch), nf) +end = min(int(ibatch)*np.ceil(nf/nbatch), nf) +do_f = range(int(start), int(end)) +if ibatch == nbatch: + do_f = range(int(start), nf) + +if ibatch > nbatch: + print('Batch number greater than number of batches, doing file merge') + # Initialize an empty list to store the file contents + contents = [] + + # Loop over the batch numbers + for iibatch in range(1, nbatch + 1): + # Construct the file path + processed_files_path0 = os.path.join(des_dir, 'processed_files' + str(iibatch) + '.txt') + + # Check if the file exists + if os.path.exists(processed_files_path0): + # Open the file and read its contents + with open(processed_files_path0, 'r') as file: + contents.append(file.read()) + os.remove(processed_files_path0) + + # Join the contents into a single string + contents = '\n'.join(contents) + + # Remove blank lines + contents = '\n'.join(line for line in contents.split('\n') if line.strip()) + + # Append the contents to processed_files_path + with open(processed_files_path, 'a') as filew: + filew.write('\n' + contents) + + with open(processed_files_path, 'r') as f: + processed_files = f.read().splitlines() + + # Filter out the files that have already been processed + src_files = [f for f in src_files if f not in processed_files] + if do_vars: ben_files = [f for f in ben_files if f not in processed_files] + + # merge the individual files into one for further vizualization + # remove the individual files for cleanliness + if len(src_files) != 0: + print('Some files have not been processed') + print(src_files) + + else: + if do_vars: + merge_subsets_into_one(des_dir,des_fil.replace('{}','*'),fnl_dir,viz_fil) + for file in glob.glob(str(des_dir / des_fil.replace('{}','*'))): + os.remove(file) + if do_steps: + merge_subsets_into_one(des_dir,des_fl2.replace('{}','*'),fnl_dir,viz_fl2) + for file in glob.glob(str(des_dir / des_fl2.replace('{}','*'))): + os.remove(file) + if do_balance: + merge_subsets_into_one(des_dir,des_fl3.replace('{}','*'),fnl_dir,viz_fl3) + for file in glob.glob(str(des_dir / des_fl3.replace('{}','*'))): + os.remove(file) + if do_wall: + merge_subsets_into_one(des_dir,des_fl4.replace('{}','*'),fnl_dir,viz_fl4) + for file in glob.glob(str(des_dir / des_fl4.replace('{}','*'))): + os.remove(file) + +else: + # do the batch + src_files = [src_files[i] for i in do_f] + if do_vars: ben_files = [ben_files[i] for i in do_f] + + if len(do_f) > 0: + if not_parallel: + # -- no parallel processing + if do_vars: + for (file, bench) in zip(src_files,ben_files): + run_loop(file,bench,processed_files_path0) + else: + for (file, bench) in zip(src_files,src_files): + run_loop(file,bench,processed_files_path0) + # -- end no parallel processing + + else: + # -- start parallel processing + ncpus = int(os.environ.get('SLURM_CPUS_PER_TASK',default=1)) + if __name__ == "__main__": + import multiprocessing as mp + pool = mp.Pool(processes=ncpus) + with open(processed_files_path0, 'a') as f: + if do_vars: + results = [pool.apply_async(run_loop, args=(file,bench,processed_files_path0)) for (file, bench) in zip(src_files, ben_files)] + else: + results = [pool.apply_async(run_loop, args=(file,bench,processed_files_path0)) for (file, bench) in zip(src_files, src_files)] + for r in results: + try: + r.get() + except Exception as e: + print(f"Error processing file: {e}") + raise e + pool.close() + # -- end parallel processing + +# -- end script \ No newline at end of file diff --git a/utils/pre-processing/SUMMA_merge_restarts_into_warmState.py b/utils/pre-processing/SUMMA_merge_restarts_into_warmState.py new file mode 100644 index 000000000..946bfd86e --- /dev/null +++ b/utils/pre-processing/SUMMA_merge_restarts_into_warmState.py @@ -0,0 +1,47 @@ +# Combine split domain state files (with 2 dimensions, hru and gru) +# Modified by W. Knoben (2021) from A. Wood (2020) +# ----------------------------------------------- + +import sys, glob +import pandas as pd +import xarray as xr + +# --------- arguments ----------- +''' +print("found %d args" % len(sys.argv)) +if len(sys.argv) == 5: + stateFileRoot = sys.argv[1] # eg './hstate/wbout_restart_' + startDate = sys.argv[2] # eg '19910301' + endDate = sys.argv[3] # eg '19920301' + Freq = sys.argv[4] # D (daily) or MS (monthly) +else: + print("USAGE: %s input_filepath/root startdate(YYYYMMDD) enddate frequency_of_states(D or MS)" % sys.argv[0]) + sys.exit(0) +''' +srcPath = '/project/gwf/gwf_cmt/wknoben/summaWorkflow_data/domain_Nelson/simulations/run3_be4_make_ics/SUMMA' +srcName = 'run3_be4_make_ics_restart_2017123123_*.nc' +desPath = '/project/gwf/gwf_cmt/wknoben/summaWorkflow_data/domain_Nelson/settings/SUMMA/' +desName = 'warmState.nc' + +# --------- code ----------- +# find the files +output_file_list = glob.glob(srcPath + '/' + srcName) +output_file_list.sort() + +out_ds = [xr.open_dataset(f) for f in output_file_list] +hru_vars = [] # variables that have hru dimension +gru_vars = [] # variables that have gru dimension + +for name, var in out_ds[0].variables.items(): + if 'hru' in var.dims: + hru_vars.append(name) + elif 'gru' in var.dims: + gru_vars.append(name) + +hru_ds = [ds[hru_vars] for ds in out_ds] +gru_ds = [ds[gru_vars] for ds in out_ds] +hru_merged = xr.concat(hru_ds, dim='hru') +gru_merged = xr.concat(gru_ds, dim='gru') +merged_ds = xr.merge([hru_merged, gru_merged]) + +merged_ds.load().to_netcdf(desPath + '/' + desName) \ No newline at end of file diff --git a/utils/convert_summa_config_v2_v3.py b/utils/pre-processing/convert_summa_config_v2_v3.py similarity index 99% rename from utils/convert_summa_config_v2_v3.py rename to utils/pre-processing/convert_summa_config_v2_v3.py index 032b68350..a1862d17c 100755 --- a/utils/convert_summa_config_v2_v3.py +++ b/utils/pre-processing/convert_summa_config_v2_v3.py @@ -87,7 +87,7 @@ def fm_v2_parse(ifile): fm_values = [] fm_comments = [] for line in iter(fm_txt.splitlines()): - if line.startswith('!'): + if line.startswith('!') or not len(line.strip()): continue m = re.match('^([^\\{}]*)\\{}(.*)$'.format(comment_sep, comment_sep), line) if m and m.group(1): # The line contains a hash / comment diff --git a/utils/pre-processing/fileManager_XXXXXX.txt b/utils/pre-processing/fileManager_XXXXXX.txt new file mode 100644 index 000000000..b431d6f73 --- /dev/null +++ b/utils/pre-processing/fileManager_XXXXXX.txt @@ -0,0 +1,20 @@ +controlVersion 'SUMMA_FILE_MANAGER_V3.0.0' ! file manager version +simStartTime '1979-01-01 00:00' ! +simEndTime '1984-12-31 23:00' ! +tmZoneInfo 'utcTime' ! +outFilePrefix 'run1' ! +settingsPath '/home/x-avanb/basin_settings/' +forcingPath '/anvil/projects/x-ees240082/users/ashley-vanbeusekom/basin_forcing/basin_XXXXXX/' +outputPath '/anvil/scratch/x-avanb/output/' +initConditionFile 'coldState_XXXXXX.nc' ! Relative to settingsPath +attributeFile 'attributes_XXXXXX.nc' ! Relative to settingsPath +trialParamFile 'trialParams_XXXXXX.nc' ! Relative to settingsPath +forcingListFile 'forcingFileListChunked.txt' ! Relative to settingsPath +decisionsFile 'modelDecisions_sunen.txt' ! Relative to settingsPath +outputControlFile 'outputControl.txt' ! Relative to settingsPath +globalHruParamFile 'localParamInfo_sun5en.txt' ! Relative to settingsPath +globalGruParamFile 'basinParamInfo.txt' ! Relative to settingsPatho +vegTableFile 'TBL_VEGPARM.TBL' ! Relative to settingsPath +soilTableFile 'TBL_SOILPARM.TBL' ! Relative to settingsPath +generalTableFile 'TBL_GENPARM.TBL' ! Relative to settingsPath +noahmpTableFile 'TBL_MPTABLE.TBL' ! Relative to settingsPath diff --git a/utils/pre-processing/gen_coldstate.py b/utils/pre-processing/gen_coldstate.py new file mode 100644 index 000000000..d7169ffab --- /dev/null +++ b/utils/pre-processing/gen_coldstate.py @@ -0,0 +1,237 @@ +#!/usr/bin/env python +''' Create a vector cold state file for SUMMA from constant values''' +# +# Author: Andy Wood, Feb 2017 +# +# Notes: quick n dirty to generate constant initial states across a domain +# all values hardwired, just gets HRU index from an existing parameter file +# improvements: could read another cold state file to get list of variables +# to populate; or read a metadata dictionary (names, types, etc) +# +# no mapping required here -- but one could map another resolution vals, similar +# to the param mapping scripts +# +# check: nSoil and nSnow might have to be 'int' instead of 'int64' in output +# +# Requirements: run with a python (eg miniconda) 2.7 that includes netCDF4 +# +# ========================================================================= + +import sys +import os +import time +import getopt +import numpy as np +import netCDF4 as nc4 +#import xarray as xr + +######################################################################## +# Subroutines # +######################################################################## + +def getNetCDFData(fn, varname): + """Read variables available to be mapped from NetCDF """ + f = nc4.Dataset(fn,'r') + data = f.variables[varname][:] + f.close() +# ds = xr.open_dataset(fn) +# data = ds[varname] + return data + +def getOutputPolyIDs(nc_file): + outPolyIDs = getNetCDFData(nc_file, 'hruId') + print("read output outPolyIds ('hruId') from example domain file") + return outPolyIDs + + +# write variables to netcdf output file +def writeNC_state_vars(nc_out, newVarName, newVarDim, newVarType, newVarVals): + + """ Write [hru] array in netCDF4 file, and variable of + """ + + print("adding data") + ncvar = nc_out.createVariable(newVarName, newVarType, (newVarDim, 'hru',),fill_value='-999.0') + ncvar[:] = newVarVals # store data in netcdf file + + +# write dimensions and dimension variables to netcdf output file +def writeNC_dims(fn, scalarv, midSoil, midToto, ifcToto, hrus, hru_type): + """ Write [hru] array in netCDF4 file, and variable of + """ + + print("writing output file") + nc_out = nc4.Dataset(fn, 'w', format='NETCDF4') + + # Create dimensions + dim_hru = nc_out.createDimension('hru', len(hrus)) + dim_scalarv = nc_out.createDimension('scalarv', scalarv) + dim_midSoil = nc_out.createDimension('midSoil', midSoil) + dim_midToto = nc_out.createDimension('midToto', midToto) + dim_ifcToto = nc_out.createDimension('ifcToto', ifcToto) + + # --- Create HRU ID variable (can be either int or string) + if hru_type == 'str': + # string HRU (need to add string length) + max_strlen = 20 # EC + dim_str = nc_out.createDimension('strlen', max_strlen) + hruId = nc_out.createVariable('hruId', 'S1', ('hru', 'strlen'),fill_value='-999') + hruId[:] = nc4.stringtochar(np.asarray(hrus, + dtype='S{}'.format(max_strlen))) + elif hru_type == 'int64': + # integer HRU + hruId = nc_out.createVariable('hruId', 'i8', ('hru', ),fill_value='-999') + hruId[:] = hrus + #hruId[:] = np.asarray(hrus, dtype='int') + + elif hru_type == 'int': + # integer HRU + hruId = nc_out.createVariable('hruId', 'int', ('hru', ),fill_value='-999') + hruId[:] = hrus + #hruId[:] = np.asarray(hrus, dtype='int') + + else: + # not recognized + sys.exit("ERROR, hru_type not recognized: must be str, int64, or int") + + # add attribute + hruId.long_name = 'USGS HUC12 ID' + + return nc_out + # leave netcdf file open + + +############################################ +# Main # +############################################ +use = ''' +Usage: %s -[h] + -h help +''' +if __name__ == '__main__': + + def usage(): + sys.stderr.write(use % sys.argv[0]) + sys.exit(1) + try: + (opts, args) = getopt.getopt(sys.argv[1:], 'h') + except getopt.error: + usage() + + verbose = False + grid_info = False + proj_info = True + for (opt,val) in opts: + if opt == '-h': + usage() + elif opt == '-v': + verbose = True + else: + raise OptionError(opt) + usage() + + if len(args) == 3: + nc_example_name = args[0] # template file (other params) + nc_out_name = args[1] # output cold-state file + hru_type = args[2] # 'int' or 'string' + # nc_in_name = args[4] # existing cold-state file + + # hardwired to forcing formats (hru index rather than grid) + outPolyIDs=getOutputPolyIDs(nc_example_name) + nOutPolygons = len(outPolyIDs) + + # === now start to create the cold state variables using the variable template === + + # settings (hardwire for now - later read from a config file -- 4 layer + #scalarv = 1 + #midSoil = 4 + #midToto = 4 + #ifcToto = 5 + #dT = 10800 # timestep of forcings in seconds + #lyrDepth = [0.1, 0.3, 0.6, 1.0] + #lyrHeight = [0.0, 0.1, 0.4, 1.0, 2.0] + + # settings 3 layer + scalarv = 1 + midSoil = 3 + midToto = 3 + ifcToto = 4 + dT = 10800 # timestep of forcings in seconds + #dT = 3600 # timestep of forcings in seconds + lyrDepth = [0.1, 0.3, 0.6] + lyrHeight = [0.0, 0.1, 0.4, 1.0] + + # initialize netcdf file by storing dimensions and hru variable + nc_out = writeNC_dims(nc_out_name, scalarv, midSoil, midToto, ifcToto, + outPolyIDs, hru_type) + + # === now loop through variables and write + # this could be done by looping through the input state file and xferring values + # could also read vars and + + # nSoil, nSnow + newVarVals = np.full((1,nOutPolygons), midSoil, dtype='f8') + writeNC_state_vars(nc_out, 'nSoil', 'scalarv', 'f8', newVarVals) + newVarVals = np.zeros((1,nOutPolygons), dtype='f8') + writeNC_state_vars(nc_out, 'nSnow', 'scalarv', 'f8', newVarVals) + + # dT + newVarVals = np.full((1,nOutPolygons), dT) + writeNC_state_vars(nc_out, 'dt_init', 'scalarv', 'f8', newVarVals) + + # SWE, SnowDepth, SfcMeltPond, SnowAlbedo, CanopyLiq, CanopyIce + newVarVals = np.zeros((1,nOutPolygons)) + writeNC_state_vars(nc_out, 'scalarSWE', 'scalarv', 'f8', newVarVals) + writeNC_state_vars(nc_out, 'scalarSnowDepth', 'scalarv', 'f8', newVarVals) + writeNC_state_vars(nc_out, 'scalarSfcMeltPond', 'scalarv', 'f8', newVarVals) + writeNC_state_vars(nc_out, 'scalarSnowAlbedo', 'scalarv', 'f8', newVarVals) + writeNC_state_vars(nc_out, 'scalarCanopyLiq', 'scalarv', 'f8', newVarVals) + writeNC_state_vars(nc_out, 'scalarCanopyIce', 'scalarv', 'f8', newVarVals) + + # CanairTemp, CanopyTemp + newVarVals = np.full((1,nOutPolygons), 283.16) + writeNC_state_vars(nc_out, 'scalarCanairTemp', 'scalarv', 'f8', newVarVals) + writeNC_state_vars(nc_out, 'scalarCanopyTemp', 'scalarv', 'f8', newVarVals) + + # AquiferStorage + newVarVals = np.full((1,nOutPolygons), 1.0) + writeNC_state_vars(nc_out, 'scalarAquiferStorage', 'scalarv', 'f8', newVarVals) + + # layer MatricHead + newVarVals = np.full((midSoil,nOutPolygons), -1.0) + writeNC_state_vars(nc_out, 'mLayerMatricHead', 'midSoil', 'f8', newVarVals) + + # layer Temp + newVarVals = np.full((midToto,nOutPolygons), 283.16) + writeNC_state_vars(nc_out, 'mLayerTemp', 'midToto', 'f8', newVarVals) + + # layer VolFracLiq + newVarVals = np.full((midToto,nOutPolygons), 0.2) + writeNC_state_vars(nc_out, 'mLayerVolFracLiq', 'midToto', 'f8', newVarVals) + + # layer VolFracIce + newVarVals = np.full((midToto,nOutPolygons), 0.0) + writeNC_state_vars(nc_out, 'mLayerVolFracIce', 'midToto', 'f8', newVarVals) + + # layer Depth, Height + newVarVals = np.full((nOutPolygons,midToto), lyrDepth).transpose() + writeNC_state_vars(nc_out, 'mLayerDepth', 'midToto', 'f8', newVarVals) + newVarVals = np.full((nOutPolygons,ifcToto), lyrHeight).transpose() + writeNC_state_vars(nc_out, 'iLayerHeight', 'ifcToto', 'f8', newVarVals) + + nc_out.close() + + else: + usage() + + + # code for reading input data variable & attributes + # to pass to processing and write routines (instead of hardwired calls above +# f = nc4.Dataset(nc_infl, 'r') +# var_in = f.variables[varname] +# attNames = [] +# attContents = [] +# attr = var_in.ncattrs() # get attributes +# for n in range(0,len(attr)): +# attNames.extend([attr[n]]) +# attContents.extend([var_in.getncattr(attr[n])]) diff --git a/utils/pre-processing/readme.md b/utils/pre-processing/readme.md new file mode 100644 index 000000000..c8937a99f --- /dev/null +++ b/utils/pre-processing/readme.md @@ -0,0 +1,3 @@ +# pre-processing folder +Helpful scripts for a variety of pre-processing purposes: +- `convert_summa_config_v2_v3.py`: convert SUMMA v2.x configuration to SUMMA v3.0.0 - `gen_coldstate.py`: create a vector cold state file for SUMMA from constant values - `subsetGRU.sh`: subset out a NA HRU forcing, parameter, and attribute files where GRU matches HRU - `SUMMA_merge_restarts_into_warmState.py`: combine split domain state files (with 2 dimensions, hru and gru) \ No newline at end of file diff --git a/utils/pre-processing/subsetGRU.sh b/utils/pre-processing/subsetGRU.sh new file mode 100755 index 000000000..7bc032046 --- /dev/null +++ b/utils/pre-processing/subsetGRU.sh @@ -0,0 +1,65 @@ +#!/bin/bash +# Subset out a NA HRU forcing, parameter, and attribute files where GRU matches HRU +# +# Inside forcingFile_out need to change forcingPath to = desForcingPath +# Inside forcingFile_out need to change initConditionFile, attributeFile, trialParamFile to = _${GRU_id} versions +# written originally by A. Van Beusekom 2025, hardwired paths run on Anvil + +module load gcc/11.2.0 +module load nco/4.9.3 + +# GRU want to subset, change to do another GRU +#just set this as GRU_nc from output error of G* on output file (here the bad file is G069381) + +GRU_file=69381 + +GRU_id=$((GRU_file-1)) +HRU_id=$GRU_id +echo "GRU order in file is ${GRU_file} starting count at 1; id is ${GRU_id} in netcdf file" + +# top paths, change these to yours +homeDir=$HOME/ +desforceDir=$PROJECT/users/ashley-vanbeusekom/basin_forcing/ +inpforceDir=$PROJECT/users/ashley-vanbeusekom/summaNorthAmerica_forcing/ +dessettingsPath=${homeDir}basin_settings/ +inpsettingsPath=${homeDir}summaNorthAmerica_settings/ +summa_exe=${homeDir}SummaSundials/summa/bin/summa_sundials.exe + +# in paths, probably won't change, but will need to make generic fileManager_XXXXXX.txt and put in ${dessettingsPath} +# fileManager_XXXXXX.txt example provided in summa/utils/pre-processing +fileManager_in=${dessettingsPath}fileManager_XXXXXX.txt +initConditionFile_in=${inpsettingsPath}coldState.nc +attributeFile_in=${inpsettingsPath}attributes.nc +trialParamFile_in=${inpsettingsPath}trialParams.nc + +# out paths, probably won't change +fileManager_out=${dessettingsPath}fileManager_${GRU_id}.txt +initConditionFile_out=${dessettingsPath}coldState_${GRU_id}.nc +attributeFile_out=${dessettingsPath}attributes_${GRU_id}.nc +trialParamFile_out=${dessettingsPath}trialParams_${GRU_id}.nc +desForcingPath=${desforceDir}basin_${GRU_id}/ + +# set up directory and new file Manager (will have to change things in it manually as above) +mkdir -p "$desForcingPath" +cp $fileManager_in $fileManager_out + +# do the subset +ncks -d hru,$HRU_id,$HRU_id $initConditionFile_in $initConditionFile_out +echo "coldState.nc HRU ${HRU_id} subsetted" +ncks -d gru,$GRU_id,$GRU_id -d hru,$HRU_id,$HRU_id $attributeFile_in $attributeFile_out +echo "attributes.nc GRU ${GRU_id} HRU ${HRU_id} subsetted" +ncks -d hru,$HRU_id,$HRU_id $trialParamFile_in $trialParamFile_out +echo "trialParams.nc HRU ${HRU_id} subsetted" + +# forcing subset has multiple files +cd $inpforceDir +for fn in NorthAmerica_remapped_*00-00-00-chunked.nc; do + output_fn=${desForcingPath}${fn} + ncks -d hru,$HRU_id,$HRU_id $fn $output_fn + echo "${fn} HRU ${HRU_id} subsetted" +done +cd $homePath + +# write summa command call file +runFile=${dessettingsPath}run_${GRU_id}.sh +echo "${summa_exe} -p never -s _testSumma -m ${fileManager_out} -r e" > $runFile