diff --git a/.github.com/CONTRIBUTING.md b/.github.com/CONTRIBUTING.md new file mode 100755 index 000000000..a1837ce5c --- /dev/null +++ b/.github.com/CONTRIBUTING.md @@ -0,0 +1,47 @@ +# Contributing + +SUMMA is Open Source software. This means that the code is made available for free, but also that development, maintenance and support are intended to be community efforts. Our rationale for moving SUMMA model development to an open source model is that we want: + +- to encourage other researchers and developers to contribute to SUMMA development, and +- to facilitate transparent development and use of the model. + +## Support + +There is no official support for the SUMMA model, other than the SUMMA documentation, the SUMMA source code archive and the description of the model in the literature. Any additional support relies on volunteer efforts by the SUMMA development community. The following resources are available: + +- [SUMMA web site](https://www.ral.ucar.edu/projects/summa): General background, SUMMA resources, and test data sets. +- [SUMMA Source code repository](https://github.com/NCAR/SUMMA) : Source code distribution, coordination of model development, bug fixes, and releases. + +We expect that the user comes prepared with some understanding of the model and scientific computing. As such, these items are specifically not supported by the SUMMA development community: + +- Building and running the SUMMA model on platforms other than LINUX, UNIX, and OSX. +- Using LINUX, UNIX, or OSX operating systems. +- Development of project specific features. +- Configuring individual model applications. + +## Submitting Issues +#### Submitting Bug Reports + +If you think you have found a bug in SUMMA, please check whether an issue has been filed on [SUMMA's Github page](https://github.com/NCAR/SUMMA/issues). If not, go please go ahead and create an issue and include the following information in your bug report: + +- Version of SUMMA that you are using (e.g. SUMMA 1.0 - even better if you can provide the specific tag or commit) +- Name and version of the fortran compiler you are using +- Operating system +- A description of relevant model settings +- A summary of the bug or error message you are getting + +If you can provide more information that is great. If you know how to run the model in a debugger, you may be able to pinpoint where the problem occurs. + +#### Proposing New Features + +SUMMA is under active development. If you would like to propose a new feature, driver, or extension to SUMMA, please file an issue on [SUMMA's Github page](https://github.com/NCAR/SUMMA/issues). Also, because SUMMA is an open source model with no official support for general-purpose development, be prepared to contribute to the implementation of your feature request. Features that are only of interest to you are unlikely to be implemented in the main source code repo (although you are of course free to modify the code in any way you see fit). + +## Contributing to SUMMA +#### Git Workflow +We have developed some documentation to help you get started if you are new to Git but want to contribute to VIC: + +- [Working with Git](https://github.com/NCAR/summa/blob/master/docs/howto/git_howto.md) +- [Git Workflow](https://github.com/NCAR/summa/blob/master/docs/howto/summa_git_workflow.md) + +#### Coding Conventions +We have some simple [https://github.com/NCAR/summa/blob/master/docs/howto/summa_coding_conventions.md](coding conventions) that we would like anyone who contributes code to SUMMA to follow. diff --git a/.github.com/ISSUE_TEMPLATE.md b/.github.com/ISSUE_TEMPLATE.md new file mode 100755 index 000000000..79eadd4c2 --- /dev/null +++ b/.github.com/ISSUE_TEMPLATE.md @@ -0,0 +1,16 @@ +#### Bug Reports + + +- Version of SUMMA that you are using (e.g. SUMMA 1.0 - even better if you can provide the specific tag or commit) +- Name and version of the fortran compiler you are using +- Operating system +- A description of relevant model settings +- A summary of the bug or error message you are getting + +#### Feature Requests + + +- Description of feature +- Description of the problem the feature addresses +- Will the proposed feature be backward compatible? +- Will the proposed feature change the science results of SUMMA? diff --git a/.github.com/PULL_REQUEST_TEMPLATE.md b/.github.com/PULL_REQUEST_TEMPLATE.md new file mode 100755 index 000000000..41493a887 --- /dev/null +++ b/.github.com/PULL_REQUEST_TEMPLATE.md @@ -0,0 +1,8 @@ +Make sure all the relevant boxes are checked (and only check the box if you actually completed the step): + +- [ ] closes #xxx (identify the issue associated with this PR) +- [ ] tests passed +- [ ] new tests added +- [ ] science test figures +- [ ] checked that the new code conforms to the [SUMMA coding conventions](https://github.com/NCAR/summa/blob/master/docs/howto/summa_coding_conventions.md) +- [ ] ReleaseNotes entry diff --git a/.gitignore b/.gitignore old mode 100644 new mode 100755 index 3cc78af0e..ef9a51193 --- a/.gitignore +++ b/.gitignore @@ -19,4 +19,16 @@ summa.exe *cscope* .tags* # OS X .DS_Store files -.DS_Store \ No newline at end of file +.DS_Store +*-local +*_local +*log +*.cbp +*.layout +gmon.out +summa.exe.dSYM* +# makefile +make.out +Makefile-* +# backup files +*.backup diff --git a/.travis.yml b/.travis.yml old mode 100644 new mode 100755 diff --git a/COPYING b/COPYING old mode 100644 new mode 100755 diff --git a/Dockerfile b/Dockerfile new file mode 100644 index 000000000..31ae087c4 --- /dev/null +++ b/Dockerfile @@ -0,0 +1,29 @@ +# use the zesty distribution, which has gcc-6 +FROM ubuntu:zesty + +# install only the packages that are needed +RUN apt-get update && \ + apt-get install -y --no-install-recommends \ + git \ + make \ + gfortran-6 \ + libnetcdff-dev \ + liblapack-dev \ + && apt-get clean + +# set environment variables for docker build +ENV F_MASTER /code +ENV FC gfortran +ENV FC_EXE gfortran +ENV FC_ENV gfortran-6-docker + +# add code directory +WORKDIR /code +ADD . /code + +# build summa +RUN make -C build/ -f Makefile + +# run summa when running the docker image +WORKDIR bin +ENTRYPOINT ["./summa.exe"] diff --git a/build/Makefile b/build/Makefile old mode 100644 new mode 100755 index ee2693bf5..1c975116a --- a/build/Makefile +++ b/build/Makefile @@ -13,11 +13,22 @@ # Define core directory below which everything resides. This is the # parent directory of the 'build' directory -F_MASTER = +##F_MASTER = # Define the Fortran Compiler. If you are using gfortran, then this needs -# to be version 4.8 or higher -FC = +# to be version 4.8 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 +##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 compiler environment. This is used in the ifeq statements in this +# Makefile to set the include and library paths and the libraries +##FC_ENV = # Define the NetCDF and LAPACK libraries and path to include files. Note # that the default paths defined are those that work for our compilers @@ -30,9 +41,44 @@ FC = # 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 +ifeq "$(FC)" "gfortran" + FLAGS_NOAH = -p -g -ffree-form -fdefault-real-8 -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 +ifeq "$(FC)" "ifort" + FLAGS_NOAH = -O0 -p -g -warn nounused -autodouble -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 +ifeq "$(FC)" "pgfortran" + FLAGS_NOAH = -O0 -pg -g -traceback -r8 -Mfree -Mbounds + FLAGS_COMM = -O0 -pg -g -traceback -Mfree -Mbounds + FLAGS_SUMMA = -O0 -pg -g -traceback -Mfree -Mbounds -Minfo -Mnoautoinline -Ktrap=inv,denorm,divz,ovf,unf,inexact +endif + +# gfortran-6 compiler used in Docker builds +ifeq "$(FC_ENV)" "gfortran-6-docker" + NCDF_PATH = /usr + LAPK_PATH = /usr + # define the lapack libraries + LIBLAPACK = -L$(LAPK_PATH)/lib -llapack -lblas +endif + +# Ubuntu gfortran compiler tested with 4.6 and higher +# also used for the travis build +ifeq "$(FC_ENV)" "gfortran-6-travis" + LAPK_PATH = /usr + # define the lapack libraries + LIBLAPACK = -L$(LAPK_PATH)/lib -llapack -lblas +endif + # gfortran compiler on OS X tested with 4.8 and higher # (works on Mac OS X with Macports) -ifeq "$(FC)" "gfortran-mp-6" +ifeq "$(FC_ENV)" "gfortran-6-macports" NCDF_PATH = /opt/local LAPK_PATH = /opt/local # define the lapack libraries - on OS X you need atlas and @@ -40,53 +86,26 @@ ifeq "$(FC)" "gfortran-mp-6" LIBLAPACK = -L$(LAPK_PATH)/lib -llapack -lblas -latlas endif -# Ubuntu gfortran compiler tested with 6.0 and higher -# also used for the travis build -ifeq "$(FC)" "gfortran-6" - NCDF_PATH = /usr/local - LAPK_PATH = /usr - # define the lapack libraries - LIBLAPACK = -L$(LAPK_PATH)/lib -llapack -lblas -endif - # Intel fortran compiler -ifeq "$(FC)" "ifort" +ifeq "$(FC_ENV)" "ifort" NCDF_PATH = /opt/netcdf4-intel LAPK_PATH = /usr # define the lapack libraries LIBLAPACK = -L$(LAPK_PATH)/lib -llapack endif -# Intel fortran compiler -ifeq "$(FC)" "ifort" - NCDF_PATH = /opt/netcdf-4.3.0+ifort-12.1 +# Portland compiler +ifeq "$(FC_ENV)" "pgfortran" + NCDF_PATH = /opt/netcdf4-pgi LAPK_PATH = /usr # define the lapack libraries LIBLAPACK = -L$(LAPK_PATH)/lib -llapack endif +# define netcdf libraries and include files LIBNETCDF = -L$(NCDF_PATH)/lib -lnetcdff INCNETCDF = -I$(NCDF_PATH)/include -# 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 -ifeq "$(FC)" "gfortran-mp-6" - FLAGS_NOAH = -ffree-form -fdefault-real-8 -ffree-line-length-none -fmax-errors=0 -g -fbacktrace -Wno-unused -Wno-unused-dummy-argument - FLAGS_COMM = -g -Wall -ffree-line-length-none -fmax-errors=0 -fbacktrace -Wno-unused -Wno-unused-dummy-argument - FLAGS_SUMMA = -g -Wall -ffree-line-length-none -fmax-errors=0 -fbacktrace -Wno-unused -Wno-unused-dummy-argument -endif -ifeq "$(FC)" "gfortran-6" - FLAGS_NOAH = -p -g -ffree-form -fdefault-real-8 -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 -Wno-unused -Wno-unused-dummy-argument - FLAGS_SUMMA = -p -g -Wall -ffree-line-length-none -fmax-errors=0 -fbacktrace -Wno-unused -Wno-unused-dummy-argument -endif -ifeq "$(FC)" "ifort" - FLAGS_NOAH = -warn nounused -autodouble -noerror_limit -FR -O0 -auto -WB -traceback -g -fltconsistency - FLAGS_COMM = -debug -warn all -check all -FR -O0 -auto -WB -traceback -g -fltconsistency -fpe0 - FLAGS_SUMMA = -debug -warn all -check all -FR -O0 -auto -WB -traceback -g -fltconsistency -fpe0 -endif - #======================================================================== # PART 1: Define directory paths #======================================================================== @@ -116,6 +135,7 @@ ENGINE_DIR = $(F_KORE_DIR)/engine # utilities SUMMA_NRUTIL= \ nrtype.f90 \ + f2008funcs.f90 \ nr_utility.f90 NRUTIL = $(patsubst %, $(ENGINE_DIR)/%, $(SUMMA_NRUTIL)) @@ -136,13 +156,20 @@ HOOKUP = $(patsubst %, $(HOOKUP_DIR)/%, $(SUMMA_HOOKUP)) SUMMA_DATAMS= \ multiconst.f90 \ var_lookup.f90 \ - data_struc.f90 \ - popMetadat.f90 + data_types.f90 \ + globalData.f90 \ + flxMapping.f90 \ + get_ixname.f90 \ + ascii_util.f90 \ + popMetadat.f90 \ + outpt_stat.f90 DATAMS = $(patsubst %, $(DSHARE_DIR)/%, $(SUMMA_DATAMS)) # utility modules SUMMA_UTILMS= \ - time_utils.f90 + time_utils.f90 \ + matrixOper.f90 \ + mDecisions.f90 UTILMS = $(patsubst %, $(ENGINE_DIR)/%, $(SUMMA_UTILMS)) # Model guts @@ -153,6 +180,7 @@ SUMMA_MODGUT= \ SUMMA_SOLVER= \ vegPhenlgy.f90 \ diagn_evar.f90 \ + stomResist.f90 \ groundwatr.f90 \ vegSWavRad.f90 \ vegNrgFlux.f90 \ @@ -160,29 +188,35 @@ SUMMA_SOLVER= \ vegLiqFlux.f90 \ snowLiqFlx.f90 \ soilLiqFlx.f90 \ + computFlux.f90 \ + computResid.f90 \ + computJacob.f90 \ + eval8summa.f90 \ + summaSolve.f90 \ systemSolv.f90 \ + varSubstep.f90 \ + opSplittin.f90 \ coupled_em.f90 SOLVER = $(patsubst %, $(ENGINE_DIR)/%, $(SUMMA_SOLVER)) # Define routines for SUMMA preliminaries SUMMA_PRELIM= \ conv_funcs.f90 \ - ascii_util.f90 \ sunGeomtry.f90 \ - get_ixname.f90 \ - mDecisions.f90 \ snow_utils.f90 \ soil_utils.f90 \ updatState.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 \ - read_icond.f90 + check_icond.f90 PRELIM = $(patsubst %, $(ENGINE_DIR)/%, $(SUMMA_PRELIM)) SUMMA_NOAHMP= \ @@ -196,6 +230,9 @@ 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 \ @@ -214,15 +251,17 @@ SUMMA_MSOLVE = \ # Define NetCDF routines SUMMA_NETCDF = \ + netcdf_util.f90 \ def_output.f90 \ - modelwrite.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 = $(PRELIM) $(MODRUN) $(SOLVER) $(NETCDF) +SUMMA_ALL = $(NETCDF) $(PRELIM) $(MODRUN) $(SOLVER) # Define the driver routine SUMMA_DRIVER= \ @@ -232,6 +271,13 @@ DRIVER = $(patsubst %, $(DRIVER_DIR)/%, $(SUMMA_DRIVER)) # Define the executable DRIVER__EX = summa.exe +# Define version number +VERSIONFILE = $(DRIVER_DIR)/summaversion.inc +VERSION = $(shell git tag | sed 's/v//') +BULTTIM = $(shell date) +GITBRCH = $(shell git describe --long --all --always | sed -e's/heads\///') +GITHASH = $(shell git rev-parse HEAD) + #======================================================================== # PART 3: Checks #====================================================================== @@ -242,6 +288,12 @@ 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 FC_ENV + $(error FC_ENV is undefined: Specify your compiler environment) +endif ifndef FLAGS_SUMMA $(error Specify flags for your compiler: $(FC)) endif @@ -273,22 +325,29 @@ check: $(info Add $(NCDF_PATH)/lib to your LD_LIBRARY_PATH) $(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) $(FLAGS_NOAH) -c $(NOAHMP) + $(FC_EXE) $(FLAGS_NOAH) -c $(NOAHMP) # compile common routines compile_comm: - $(FC) $(FLAGS_COMM) -c $(COMM_ALL) + $(FC_EXE) $(FLAGS_COMM) -c $(COMM_ALL) # compile SUMMA routines -compile_summa: - $(FC) $(FLAGS_SUMMA) -c $(SUMMA_ALL) $(DRIVER) \ +compile_summa: update_version + $(FC_EXE) $(FLAGS_SUMMA) -c $(SUMMA_ALL) $(DRIVER) \ $(INCNETCDF) # link routines link: - $(FC) *.o $(LIBNETCDF) $(LIBLAPACK) -o $(DRIVER__EX) + $(FC_EXE) -pg -g *.o $(LIBNETCDF) $(LIBLAPACK) -o $(DRIVER__EX) # Remove object files clean: diff --git a/build/source/driver/multi_driver.f90 b/build/source/driver/multi_driver.f90 old mode 100644 new mode 100755 index a887a8661..1ca7de77f --- a/build/source/driver/multi_driver.f90 +++ b/build/source/driver/multi_driver.f90 @@ -24,27 +24,34 @@ program multi_driver ! use desired modules ! ***************************************************************************** USE nrtype ! variable types, etc. +USE netcdf ! netcdf libraries ! provide access to subroutines and functions USE summaFileManager,only:summa_SetDirsUndPhiles ! sets directories and filenames USE module_sf_noahmplsm,only:read_mp_veg_parameters ! module to read NOAH vegetation tables -USE module_sf_noahmplsm,only:redprm ! module to assign more Noah-Mp parameters -USE allocspace_module,only:init_metad ! module to allocate space for metadata structures -USE allocspace_module,only:alloc_stim ! module to allocate space for scalar time structures -USE allocspace_module,only:alloc_time ! module to allocate space for model time structures -USE allocspace_module,only:alloc_forc ! module to allocate space for model forcing data strictures -USE allocspace_module,only:alloc_mpar ! module to allocate space for local column model parameter structures -USE allocspace_module,only:alloc_mvar ! module to allocate space for local column model variable structures -USE allocspace_module,only:alloc_indx ! module to allocate space for local column model indices -USE allocspace_module,only:alloc_bpar ! module to allocate space for basin-average model parameter structures -USE allocspace_module,only:alloc_bvar ! module to allocate space for basin-average model variable structures +USE module_sf_noahmplsm,only:redprm ! module to assign more Noah-MP parameters +USE module_sf_noahmplsm,only:isWater ! parameter for water land cover type +USE nr_utility_module,only:arth ! get a sequence of numbers +USE ascii_util_module,only:file_open ! open ascii file +USE ascii_util_module,only:get_vlines ! read a vector of non-comment lines from an ASCII file +USE ascii_util_module,only:split_line ! extract the list of variable names from the character string +use time_utils_module,only:elapsedSec ! calculate the elapsed time +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 +USE childStruc_module,only:childStruc ! module to create a child data structure USE mDecisions_module,only:mDecisions ! module to read model decisions 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 def_output_module,only:def_output ! module to define model output USE ffile_info_module,only:ffile_info ! module to read information on forcing datafile +USE read_attrb_module,only:read_dimension ! module to read dimensions of GRU and HRU USE read_attrb_module,only:read_attrb ! module to read local attributes USE read_pinit_module,only:read_pinit ! module to read initial model parameter values USE paramCheck_module,only:paramCheck ! module to check consistency of model parameters +USE check_icond_module,only:check_icond ! module to check initial conditions USE read_icond_module,only:read_icond ! module to read initial conditions +USE read_icond_module,only:read_icond_nlayers ! module to read initial conditions +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 var_derive_module,only:calcHeight ! module to calculate height at layer interfaces and layer mid-point @@ -54,46 +61,85 @@ program multi_driver USE var_derive_module,only:fracFuture ! module to calculate the fraction of runoff in future time steps (time delay histogram) USE read_force_module,only:read_force ! module to read model forcing data USE derivforce_module,only:derivforce ! module to compute derived forcing data -USE modelwrite_module,only:writeAttrb,writeParam ! module to write model attributes and parameters -USE modelwrite_module,only:writeForce ! module to write model forcing data -USE modelwrite_module,only:writeModel,writeBasin ! module to write model output +USE modelwrite_module,only:writeParm,writeTime ! module to write model attributes and parameters +USE modelwrite_module,only:writeData,writeBasin ! module to write model output +USE modelwrite_module,only:writeRestart ! module to write model Restart +USE vegPhenlgy_module,only:vegPhenlgy ! module to compute vegetation phenology USE coupled_em_module,only:coupled_em ! module to run the coupled energy and mass model USE groundwatr_module,only:groundwatr ! module to simulate regional groundwater balance USE qTimeDelay_module,only:qOverland ! module to route water through an "unresolved" river network -! provide access to data +USE netcdf_util_module,only:nc_file_close ! module to handle netcdf stuff for inputs and outputs +! provide access to file paths USE summaFileManager,only:SETNGS_PATH ! define path to settings files (e.g., Noah vegetation tables) +USE summaFileManager,only:MODEL_INITCOND ! name of model initial conditions file +USE summaFileManager,only:LOCAL_ATTRIBUTES ! name of model initial attributes file USE summaFileManager,only:OUTPUT_PATH,OUTPUT_PREFIX ! define output file USE summaFileManager,only:LOCALPARAM_INFO,BASINPARAM_INFO ! files defining the default values and constraints for model parameters -USE data_struc,only:doJacobian ! flag to compute the Jacobian -USE data_struc,only:localParFallback ! local column default parameters -USE data_struc,only:basinParFallback ! basin-average default parameters -USE data_struc,only:mpar_meta,bpar_meta ! metadata for local column and basin-average model parameters -USE data_struc,only:numtim ! number of time steps -USE data_struc,only:time_data,time_hru,refTime ! time and reference time -USE data_struc,only:forc_data,forc_hru ! model forcing data -USE data_struc,only:type_data,type_hru ! classification of veg, soils etc. -USE data_struc,only:attr_data,attr_hru ! local attributes (lat, lon, elev, etc.) -USE data_struc,only:mpar_data,mpar_hru ! local column model parameters -USE data_struc,only:mvar_data,mvar_hru ! local column model variables -USE data_struc,only:indx_data,indx_hru ! local column model indices -USE data_struc,only:bpar_data ! basin-average model parameters -USE data_struc,only:bvar_data ! basin-average model variables -USE data_struc,only:model_decisions ! model decisions -USE data_struc,only:urbanVegCategory ! vegetation category for urban areas -USE data_struc,only:globalPrintFlag ! global print flag +! provide access to the derived types to define the data structures +USE data_types,only:& + ! no spatial dimension + var_i, & ! x%var(:) (i4b) + var_d, & ! x%var(:) (dp) + var_ilength, & ! x%var(:)%dat (i4b) + var_dlength, & ! x%var(:)%dat (dp) + ! no variable dimension + hru_i, & ! x%hru(:) (i4b) + hru_d, & ! x%hru(:) (dp) + ! gru dimension + gru_int, & ! x%gru(:)%var(:) (i4b) + 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_double, & ! x%gru(:)%hru(:)%var(:) (dp) + gru_hru_intVec, & ! x%gru(:)%hru(:)%var(:)%dat (i4b) + gru_hru_doubleVec ! x%gru(:)%hru(:)%var(:)%dat (dp) +USE data_types,only:extended_info ! extended metadata structure +! provide access to runtime options +USE globalData,only:iRunModeFull,iRunModeGRU,iRunModeHRU +! provide access to metadata structures +USE globalData,only:time_meta,forc_meta,attr_meta,type_meta ! metadata structures +USE globalData,only:prog_meta,diag_meta,flux_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:model_decisions ! model decision structure +! provide access to global data +USE globalData,only:refTime ! reference time +USE globalData,only:startTime ! start time +USE globalData,only:finshTime ! end time +USE globalData,only:doJacobian ! flag to compute the Jacobian +USE globalData,only:gru_struc ! gru-hru mapping structures +USE globalData,only:localParFallback ! local column default parameters +USE globalData,only:basinParFallback ! basin-average default parameters +USE globalData,only:structInfo ! information on the data structures +USE globalData,only:numtim ! number of time steps +USE globalData,only:urbanVegCategory ! vegetation category for urban areas +USE globalData,only:globalPrintFlag ! global print flag +USE globalData,only:integerMissing ! missing integer value +! provide access to Noah-MP parameters USE NOAHMP_VEG_PARAMETERS,only:SAIM,LAIM ! 2-d tables for stem area index and leaf area index (vegType,month) USE NOAHMP_VEG_PARAMETERS,only:HVT,HVB ! height at the top and bottom of vegetation (vegType) -! named variables for elements of model structures +USE noahmp_globals,only:RSMIN ! minimum stomatal resistance (vegType) +USE var_lookup,only:maxvarForc,maxvarProg,maxvarDiag ! size of variable vectors +USE var_lookup,only:maxvarFlux,maxvarIndx,maxvarBvar ! size of variable vectors +! provide access to the named variables that describe elements of parent model structures USE var_lookup,only:iLookTIME,iLookFORCE ! look-up values for time and forcing data structures USE var_lookup,only:iLookTYPE ! look-up values for classification of veg, soils etc. USE var_lookup,only:iLookATTR ! look-up values for local attributes -USE var_lookup,only:iLookMVAR ! look-up values for local column model variables USE var_lookup,only:iLookPARAM ! look-up values for local column model parameters USE var_lookup,only:iLookINDEX ! look-up values for local column index variables +USE var_lookup,only:iLookPROG ! look-up values for local column model prognostic (state) variables +USE var_lookup,only:iLookDIAG ! look-up values for local column model diagnostic variables +USE var_lookup,only:iLookFLUX ! look-up values for local column model fluxes USE var_lookup,only:iLookBVAR ! look-up values for basin-average model variables USE var_lookup,only:iLookBPAR ! look-up values for basin-average model parameters USE var_lookup,only:iLookDECISIONS ! look-up values for model decisions -! named variables for model decisions +USE var_lookup,only:iLookVarType ! look-up values for variable type structure +! provide access to the named variables that describe elements of child model structures +USE var_lookup,only:childFLUX_MEAN ! look-up values for timestep-average model fluxes +! provide access to the named variables that describe model decisions USE mDecisions_module,only: & ! look-up values for method used to compute derivative numerical, & ! numerical solution analytical ! analytical solution @@ -103,562 +149,1161 @@ program multi_driver 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 +USE output_stats,only:calcStats ! module for compiling output statistics +USE globalData,only:nFreq,outFreq ! model output files +USE globalData,only:ncid ! file id of netcdf output file +USE var_lookup,only:maxFreq ! maximum # of output files implicit none ! ***************************************************************************** ! (0) variable definitions ! ***************************************************************************** -! define counters -integer(i4b) :: iHRU,jHRU,kHRU ! index of the hydrologic response unit -integer(i4b) :: nHRU ! number of hydrologic response units -integer(i4b) :: iStep=0 ! index of model time step -integer(i4b) :: jStep=0 ! index of model output +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 +type(gru_hru_doubleVec) :: diagStat ! x%gru(:)%hru(:)%var(:)%dat -- model diagnostic variables +type(gru_hru_doubleVec) :: fluxStat ! x%gru(:)%hru(:)%var(:)%dat -- model fluxes +type(gru_hru_doubleVec) :: indxStat ! x%gru(:)%hru(:)%var(:)%dat -- model indices +type(gru_doubleVec) :: bvarStat ! x%gru(:)%var(:)%dat -- basin-average variabl +! define the primary data structures (scalars) +type(var_i) :: timeStruct ! x%var(:) -- model time data +type(gru_hru_double) :: forcStruct ! x%gru(:)%hru(:)%var(:) -- model forcing data +type(gru_hru_double) :: attrStruct ! x%gru(:)%hru(:)%var(:) -- local attributes for each HRU +type(gru_hru_int) :: typeStruct ! x%gru(:)%hru(:)%var(:) -- local classification of soil veg etc. for each HRU +! define the primary data structures (variable length vectors) +type(gru_hru_intVec) :: indxStruct ! x%gru(:)%hru(:)%var(:)%dat -- model indices +type(gru_hru_doubleVec) :: mparStruct ! x%gru(:)%hru(:)%var(:)%dat -- model parameters +type(gru_hru_doubleVec) :: progStruct ! x%gru(:)%hru(:)%var(:)%dat -- model prognostic (state) variables +type(gru_hru_doubleVec) :: diagStruct ! x%gru(:)%hru(:)%var(:)%dat -- model diagnostic variables +type(gru_hru_doubleVec) :: fluxStruct ! x%gru(:)%hru(:)%var(:)%dat -- model fluxes +! define the basin-average structures +type(gru_double) :: bparStruct ! x%gru(:)%var(:) -- basin-average parameters +type(gru_doubleVec) :: bvarStruct ! x%gru(:)%var(:)%dat -- basin-average variables +! define the ancillary data structures +type(gru_hru_double) :: dparStruct ! x%gru(:)%hru(:)%var(:) -- default model parameters +! define indices +integer(i4b) :: iStruct ! loop through data structures +integer(i4b) :: iGRU +integer(i4b) :: iHRU,jHRU,kHRU ! index of the hydrologic response unit +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 +integer(i4b) :: modelTimeStep=0 ! index of model time step +integer(i4b) :: waterYearTimeStep=0 ! index of water year +integer(i4b),dimension(maxFreq) :: outputTimeStep=0 ! timestep in output files +! define the time output +logical(lgt) :: printProgress ! flag to print progress +integer(i4b),parameter :: ixProgress_im=1000 ! named variable to print progress once per month +integer(i4b),parameter :: ixProgress_id=1001 ! named variable to print progress once per day +integer(i4b),parameter :: ixProgress_ih=1002 ! named variable to print progress once per hour +integer(i4b),parameter :: ixProgress_never=1003 ! named variable to print progress never +integer(i4b) :: ixProgress=ixProgress_id ! define frequency to write progress ! define the re-start file -logical(lgt) :: printRestart ! flag to print a re-start file -integer(i4b),parameter :: ixRestart_im=1001 ! named variable to print a re-start file once per month -integer(i4b),parameter :: ixRestart_id=1002 ! named variable to print a re-start file once per day -integer(i4b),parameter :: ixRestart_never=1003 ! named variable to print a re-start file never -integer(i4b) :: ixRestart=ixRestart_never ! define frequency to write restart files +logical(lgt) :: printRestart ! flag to print a re-start file +integer(i4b),parameter :: ixRestart_iy=1000 ! named variable to print a re-start file once per year +integer(i4b),parameter :: ixRestart_im=1001 ! named variable to print a re-start file once per month +integer(i4b),parameter :: ixRestart_id=1002 ! named variable to print a re-start file once per day +integer(i4b),parameter :: ixRestart_never=1003 ! named variable to print a re-start file never +integer(i4b) :: ixRestart=ixRestart_never ! define frequency to write restart files ! define output file -character(len=8) :: cdate1='' ! initial date -character(len=10) :: ctime1='' ! initial time -character(len=64) :: output_fileSuffix='' ! suffix for the output file -character(len=256) :: summaFileManagerFile='' ! path/name of file defining directories and files -character(len=256) :: fileout='' ! output filename -! define pointers for model indices -integer(i4b),pointer :: nSnow=>null() ! number of snow layers -integer(i4b),pointer :: nSoil=>null() ! number of soil layers -integer(i4b),pointer :: nLayers=>null() ! total number of layers -integer(i4b),pointer :: midSnowStartIndex=>null() ! start index of the midSnow vector for a given timestep -integer(i4b),pointer :: midSoilStartIndex=>null() ! start index of the midSoil vector for a given timestep -integer(i4b),pointer :: midTotoStartIndex=>null() ! start index of the midToto vector for a given timestep -integer(i4b),pointer :: ifcSnowStartIndex=>null() ! start index of the ifcSnow vector for a given timestep -integer(i4b),pointer :: ifcSoilStartIndex=>null() ! start index of the ifcSoil vector for a given timestep -integer(i4b),pointer :: ifcTotoStartIndex=>null() ! start index of the ifcToto vector for a given timestep -real(dp),allocatable :: dt_init(:) ! used to initialize the length of the sub-step for each HRU -real(dp),pointer :: totalArea=>null() ! total basin area (m2) -! exfiltration -real(dp),parameter :: supersatScale=0.001_dp ! scaling factor for the logistic function (-) -real(dp),parameter :: xMatch = 0.99999_dp ! point where x-value and function value match (-) -real(dp),parameter :: safety = 0.01_dp ! safety factor to ensure logistic function is less than 1 -real(dp),parameter :: fSmall = epsilon(xMatch) ! smallest possible value to test -real(dp),allocatable :: upArea(:) ! area upslope of each HRU -! general local variables -real(dp) :: fracHRU ! fractional area of a given HRU (-) -real(dp),allocatable :: zSoilReverseSign(:) ! height at bottom of each soil layer, negative downwards (m) -real(dp),dimension(12) :: greenVegFrac_monthly ! fraction of green vegetation in each month (0-1) -real(dp),parameter :: doubleMissing=-9999._dp ! missing value +integer(i4b) :: ctime1(8) ! initial time +character(len=256) :: output_fileSuffix='' ! suffix for the output file +character(len=256) :: summaFileManagerFile='' ! path/name of file defining directories and files +character(len=256) :: fileout='' ! output filename +! define model control structures +integer(i4b) :: nLayers ! total number of layers +integer(i4b),parameter :: no=0 ! .false. +integer(i4b),parameter :: yes=1 ! .true. +logical(lgt) :: computeVegFluxFlag ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) +type(hru_i),allocatable :: computeVegFlux(:) ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) +type(hru_d),allocatable :: dt_init(:) ! used to initialize the length of the sub-step for each HRU +type(hru_d),allocatable :: upArea(:) ! area upslope of each HRU +! general local variables +integer(i4b) :: ivar ! index of model variable +real(dp) :: fracHRU ! fractional area of a given HRU (-) +logical(lgt) :: flux_mask(maxvarFlux) ! mask defining desired flux variables +integer(i4b) :: forcNcid=integerMissing ! netcdf id for current netcdf forcing file +integer(i4b) :: iFile=1 ! index of current forcing file from forcing file list +integer(i4b) :: forcingStep=integerMissing ! index of current time step in current forcing file +real(dp),allocatable :: zSoilReverseSign(:) ! height at bottom of each soil layer, negative downwards (m) +real(dp),dimension(12) :: greenVegFrac_monthly ! fraction of green vegetation in each month (0-1) +logical(lgt),parameter :: overwriteRSMIN=.false. ! flag to overwrite RSMIN +real(dp) :: notUsed_canopyDepth ! NOT USED: canopy depth (m) +real(dp) :: notUsed_exposedVAI ! NOT USED: exposed vegetation area index (m2 m-2) ! error control -integer(i4b) :: err=0 ! error code -character(len=1024) :: message='' ! error message - +integer(i4b) :: err=0 ! error code +character(len=1024) :: message='' ! error message +! output control +integer(i4b) :: iFreq ! index for looping through output files +logical(lgt) :: statForc_mask(maxvarForc) ! mask defining forc stats +logical(lgt) :: statProg_mask(maxvarProg) ! mask defining prog stats +logical(lgt) :: statDiag_mask(maxvarDiag) ! mask defining diag stats +logical(lgt) :: statFlux_mask(maxvarFlux) ! mask defining flux stats +logical(lgt) :: statIndx_mask(maxvarIndx) ! mask defining indx stats +logical(lgt) :: statBvar_mask(maxvarBvar) ! mask defining bvar stats +integer(i4b),allocatable :: forcChild_map(:) ! index of the child data structure: stats forc +integer(i4b),allocatable :: progChild_map(:) ! index of the child data structure: stats prog +integer(i4b),allocatable :: diagChild_map(:) ! index of the child data structure: stats diag +integer(i4b),allocatable :: fluxChild_map(:) ! index of the child data structure: stats flux +integer(i4b),allocatable :: indxChild_map(:) ! index of the child data structure: stats indx +integer(i4b),allocatable :: bvarChild_map(:) ! index of the child data structure: stats bvar +type(extended_info),allocatable :: statForc_meta(:) ! child metadata for stats +type(extended_info),allocatable :: statProg_meta(:) ! child metadata for stats +type(extended_info),allocatable :: statDiag_meta(:) ! child metadata for stats +type(extended_info),allocatable :: statFlux_meta(:) ! child metadata for stats +type(extended_info),allocatable :: statIndx_meta(:) ! child metadata for stats +type(extended_info),allocatable :: statBvar_meta(:) ! child metadata for stats +! stuff for restart file +character(len=256) :: timeString ! protion of restart file name that contains the write-out time +character(len=256) :: restartFile ! restart file name +character(len=256) :: attrFile ! attributes file name +! parallelize the model run +integer(i4b) :: startGRU ! index of the starting GRU for parallelization run +integer(i4b) :: checkHRU ! index of the HRU for a single HRU run +integer(i4b) :: fileGRU ! number of GRUs in the input file +integer(i4b) :: fileHRU ! number of HRUs in the input file +integer(i4b) :: iRunMode ! define the current running mode +character(len=128) :: fmtGruOutput ! a format string used to write start and end GRU in output file names + ! version information generated during compiling +INCLUDE 'summaversion.inc' ! ***************************************************************************** ! (1) inital priming -- get command line arguments, identify files, etc. ! ***************************************************************************** -print*, 'start' +! get the command line arguments +call getCommandArguments() + ! get the initial time -call date_and_time(cdate1,ctime1) -print*,ctime1 -! get command-line arguments for the output file suffix -call getarg(1,output_fileSuffix) -if (len_trim(output_fileSuffix) == 0) then - print*,'1st command-line argument missing, expect text string defining the output file suffix'; stop -endif -! get command-line argument for the muster file -call getarg(2,summaFileManagerFile) ! path/name of file defining directories and files -if (len_trim(summaFileManagerFile) == 0) then - print*,'2nd command-line argument missing, expect path/name of muster file'; stop -endif +call date_and_time(values=ctime1) +print "(A,I2.2,':',I2.2,':',I2.2)", 'start at ',ctime1(5:7) + ! set directories and files -- summaFileManager used as command-line argument call summa_SetDirsUndPhiles(summaFileManagerFile,err,message); call handle_err(err,message) + ! initialize the Jacobian flag doJacobian=.false. +! allocate time structures +call allocLocal(time_meta, refTime, err=err, message=message); call handle_err(err,message) ! reference time for the model simulation +call allocLocal(time_meta, startTime, err=err, message=message); call handle_err(err,message) ! start time for the model simulation +call allocLocal(time_meta, finshTime, err=err, message=message); call handle_err(err,message) ! end time for the model simulation + ! ***************************************************************************** -! (2) read model metadata +! (2) populate/check metadata structures ! ***************************************************************************** -! initialize model metadata structures -call init_metad(err,message); call handle_err(err,message) ! populate metadata for all model variables call popMetadat(err,message); call handle_err(err,message) -! read default values and constraints for model parameters (local column, and basin-average) -call read_pinit(LOCALPARAM_INFO,.TRUE., mpar_meta,localParFallback,err,message); call handle_err(err,message) -call read_pinit(BASINPARAM_INFO,.FALSE.,bpar_meta,basinParFallback,err,message); call handle_err(err,message) + +! define mapping between fluxes and states +call flxMapping(err,message); call handle_err(err,message) + +! check data structures +call checkStruc(err,message); call handle_err(err,message) + +! 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, message) +call handle_err(err,message) ! ***************************************************************************** -! (3) read information for each HRU and allocate space for data structures +! (3a) read the number of GRUs and HRUs, and allocate the gru-hru mapping structures ! ***************************************************************************** -! read local attributes for each HRU -call read_attrb(nHRU,err,message); call handle_err(err,message) -! allocate space for HRU data structures -! NOTE: attr_hru and type_hru are defined in read_attrb -call alloc_mpar(nHRU,err,message); call handle_err(err,message) -call alloc_mvar(nHRU,err,message); call handle_err(err,message) -call alloc_indx(nHRU,err,message); call handle_err(err,message) -! allocate space for basin data structures -call alloc_bpar(err,message); call handle_err(err,message) -call alloc_bvar(err,message); call handle_err(err,message) -! allocate space for the forcing and time structures -call alloc_forc(nHRU,err,message); call handle_err(err,message) -call alloc_time(nHRU,err,message); call handle_err(err,message) -call alloc_stim(refTime,err,message); call handle_err(err,message) -! allocate space for the time step (recycled for each HRU for subsequent calls to coupled_em) -allocate(dt_init(nHRU),stat=err); call handle_err(err,'problem allocating space for dt_init') +! obtain the HRU and GRU dimensions in the LocalAttribute file +attrFile = trim(SETNGS_PATH)//trim(LOCAL_ATTRIBUTES) +select case (iRunMode) + case(iRunModeFull); call read_dimension(trim(attrFile),fileGRU,fileHRU,nGRU,nHRU,err,message) + case(iRunModeGRU ); call read_dimension(trim(attrFile),fileGRU,fileHRU,nGRU,nHRU,err,message,startGRU=startGRU) + case(iRunModeHRU ); call read_dimension(trim(attrFile),fileGRU,fileHRU,nGRU,nHRU,err,message,checkHRU=checkHRU) +end select +call handle_err(err,message) ! ***************************************************************************** -! (4a) read description of model forcing datafile used in each HRU +! (3b) read model attributes ! ***************************************************************************** -call ffile_info(nHRU,err,message); call handle_err(err,message) +! read number of snow and soil layers +restartFile = trim(SETNGS_PATH)//trim(MODEL_INITCOND) +call read_icond_nlayers(trim(restartFile),nGRU,indx_meta,err,message) +call handle_err(err,message) ! ***************************************************************************** -! (4b) read model decisions +! (3c) allocate space for other data structures +! ***************************************************************************** +! loop through data structures +do iStruct=1,size(structInfo) + ! allocate space + select case(trim(structInfo(iStruct)%structName)) + case('time'); call allocGlobal(time_meta, timeStruct, err, message) ! model forcing data + case('forc'); call allocGlobal(forc_meta, forcStruct, err, message) ! model forcing data + case('attr'); call allocGlobal(attr_meta, attrStruct, err, message) ! local attributes for each HRU + case('type'); call allocGlobal(type_meta, typeStruct, err, message) ! local classification of soil veg etc. for each HRU + case('mpar'); call allocGlobal(mpar_meta, mparStruct, err, message) ! model parameters + case('indx'); call allocGlobal(indx_meta, indxStruct, err, message) ! model variables + case('prog'); call allocGlobal(prog_meta, progStruct, err, message) ! model prognostic (state) variables + case('diag'); call allocGlobal(diag_meta, diagStruct, err, message) ! model diagnostic variables + case('flux'); call allocGlobal(flux_meta, fluxStruct, err, message) ! model fluxes + case('bpar'); call allocGlobal(bpar_meta, bparStruct, err, message) ! basin-average parameters + case('bvar'); call allocGlobal(bvar_meta, bvarStruct, err, message) ! basin-average variables + case('deriv'); cycle + case default; err=20; message='unable to find structure name: '//trim(structInfo(iStruct)%structName) + end select + ! check errors + call handle_err(err,trim(message)//'[structure = '//trim(structInfo(iStruct)%structName)//']') +end do ! looping through data structures + +! ***************************************************************************** +! (3c) allocate space for other 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,message) ! default model parameters +call handle_err(err,trim(message)//' [problem allocating dparStruct]') + +! allocate space for the time step and computeVegFlux flags (recycled for each GRU for subsequent calls to coupled_em) +allocate(dt_init(nGRU),upArea(nGRU),computeVegFlux(nGRU),stat=err) +call handle_err(err,'problem allocating space for dt_init, upArea, or computeVegFlux [GRU]') + +! allocate space for the HRUs +do iGRU=1,nGRU + hruCount = gru_struc(iGRU)%hruCount + allocate(dt_init(iGRU)%hru(hruCount),upArea(iGRU)%hru(hruCount),computeVegFlux(iGRU)%hru(hruCount),stat=err) + call handle_err(err,'problem allocating space for dt_init, upArea, or computeVegFlux [HRU]') +end do + +! ***************************************************************************** +! (4a) read local attributes for each HRU +! ***************************************************************************** +call read_attrb(trim(attrFile),nGRU,attrStruct,typeStruct,err,message) +call handle_err(err,message) + +! ***************************************************************************** +! (4b) read description of model forcing datafile used in each HRU +! ***************************************************************************** +call ffile_info(nGRU,err,message); call handle_err(err,message) + +! ***************************************************************************** +! (4c) read model decisions ! ***************************************************************************** call mDecisions(err,message); call handle_err(err,message) ! ***************************************************************************** -! (5a) read Noah vegetation and soil tables +! (4d) allocate space for output statistics data structures +! ***************************************************************************** +! 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(:)%outfreq>0)) +statProg_mask = ((prog_meta(:)%vartype==iLookVarType%scalarv).and.(prog_meta(:)%outfreq>0)) +statDiag_mask = ((diag_meta(:)%vartype==iLookVarType%scalarv).and.(diag_meta(:)%outfreq>0)) +statFlux_mask = ((flux_meta(:)%vartype==iLookVarType%scalarv).and.(flux_meta(:)%outfreq>0)) +statIndx_mask = ((indx_meta(:)%vartype==iLookVarType%scalarv).and.(indx_meta(:)%outfreq>0)) +statBvar_mask = ((bvar_meta(:)%vartype==iLookVarType%scalarv).and.(bvar_meta(:)%outfreq>0)) + +! 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,message) + case('prog'); call childStruc(prog_meta,statProg_mask,statProg_meta,progChild_map,err,message) + case('diag'); call childStruc(diag_meta,statDiag_mask,statDiag_meta,diagChild_map,err,message) + case('flux'); call childStruc(flux_meta,statFlux_mask,statFlux_meta,fluxChild_map,err,message) + case('indx'); call childStruc(indx_meta,statIndx_mask,statIndx_meta,indxChild_map,err,message) + case('bvar'); call childStruc(bvar_meta,statBvar_mask,statBvar_meta,bvarChild_map,err,message) + end select + ! check errors + call handle_err(err,trim(message)//'[statistics for = '//trim(structInfo(iStruct)%structName)//']') +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 + +! 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,message) ! model forcing data + case('prog'); call allocGlobal(statProg_meta(:)%var_info,progStat,err,message) ! model prognostic (state) variables + case('diag'); call allocGlobal(statDiag_meta(:)%var_info,diagStat,err,message) ! model diagnostic variables + case('flux'); call allocGlobal(statFlux_meta(:)%var_info,fluxStat,err,message) ! model fluxes + case('indx'); call allocGlobal(statIndx_meta(:)%var_info,indxStat,err,message) ! index vars + case('bvar'); call allocGlobal(statBvar_meta(:)%var_info,bvarStat,err,message) ! basin-average variables + case default; cycle + end select + ! check errors + call handle_err(err,trim(message)//'[statistics for = '//trim(structInfo(iStruct)%structName)//']') +end do ! iStruct + +! ***************************************************************************** +! (5a) read default model parameters +! ***************************************************************************** +! read default values and constraints for model parameters (local column, and basin-average) +call read_pinit(LOCALPARAM_INFO,.TRUE., mpar_meta,localParFallback,err,message); call handle_err(err,message) +call read_pinit(BASINPARAM_INFO,.FALSE.,bpar_meta,basinParFallback,err,message); call handle_err(err,message) + +! ***************************************************************************** +! (5b) read Noah vegetation and soil tables ! ***************************************************************************** ! define monthly fraction of green vegetation -! J F M A M J J A S O N D greenVegFrac_monthly = (/0.01_dp, 0.02_dp, 0.03_dp, 0.07_dp, 0.50_dp, 0.90_dp, 0.95_dp, 0.96_dp, 0.65_dp, 0.24_dp, 0.11_dp, 0.02_dp/) + ! read Noah soil and vegetation tables call soil_veg_gen_parm(trim(SETNGS_PATH)//'VEGPARM.TBL', & ! filename for vegetation table trim(SETNGS_PATH)//'SOILPARM.TBL', & ! filename for soils table trim(SETNGS_PATH)//'GENPARM.TBL', & ! filename for general table trim(model_decisions(iLookDECISIONS%vegeParTbl)%cDecision), & ! classification system used for vegetation trim(model_decisions(iLookDECISIONS%soilCatTbl)%cDecision)) ! classification system used for soils + ! read Noah-MP vegetation tables call read_mp_veg_parameters(trim(SETNGS_PATH)//'MPTABLE.TBL', & ! filename for Noah-MP table trim(model_decisions(iLookDECISIONS%vegeParTbl)%cDecision)) ! classification system used for vegetation + ! define urban vegetation category select case(trim(model_decisions(iLookDECISIONS%vegeParTbl)%cDecision)) - case('USGS'); urbanVegCategory=1 - case('MODIFIED_IGBP_MODIS_NOAH'); urbanVegCategory=13 + case('USGS'); urbanVegCategory = 1 + case('MODIFIED_IGBP_MODIS_NOAH'); urbanVegCategory = 13 + case('plumberCABLE'); urbanVegCategory = -999 + case('plumberCHTESSEL'); urbanVegCategory = -999 + case('plumberSUMMA'); urbanVegCategory = -999 case default; call handle_err(30,'unable to identify vegetation category') end select +! set default model parameters +do iGRU=1,nGRU + do iHRU=1,gru_struc(iGRU)%hruCount + ! set parmameters 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 + dparStruct%gru(iGRU)%hru(iHRU)%var, & ! default model parameters + err,message); call handle_err(err,message) ! error control + ! copy over to the parameter structure + ! NOTE: constant for the dat(:) dimension (normally depth) + do ivar=1,size(localParFallback) + mparStruct%gru(iGRU)%hru(iHRU)%var(ivar)%dat(:) = dparStruct%gru(iGRU)%hru(iHRU)%var(ivar) + end do ! looping through variables + end do ! looping through HRUs + ! set default for basin-average parameters + bparStruct%gru(iGRU)%var(:) = basinParFallback(:)%default_val +end do ! looping through GRUs + ! ***************************************************************************** -! (5b) read trial model parameter values for each HRU, and populate initial data structures -! ***************************************************************************** -call read_param(nHRU,err,message); call handle_err(err,message) -bpar_data%var(:) = basinParFallback(:)%default_val - -! ***************************************************************************** -! (5c) compute derived model variables that are pretty much constant for the basin as a whole -! ***************************************************************************** -call fracFuture(err,message); call handle_err(err,message) ! calculate the fraction of runoff in future time steps - -! loop through HRUs -do iHRU=1,nHRU - - ! assign the structures to the appropriate HRUs - attr_data => attr_hru(iHRU) - type_data => type_hru(iHRU) - mpar_data => mpar_hru(iHRU) - mvar_data => mvar_hru(iHRU) - indx_data => indx_hru(iHRU) - - ! check that the parameters are consistent - call paramCheck(err,message); call handle_err(err,message) - ! read description of model initial conditions -- also initializes model structure components - ! NOTE: at this stage the same initial conditions are used for all HRUs -- need to modify - call read_icond(err,message); call handle_err(err,message) - print*, 'aquifer storage = ', mvar_data%var(iLookMVAR%scalarAquiferStorage)%dat(1) - ! assign pointers to model layers - ! NOTE: layer structure is different for each HRU - nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) - nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1) - nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1) - ! re-calculate height of each layer - call calcHeight(& - ! input/output: data structures - indx_data, & ! intent(in): layer type - mvar_data, & ! intent(inout): model variables for a local HRU - ! output: error control - err,message); call handle_err(err,message) - ! compute derived model variables that are pretty much constant over each HRU - call E2T_lookup(err,message); call handle_err(err,message) ! calculate a look-up table for the temperature-enthalpy conversion - call rootDensty(err,message); call handle_err(err,message) ! calculate vertical distribution of root density - call satHydCond(err,message); call handle_err(err,message) ! calculate saturated hydraulic conductivity in each soil layer - call v_shortcut(err,message); call handle_err(err,message) ! calculate "short-cut" variables such as volumetric heat capacity - ! overwrite the vegetation height - HVT(type_data%var(iLookTYPE%vegTypeIndex)) = mpar_data%var(iLookPARAM%heightCanopyTop) - HVB(type_data%var(iLookTYPE%vegTypeIndex)) = mpar_data%var(iLookPARAM%heightCanopyBottom) - ! overwrite the tables for LAI and SAI - if(model_decisions(iLookDECISIONS%LAI_method)%iDecision == specified)then - SAIM(type_data%var(iLookTYPE%vegTypeIndex),:) = mpar_data%var(iLookPARAM%winterSAI) - LAIM(type_data%var(iLookTYPE%vegTypeIndex),:) = mpar_data%var(iLookPARAM%summerLAI)*greenVegFrac_monthly - endif - ! initialize canopy drip - ! NOTE: canopy drip from the previous time step is used to compute throughfall for the current time step - mvar_hru(iHRU)%var(iLookMVAR%scalarCanopyLiqDrainage)%dat(1) = 0._dp ! not used - ! define the filename for model spinup - write(fileout,'(a,i0,a,i0,a)') trim(OUTPUT_PATH)//trim(OUTPUT_PREFIX)//'_spinup'//trim(output_fileSuffix)//'.nc' - ! define the file if the first parameter set - if(iHRU==1) then - call def_output(nHRU,fileout,err,message); call handle_err(err,message) - endif - ! write local model attributes and parameters to the model output file - call writeAttrb(fileout,iHRU,err,message); call handle_err(err,message) - call writeParam(fileout,iHRU,err,message); call handle_err(err,message) - ! initialize indices - indx_data%var(iLookINDEX%midSnowStartIndex)%dat(1) = 1 - indx_data%var(iLookINDEX%midSoilStartIndex)%dat(1) = 1 - indx_data%var(iLookINDEX%midTotoStartIndex)%dat(1) = 1 - indx_data%var(iLookINDEX%ifcSnowStartIndex)%dat(1) = 1 - indx_data%var(iLookINDEX%ifcSoilStartIndex)%dat(1) = 1 - indx_data%var(iLookINDEX%ifcTotoStartIndex)%dat(1) = 1 - -end do ! (looping through HRUs) - -! allocate space for the upslope area -allocate(upArea(nHRU),stat=err); call handle_err(err,'problem allocating space for upArea') - -! identify the total basin area (m2) -totalArea => bvar_data%var(iLookBVAR%basin__totalArea)%dat(1) -totalArea = 0._dp -do iHRU=1,nHRU - totalArea = totalArea + attr_hru(iHRU)%var(iLookATTR%HRUarea) -end do +! (5c) read trial model parameter values for each HRU, and populate initial data structures +! ***************************************************************************** +call read_param(iRunMode,checkHRU,startGRU,nHRU,nGRU,typeStruct,mparStruct,bparStruct,err,message); call handle_err(err,message) + +! ***************************************************************************** +! (5d) compute derived model variables that are pretty much constant for the basin as a whole +! ***************************************************************************** +! loop through GRUs +do iGRU=1,nGRU -! compute total area of the upstream HRUS that flow into each HRU -do iHRU=1,nHRU - upArea(iHRU) = 0._dp - do jHRU=1,nHRU - ! check if jHRU flows into iHRU - if(type_hru(jHRU)%var(iLookTYPE%downHRUindex) == type_hru(iHRU)%var(iLookTYPE%hruIndex))then - upArea(iHRU) = upArea(iHRU) + attr_hru(jHRU)%var(iLookATTR%HRUarea) - endif ! (if jHRU is an upstream HRU) - end do ! jHRU -end do ! iHRU - -! initialize aquifer storage -! NOTE: this is ugly: need to add capabilities to initialize basin-wide state variables -select case(model_decisions(iLookDECISIONS%spatial_gw)%iDecision) - case(localColumn) - bvar_data%var(iLookBVAR%basin__AquiferStorage)%dat(1) = 0._dp ! not used - case(singleBasin) - bvar_data%var(iLookBVAR%basin__AquiferStorage)%dat(1) = 1._dp - do iHRU=1,nHRU - mvar_hru(iHRU)%var(iLookMVAR%scalarAquiferStorage)%dat(1) = 0._dp ! not used + ! calculate the fraction of runoff in future time steps + call fracFuture(bparStruct%gru(iGRU)%var, & ! vector of basin-average model parameters + bvarStruct%gru(iGRU), & ! data structure of basin-average variables + err,message) ! error control + call handle_err(err,message) + + ! loop through local HRUs + do iHRU=1,gru_struc(iGRU)%hruCount + + kHRU=0 + ! check the network topology (only expect there to be one downslope HRU) + do jHRU=1,gru_struc(iGRU)%hruCount + if(typeStruct%gru(iGRU)%hru(iHRU)%var(iLookTYPE%downHRUindex) == typeStruct%gru(iGRU)%hru(jHRU)%var(iLookTYPE%hruIndex))then + if(kHRU==0)then ! check there is a unique match + kHRU=jHRU + else + call handle_err(20,'multi_driver: only expect there to be one downslope HRU') + end if ! (check there is a unique match) + end if ! (if identified a downslope HRU) end do - case default; call handle_err(20,'unable to identify decision for regional representation of groundwater') -endselect + + ! check that the parameters are consistent + call paramCheck(mparStruct%gru(iGRU)%hru(iHRU),err,message); call handle_err(err,message) + + ! calculate a look-up table for the temperature-enthalpy conversion + call E2T_lookup(mparStruct%gru(iGRU)%hru(iHRU),err,message); call handle_err(err,message) + + end do ! HRU +end do ! GRU + +! read description of model initial conditions -- also initializes model structure components +! NOTE: at this stage the same initial conditions are used for all HRUs -- need to modify +call read_icond(restartFile, & ! name of initial conditions file + nGRU, & ! number of response units + prog_meta, & ! metadata + progStruct, & ! model prognostic (state) variables + indxStruct, & ! layer indexes + err,message) ! error control +call handle_err(err,message) + +! check initial conditions +call check_icond(nGRU, & ! number of response units + progStruct, & ! model prognostic (state) variables + mparStruct, & ! model parameters + indxStruct, & ! layer indexes + err,message) ! error control +call handle_err(err,message) + +! loop through GRUs +do iGRU=1,nGRU + ! loop through local HRUs + do iHRU=1,gru_struc(iGRU)%hruCount + + ! re-calculate height of each layer + call calcHeight(& + ! input/output: data structures + indxStruct%gru(iGRU)%hru(iHRU), & ! intent(in): layer type + progStruct%gru(iGRU)%hru(iHRU), & ! intent(inout): model prognostic (state) variables for a local HRU + ! output: error control + err,message); call handle_err(err,message) + + ! calculate vertical distribution of root density + call rootDensty(mparStruct%gru(iGRU)%hru(iHRU), & ! vector of model parameters + indxStruct%gru(iGRU)%hru(iHRU), & ! data structure of model indices + progStruct%gru(iGRU)%hru(iHRU), & ! data structure of model prognostic (state) variables + diagStruct%gru(iGRU)%hru(iHRU), & ! data structure of model diagnostic variables + err,message) ! error control + call handle_err(err,message) + + ! calculate saturated hydraulic conductivity in each soil layer + call satHydCond(mparStruct%gru(iGRU)%hru(iHRU), & ! vector of model parameters + indxStruct%gru(iGRU)%hru(iHRU), & ! data structure of model indices + progStruct%gru(iGRU)%hru(iHRU), & ! data structure of model prognostic (state) variables + fluxStruct%gru(iGRU)%hru(iHRU), & ! data structure of model fluxes + err,message) ! error control + call handle_err(err,message) -! initialize time step length for each HRU -do iHRU=1,nHRU - dt_init(iHRU) = mvar_hru(iHRU)%var(iLookMVAR%dt_init)%dat(1) ! seconds -end do + ! calculate "short-cut" variables such as volumetric heat capacity + call v_shortcut(mparStruct%gru(iGRU)%hru(iHRU), & ! vector of model parameters + diagStruct%gru(iGRU)%hru(iHRU), & ! data structure of model diagnostic variables + err,message) ! error control + call handle_err(err,message) -! initialize time step index -jstep=1 + ! 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) + + ! overwrite the tables for LAI and SAI + if(model_decisions(iLookDECISIONS%LAI_method)%iDecision == specified)then + SAIM(typeStruct%gru(iGRU)%hru(iHRU)%var(iLookTYPE%vegTypeIndex),:) = mparStruct%gru(iGRU)%hru(iHRU)%var(iLookPARAM%winterSAI)%dat(1) + LAIM(typeStruct%gru(iGRU)%hru(iHRU)%var(iLookTYPE%vegTypeIndex),:) = mparStruct%gru(iGRU)%hru(iHRU)%var(iLookPARAM%summerLAI)%dat(1)*greenVegFrac_monthly + endif + + ! initialize canopy drip + ! NOTE: canopy drip from the previous time step is used to compute throughfall for the current time step + fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._dp ! not used + end do ! (looping through HRUs) + + ! compute total area of the upstream HRUS that flow into each HRU + do iHRU=1,gru_struc(iGRU)%hruCount + upArea(iGRU)%hru(iHRU) = 0._dp + do jHRU=1,gru_struc(iGRU)%hruCount + ! check if jHRU flows into iHRU; assume no exchange between GRUs + if(typeStruct%gru(iGRU)%hru(jHRU)%var(iLookTYPE%downHRUindex)==typeStruct%gru(iGRU)%hru(iHRU)%var(iLookTYPE%hruIndex))then + upArea(iGRU)%hru(iHRU) = upArea(iGRU)%hru(iHRU) + attrStruct%gru(iGRU)%hru(jHRU)%var(iLookATTR%HRUarea) + endif ! (if jHRU is an upstream HRU) + end do ! jHRU + end do ! iHRU + + ! identify the total basin area for a GRU (m2) + associate(totalArea => bvarStruct%gru(iGRU)%var(iLookBVAR%basin__totalArea)%dat(1) ) + totalArea = 0._dp + do iHRU=1,gru_struc(iGRU)%hruCount + totalArea = totalArea + attrStruct%gru(iGRU)%hru(iHRU)%var(iLookATTR%HRUarea) + end do + end associate + + ! initialize aquifer storage + ! NOTE: this is ugly: need to add capabilities to initialize basin-wide state variables + ! 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 case(model_decisions(iLookDECISIONS%spatial_gw)%iDecision) + ! 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._dp ! set to zero to be clear that there is no basin-average aquifer storage in this configuration + ! NOTE: 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._dp + do iHRU=1,gru_struc(iGRU)%hruCount + progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarAquiferStorage)%dat(1) = 0._dp ! set to zero to be clear that there is no local aquifer storage in this configuration + end do + case default; call handle_err(20,'unable to identify decision for regional representation of groundwater') + end select + + ! initialize time step length for each HRU + do iHRU=1,gru_struc(iGRU)%hruCount + dt_init(iGRU)%hru(iHRU) = progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%dt_init)%dat(1) ! seconds + end do + +end do ! (looping through GRUs) + + +! ***************************************************************************** +! (5e) initialize first output sequence +! ***************************************************************************** +! define the output file +! NOTE: currently assumes that nSoil is constant across the model domain + +! set up the output file names as: OUTPUT_PREFIX_spinup|waterYear_output_fileSuffix_startGRU-endGRU_outfreq.nc or OUTPUT_PREFIX_spinup|waterYear_output_fileSuffix_HRU_outfreq.nc; +if (OUTPUT_PREFIX(len_trim(OUTPUT_PREFIX):len_trim(OUTPUT_PREFIX)) /= '_') OUTPUT_PREFIX=trim(OUTPUT_PREFIX)//'_' ! separate OUTPUT_PREFIX from others by underscore +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 + +!fileout = trim(OUTPUT_PATH)//trim(OUTPUT_PREFIX)//'output'//trim(output_fileSuffix) +write(fileout,'(a,i0,3(a,i2.2),a)') trim(OUTPUT_PATH)//trim(OUTPUT_PREFIX), & + startTime%var(iLookTIME%iyyy), '-', & + startTime%var(iLookTIME%im), '-', & + startTime%var(iLookTIME%id), '-', & + startTime%var(iLookTIME%ih), & + '_spinup'//trim(output_fileSuffix) +call def_output(nHRU,gru_struc(1)%hruInfo(1)%nSoil,fileout,err,message); call handle_err(err,message) + +! write local model attributes and parameters to the model output file +do iGRU=1,nGRU + do iHRU=1,gru_struc(iGRU)%hruCount + call writeParm(gru_struc(iGRU)%hruInfo(iHRU)%hru_ix,attrStruct%gru(iGRU)%hru(iHRU),attr_meta,err,message); call handle_err(err,message) + call writeParm(gru_struc(iGRU)%hruInfo(iHRU)%hru_ix,typeStruct%gru(iGRU)%hru(iHRU),type_meta,err,message); call handle_err(err,message) + call writeParm(gru_struc(iGRU)%hruInfo(iHRU)%hru_ix,mparStruct%gru(iGRU)%hru(iHRU),mpar_meta,err,message); call handle_err(err,message) + enddo ! HRU + call writeParm(integerMissing,bparStruct%gru(iGRU),bpar_meta,err,message); call handle_err(err,message) +end do ! GRU + +! stop +!call stop_program('testing') ! **************************************************************************** ! (6) loop through time ! **************************************************************************** -do istep=1,numtim +! initialize time step index +waterYearTimeStep = 1 +outputTimeStep(1:nFreq) = 1 + +do modelTimeStep=1,numtim + + ! read forcing data + do iGRU=1,nGRU + do iHRU=1,gru_struc(iGRU)%hruCount + + ! read forcing data + call read_force(& + ! input + modelTimeStep, & ! intent(in): time step index + gru_struc(iGRU)%hruInfo(iHRU)%hru_nc, & ! intent(in): index of hru in netcdf + ! input-output + iFile, & ! intent(inout): index of current forcing file in forcing file list + forcingStep, & ! intent(inout): index of read position in time dimension in current netcdf file + forcNcid, & ! intent(inout): netcdf file identifier for the current forcing file + ! output + timeStruct%var, & ! intent(out): time data structure (integer) + forcStruct%gru(iGRU)%hru(iHRU)%var, & ! intent(out): forcing data structure (double precision) + err, message) ! intent(out): error control + call handle_err(err,message) + end do + end do ! (end looping through global GRUs) ! set print flag globalPrintFlag=.false. - ! read a line of forcing data (if not already opened, open file, and get to the correct place) - ! NOTE: only read data once: if same data used for multiple HRUs, data is copied across - do iHRU=1,nHRU ! loop through HRUs - ! assign pointers to HRUs - time_data => time_hru(iHRU) - forc_data => forc_hru(iHRU) - ! read forcing data - call read_force(istep,iHRU,err,message); call handle_err(err,message) - end do ! (end looping through HRUs) - print*, time_data%var - + ! print progress + select case(ixProgress) + case(ixProgress_im); printProgress = (timeStruct%var(iLookTIME%id) == 1 .and. timeStruct%var(iLookTIME%ih) == 0 .and. timeStruct%var(iLookTIME%imin) == 0) + case(ixProgress_id); printProgress = (timeStruct%var(iLookTIME%ih) == 0 .and. timeStruct%var(iLookTIME%imin) == 0) + case(ixProgress_ih); printProgress = (timeStruct%var(iLookTIME%imin) == 0) + case(ixProgress_never); printProgress = .false. + case default; call handle_err(20,'unable to identify option for the restart file') + end select + if(printProgress) write(*,'(i4,1x,5(i2,1x))') timeStruct%var +! write(*,'(i4,1x,5(i2,1x))') timeStruct%var + + ! NOTE: this is done because of the check in coupled_em if computeVegFlux changes in subsequent time steps + ! (if computeVegFlux changes, then the number of state variables changes, and we need to reoranize the data structures) + ! compute the exposed LAI and SAI and whether veg is buried by snow + if(modelTimeStep==1)then + do iGRU=1,nGRU + do iHRU=1,gru_struc(iGRU)%hruCount + + ! get vegetation phenology + 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 + ! 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,message) ! intent(out): error control + call handle_err(err,message) + + ! save the flag for computing the vegetation fluxes + if(computeVegFluxFlag) computeVegFlux(iGRU)%hru(iHRU) = yes + if(.not.computeVegFluxFlag) computeVegFlux(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 ! ***************************************************************************** ! (7) create a new NetCDF output file, and write parameters and forcing data ! ***************************************************************************** ! check the start of a new water year - if(time_data%var(iLookTIME%im) ==10 .and. & ! month = October - time_data%var(iLookTIME%id) ==1 .and. & ! day = 1 - time_data%var(iLookTIME%ih) ==1 .and. & ! hour = 1 - time_data%var(iLookTIME%imin)==0)then ! minute = 0 + if(timeStruct%var(iLookTIME%im) ==10 .and. & ! month = October + timeStruct%var(iLookTIME%id) ==1 .and. & ! day = 1 + timeStruct%var(iLookTIME%ih) ==0 .and. & ! hour = 1 + timeStruct%var(iLookTIME%imin)==0)then ! minute = 0 + + ! close any output files that are already open + do iFreq = 1,nFreq + if (ncid(iFreq).ne.integerMissing) then + call nc_file_close(ncid(iFreq),err,message) + call handle_err(err,message) + end if + end do + ! define the filename - write(fileout,'(a,i0,a,i0,a)') trim(OUTPUT_PATH)//trim(OUTPUT_PREFIX)//'_',& - time_data%var(iLookTIME%iyyy),'-',time_data%var(iLookTIME%iyyy)+1,& - trim(output_fileSuffix)//'.nc' - ! define the file - call def_output(nHRU,fileout,err,message); call handle_err(err,message) - ! write parameters for each HRU, and re-set indices - do iHRU=1,nHRU - attr_data => attr_hru(iHRU) - type_data => type_hru(iHRU) - mpar_data => mpar_hru(iHRU) - indx_data => indx_hru(iHRU) - ! write model parameters to the model output file - call writeAttrb(fileout,iHRU,err,message); call handle_err(err,message) - call writeParam(fileout,iHRU,err,message); call handle_err(err,message) - ! re-initalize the indices for midSnow, midSoil, midToto, and ifcToto - jStep=1 - indx_data%var(iLookINDEX%midSnowStartIndex)%dat(1) = 1 - indx_data%var(iLookINDEX%midSoilStartIndex)%dat(1) = 1 - indx_data%var(iLookINDEX%midTotoStartIndex)%dat(1) = 1 - indx_data%var(iLookINDEX%ifcSnowStartIndex)%dat(1) = 1 - indx_data%var(iLookINDEX%ifcSoilStartIndex)%dat(1) = 1 - indx_data%var(iLookINDEX%ifcTotoStartIndex)%dat(1) = 1 - end do ! (looping through HRUs) - endif ! if start of a new water year, and defining a new file - - ! initialize runoff variables - bvar_data%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) = 0._dp ! surface runoff (m s-1) - bvar_data%var(iLookBVAR%basin__ColumnOutflow)%dat(1) = 0._dp ! outflow from all "outlet" HRUs (those with no downstream HRU) - - ! initialize baseflow variables - bvar_data%var(iLookBVAR%basin__AquiferRecharge)%dat(1) = 0._dp ! recharge to the aquifer (m s-1) - bvar_data%var(iLookBVAR%basin__AquiferBaseflow)%dat(1) = 0._dp ! baseflow from the aquifer (m s-1) - bvar_data%var(iLookBVAR%basin__AquiferTranspire)%dat(1) = 0._dp ! transpiration loss from the aquifer (m s-1) + write(fileout,'(a,i0,a,i0,a)') trim(OUTPUT_PATH)//trim(OUTPUT_PREFIX),& + timeStruct%var(iLookTIME%iyyy),'-',timeStruct%var(iLookTIME%iyyy)+1,& + trim(output_fileSuffix) - ! initialize total inflow for each layer in a soil column - do iHRU=1,nHRU - mvar_hru(iHRU)%var(iLookMVAR%mLayerColumnInflow)%dat(:) = 0._dp - end do + ! define the file + call def_output(nHRU,gru_struc(1)%hruInfo(1)%nSoil,fileout,err,message); call handle_err(err,message) + ! write parameters for each HRU, and re-set indices + do iGRU=1,nGRU + do iHRU=1,gru_struc(iGRU)%hruCount + call writeParm(iHRU,attrStruct%gru(iGRU)%hru(iHRU),attr_meta,err,message); call handle_err(err,message) + call writeParm(iHRU,typeStruct%gru(iGRU)%hru(iHRU),type_meta,err,message); call handle_err(err,message) + call writeParm(iHRU,mparStruct%gru(iGRU)%hru(iHRU),mpar_meta,err,message); call handle_err(err,message) + ! re-initalize the indices for midSnow, midSoil, midToto, and ifcToto + waterYearTimeStep=1 + outputTimeStep=1 + indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%midSnowStartIndex)%dat(1) = 1 + indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%midSoilStartIndex)%dat(1) = 1 + indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%midTotoStartIndex)%dat(1) = 1 + indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%ifcSnowStartIndex)%dat(1) = 1 + indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%ifcSoilStartIndex)%dat(1) = 1 + indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%ifcTotoStartIndex)%dat(1) = 1 + end do ! (looping through HRUs) + call writeParm(integerMissing,bparStruct%gru(iGRU),bpar_meta,err,message); call handle_err(err,message) + end do ! (looping through GRUs) + + end if ! if start of a new water year, and defining a new file ! **************************************************************************** - ! (8) loop through HRUs + ! (8) loop through HRUs and GRUs ! **************************************************************************** - do iHRU=1,nHRU - - ! print progress - !print*, 'iHRU = ', iHRU - - ! assign pointers to HRUs - time_data => time_hru(iHRU) - forc_data => forc_hru(iHRU) - attr_data => attr_hru(iHRU) - type_data => type_hru(iHRU) - mpar_data => mpar_hru(iHRU) - mvar_data => mvar_hru(iHRU) - indx_data => indx_hru(iHRU) - - ! identify the area covered by the current HRU - fracHRU = attr_data%var(iLookATTR%HRUarea) / bvar_data%var(iLookBVAR%basin__totalArea)%dat(1) - - ! assign pointers to model layers - ! NOTE: layer structure is different for each HRU - nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) - nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1) - nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1) - - ! get height at bottom of each soil layer, negative downwards (used in Noah MP) - allocate(zSoilReverseSign(nSoil),stat=err); call handle_err(err,'problem allocating space for zSoilReverseSign') - zSoilReverseSign(1:nSoil) = -mvar_data%var(iLookMVAR%iLayerHeight)%dat(nSnow+1:nSnow+nSoil) - - ! assign pointers to model indices - midSnowStartIndex => indx_data%var(iLookINDEX%midSnowStartIndex)%dat(1) - midSoilStartIndex => indx_data%var(iLookINDEX%midSoilStartIndex)%dat(1) - midTotoStartIndex => indx_data%var(iLookINDEX%midTotoStartIndex)%dat(1) - ifcSnowStartIndex => indx_data%var(iLookINDEX%ifcSnowStartIndex)%dat(1) - ifcSoilStartIndex => indx_data%var(iLookINDEX%ifcSoilStartIndex)%dat(1) - ifcTotoStartIndex => indx_data%var(iLookINDEX%ifcTotoStartIndex)%dat(1) - - ! get NOAH-MP parameters - call REDPRM(type_data%var(iLookTYPE%vegTypeIndex), & ! vegetation type index - type_data%var(iLookTYPE%soilTypeIndex), & ! soil type - type_data%var(iLookTYPE%slopeTypeIndex), & ! slope type index - zSoilReverseSign, & ! * not used: height at bottom of each layer [NOTE: negative] (m) - nSoil, & ! number of soil layers - urbanVegCategory) ! vegetation category for urban areas - ! overwrite the vegetation height - HVT(type_data%var(iLookTYPE%vegTypeIndex)) = mpar_data%var(iLookPARAM%heightCanopyTop) - HVB(type_data%var(iLookTYPE%vegTypeIndex)) = mpar_data%var(iLookPARAM%heightCanopyBottom) + ! initialize variables + do iGRU=1,nGRU + + ! initialize runoff variables + bvarStruct%gru(iGRU)%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) = 0._dp ! surface runoff (m s-1) + bvarStruct%gru(iGRU)%var(iLookBVAR%basin__ColumnOutflow)%dat(1) = 0._dp ! outflow from all "outlet" HRUs (those with no downstream HRU) + + ! initialize baseflow variables + bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferRecharge)%dat(1) = 0._dp ! recharge to the aquifer (m s-1) + bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferBaseflow)%dat(1) = 0._dp ! baseflow from the aquifer (m s-1) + bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferTranspire)%dat(1) = 0._dp ! transpiration loss from the aquifer (m s-1) + + ! initialize total inflow for each layer in a soil column + do iHRU=1,gru_struc(iGRU)%hruCount + fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%mLayerColumnInflow)%dat(:) = 0._dp + end do - ! overwrite the tables for LAI and SAI - if(model_decisions(iLookDECISIONS%LAI_method)%iDecision == specified)then - SAIM(type_data%var(iLookTYPE%vegTypeIndex),:) = mpar_data%var(iLookPARAM%winterSAI) - LAIM(type_data%var(iLookTYPE%vegTypeIndex),:) = mpar_data%var(iLookPARAM%summerLAI)*greenVegFrac_monthly - endif + ! loop through HRUs + do iHRU=1,gru_struc(iGRU)%hruCount + + ! identify the area covered by the current HRU + fracHRU = attrStruct%gru(iGRU)%hru(iHRU)%var(iLookATTR%HRUarea) / bvarStruct%gru(iGRU)%var(iLookBVAR%basin__totalArea)%dat(1) + + ! assign model layers + ! NOTE: layer structure is different for each HRU + gru_struc(iGRU)%hruInfo(iHRU)%nSnow = indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%nSnow)%dat(1) + gru_struc(iGRU)%hruInfo(iHRU)%nSoil = indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%nSoil)%dat(1) + nLayers = indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%nLayers)%dat(1) + + ! get height at bottom of each soil layer, negative downwards (used in Noah MP) + allocate(zSoilReverseSign(gru_struc(iGRU)%hruInfo(iHRU)%nSoil),stat=err); call handle_err(err,'problem allocating space for zSoilReverseSign') + zSoilReverseSign(:) = -progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%iLayerHeight)%dat(gru_struc(iGRU)%hruInfo(iHRU)%nSnow+1:nLayers) + + ! get NOAH-MP parameters + call REDPRM(typeStruct%gru(iGRU)%hru(iHRU)%var(iLookTYPE%vegTypeIndex), & ! vegetation type index + typeStruct%gru(iGRU)%hru(iHRU)%var(iLookTYPE%soilTypeIndex), & ! soil type + typeStruct%gru(iGRU)%hru(iHRU)%var(iLookTYPE%slopeTypeIndex), & ! slope type index + zSoilReverseSign, & ! * not used: height at bottom of each layer [NOTE: negative] (m) + gru_struc(iGRU)%hruInfo(iHRU)%nSoil, & ! 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); call handle_err(err,'problem deallocating space for zSoilReverseSign') + + ! overwrite the minimum resistance + if(overwriteRSMIN) RSMIN = mparStruct%gru(iGRU)%hru(iHRU)%var(iLookPARAM%minStomatalResistance)%dat(1) + + ! 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) + + ! overwrite the tables for LAI and SAI + if(model_decisions(iLookDECISIONS%LAI_method)%iDecision == specified)then + SAIM(typeStruct%gru(iGRU)%hru(iHRU)%var(iLookTYPE%vegTypeIndex),:) = mparStruct%gru(iGRU)%hru(iHRU)%var(iLookPARAM%winterSAI)%dat(1) + LAIM(typeStruct%gru(iGRU)%hru(iHRU)%var(iLookTYPE%vegTypeIndex),:) = mparStruct%gru(iGRU)%hru(iHRU)%var(iLookPARAM%summerLAI)%dat(1)*greenVegFrac_monthly + end if + + ! cycle water pixel + if (typeStruct%gru(iGRU)%hru(iHRU)%var(iLookTYPE%vegTypeIndex) == isWater) cycle + + ! compute derived forcing variables + call derivforce(timeStruct%var, & ! vector of time information + forcStruct%gru(iGRU)%hru(iHRU)%var,& ! vector of model forcing data + attrStruct%gru(iGRU)%hru(iHRU)%var,& ! vector of model attributes + mparStruct%gru(iGRU)%hru(iHRU), & ! vector of model parameters + diagStruct%gru(iGRU)%hru(iHRU), & ! data structure of model diagnostic variables + fluxStruct%gru(iGRU)%hru(iHRU), & ! data structure of model fluxes + err,message) ! error control + call handle_err(err,message) + + ! **************************************************************************** + ! (9) run the model + ! **************************************************************************** + ! set the flag to compute the vegetation flux + computeVegFluxFlag = (computeVegFlux(iGRU)%hru(iHRU) == yes) + + !print*, 'iHRU = ', iHRU + + ! initialize the number of flux calls + diagStruct%gru(iGRU)%hru(iHRU)%var(iLookDIAG%numFluxCalls)%dat(1) = 0._dp + + ! run the model for a single parameter set and time step + call coupled_em(& + ! model control + gru_struc(iGRU)%hruInfo(iHRU)%hru_id, & ! intent(in): hruId + dt_init(iGRU)%hru(iHRU), & ! intent(inout): initial time step + computeVegFluxFlag, & ! intent(inout): flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) + ! data structures (input) + typeStruct%gru(iGRU)%hru(iHRU), & ! intent(in): local classification of soil veg etc. for each HRU + attrStruct%gru(iGRU)%hru(iHRU), & ! intent(in): local attributes for each HRU + forcStruct%gru(iGRU)%hru(iHRU), & ! intent(in): model forcing data + mparStruct%gru(iGRU)%hru(iHRU), & ! intent(in): model parameters + bvarStruct%gru(iGRU), & ! intent(in): basin-average model variables + ! data structures (input-output) + indxStruct%gru(iGRU)%hru(iHRU), & ! intent(inout): model indices + 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 + fluxStruct%gru(iGRU)%hru(iHRU), & ! intent(inout): model fluxes for a local HRU + ! error control + err,message) ! intent(out): error control + call handle_err(err,message) + + ! update layer numbers that could be changed in coupled_em() + gru_struc(iGRU)%hruInfo(iHRU)%nSnow = indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%nSnow)%dat(1) + gru_struc(iGRU)%hruInfo(iHRU)%nSoil = indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%nSoil)%dat(1) + +! ! check feasibiility of certain states +! call check_icond(nGRU,nHRU, & ! number of response units +! progStruct, & ! model prognostic (state) variables +! mparStruct, & ! model parameters +! indxStruct, & ! layer indexes +! err,message) ! error control +! call handle_err(err,message) + + ! save the flag for computing the vegetation fluxes + if(computeVegFluxFlag) computeVegFlux(iGRU)%hru(iHRU) = yes + if(.not.computeVegFluxFlag) computeVegFlux(iGRU)%hru(iHRU) = no + + kHRU = 0 + ! identify the downslope HRU + dsHRU: do jHRU=1,gru_struc(iGRU)%hruCount + if(typeStruct%gru(iGRU)%hru(iHRU)%var(iLookTYPE%downHRUindex) == typeStruct%gru(iGRU)%hru(jHRU)%var(iLookTYPE%hruIndex))then + if(kHRU==0)then ! check there is a unique match + kHRU=jHRU + exit dsHRU + end if ! (check there is a unique match) + end if ! (if identified a downslope HRU) + end do dsHRU + + ! add inflow to the downslope HRU + if(kHRU > 0)then ! if there is a downslope HRU + fluxStruct%gru(iGRU)%hru(kHRU)%var(iLookFLUX%mLayerColumnInflow)%dat(:) = fluxStruct%gru(iGRU)%hru(kHRU)%var(iLookFLUX%mLayerColumnInflow)%dat(:) + fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%mLayerColumnOutflow)%dat(:) + + ! increment basin column outflow (m3 s-1) + else + bvarStruct%gru(iGRU)%var(iLookBVAR%basin__ColumnOutflow)%dat(1) = bvarStruct%gru(iGRU)%var(iLookBVAR%basin__ColumnOutflow)%dat(1) + sum(fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%mLayerColumnOutflow)%dat(:)) + end if + + ! increment basin surface runoff (m s-1) + bvarStruct%gru(iGRU)%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) = bvarStruct%gru(iGRU)%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) + fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarSurfaceRunoff)%dat(1) * fracHRU + + ! increment basin-average baseflow input variables (m s-1) + bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferRecharge)%dat(1) = bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferRecharge)%dat(1) + fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarSoilDrainage)%dat(1) * fracHRU + bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferTranspire)%dat(1) = bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferTranspire)%dat(1) + fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarAquiferTranspire)%dat(1) * fracHRU + + ! increment aquifer baseflow -- ONLY if baseflow is computed individually for each HRU + ! NOTE: groundwater computed later for singleBasin + if(model_decisions(iLookDECISIONS%spatial_gw)%iDecision == localColumn)then + bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferBaseflow)%dat(1) = bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferBaseflow)%dat(1) + fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarAquiferBaseflow)%dat(1) * fracHRU + end if + + ! calculate output Statistics + call calcStats(forcStat%gru(iGRU)%hru(iHRU)%var,forcStruct%gru(iGRU)%hru(iHRU)%var,statForc_meta,waterYearTimeStep,err,message); call handle_err(err,message) + call calcStats(progStat%gru(iGRU)%hru(iHRU)%var,progStruct%gru(iGRU)%hru(iHRU)%var,statProg_meta,waterYearTimeStep,err,message); call handle_err(err,message) + call calcStats(diagStat%gru(iGRU)%hru(iHRU)%var,diagStruct%gru(iGRU)%hru(iHRU)%var,statDiag_meta,waterYearTimeStep,err,message); call handle_err(err,message) + call calcStats(fluxStat%gru(iGRU)%hru(iHRU)%var,fluxStruct%gru(iGRU)%hru(iHRU)%var,statFlux_meta,waterYearTimeStep,err,message); call handle_err(err,message) + call calcStats(indxStat%gru(iGRU)%hru(iHRU)%var,indxStruct%gru(iGRU)%hru(iHRU)%var,statIndx_meta,waterYearTimeStep,err,message); call handle_err(err,message) + + ! write the model output to the NetCDF file + ! Passes the full metadata structure rather than the stats metadata structure because + ! we have the option to write out data of types other than statistics. + ! Thus, we must also pass the stats parent->child maps from childStruct. + call writeData(waterYearTimeStep,outputTimeStep,forc_meta,forcStat%gru(iGRU)%hru(iHRU)%var,forcStruct%gru(iGRU)%hru(iHRU)%var,forcChild_map,indxStruct%gru(iGRU)%hru(iHRU)%var,gru_struc(iGRU)%hruInfo(iHRU)%hru_ix,err,message); call handle_err(err,message) + call writeData(waterYearTimeStep,outputTimeStep,prog_meta,progStat%gru(iGRU)%hru(iHRU)%var,progStruct%gru(iGRU)%hru(iHRU)%var,progChild_map,indxStruct%gru(iGRU)%hru(iHRU)%var,gru_struc(iGRU)%hruInfo(iHRU)%hru_ix,err,message); call handle_err(err,message) + call writeData(waterYearTimeStep,outputTimeStep,diag_meta,diagStat%gru(iGRU)%hru(iHRU)%var,diagStruct%gru(iGRU)%hru(iHRU)%var,diagChild_map,indxStruct%gru(iGRU)%hru(iHRU)%var,gru_struc(iGRU)%hruInfo(iHRU)%hru_ix,err,message); call handle_err(err,message) + call writeData(waterYearTimeStep,outputTimeStep,flux_meta,fluxStat%gru(iGRU)%hru(iHRU)%var,fluxStruct%gru(iGRU)%hru(iHRU)%var,fluxChild_map,indxStruct%gru(iGRU)%hru(iHRU)%var,gru_struc(iGRU)%hruInfo(iHRU)%hru_ix,err,message); call handle_err(err,message) + call writeData(waterYearTimeStep,outputTimeStep,indx_meta,indxStat%gru(iGRU)%hru(iHRU)%var,indxStruct%gru(iGRU)%hru(iHRU)%var,indxChild_map,indxStruct%gru(iGRU)%hru(iHRU)%var,gru_struc(iGRU)%hruInfo(iHRU)%hru_ix,err,message); call handle_err(err,message) + + ! increment the model indices + nLayers = gru_struc(iGRU)%hruInfo(iHRU)%nSnow + gru_struc(iGRU)%hruInfo(iHRU)%nSoil + indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%midSnowStartIndex)%dat(1) = indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%midSnowStartIndex)%dat(1) + gru_struc(iGRU)%hruInfo(iHRU)%nSnow + indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%midSoilStartIndex)%dat(1) = indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%midSoilStartIndex)%dat(1) + gru_struc(iGRU)%hruInfo(iHRU)%nSoil + indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%midTotoStartIndex)%dat(1) = indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%midTotoStartIndex)%dat(1) + nLayers + indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%ifcSnowStartIndex)%dat(1) = indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%ifcSnowStartIndex)%dat(1) + gru_struc(iGRU)%hruInfo(iHRU)%nSnow+1 + indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%ifcSoilStartIndex)%dat(1) = indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%ifcSoilStartIndex)%dat(1) + gru_struc(iGRU)%hruInfo(iHRU)%nSoil+1 + indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%ifcTotoStartIndex)%dat(1) = indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%ifcTotoStartIndex)%dat(1) + nLayers+1 - ! define the green vegetation fraction of the grid box (used to compute LAI) - mvar_data%var(iLookMVAR%scalarGreenVegFraction)%dat(1) = greenVegFrac_monthly(time_data%var(iLookTIME%im)) - - ! compute derived forcing variables - call derivforce(err,message); call handle_err(err,message) - - ! **************************************************************************** - ! (9) run the model - ! **************************************************************************** - ! define the need to calculate the re-start file - select case(ixRestart) - case(ixRestart_im); printRestart = (time_data%var(iLookTIME%id) == 1 .and. time_data%var(iLookTIME%ih) == 1 .and. time_data%var(iLookTIME%imin) == 0) - case(ixRestart_id); printRestart = (time_data%var(iLookTIME%ih) == 1 .and. time_data%var(iLookTIME%imin) == 0) - case(ixRestart_never); printRestart = .false. - case default; call handle_err(20,'unable to identify option for the restart file') - end select - !printRestart = .true. + end do ! (looping through HRUs) - ! run the model for a single parameter set and time step - call coupled_em(printRestart, & ! flag to print a re-start file - output_fileSuffix, & ! name of the experiment used in the restart file - dt_init(iHRU), & ! initial time step - err,message) ! error control + ! compute water balance for the basin aquifer + if(model_decisions(iLookDECISIONS%spatial_gw)%iDecision == singleBasin)then + call handle_err(20,'multi_driver/bigBucket groundwater code not transferred from old code base yet') + end if + + ! perform the routing + associate(totalArea => bvarStruct%gru(iGRU)%var(iLookBVAR%basin__totalArea)%dat(1) ) + call qOverland(& + ! input + model_decisions(iLookDECISIONS%subRouting)%iDecision, & ! intent(in): index for routing method + bvarStruct%gru(iGRU)%var(iLookBVAR%basin__SurfaceRunoff)%dat(1), & ! intent(in): surface runoff (m s-1) + bvarStruct%gru(iGRU)%var(iLookBVAR%basin__ColumnOutflow)%dat(1)/totalArea, & ! intent(in): outflow from all "outlet" HRUs (those with no downstream HRU) + bvarStruct%gru(iGRU)%var(iLookBVAR%basin__AquiferBaseflow)%dat(1), & ! intent(in): baseflow from the aquifer (m s-1) + bvarStruct%gru(iGRU)%var(iLookBVAR%routingFractionFuture)%dat, & ! intent(in): fraction of runoff in future time steps (m s-1) + bvarStruct%gru(iGRU)%var(iLookBVAR%routingRunoffFuture)%dat, & ! intent(in): runoff in future time steps (m s-1) + ! output + bvarStruct%gru(iGRU)%var(iLookBVAR%averageInstantRunoff)%dat(1), & ! intent(out): instantaneous runoff (m s-1) + bvarStruct%gru(iGRU)%var(iLookBVAR%averageRoutedRunoff)%dat(1), & ! intent(out): routed runoff (m s-1) + err,message) ! intent(out): error control call handle_err(err,message) + end associate + + ! calc basin stats + call calcStats(bvarStat%gru(iGRU)%var(:),bvarStruct%gru(iGRU)%var(:),statBvar_meta,waterYearTimeStep,err,message); call handle_err(err,message) - kHRU = 0 - ! identify the downslope HRU - do jHRU=1,nHRU - if(type_hru(iHRU)%var(iLookTYPE%downHRUindex) == type_hru(jHRU)%var(iLookTYPE%hruIndex))then - if(kHRU==0)then ! check there is a unique match - kHRU=jHRU - else - call handle_err(20,'multi_driver: only expect there to be one downslope HRU') - endif ! (check there is a unique match) - endif ! (if identified a downslope HRU) - end do + ! write basin-average variables + call writeBasin(waterYearTimeStep,outputTimeStep,bvar_meta,bvarStat%gru(iGRU)%var,bvarStruct%gru(iGRU)%var,bvarChild_map,err,message); call handle_err(err,message) - !write(*,'(a,1x,i4,1x,10(f20.10,1x))') 'iHRU, averageColumnOutflow = ', iHRU, mvar_data%var(iLookMVAR%averageColumnOutflow)%dat(:) + end do ! (looping through GRUs) - ! add inflow to the downslope HRU - if(kHRU > 0)then ! if there is a downslope HRU - mvar_hru(kHRU)%var(iLookMVAR%mLayerColumnInflow)%dat(:) = mvar_hru(kHRU)%var(iLookMVAR%mLayerColumnInflow)%dat(:) & - + mvar_data%var(iLookMVAR%averageColumnOutflow)%dat(:) + ! write current time to all files + call WriteTime(waterYearTimeStep,outputTimeStep,time_meta,timeStruct%var,err,message) - ! increment basin column outflow (m3 s-1) - else - bvar_data%var(iLookBVAR%basin__ColumnOutflow)%dat(1) = bvar_data%var(iLookBVAR%basin__ColumnOutflow)%dat(1) + & - sum(mvar_data%var(iLookMVAR%averageColumnOutflow)%dat(:)) - endif + ! increment output file timestep + do iFreq = 1,nFreq + if (mod(waterYearTimeStep,outFreq(iFreq))==0) then + outputTimeStep(iFreq) = outputTimeStep(iFreq) + 1 + end if + end do + + ! increment forcingStep + forcingStep=forcingStep+1 - ! increment basin surface runoff (m s-1) - bvar_data%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) = bvar_data%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) + & - mvar_data%var(iLookMVAR%averageSurfaceRunoff)%dat(1) * fracHRU - - ! increment basin-average baseflow input variables (m s-1) - bvar_data%var(iLookBVAR%basin__AquiferRecharge)%dat(1) = bvar_data%var(iLookBVAR%basin__AquiferRecharge)%dat(1) + & - mvar_data%var(iLookMVAR%averageSoilDrainage)%dat(1) * fracHRU - bvar_data%var(iLookBVAR%basin__AquiferTranspire)%dat(1) = bvar_data%var(iLookBVAR%basin__AquiferTranspire)%dat(1) + & - mvar_data%var(iLookMVAR%averageAquiferTranspire)%dat(1) * fracHRU - - ! increment aquifer baseflow -- ONLY if baseflow is computed individually for each HRU - ! NOTE: groundwater computed later for singleBasin - if(model_decisions(iLookDECISIONS%spatial_gw)%iDecision == localColumn)then - bvar_data%var(iLookBVAR%basin__AquiferBaseflow)%dat(1) = bvar_data%var(iLookBVAR%basin__AquiferBaseflow)%dat(1) + & - mvar_data%var(iLookMVAR%averageAquiferBaseflow)%dat(1) * fracHRU - endif + ! increment the time index + waterYearTimeStep = waterYearTimeStep+1 - ! write the forcing data to the model output file - call writeForce(fileout,iHRU,jstep,err,message); call handle_err(err,message) + !print*, 'PAUSE: in driver: testing differences'; read(*,*) + !stop 'end of time step' - ! write the model output to the NetCDF file - call writeModel(fileout,iHRU,jstep,err,message); call handle_err(err,message) - !if(istep>6) call handle_err(20,'stopping on a specified step: after call to writeModel') + ! query whether this timestep requires a re-start file + select case(ixRestart) + case(ixRestart_iy); printRestart = (timeStruct%var(iLookTIME%im) == 1 .and. timeStruct%var(iLookTIME%id) == 1 .and. timeStruct%var(iLookTIME%ih) == 0 .and. timeStruct%var(iLookTIME%imin) == 0) + case(ixRestart_im); printRestart = (timeStruct%var(iLookTIME%id) == 1 .and. timeStruct%var(iLookTIME%ih) == 0 .and. timeStruct%var(iLookTIME%imin) == 0) + case(ixRestart_id); printRestart = (timeStruct%var(iLookTIME%ih) == 0 .and. timeStruct%var(iLookTIME%imin) == 0) + case(ixRestart_never); printRestart = .false. + case default; call handle_err(20,'unable to identify option for the restart file') + end select + + ! print a restart file if requested + if(printRestart)then + write(timeString,'(a,i4,3(a,i2.2))') '_',timeStruct%var(iLookTIME%iyyy),'-',timeStruct%var(iLookTIME%im),'-',timeStruct%var(iLookTIME%id),'-',timeStruct%var(iLookTIME%ih) + restartFile=trim(OUTPUT_PATH)//trim(OUTPUT_PREFIX)//'_'//trim('summaRestart')//trim(timeString)//trim(output_fileSuffix)//'.nc' + call writeRestart(restartFile,nGRU,nHRU,prog_meta,progStruct,indx_meta,indxStruct,err,message) + call handle_err(err,message) + end if - ! increment the model indices - midSnowStartIndex = midSnowStartIndex + nSnow - midSoilStartIndex = midSoilStartIndex + nSoil - midTotoStartIndex = midTotoStartIndex + nLayers - ifcSnowStartIndex = ifcSnowStartIndex + nSnow+1 - ifcSoilStartIndex = ifcSoilStartIndex + nSoil+1 - ifcTotoStartIndex = ifcTotoStartIndex + nLayers+1 +end do ! (looping through time) - ! deallocate height at bottom of each soil layer(used in Noah MP) - deallocate(zSoilReverseSign,stat=err); call handle_err(err,'problem deallocating space for zSoilReverseSign') +! close any remaining output files +do iFreq = 1,nFreq + if (ncid(iFreq).ne.integerMissing) then + call nc_file_close(ncid(iFreq),err,message) + call handle_err(err,message) + end if +end do - end do ! (looping through HRUs) +! deallocate space for dt_init and upArea +deallocate(dt_init,upArea,stat=err); call handle_err(err,'unable to deallocate space for dt_init and upArea') - ! compute water balance for the basin aquifer - if(model_decisions(iLookDECISIONS%spatial_gw)%iDecision == singleBasin)then - call handle_err(20,'multi_driver/bigBucket groundwater code not transferred from old code base yet') - endif +call stop_program('finished simulation successfully.') - ! perform the routing - call qOverland(& - ! input - model_decisions(iLookDECISIONS%subRouting)%iDecision, & ! intent(in): index for routing method - bvar_data%var(iLookBVAR%basin__SurfaceRunoff)%dat(1), & ! intent(in): surface runoff (m s-1) - bvar_data%var(iLookBVAR%basin__ColumnOutflow)%dat(1)/totalArea, & ! intent(in): outflow from all "outlet" HRUs (those with no downstream HRU) - bvar_data%var(iLookBVAR%basin__AquiferBaseflow)%dat(1), & ! intent(in): baseflow from the aquifer (m s-1) - bvar_data%var(iLookBVAR%routingFractionFuture)%dat, & ! intent(in): fraction of runoff in future time steps (m s-1) - bvar_data%var(iLookBVAR%routingRunoffFuture)%dat, & ! intent(in): runoff in future time steps (m s-1) - ! output - bvar_data%var(iLookBVAR%averageInstantRunoff)%dat(1), & ! intent(out): instantaneous runoff (m s-1) - bvar_data%var(iLookBVAR%averageRoutedRunoff)%dat(1), & ! intent(out): routed runoff (m s-1) - err,message) ! intent(out): error control - call handle_err(err,message) +contains - ! write basin-average variables - call writeBasin(fileout,jstep,err,message); call handle_err(err,message) + ! ************************************************************************************************** + ! internal function to obtain the command line arguments + ! ************************************************************************************************** + subroutine getCommandArguments() + implicit none + integer(i4b) :: iArgument ! index of command line argument + integer(i4b) :: nArgument ! number of command line arguments + character(len=256),allocatable :: argString(:) ! string to store command line arguments + integer(i4b) :: nLocalArgument ! number of command line arguments to read for a switch + character(len=70), parameter :: spaces = '' + nArgument = command_argument_count() + ! check numbers of command-line arguments and obtain all arguments + if (nArgument < 1) then + call printCommandHelp() + end if + + allocate(argString(nArgument)) + do iArgument = 1,nArgument + call get_command_argument(iArgument,argString(iArgument)) + ! print versions if needed + if (trim(argString(iArgument)) == '-v' .or. trim(argString(iArgument)) == '--version') then + ! print version numbers + + print "(A)", '----------------------------------------------------------------------' + print "(A)", ' SUMMA - Structure for Unifying Multiple Modeling Alternatives ' + print "(A)", spaces(1:int((70 - len_trim(summaVersion) - 9) / 2))//'Version: ' //trim(summaVersion) + print "(A)", spaces(1:int((70 - len_trim(buildTime) - 12) / 2)) //'Build Time: '//trim(buildTime) + print "(A)", spaces(1:int((70 - len_trim(gitBranch) - 12) / 2)) //'Git Branch: '//trim(gitBranch) + print "(A)", spaces(1:int((70 - len_trim(gitHash) - 10) / 2)) //'Git Hash: ' //trim(gitHash) + print "(A)", '----------------------------------------------------------------------' + if (nArgument == 1) stop + end if + end do + + ! initialize command line argument variables + startGRU = integerMissing; nGRU = integerMissing; checkHRU = integerMissing; nHRU = integerMissing + nGRU = integerMissing; nHRU = integerMissing + iRunMode = iRunModeFull + + ! loop through all command arguments + nLocalArgument = 0 + do iArgument = 1,nArgument + if (nLocalArgument>0) then; nLocalArgument = nLocalArgument -1; cycle; end if ! skip the arguments have been read + select case (trim(argString(iArgument))) + + case ('-m', '--master') + ! update arguments + nLocalArgument = 1 + if (iArgument+nLocalArgument>nArgument) call handle_err(1,"missing argument file_suffix; type 'summa.exe --help' for correct usage") + ! get name of master control file + summaFileManagerFile=trim(argString(iArgument+1)) + print "(A)", "file_master is '"//trim(summaFileManagerFile)//"'." + + case ('-s', '--suffix') + ! define file suffix + nLocalArgument = 1 + ! check if the number of command line arguments is correct + if (iArgument+nLocalArgument>nArgument) call handle_err(1,"missing argument file_suffix; type 'summa.exe --help' for correct usage") + output_fileSuffix=trim(argString(iArgument+1)) + print "(A)", "file_suffix is '"//trim(output_fileSuffix)//"'." + + case ('-h', '--hru') + ! define a single HRU run + if (iRunMode == iRunModeGRU) call handle_err(1,"single-HRU run and GRU-parallelization run cannot be both selected.") + iRunMode=iRunModeHRU + nLocalArgument = 1 + ! check if the number of command line arguments is correct + if (iArgument+nLocalArgument>nArgument) call handle_err(1,"missing argument checkHRU; type 'summa.exe --help' for correct usage") + read(argString(iArgument+1),*) checkHRU ! read the index of the HRU for a single HRU run + nHRU=1; nGRU=1 ! nHRU and nGRU are both one in this case + ! examines the checkHRU is correct + if (checkHRU<1) then + call handle_err(1,"illegal iHRU specification; type 'summa.exe --help' for correct usage") + else + print '(A)',' Single-HRU run activated. HRU '//trim(argString(iArgument+1))//' is selected for simulation.' + end if + + case ('-g','--gru') + ! define a GRU parallelization run; get the starting GRU and countGRU + if (iRunMode == iRunModeHRU) call handle_err(1,"single-HRU run and GRU-parallelization run cannot be both selected.") + iRunMode=iRunModeGRU + nLocalArgument = 2 + ! check if the number of command line arguments is correct + if (iArgument+nLocalArgument>nArgument) call handle_err(1,"missing argument startGRU or countGRU; type 'summa.exe --help' for correct usage") + read(argString(iArgument+1),*) startGRU ! read the argument of startGRU + read(argString(iArgument+2),*) nGRU ! read the argument of countGRU + if (startGRU<1 .or. nGRU<1) then + call handle_err(1,'startGRU and countGRU must be larger than 1.') + else + print '(A)', ' GRU-Parallelization run activated. '//trim(argString(iArgument+2))//' GRUs are selected for simulation.' + end if + + case ('-p', '--progress') + ! define the frequency to print progress + nLocalArgument = 1 + ! check if the number of command line arguments is correct + if (iArgument+nLocalArgument>nArgument) call handle_err(1, "missing argument freqProgress; type 'summa.exe --help' for correct usage") + select case (trim(argString(iArgument+1))) + case ('m' , 'month'); ixProgress = ixProgress_im + case ('d' , 'day'); ixProgress = ixProgress_id + case ('h' , 'hour'); ixProgress = ixProgress_ih + case ('n' , 'never'); ixProgress = ixProgress_never + case default; call handle_err(1,'unknown frequency to print progress') + end select + + case ('-r', '--restart') + ! define the frequency to write restart files + nLocalArgument = 1 + ! check if the number of command line arguments is correct + if (iArgument+nLocalArgument>nArgument) call handle_err(1, "missing argument freqRestart; type 'summa.exe --help' for correct usage") + select case (trim(argString(iArgument+1))) + case ('y' , 'year'); ixRestart = ixRestart_iy + case ('m' , 'month'); ixRestart = ixRestart_im + case ('d' , 'day'); ixRestart = ixRestart_id + case ('n' , 'never'); ixRestart = ixRestart_never + case default; call handle_err(1,'unknown frequency to write restart files') + end select + + ! do nothing + case ('-v','--version') + + ! print help message + case ('--help') + call printCommandHelp - ! increment the time index - jstep = jstep+1 + case default + call printCommandHelp + call handle_err(1, 'unknown command line option') - !stop 'end of time step' + end select + end do ! looping through command line arguments -end do ! (looping through time) + ! check if master_file has been received. + if (len(trim(summaFileManagerFile))==0) call handle_err(1, "master_file is not received; type 'summa.exe --help' for correct usage") -! deallocate space for dt_init and upArea -deallocate(dt_init,upArea,stat=err); call handle_err(err,'unable to deallocate space for dt_init and upArea') + ! set startGRU for full run + if (iRunMode==iRunModeFull) startGRU=1 -call stop_program('finished simulation') + end subroutine getCommandArguments -contains + ! ************************************************************************************************** + ! internal subroutine to print the correct command line usage of SUMMA + ! ************************************************************************************************** + subroutine printCommandHelp() + implicit none + ! command line usage + print "(//A)",'Usage: summa.exe -m master_file [-s fileSuffix] [-g startGRU countGRU] [-h iHRU] [-r freqRestart] [-p freqProgress] [-c]' + print "(A,/)", ' summa.exe summa executable' + print "(A)", 'Running options:' + print "(A)", ' -m --master Define path/name of master file (required)' + print "(A)", ' -s --suffix Add fileSuffix to the output files' + print "(A)", ' -g --gru Run a subset of countGRU GRUs starting from index startGRU' + print "(A)", ' -h --hru Run a single HRU with index of iHRU' + print "(A)", ' -r --restart Define frequency [y,m,d,never] to write restart files' + print "(A)", ' -p --progress Define frequency [m,d,h,never] to print progress' + print "(A)", ' -v --version Display version infotmation of the current built' + stop + end subroutine printCommandHelp ! ************************************************************************************************** - ! private subroutine handle_err: error handler + ! internal subroutine handle_err: error handler ! ************************************************************************************************** subroutine handle_err(err,message) ! used to handle error codes - USE data_struc,only:mvar_data,mpar_data,indx_data ! variable data structure - USE var_lookup,only:iLookMVAR,iLookPARAM,iLookINDEX ! named variables defining elements in data structure + USE var_lookup,only:iLookPROG,iLookDIAG,iLookFLUX,iLookPARAM,iLookINDEX ! named variables defining elements in data structure implicit none - ! define dummy variables - integer(i4b),intent(in)::err ! error code - character(*),intent(in)::message ! error message + ! dummy variables + integer(i4b),intent(in) :: err ! error code + character(*),intent(in) :: message ! error message + ! local variables + integer(i4b) :: nc_err ! error code of nc_close + character(len=256) :: cmessage ! error message of the downwind routine + ! return if A-OK if(err==0) return ! process error messages if (err>0) then - write(*,'(a)') 'FATAL ERROR: '//trim(message) + write(*,'(//a/)') 'FATAL ERROR: '//trim(message) else - write(*,'(a)') 'WARNING: '//trim(message); print*,'(can keep going, but stopping anyway)' + write(*,'(//a/)') 'WARNING: '//trim(message); print*,'(can keep going, but stopping anyway)' endif ! dump variables print*, 'error, variable dump:' - if(allocated(dt_init)) print*, 'dt = ', dt_init - print*, 'istep = ', istep - if(associated(type_data))then - print*, 'HRU index = ', type_data%var(iLookTYPE%hruIndex) - endif - if(associated(forc_data))then - print*, 'pptrate = ', forc_data%var(iLookFORCE%pptrate) - print*, 'airtemp = ', forc_data%var(iLookFORCE%airtemp) - endif - if(associated(mpar_data))then - print*, 'theta_res = ', mpar_data%var(iLookPARAM%theta_res) ! soil residual volumetric water content (-) - print*, 'theta_sat = ', mpar_data%var(iLookPARAM%theta_sat) ! soil porosity (-) - print*, 'plantWiltPsi = ', mpar_data%var(iLookPARAM%plantWiltPsi) ! matric head at wilting point (m) - print*, 'soilStressParam = ', mpar_data%var(iLookPARAM%soilStressParam) ! parameter in the exponential soil stress function (-) - print*, 'critSoilWilting = ', mpar_data%var(iLookPARAM%critSoilWilting) ! critical vol. liq. water content when plants are wilting (-) - print*, 'critSoilTranspire = ', mpar_data%var(iLookPARAM%critSoilTranspire) ! critical vol. liq. water content when transpiration is limited (-) - endif - if(associated(mvar_data))then - if(associated(mvar_data%var(iLookMVAR%scalarSWE)%dat))then - print*, 'scalarSWE = ', mvar_data%var(iLookMVAR%scalarSWE)%dat(1) - print*, 'scalarSnowDepth = ', mvar_data%var(iLookMVAR%scalarSnowDepth)%dat(1) - print*, 'scalarCanopyTemp = ', mvar_data%var(iLookMVAR%scalarCanopyTemp)%dat(1) - print*, 'scalarRainPlusMelt = ', mvar_data%var(iLookMVAR%scalarRainPlusMelt)%dat(1) - write(*,'(a,100(i4,1x))' ) 'layerType = ', indx_data%var(iLookINDEX%layerType)%dat - write(*,'(a,100(f11.5,1x))') 'mLayerDepth = ', mvar_data%var(iLookMVAR%mLayerDepth)%dat - write(*,'(a,100(f11.5,1x))') 'mLayerTemp = ', mvar_data%var(iLookMVAR%mLayerTemp)%dat - write(*,'(a,100(f11.5,1x))') 'mLayerVolFracIce = ', mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat - write(*,'(a,100(f11.5,1x))') 'mLayerVolFracLiq = ', mvar_data%var(iLookMVAR%mLayerVolFracLiq)%dat - print*, 'mLayerMatricHead = ', mvar_data%var(iLookMVAR%mLayerMatricHead)%dat - print*, 'column inflow = ', mvar_data%var(iLookMVAR%mLayerColumnInflow)%dat - - endif - endif + if(allocated(timeStruct%var))then + ! print time step + print*, 'modelTimeStep = ', modelTimeStep + ! print information for the HRUs + if(iGRU<=nGRU)then + if(iHRU<=gru_struc(iGRU)%hruCount)then + print*, 'initial time step = ', dt_init(iGRU)%hru(iHRU) + print*, 'HRU index = ', typeStruct%gru(iGRU)%hru(iHRU)%var(iLookTYPE%hruIndex) + print*, 'pptrate = ', forcStruct%gru(iGRU)%hru(iHRU)%var(iLookFORCE%pptrate) + print*, 'airtemp = ', forcStruct%gru(iGRU)%hru(iHRU)%var(iLookFORCE%airtemp) + print*, 'theta_res = ', mparStruct%gru(iGRU)%hru(iHRU)%var(iLookPARAM%theta_res)%dat(1) ! soil residual volumetric water content (-) + print*, 'theta_sat = ', mparStruct%gru(iGRU)%hru(iHRU)%var(iLookPARAM%theta_sat)%dat(1) ! soil porosity (-) + print*, 'plantWiltPsi = ', mparStruct%gru(iGRU)%hru(iHRU)%var(iLookPARAM%plantWiltPsi)%dat(1) ! matric head at wilting point (m) + print*, 'soilStressParam = ', mparStruct%gru(iGRU)%hru(iHRU)%var(iLookPARAM%soilStressParam)%dat(1) ! parameter in the exponential soil stress function (-) + print*, 'critSoilWilting = ', mparStruct%gru(iGRU)%hru(iHRU)%var(iLookPARAM%critSoilWilting)%dat(1) ! critical vol. liq. water content when plants are wilting (-) + print*, 'critSoilTranspire = ', mparStruct%gru(iGRU)%hru(iHRU)%var(iLookPARAM%critSoilTranspire)%dat(1) ! critical vol. liq. water content when transpiration is limited (-) + print*, 'scalarSWE = ', progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarSWE)%dat(1) + print*, 'scalarSnowDepth = ', progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarSnowDepth)%dat(1) + print*, 'scalarCanopyTemp = ', progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarCanopyTemp)%dat(1) + print*, 'scalarRainPlusMelt = ', fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%scalarRainPlusMelt)%dat(1) + write(*,'(a,100(i4,1x))' ) 'layerType = ', indxStruct%gru(iGRU)%hru(iHRU)%var(iLookINDEX%layerType)%dat + write(*,'(a,100(f11.5,1x))') 'mLayerDepth = ', progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerDepth)%dat + write(*,'(a,100(f11.5,1x))') 'mLayerTemp = ', progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerTemp)%dat + write(*,'(a,100(f11.5,1x))') 'mLayerVolFracIce = ', progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerVolFracIce)%dat + write(*,'(a,100(f11.5,1x))') 'mLayerVolFracLiq = ', progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerVolFracLiq)%dat + print*, 'mLayerMatricHead = ', progStruct%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerMatricHead)%dat + print*, 'column inflow = ', fluxStruct%gru(iGRU)%hru(iHRU)%var(iLookFLUX%mLayerColumnInflow)%dat + endif ! if HRU is valid + endif ! if GRU is valid + endif ! if the time structure is allocated print*,'error code = ', err - if(associated(time_data)) print*, time_data%var - write(*,'(a)') trim(message) + if(allocated(timeStruct%var)) print*, timeStruct%var + !write(*,'(a)') trim(message) + + ! close any remaining output files + do iFreq = 1,nFreq + if (ncid(iFreq).ne.integerMissing) then + call nc_file_close(ncid(iFreq),nc_err,cmessage) + if(nc_err/=0) print*, trim(cmessage) + end if + end do + stop end subroutine handle_err @@ -672,15 +1317,32 @@ subroutine stop_program(message) character(*),intent(in)::message ! define the local variables integer(i4b),parameter :: outunit=6 ! write to screen - character(len=8) :: cdate2 ! final date - character(len=10) :: ctime2 ! final time + integer(i4b) :: ctime2(8) ! final time + real(dp) :: elpSec ! elapsed seconds + integer(i4b) :: nc_err ! error code of nc_close + character(len=256) :: cmessage ! error message of the downwind routine + + ! 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,nFreq + if (ncid(iFreq).ne.integerMissing) then + err = nf90_close(ncid(iFreq)) + end if + end do + ! get the final date and time - call date_and_time(cdate2,ctime2) + call date_and_time(values=ctime2) + + elpSec = elapsedSec(ctime1,ctime2) + ! print initial and final date and time - write(outunit,*) 'initial date/time = '//'ccyy='//cdate1(1:4)//' - mm='//cdate1(5:6)//' - dd='//cdate1(7:8), & - ' - hh='//ctime1(1:2)//' - mi='//ctime1(3:4)//' - ss='//ctime1(5:10) - write(outunit,*) 'final date/time = '//'ccyy='//cdate2(1:4)//' - mm='//cdate2(5:6)//' - dd='//cdate2(7:8), & - ' - hh='//ctime2(1:2)//' - mi='//ctime2(3:4)//' - ss='//ctime2(5:10) + write(outunit,"(A,I4,'-',I2.2,'-',I2.2,2x,I2,':',I2.2,':',I2.2,'.',I3.3)") 'initial date/time = ',ctime1(1:3),ctime1(5:8) + write(outunit,"(A,I4,'-',I2.2,'-',I2.2,2x,I2,':',I2.2,':',I2.2,'.',I3.3)") ' final date/time = ',ctime2(1:3),ctime2(5:8) + ! print elapsed time + write(outunit,"(/,A,1PG15.7,A)") ' elapsed time = ', elpSec, ' s' + write(outunit,"(A,1PG15.7,A)") ' or ', elpSec/60_dp, ' m' + write(outunit,"(A,1PG15.7,A)") ' or ', elpSec/3600_dp, ' h' + write(outunit,"(A,1PG15.7,A/)") ' or ', elpSec/86400_dp, ' d' ! stop with message print*,'FORTRAN STOP: '//trim(message) stop @@ -753,7 +1415,6 @@ SUBROUTINE SOIL_VEG_GEN_PARM(FILENAME_VEGTABLE, FILENAME_SOILTABLE, FILENAME_GEN CALL wrf_error_fatal ( message ) END IF - LUMATCH=0 FIND_LUTYPE : DO WHILE (LUMATCH == 0) @@ -800,7 +1461,7 @@ SUBROUTINE SOIL_VEG_GEN_PARM(FILENAME_VEGTABLE, FILENAME_SOILTABLE, FILENAME_GEN EMISSMAXTBL(LC), ALBEDOMINTBL(LC), & ALBEDOMAXTBL(LC), Z0MINTBL(LC), Z0MAXTBL(LC) ENDDO -! + READ (19,*) READ (19,*)TOPT_DATA READ (19,*) @@ -814,7 +1475,7 @@ SUBROUTINE SOIL_VEG_GEN_PARM(FILENAME_VEGTABLE, FILENAME_SOILTABLE, FILENAME_GEN READ (19,*) READ (19,*)NATURAL ENDIF -! + 2002 CONTINUE CLOSE (19) @@ -837,8 +1498,6 @@ SUBROUTINE SOIL_VEG_GEN_PARM(FILENAME_VEGTABLE, FILENAME_SOILTABLE, FILENAME_GEN LUMATCH=0 - - ! MPC add a new soil table FIND_soilTYPE : DO WHILE (LUMATCH == 0) READ (19,*) diff --git a/build/source/driver/summaversion.inc b/build/source/driver/summaversion.inc new file mode 100755 index 000000000..b1281a82b --- /dev/null +++ b/build/source/driver/summaversion.inc @@ -0,0 +1,4 @@ +character(len=64), parameter :: summaVersion = '1.0.0' +character(len=64), parameter :: buildTime = 'Sun Apr 9 09:49:57 MDT 2017' +character(len=64), parameter :: gitBranch = 'feature/checkChanges-0-ge264732' +character(len=64), parameter :: gitHash = 'e264732f654fc7d11d7e91e807da8cf1ba6bd3d9' diff --git a/build/source/engine/ascii_util.f90 b/build/source/dshare/ascii_util.f90 old mode 100644 new mode 100755 similarity index 93% rename from build/source/engine/ascii_util.f90 rename to build/source/dshare/ascii_util.f90 index 7cf5c4336..4e2906e31 --- a/build/source/engine/ascii_util.f90 +++ b/build/source/dshare/ascii_util.f90 @@ -35,7 +35,7 @@ subroutine file_open(infile,unt,err,message) implicit none ! declare dummy variables character(*),intent(in) :: infile ! filename - integer(i4b),intent(in) :: unt ! file unit + integer(i4b),intent(out) :: unt ! file unit integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! declare local variables @@ -48,19 +48,19 @@ subroutine file_open(infile,unt,err,message) if(.not.xist)then message=trim(message)//"FileNotFound[file='"//trim(infile)//"']" err=10; return - endif + end if ! check if the file is already open inquire(file=trim(infile),opened=xopn) ! Check if the file is open if(xopn)then message=trim(message)//"FileAlreadyOpen['"//trim(infile)//"']" err=20; return - endif + end if ! open file - open(unt,file=trim(infile),status="old",action="read",iostat=err) + open(newunit=unt,file=trim(infile),status="old",action="read",iostat=err) if(err/=0)then message=trim(message)//"OpenError['"//trim(infile)//"']" err=20; return - endif + end if end subroutine file_open @@ -76,10 +76,10 @@ 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=2048 + integer(i4b),parameter :: cLen=8192 character(len=cLen) :: temp ! temporary line of characters integer(i4b) :: iword ! loop through words - integer(i4b),parameter :: maxWords=100 ! maximum number of words in a line + 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 @@ -109,14 +109,14 @@ subroutine split_line(inline,words,err,message) else allocate(current%next); current%next=node(cword,iword,null()) current=>current%next - endif + end if ! check that the line has fewer words than maxWords - if (iword==maxWords)then; err=20; message=trim(message)//"exceedMaxWords [line = "//trim(inline)//"]"; return; endif + if (iword==maxWords)then; err=20; message=trim(message)//"exceedMaxWords [line = "//trim(inline)//"]"; return; end if end do ! ***** allocate space for the list of words nWords = current%ix allocate(words(nWords),stat=err) - if(err/=0)then; err=30; message=trim(message)//"problemAllocateWords"; return; endif + if(err/=0)then; err=30; message=trim(message)//"problemAllocateWords"; return; end if ! ***** save the list in a vector, and deallocate space as we go... current=>list do while(associated(current)) @@ -140,7 +140,7 @@ subroutine get_vlines(unt,vlines,err,message) character(*),intent(out) :: message ! error message ! declare local variables integer(i4b) :: iline ! loop through lines in the file - integer(i4b),parameter :: maxLines=1000 ! maximum number of valid lines in a 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 @@ -159,7 +159,7 @@ subroutine get_vlines(unt,vlines,err,message) 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)=='!')cycle + 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 @@ -169,12 +169,12 @@ subroutine get_vlines(unt,vlines,err,message) allocate(current%next) current%next=node(temp,icount,null()) current=>current%next - endif - if (iline==maxLines)then; err=20; message=trim(message)//"exceedMaxLines"; return; endif + 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; endif + 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)) diff --git a/build/source/dshare/data_struc.f90 b/build/source/dshare/data_struc.f90 deleted file mode 100644 index a4bc4474f..000000000 --- a/build/source/dshare/data_struc.f90 +++ /dev/null @@ -1,165 +0,0 @@ -! 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 data_struc - ! used to define model data structures - USE nrtype - USE multiconst,only:integerMissing - implicit none - private - ! *********************************************************************************************************** - ! Define the model decisions - ! *********************************************************************************************************** - ! the model decision structure - type,public :: model_options - character(len=64) :: cOption='notPopulatedYet' - character(len=64) :: cDecision='notPopulatedYet' - integer(i4b) :: iDecision=integerMissing - end type model_options - type(model_options),pointer,save,public :: model_decisions(:) ! the decision structure - ! *********************************************************************************************************** - ! Define metadata for model forcing datafile - ! *********************************************************************************************************** - ! define a derived type for the data in the file - type,public :: file_info - character(len=256) :: filenmDesc='notPopulatedYet' ! name of file that describes the data - character(len=256) :: filenmData='notPopulatedYet' ! name of data file - integer(i4b) :: ncols ! number of columns in the file - integer(i4b) :: ixFirstHRU ! index of the first HRU to share the same data - integer(i4b),pointer :: time_ix(:) => null() ! column index for each time variable - integer(i4b),pointer :: data_ix(:) => null() ! column index for each forcing data variable - end type file_info - ! and save all the data in a single data structure - ! NOTE: vector (HRU dimension) - type(file_info),pointer,save,public :: forcFileInfo(:) => null() ! file info for model forcing data - ! *********************************************************************************************************** - ! Define metadata on model parameters - ! *********************************************************************************************************** - ! define a data type to store model parameter information - type,public :: par_info - real(dp) :: default_val ! default parameter value - real(dp) :: lower_limit ! lower bound - real(dp) :: upper_limit ! upper bound - endtype par_info - ! define a vector, with a separate element for each parameter (variable) - type(par_info),pointer,save,public :: localParFallback(:) => null() ! local column default parameters - type(par_info),pointer,save,public :: basinParFallback(:) => null() ! basin-average default parameters - ! *********************************************************************************************************** - ! Define variable metadata - ! *********************************************************************************************************** - ! define derived type for model variables, including name, decription, and units - type,public :: var_info - character(len=64) :: varname='' ! variable name - CHARACTER(len=128) :: vardesc='' ! variable description - character(len=64) :: varunit='' ! variable units - character(len=32) :: vartype='' ! variable type (scalar, model layers, etc.) - logical(lgt) :: v_write=.FALSE. ! flag to write variable to the output file - endtype var_info - ! define arrays of metadata - type(var_info),pointer,save,public :: time_meta(:) => null() ! model time information - type(var_info),pointer,save,public :: forc_meta(:) => null() ! model forcing data - type(var_info),pointer,save,public :: attr_meta(:) => null() ! local attributes - type(var_info),pointer,save,public :: type_meta(:) => null() ! local classification of veg, soil, etc. - type(var_info),pointer,save,public :: mpar_meta(:) => null() ! local model parameters for each HRU - type(var_info),pointer,save,public :: mvar_meta(:) => null() ! local model variables for each HRU - type(var_info),pointer,save,public :: indx_meta(:) => null() ! local model indices for each HRU - type(var_info),pointer,save,public :: bpar_meta(:) => null() ! basin parameters for aggregated processes - type(var_info),pointer,save,public :: bvar_meta(:) => null() ! basin parameters for aggregated processes - ! *********************************************************************************************************** - ! Define hierarchal derived data types - ! *********************************************************************************************************** - ! define named variables to describe the layer type - integer(i4b),parameter,public :: ix_soil=1001 ! named variable to denote a soil layer - integer(i4b),parameter,public :: ix_snow=1002 ! named variable to denote a snow layer - integer(i4b),parameter,public :: ix_mixd=1003 ! named variable to denote a mixed layer - ! 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(dp),pointer :: dat(:) => null() - endtype dlength - ! ** integer type - type, public :: ilength - integer(i4b),pointer :: dat(:) => null() - endtype ilength - ! define derived types to hold data for multiple variables - ! NOTE: use derived types here to facilitate adding extra dimensions (e.g., spatial) - ! ** double precision type of variable length - type, public :: var_dlength - type(dlength),pointer :: var(:) => null() - endtype var_dlength - ! ** integer type of variable length - type, public :: var_ilength - type(ilength),pointer :: var(:) => null() - endtype var_ilength - ! ** double precision type of fixed length - type, public :: var_d - real(dp),pointer :: var(:) => null() - endtype var_d - ! ** integer type of variable length - type, public :: var_i - integer(i4b),pointer :: var(:) => null() - endtype var_i - ! define top-level derived types - ! NOTE: either allocate directly, or use to point to higher dimensional structures - type(var_i),pointer,save,public :: time_hru(:) => null() ! model time data - type(var_d),pointer,save,public :: forc_hru(:) => null() ! model forcing data - type(var_d),pointer,save,public :: attr_hru(:) => null() ! local attributes for each HRU - type(var_i),pointer,save,public :: type_hru(:) => null() ! local classification of soil veg etc. for each HRU - type(var_d),pointer,save,public :: mpar_hru(:) => null() ! model parameters - type(var_dlength),pointer,save,public :: mvar_hru(:) => null() ! model variables - type(var_ilength),pointer,save,public :: indx_hru(:) => null() ! model indices - ! define data types for individual HRUs, and for basin-average quantities - type(var_i),pointer,save,public :: time_data => null() ! model time data - type(var_d),pointer,save,public :: forc_data => null() ! model forcing data - type(var_d),pointer,save,public :: attr_data => null() ! local attributes - type(var_i),pointer,save,public :: type_data => null() ! local classification of veg, soil, etc. - type(var_d),pointer,save,public :: mpar_data => null() ! local column model parameters - type(var_dlength),pointer,save,public :: mvar_data => null() ! local column model variables - type(var_ilength),pointer,save,public :: indx_data => null() ! local column model indices - type(var_d),pointer,save,public :: bpar_data => null() ! basin-average model parameters - type(var_dlength),pointer,save,public :: bvar_data => null() ! basin-average model variables - ! *********************************************************************************************************** - ! Define common variables - ! *********************************************************************************************************** - integer(i4b),save,public :: nSnow ! number of snow layers - integer(i4b),save,public :: nSoil ! number of soil layers - integer(i4b),save,public :: nLayers ! total number of layers in the snow-soil system - integer(i4b),save,public :: numtim ! number of time steps - real(dp),save,public :: data_step ! time step of the data - real(dp),save,public :: refJulday ! reference time in fractional julian days - real(dp),save,public :: fracJulday ! fractional julian days since the start of year - real(dp),save,public :: dJulianStart ! julian day of start time of simulation - real(dp),save,public :: dJulianFinsh ! julian day of end time of simulation - integer(i4b),save,public :: yearLength ! number of days in the current year - integer(i4b),save,public :: urbanVegCategory=1 ! 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 - ! *********************************************************************************************************** - ! Define ancillary data structures - ! *********************************************************************************************************** - type(var_i),pointer,save,public :: refTime => null() ! reference time for the model simulation - type(var_i),pointer,save,public :: startTime => null() ! start time for the model simulation - type(var_i),pointer,save,public :: finshTime => null() ! end time for the model simulation - ! *********************************************************************************************************** - - -END MODULE data_struc - diff --git a/build/source/dshare/data_types.f90 b/build/source/dshare/data_types.f90 new file mode 100755 index 000000000..c35aa1757 --- /dev/null +++ b/build/source/dshare/data_types.f90 @@ -0,0 +1,221 @@ +! 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 data_types + ! used to define model data structures + USE nrtype, integerMissing=>nr_integerMissing + USE var_lookup,only:maxvarStat + implicit none + ! constants necessary for variable defs + private + + ! *********************************************************************************************************** + ! Define the model decisions + ! *********************************************************************************************************** + ! the model decision structure + type,public :: model_options + character(len=64) :: cOption = 'notPopulatedYet' + character(len=64) :: cDecision = 'notPopulatedYet' + integer(i4b) :: iDecision = integerMissing + end type model_options + + ! *********************************************************************************************************** + ! Define metadata for model forcing datafile + ! *********************************************************************************************************** + ! 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 :: data_id(:) ! netcdf variable id for each forcing data variable + character(len=256),allocatable :: varName(:) ! netcdf variable name for each forcing data variable + real(dp) :: firstJulDay ! first julian day in forcing file + real(dp) :: convTime2Days ! factor to convert time to days + end type file_info + + ! *********************************************************************************************************** + ! Define metadata on model parameters + ! *********************************************************************************************************** + ! define a data type to store model parameter information + type,public :: par_info + real(dp) :: default_val ! default parameter value + real(dp) :: lower_limit ! lower bound + real(dp) :: upper_limit ! upper bound + endtype par_info + + ! *********************************************************************************************************** + ! Define variable metadata + ! *********************************************************************************************************** + ! 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 + logical(lgt),dimension(maxvarStat) :: statFlag = .false. ! statistic flag (on/off) + integer(i4b) :: outFreq = integerMissing ! output file id # - each variable may be output to exactly one of maxFreq output files + integer(i4b),dimension(maxvarStat) :: ncVarID = integerMissing ! netcdf variable id + 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 + 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 + endtype flux2state + + ! *********************************************************************************************************** + ! Define summary of data structures + ! *********************************************************************************************************** + ! 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 + end type struct_info + + ! *********************************************************************************************************** + ! Define data types to map between GRUs and HRUs + ! *********************************************************************************************************** + + ! 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(i4b) :: 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(i4b) :: gruId ! 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 + 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 ! index of a hru within a gru + endtype hru2gru_map + + ! *********************************************************************************************************** + ! Define hierarchal derived data types + ! *********************************************************************************************************** + ! 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(dp),allocatable :: dat(:) ! dat(:) + endtype dlength + ! ** integer type + type, public :: ilength + integer(i4b),allocatable :: dat(:) ! dat(:) + endtype ilength + + ! define derived types to hold data for multiple variables + ! NOTE: use derived types here to facilitate adding extra dimensions (e.g., spatial) + ! ** double precision type of variable length + type, public :: var_dlength + type(dlength),allocatable :: var(:) ! var(:)%dat + endtype var_dlength + ! ** integer type of variable length + type, public :: var_ilength + type(ilength),allocatable :: var(:) ! var(:)%dat + endtype var_ilength + ! ** double precision type of fixed length + type, public :: var_d + real(dp),allocatable :: var(:) ! var(:) + endtype var_d + ! ** integer type of fixed length + type, public :: var_i + integer(i4b),allocatable :: var(:) ! var(:) + endtype var_i + + ! ** double precision type of fixed length + type, public :: hru_d + real(dp),allocatable :: hru(:) ! hru(:) + endtype hru_d + ! ** integer type of fixed length + type, public :: hru_i + integer(i4b),allocatable :: hru(:) ! hru(:) + endtype hru_i + + ! 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 + endtype hru_doubleVec + ! ** integer type of variable length + type, public :: hru_intVec + type(var_ilength),allocatable :: hru(:) ! hru(:)%var(:)%dat + endtype hru_intVec + ! ** double precision type of fixed length + type, public :: hru_double + type(var_d),allocatable :: hru(:) ! hru(:)%var(:) + endtype hru_double + ! ** integer type of fixed length + type, public :: hru_int + type(var_i),allocatable :: hru(:) ! hru(:)%var(:) + endtype hru_int + + ! 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 + endtype gru_doubleVec + ! ** integer type of variable length + type, public :: gru_intVec + type(var_ilength),allocatable :: gru(:) ! gru(:)%var(:)%dat + endtype gru_intVec + ! ** double precision type of fixed length + type, public :: gru_double + type(var_d),allocatable :: gru(:) ! gru(:)%var(:) + endtype gru_double + ! ** integer type of variable length + type, public :: gru_int + type(var_i),allocatable :: gru(:) ! gru(:)%var(:) + endtype gru_int + + ! 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 + endtype gru_hru_doubleVec + ! ** integer type of variable length + type, public :: gru_hru_intVec + type(hru_intVec),allocatable :: gru(:) ! gru(:)%hru(:)%var(:)%dat + endtype gru_hru_intVec + ! ** double precision type of fixed length + type, public :: gru_hru_double + type(hru_double),allocatable :: gru(:) ! gru(:)%hru(:)%var(:) + endtype gru_hru_double + ! ** integer type of variable length + type, public :: gru_hru_int + type(hru_int),allocatable :: gru(:) ! gru(:)%hru(:)%var(:) + endtype gru_hru_int + +END MODULE data_types + diff --git a/build/source/dshare/flxMapping.f90 b/build/source/dshare/flxMapping.f90 new file mode 100755 index 000000000..419a71357 --- /dev/null +++ b/build/source/dshare/flxMapping.f90 @@ -0,0 +1,209 @@ +module flxMapping_module +implicit none +private +public::flxMapping +contains + + 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 + ! structures of named 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) + ! 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 + ! access missing values + USE globalData,only:integerMissing ! missing integer + implicit none + ! dummy variables + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! local variables + integer(i4b) :: iVar ! variable index + integer(i4b) :: nFlux ! number of fluxes + integer(i4b),parameter :: integerUndefined=0 ! named variable to denote that the flux is undefined + ! initialize error control + err=0; message='flxMapping/' + + ! get the number of fluxes + nFlux = size(flux_meta) + + ! ----- + ! - original state variables... + ! ----------------------------- + + ! ** initialize flux-to-state mapping + do iVar=1,nFlux + flux2state_orig(iVar)%state1 = integerUndefined + flux2state_orig(iVar)%state2 = integerUndefined + end do + + ! ** define mapping between fluxes and states + + ! net energy and mass fluxes for the vegetation domain + flux2state_orig(iLookFLUX%scalarCanopyNetLiqFlux) = flux2state(state1=iname_watCanopy, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarCanairNetNrgFlux) = flux2state(state1=iname_nrgCanair, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarCanopyNetNrgFlux) = flux2state(state1=iname_nrgCanopy, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarGroundNetNrgFlux) = flux2state(state1=iname_nrgLayer, state2=integerMissing) + + ! precipitation -- does not depend on state variables + flux2state_orig(iLookFLUX%scalarRainfall) = flux2state(state1=integerMissing, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarSnowfall) = flux2state(state1=integerMissing, state2=integerMissing) + + ! shortwave radiation -- does not depend on state variables + flux2state_orig(iLookFLUX%spectralIncomingDirect) = flux2state(state1=integerMissing, state2=integerMissing) + flux2state_orig(iLookFLUX%spectralIncomingDiffuse) = flux2state(state1=integerMissing, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarCanopySunlitPAR) = flux2state(state1=integerMissing, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarCanopyShadedPAR) = flux2state(state1=integerMissing, state2=integerMissing) + flux2state_orig(iLookFLUX%spectralBelowCanopyDirect) = flux2state(state1=integerMissing, state2=integerMissing) + flux2state_orig(iLookFLUX%spectralBelowCanopyDiffuse) = flux2state(state1=integerMissing, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarBelowCanopySolar) = flux2state(state1=integerMissing, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarCanopyAbsorbedSolar) = flux2state(state1=integerMissing, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarGroundAbsorbedSolar) = flux2state(state1=integerMissing, state2=integerMissing) + + ! longwave radiation -- assume calculated when the canopy energy state variable is active OR when the ground energy state variable is active + flux2state_orig(iLookFLUX%scalarLWRadCanopy) = flux2state(state1=iname_nrgCanopy, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarLWRadGround) = flux2state(state1=iname_nrgCanopy, state2=iname_nrgLayer) + flux2state_orig(iLookFLUX%scalarLWRadUbound2Canopy) = flux2state(state1=iname_nrgCanopy, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarLWRadUbound2Ground) = flux2state(state1=iname_nrgCanopy, state2=iname_nrgLayer) + flux2state_orig(iLookFLUX%scalarLWRadUbound2Ubound) = flux2state(state1=iname_nrgCanopy, state2=iname_nrgLayer) + flux2state_orig(iLookFLUX%scalarLWRadCanopy2Ubound) = flux2state(state1=iname_nrgCanopy, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarLWRadCanopy2Ground) = flux2state(state1=iname_nrgCanopy, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarLWRadCanopy2Canopy) = flux2state(state1=iname_nrgCanopy, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarLWRadGround2Ubound) = flux2state(state1=iname_nrgCanopy, state2=iname_nrgLayer) + flux2state_orig(iLookFLUX%scalarLWRadGround2Canopy) = flux2state(state1=iname_nrgCanopy, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarLWNetCanopy) = flux2state(state1=iname_nrgCanopy, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarLWNetGround) = flux2state(state1=iname_nrgCanopy, state2=iname_nrgLayer) + flux2state_orig(iLookFLUX%scalarLWNetUbound) = flux2state(state1=iname_nrgCanopy, state2=iname_nrgLayer) + + ! turbulent heat transfer -- assume calculated when the canopy energy state variable is active OR when the ground energy state variable is active + flux2state_orig(iLookFLUX%scalarEddyDiffusCanopyTop) = flux2state(state1=iname_nrgCanopy, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarFrictionVelocity) = flux2state(state1=iname_nrgCanopy, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarWindspdCanopyTop) = flux2state(state1=iname_nrgCanopy, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarWindspdCanopyBottom) = flux2state(state1=iname_nrgCanopy, state2=integerMissing) + 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%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) + flux2state_orig(iLookFLUX%scalarLatHeatTotal) = flux2state(state1=iname_nrgCanopy, state2=iname_nrgLayer) + flux2state_orig(iLookFLUX%scalarLatHeatCanopyEvap) = flux2state(state1=iname_nrgCanopy, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarLatHeatCanopyTrans) = flux2state(state1=iname_nrgCanopy, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarLatHeatGround) = flux2state(state1=iname_nrgCanopy, state2=iname_nrgLayer) + flux2state_orig(iLookFLUX%scalarCanopyAdvectiveHeatFlux) = flux2state(state1=iname_nrgCanopy, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarGroundAdvectiveHeatFlux) = flux2state(state1=iname_nrgCanopy, state2=iname_nrgLayer) + flux2state_orig(iLookFLUX%scalarCanopySublimation) = flux2state(state1=iname_nrgCanopy, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarSnowSublimation) = flux2state(state1=iname_nrgCanopy, state2=iname_nrgLayer) + + ! stomatal resistance and photosynthesis -- calculated when the canopy energy state variable is active + flux2state_orig(iLookFLUX%scalarStomResistSunlit) = flux2state(state1=iname_nrgCanopy, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarStomResistShaded) = flux2state(state1=iname_nrgCanopy, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarPhotosynthesisSunlit) = flux2state(state1=iname_nrgCanopy, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarPhotosynthesisShaded) = flux2state(state1=iname_nrgCanopy, state2=integerMissing) + + ! liquid water fluxes associated with evapotranspiration + ! NOTE 1: calculated in the energy balance routines: energy balance must be calculated first in order for water to balance + ! NOTE 2: if implement strang splitting, need to average fluxes from the start and end of the time step + 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%mLayerTranspire) = flux2state(state1=iname_matLayer, state2=integerMissing) + + ! liquid and solid water fluxes through the canopy + flux2state_orig(iLookFLUX%scalarThroughfallSnow) = flux2state(state1=integerMissing, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarCanopySnowUnloading) = flux2state(state1=integerMissing, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarThroughfallRain) = flux2state(state1=iname_watCanopy, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarCanopyLiqDrainage) = flux2state(state1=iname_watCanopy, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarCanopyMeltFreeze) = flux2state(state1=integerMissing, state2=integerMissing) + + ! energy fluxes and for the snow and soil domains + flux2state_orig(iLookFLUX%iLayerConductiveFlux) = flux2state(state1=iname_nrgLayer, state2=integerMissing) + flux2state_orig(iLookFLUX%iLayerAdvectiveFlux) = flux2state(state1=iname_nrgLayer, state2=integerMissing) + flux2state_orig(iLookFLUX%iLayerNrgFlux) = flux2state(state1=iname_nrgLayer, state2=integerMissing) + flux2state_orig(iLookFLUX%mLayerNrgFlux) = flux2state(state1=iname_nrgLayer, state2=integerMissing) + + ! liquid water fluxes for the snow domain + flux2state_orig(iLookFLUX%scalarSnowDrainage) = flux2state(state1=iname_watLayer, state2=integerMissing) + flux2state_orig(iLookFLUX%iLayerLiqFluxSnow) = flux2state(state1=iname_watLayer, state2=integerMissing) + flux2state_orig(iLookFLUX%mLayerLiqFluxSnow) = flux2state(state1=iname_watLayer, state2=integerMissing) + + ! liquid water fluxes for the soil domain + flux2state_orig(iLookFLUX%scalarRainPlusMelt) = flux2state(state1=iname_watLayer, state2=integerMissing) + flux2state_orig(iLookFLUX%scalarMaxInfilRate) = flux2state(state1=iname_matLayer, state2=integerMissing) + 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%mLayerSatHydCondMP) = flux2state(state1=integerMissing, state2=integerMissing) + flux2state_orig(iLookFLUX%mLayerSatHydCond) = flux2state(state1=integerMissing, state2=integerMissing) + flux2state_orig(iLookFLUX%iLayerSatHydCond) = flux2state(state1=integerMissing, state2=integerMissing) + flux2state_orig(iLookFLUX%mLayerHydCond) = flux2state(state1=iname_matLayer, state2=integerMissing) + flux2state_orig(iLookFLUX%iLayerLiqFluxSoil) = flux2state(state1=iname_matLayer, state2=integerMissing) + flux2state_orig(iLookFLUX%mLayerLiqFluxSoil) = flux2state(state1=iname_matLayer, state2=integerMissing) + flux2state_orig(iLookFLUX%mLayerBaseflow) = flux2state(state1=iname_matLayer, state2=integerMissing) + flux2state_orig(iLookFLUX%mLayerColumnInflow) = flux2state(state1=integerMissing, state2=integerMissing) + 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) + + ! ** copy across flux metadata + do iVar=1,nFlux + flux2state_orig(iVar)%var_info = flux_meta(iVar) + end do + + ! ** check all variables are defined + do iVar=1,nFlux + if(flux2state_orig(iVar)%state1==integerUndefined .or. flux2state_orig(iVar)%state2==integerUndefined)then + message=trim(message)//'flux-to-state mapping is undefined for variable "'//trim(flux_meta(iVar)%varname)//'"' + err=20; return + endif + end do + + ! ----- + ! - liquid water state variables... + ! --------------------------------- + + ! initialize to the original structure + do iVar=1,nFlux + flux2state_liq(iVar)%state1 = flux2state_orig(iVar)%state1 + flux2state_liq(iVar)%state2 = flux2state_orig(iVar)%state2 + end do + + ! modify the state type names associated with the flux mapping structure + do iVar=1,nFlux + ! (mass of total water on the vegetation canopy --> mass of liquid water) + if(flux2state_liq(iVar)%state1==iname_watCanopy) flux2state_liq(iVar)%state1=iname_liqCanopy + if(flux2state_liq(iVar)%state2==iname_watCanopy) flux2state_liq(iVar)%state2=iname_liqCanopy + ! (volumetric total water in the snow+soil domain --> volumetric liquid water) + if(flux2state_liq(iVar)%state1==iname_watLayer) flux2state_liq(iVar)%state1=iname_liqLayer + if(flux2state_liq(iVar)%state2==iname_watLayer) flux2state_liq(iVar)%state2=iname_liqLayer + ! (total water matric potential in the snow+soil domain --> liquid water matric potential) + if(flux2state_liq(iVar)%state1==iname_matLayer) flux2state_liq(iVar)%state1=iname_lmpLayer + if(flux2state_liq(iVar)%state2==iname_matLayer) flux2state_liq(iVar)%state2=iname_lmpLayer + end do + + ! copy across flux metadata + do iVar=1,nFlux + flux2state_liq(iVar)%var_info = flux_meta(iVar) + end do + + end subroutine flxMapping + +end module flxMapping_module diff --git a/build/source/dshare/get_ixname.f90 b/build/source/dshare/get_ixname.f90 new file mode 100755 index 000000000..f9818f0c2 --- /dev/null +++ b/build/source/dshare/get_ixname.f90 @@ -0,0 +1,988 @@ +! 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 get_ixname_module +! used to get the index of a named variable +USE nrtype, integerMissing=>nr_integerMissing +implicit none +private +public::get_ixdecisions +public::get_ixtime +public::get_ixattr +public::get_ixtype +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 +public::get_statName +contains + + ! ******************************************************************************************************************* + ! public function get_ixdecisions: get the index of the named variables for the model decisions + ! ******************************************************************************************************************* + function get_ixdecisions(varName) + USE var_lookup,only:iLookDECISIONS ! indices of the named variables + implicit none + ! define dummy variables + character(*), intent(in) :: varName ! variable name + integer(i4b) :: get_ixdecisions ! index of the named variable + ! get the index of the named variables + select case(trim(varName)) + case('simulStart' ); get_ixdecisions=iLookDECISIONS%simulStart ! ( 1) simulation start time + case('simulFinsh' ); get_ixdecisions=iLookDECISIONS%simulFinsh ! ( 2) simulation end time + case('soilCatTbl' ); get_ixdecisions=iLookDECISIONS%soilCatTbl ! ( 3) soil-category dateset + case('vegeParTbl' ); get_ixdecisions=iLookDECISIONS%vegeParTbl ! ( 4) vegetation category dataset + case('soilStress' ); get_ixdecisions=iLookDECISIONS%soilStress ! ( 5) choice of function for the soil moisture control on stomatal resistance + case('stomResist' ); get_ixdecisions=iLookDECISIONS%stomResist ! ( 6) choice of function for stomatal resistance + case('bbTempFunc' ); get_ixdecisions=iLookDECISIONS%bbTempFunc ! ( 7) Ball-Berry: leaf temperature controls on photosynthesis + stomatal resistance + case('bbHumdFunc' ); get_ixdecisions=iLookDECISIONS%bbHumdFunc ! ( 8) Ball-Berry: humidity controls on stomatal resistance + case('bbElecFunc' ); get_ixdecisions=iLookDECISIONS%bbElecFunc ! ( 9) Ball-Berry: dependence of photosynthesis on PAR + case('bbCO2point' ); get_ixdecisions=iLookDECISIONS%bbCO2point ! (10) Ball-Berry: use of CO2 compensation point to calculate stomatal resistance + case('bbNumerics' ); get_ixdecisions=iLookDECISIONS%bbNumerics ! (11) Ball-Berry: iterative numerical solution method + case('bbAssimFnc' ); get_ixdecisions=iLookDECISIONS%bbAssimFnc ! (12) Ball-Berry: controls on carbon assimilation + case('bbCanIntg8' ); get_ixdecisions=iLookDECISIONS%bbCanIntg8 ! (13) Ball-Berry: scaling of photosynthesis from the leaf to the canopy + case('num_method' ); get_ixdecisions=iLookDECISIONS%num_method ! (14) choice of numerical method + case('fDerivMeth' ); get_ixdecisions=iLookDECISIONS%fDerivMeth ! (15) choice of method to calculate flux derivatives + case('LAI_method' ); get_ixdecisions=iLookDECISIONS%LAI_method ! (16) choice of method to determine LAI and SAI + case('cIntercept' ); get_ixdecisions=iLookDECISIONS%cIntercept ! (17) choice of parameterization for canopy interception + case('f_Richards' ); get_ixdecisions=iLookDECISIONS%f_Richards ! (18) form of Richards' equation + case('groundwatr' ); get_ixdecisions=iLookDECISIONS%groundwatr ! (19) choice of groundwater parameterization + case('hc_profile' ); get_ixdecisions=iLookDECISIONS%hc_profile ! (20) choice of hydraulic conductivity profile + case('bcUpprTdyn' ); get_ixdecisions=iLookDECISIONS%bcUpprTdyn ! (21) type of upper boundary condition for thermodynamics + case('bcLowrTdyn' ); get_ixdecisions=iLookDECISIONS%bcLowrTdyn ! (22) type of lower boundary condition for thermodynamics + case('bcUpprSoiH' ); get_ixdecisions=iLookDECISIONS%bcUpprSoiH ! (23) type of upper boundary condition for soil hydrology + case('bcLowrSoiH' ); get_ixdecisions=iLookDECISIONS%bcLowrSoiH ! (24) type of lower boundary condition for soil hydrology + case('veg_traits' ); get_ixdecisions=iLookDECISIONS%veg_traits ! (25) choice of parameterization for vegetation roughness length and displacement height + case('rootProfil' ); get_ixdecisions=iLookDECISIONS%rootProfil ! (26) choice of parameterization for the rooting profile + case('canopyEmis' ); get_ixdecisions=iLookDECISIONS%canopyEmis ! (27) choice of parameterization for canopy emissivity + case('snowIncept' ); get_ixdecisions=iLookDECISIONS%snowIncept ! (28) choice of parameterization for snow interception + case('windPrfile' ); get_ixdecisions=iLookDECISIONS%windPrfile ! (29) choice of canopy wind profile + case('astability' ); get_ixdecisions=iLookDECISIONS%astability ! (30) choice of stability function + case('compaction' ); get_ixdecisions=iLookDECISIONS%compaction ! (31) choice of compaction routine + case('snowLayers' ); get_ixdecisions=iLookDECISIONS%snowLayers ! (32) choice of method to combine and sub-divide snow layers + case('thCondSnow' ); get_ixdecisions=iLookDECISIONS%thCondSnow ! (33) choice of thermal conductivity representation for snow + case('thCondSoil' ); get_ixdecisions=iLookDECISIONS%thCondSoil ! (34) choice of thermal conductivity representation for soil + case('canopySrad' ); get_ixdecisions=iLookDECISIONS%canopySrad ! (35) choice of method for canopy shortwave radiation + case('alb_method' ); get_ixdecisions=iLookDECISIONS%alb_method ! (36) choice of albedo representation + case('spatial_gw' ); get_ixdecisions=iLookDECISIONS%spatial_gw ! (37) choice of method for spatial representation of groundwater + case('subRouting' ); get_ixdecisions=iLookDECISIONS%subRouting ! (38) choice of method for sub-grid routing + case('snowDenNew' ); get_ixdecisions=iLookDECISIONS%snowDenNew ! (39) choice of method for new snow density + ! get to here if cannot find the variable + case default + get_ixdecisions = integerMissing + end select + end function get_ixdecisions + + + ! ******************************************************************************************************************* + ! public function get_ixtime: get the index of the named variables for the model time + ! ******************************************************************************************************************* + 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 + ! 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 + ! get to here if cannot find the variable + case default + get_ixtime = integerMissing + end select + end function get_ixtime + + + ! ******************************************************************************************************************* + ! public function get_ixforce: get the index of the named variables for the model forcing data + ! ******************************************************************************************************************* + 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 + ! 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) + ! get to here if cannot find the variable + case default + get_ixforce = integerMissing + end select + end function get_ixforce + + + ! ******************************************************************************************************************* + ! public function get_ixAttr: get the index of the named variables for the site characteristics + ! ******************************************************************************************************************* + function get_ixAttr(varName) + USE var_lookup,only:iLookATTR ! indices of the named variables + implicit none + ! define dummy variables + character(*), intent(in) :: varName ! variable name + integer(i4b) :: get_ixAttr ! index of the named variable + ! get the index of the named variables + select case(trim(varName)) + case('latitude' ); get_ixAttr = iLookATTR%latitude ! latitude (degrees north) + case('longitude' ); get_ixAttr = iLookATTR%longitude ! longitude (degrees east) + case('elevation' ); get_ixAttr = iLookATTR%elevation ! elevation (m) + case('tan_slope' ); get_ixAttr = iLookATTR%tan_slope ! tan water table slope, taken as tan local ground surface slope (-) + case('contourLength' ); get_ixAttr = iLookATTR%contourLength ! length of contour at downslope edge of HRU (m) + case('HRUarea' ); get_ixAttr = iLookATTR%HRUarea ! area of each HRU (m2) + case('mHeight' ); get_ixAttr = iLookATTR%mHeight ! measurement height above bare ground (m) + ! get to here if cannot find the variable + case default + get_ixAttr = integerMissing + end select + end function get_ixAttr + + + ! ******************************************************************************************************************* + ! public function get_ixType: get the index of the named variables for the local classification of veg, soil, etc. + ! ******************************************************************************************************************* + function get_ixType(varName) + USE var_lookup,only:iLookTYPE ! indices of the named variables + implicit none + ! define dummy variables + character(*), intent(in) :: varName ! variable name + integer(i4b) :: get_ixType ! index of the named variable + ! get the index of the named variables + select case(trim(varName)) + case('hruIndex' ); get_ixType = iLookTYPE%hruIndex ! index defining HRU index + case('vegTypeIndex' ); get_ixType = iLookTYPE%vegTypeIndex ! index defining vegetation type + case('soilTypeIndex' ); get_ixType = iLookTYPE%soilTypeIndex ! index defining soil type + case('slopeTypeIndex' ); get_ixType = iLookTYPE%slopeTypeIndex ! index defining slope + case('downHRUindex' ); get_ixType = iLookTYPE%downHRUindex ! index of downslope HRU (0 = basin outlet) + ! get to here if cannot find the variable + case default + get_ixType = integerMissing + end select + end function get_ixType + + + ! ******************************************************************************************************************* + ! public function get_ixparam: get the index of the named variables for the model parameters + ! ******************************************************************************************************************* + 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 + ! 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) + ! 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 (-) + ! 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) + ! 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) + ! 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 (-) + ! 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) + ! 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) + ! 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 (-) + ! 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 (-) + ! 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) + ! 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 (-) + ! 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('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 (-) + ! 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) + ! get to here if cannot find the variable + case default + get_ixparam = integerMissing + end select + end function get_ixparam + + + ! ******************************************************************************************************************* + ! public function get_ixprog: get the index of the named variables for the prognostic (state) variables + ! ******************************************************************************************************************* + 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 + ! 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) + ! 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) + ! 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) + ! 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) + ! 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) + ! 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) + ! get to here if cannot find the variable + case default + get_ixprog = integerMissing + end select + end function get_ixprog + + + ! ******************************************************************************************************************* + ! public function get_ixdiag: get the index of the named variables for the diagnostic variables + ! ******************************************************************************************************************* + 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 + ! 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('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) + ! 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) + ! 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 (-) + ! 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 (-) + ! 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 (-) + ! 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 + ! 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) + ! 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) + ! 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) + ! 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) + ! number of function evaluations + case('numFluxCalls' ); get_ixdiag = iLookDIAG%numFluxCalls ! number of flux calls (-) + ! get to here if cannot find the variable + case default + get_ixdiag = integerMissing + end select + end function get_ixdiag + + + ! ******************************************************************************************************************* + ! public function get_ixdiag: get the index of the named variables for the fluxes + ! ******************************************************************************************************************* + 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 + ! 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) + ! 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) + ! 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) + ! 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) + ! 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) + ! 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) + ! 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) + ! 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) + ! 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) + ! 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 default + get_ixflux = integerMissing + end select + end function get_ixflux + + + ! ******************************************************************************************************************* + ! public function get_ixderiv: get the index of the named variables for the model derivatives + ! ******************************************************************************************************************* + 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 + ! 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) + ! 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) + ! 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) + ! 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) + ! 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) + ! 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) + ! 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 default + get_ixderiv = integerMissing + end select + end function get_ixderiv + + + ! ******************************************************************************************************************* + ! public function get_ixindex: get the index of the named variables for the model indices + ! ******************************************************************************************************************* + function get_ixindex(varName) + USE var_lookup,only:iLookINDEX ! indices of the named variables + implicit none + ! define dummy variables + character(*), intent(in) :: varName ! parameter name + integer(i4b) :: get_ixINDEX ! index of the named variable + ! get the index of the named variables + select case(trim(varName)) + ! number of model layers, and layer indices + case('nSnow' ); get_ixINDEX = iLookINDEX%nSnow ! number of snow layers (-) + case('nSoil' ); get_ixINDEX = iLookINDEX%nSoil ! number of soil layers (-) + case('nLayers' ); get_ixINDEX = iLookINDEX%nLayers ! total number of layers (-) + case('layerType' ); get_ixINDEX = iLookINDEX%layerType ! index defining type of layer (snow or soil) (-) + ! number of state variables of different type + case('nCasNrg' ); get_ixINDEX = iLookINDEX%nCasNrg ! number of energy state variables for the canopy air space domain (-) + case('nVegNrg' ); get_ixINDEX = iLookINDEX%nVegNrg ! number of energy state variables for the vegetation canopy (-) + case('nVegMass' ); get_ixINDEX = iLookINDEX%nVegMass ! number of hydrology states for vegetation (mass of water) (-) + case('nVegState' ); get_ixINDEX = iLookINDEX%nVegState ! number of vegetation state variables (-) + case('nNrgState' ); get_ixINDEX = iLookINDEX%nNrgState ! number of energy state variables (-) + case('nWatState' ); get_ixINDEX = iLookINDEX%nWatState ! number of "total water" states (vol. total water content) (-) + case('nMatState' ); get_ixINDEX = iLookINDEX%nMatState ! number of matric head state variables (-) + case('nMassState' ); get_ixINDEX = iLookINDEX%nMassState ! number of hydrology state variables (mass of water) (-) + case('nState' ); get_ixINDEX = iLookINDEX%nState ! total number of model state variables (-) + ! number of state variables within different domains in the snow+soil system + case('nSnowSoilNrg' ); get_ixINDEX = iLookINDEX%nSnowSoilNrg ! number of energy states in the snow+soil domain (-) + case('nSnowOnlyNrg' ); get_ixINDEX = iLookINDEX%nSnowOnlyNrg ! number of energy states in the snow domain (-) + case('nSoilOnlyNrg' ); get_ixINDEX = iLookINDEX%nSoilOnlyNrg ! number of energy states in the soil domain (-) + case('nSnowSoilHyd' ); get_ixINDEX = iLookINDEX%nSnowSoilHyd ! number of hydrology states in the snow+soil domain (-) + case('nSnowOnlyHyd' ); get_ixINDEX = iLookINDEX%nSnowOnlyHyd ! number of hydrology states in the snow domain (-) + case('nSoilOnlyHyd' ); get_ixINDEX = iLookINDEX%nSoilOnlyHyd ! number of hydrology states in the soil domain (-) + ! type of model state variables + case('ixControlVolume' ); get_ixINDEX = iLookINDEX%ixControlVolume ! index of the control volume for different domains (veg, snow, soil) (-) + case('ixDomainType' ); get_ixINDEX = iLookINDEX%ixDomainType ! index of the type of domain (iname_veg, iname_snow, iname_soil) (-) + case('ixStateType' ); get_ixINDEX = iLookINDEX%ixStateType ! index of the type of every state variable (iname_nrgCanair, ...) (-) + case('ixHydType' ); get_ixINDEX = iLookINDEX%ixHydType ! index of the type of hydrology states in snow+soil domain (-) + ! type of model state variables (state subset) + case('ixDomainType_subset' ); get_ixINDEX = iLookINDEX%ixDomainType_subset ! [state subset] id of domain for desired model state variables (-) + case('ixStateType_subset' ); get_ixINDEX = iLookINDEX%ixStateType_subset ! [state subset] type of desired model state variables (-) + ! mapping between state subset and the full state vector + case('ixMapFull2Subset' ); get_ixINDEX = iLookINDEX%ixMapFull2Subset ! list of indices of the state subset in the full state vector (-) + case('ixMapSubset2Full' ); get_ixINDEX = iLookINDEX%ixMapSubset2Full ! list of indices of the full state vector in the state subset (-) + ! indices of model specific state variables + case('ixCasNrg' ); get_ixINDEX = iLookINDEX%ixCasNrg ! index of canopy air space energy state variable (-) + case('ixVegNrg' ); get_ixINDEX = iLookINDEX%ixVegNrg ! index of canopy energy state variable (-) + case('ixVegHyd' ); get_ixINDEX = iLookINDEX%ixVegHyd ! index of canopy hydrology state variable (mass) (-) + case('ixTopNrg' ); get_ixINDEX = iLookINDEX%ixTopNrg ! index of upper-most energy state in the snow+soil subdomain (-) + case('ixTopHyd' ); get_ixINDEX = iLookINDEX%ixTopHyd ! index of upper-most hydrology state in the snow+soil subdomain (-) + ! vectors of indices for specific state types + case('ixNrgOnly' ); get_ixINDEX = iLookINDEX%ixNrgOnly ! indices IN THE STATE SUBSET for all energy states (-) + case('ixHydOnly' ); get_ixINDEX = iLookINDEX%ixHydOnly ! indices IN THE STATE SUBSET for hydrology states in the snow+soil domain (-) + case('ixMatOnly' ); get_ixINDEX = iLookINDEX%ixMatOnly ! indices IN THE STATE SUBSET for matric head state variables (-) + case('ixMassOnly' ); get_ixINDEX = iLookINDEX%ixMassOnly ! indices IN THE STATE SUBSET for hydrology states (mass of water) (-) + ! vectors of indicesfor specific state types within specific sub-domains + case('ixSnowSoilNrg' ); get_ixINDEX = iLookINDEX%ixSnowSoilNrg ! indices IN THE STATE SUBSET for energy states in the snow+soil domain (-) + case('ixSnowOnlyNrg' ); get_ixINDEX = iLookINDEX%ixSnowOnlyNrg ! indices IN THE STATE SUBSET for energy states in the snow domain (-) + case('ixSoilOnlyNrg' ); get_ixINDEX = iLookINDEX%ixSoilOnlyNrg ! indices IN THE STATE SUBSET for energy states in the soil domain (-) + case('ixSnowSoilHyd' ); get_ixINDEX = iLookINDEX%ixSnowSoilHyd ! indices IN THE STATE SUBSET for hydrology states in the snow+soil domain (-) + case('ixSnowOnlyHyd' ); get_ixINDEX = iLookINDEX%ixSnowOnlyHyd ! indices IN THE STATE SUBSET for hydrology states in the snow domain (-) + case('ixSoilOnlyHyd' ); get_ixINDEX = iLookINDEX%ixSoilOnlyHyd ! indices IN THE STATE SUBSET for hydrology states in the soil domain (-) + ! vectors of indices for specfic state types within specific sub-domains + case('ixNrgCanair' ); get_ixINDEX = iLookINDEX%ixNrgCanair ! indices IN THE STATE SUBSET for energy states in canopy air space domain (-) + case('ixNrgCanopy' ); get_ixINDEX = iLookINDEX%ixNrgCanopy ! indices IN THE STATE SUBSET for energy states in the canopy domain (-) + case('ixHydCanopy' ); get_ixINDEX = iLookINDEX%ixHydCanopy ! indices IN THE STATE SUBSET 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 (-) + ! 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 (-) + ! 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 (-) + ! indices for the model output files + case('midSnowStartIndex' ); get_ixINDEX = iLookINDEX%midSnowStartIndex ! start index of the midSnow vector for a given timestep (-) + case('midSoilStartIndex' ); get_ixINDEX = iLookINDEX%midSoilStartIndex ! start index of the midSoil vector for a given timestep (-) + case('midTotoStartIndex' ); get_ixINDEX = iLookINDEX%midTotoStartIndex ! start index of the midToto vector for a given timestep (-) + case('ifcSnowStartIndex' ); get_ixINDEX = iLookINDEX%ifcSnowStartIndex ! start index of the ifcSnow vector for a given timestep (-) + case('ifcSoilStartIndex' ); get_ixINDEX = iLookINDEX%ifcSoilStartIndex ! start index of the ifcSoil vector for a given timestep (-) + case('ifcTotoStartIndex' ); get_ixINDEX = iLookINDEX%ifcTotoStartIndex ! start index of the ifcToto vector for a given timestep (-) + case default + get_ixindex = integerMissing + end select + end function get_ixindex + + + ! ******************************************************************************************************************* + ! public function get_ixbpar: get the index of the named variables for the basin-average variables + ! ******************************************************************************************************************* + 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 + ! 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 (-) + ! 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) + ! get to here if cannot find the variable + case default + get_ixbpar = integerMissing + end select + end function get_ixbpar + + + ! ******************************************************************************************************************* + ! public function get_ixbvar: get the index of the named variables for the basin-average variables + ! ******************************************************************************************************************* + 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 + ! 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) + ! 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) + ! 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) + ! get to here if cannot find the variable + case default + get_ixbvar = integerMissing + end select + end function get_ixbvar + + ! ********************************************************************************************************* + ! public function get_ixVarType: get the index of the named variable type + ! ********************************************************************************************************* + function get_ixVarType(varType) + USE var_lookup,only:iLookVarType ! indices of the named variable types + implicit none + ! define dummy variables + character(*), intent(in) :: varType ! variable type name + integer(i4b) :: get_ixVarType ! index of the named variable type list + ! get the index of the named variables + select case(trim(varType)) + case('scalarv'); get_ixVarType = iLookVarType%scalarv + case('wLength'); get_ixVarType = iLookVarType%wLength + case('midSnow'); get_ixVarType = iLookVarType%midSnow + case('midSoil'); get_ixVarType = iLookVarType%midSoil + case('midToto'); get_ixVarType = iLookVarType%midToto + case('ifcSnow'); get_ixVarType = iLookVarType%ifcSnow + case('ifcSoil'); get_ixVarType = iLookVarType%ifcSoil + case('ifcToto'); get_ixVarType = iLookVarType%ifcToto + case('parSoil'); get_ixVarType = iLookVarType%parSoil + case('routing'); get_ixVarType = iLookVarType%routing + case('unknown'); get_ixVarType = iLookVarType%unknown + ! get to here if cannot find the variable + case default + get_ixVarType = integerMissing + end select + end function get_ixVarType + + ! **************************************************************************************************************** + ! public function get_varTypeName: get the index of the named variable type + ! **************************************************************************************************************** + function get_varTypeName(varType) + USE var_lookup,only:iLookVarType ! indices of the named variable types + implicit none + ! define dummy variables + integer(i4b), intent(in) :: varType ! variable type name + character(LEN=7) :: get_varTypeName ! index of the named variable type list + ! get the index of the named variables + select case(varType) + case(iLookVarType%scalarv);get_varTypeName='scalarv' + case(iLookVarType%wLength);get_varTypeName='wLength' + case(iLookVarType%midSnow);get_varTypeName='midSnow' + case(iLookVarType%midSoil);get_varTypeName='midSoil' + case(iLookVarType%midToto);get_varTypeName='midToto' + case(iLookVarType%ifcSnow);get_varTypeName='ifcSnow' + case(iLookVarType%ifcSoil);get_varTypeName='ifcSoil' + case(iLookVarType%ifcToto);get_varTypeName='ifcToto' + case(iLookVarType%parSoil);get_varTypeName='parSoil' + case(iLookVarType%routing);get_varTypeName='routing' + case(iLookVarType%unknown);get_varTypeName='unknown' + ! get to here if cannot find the variable + case default + get_VarTypeName = 'missing' + end select + end function get_VarTypeName + + ! ******************************************************************************************************************* + ! public subroutine get_ixUnknown: get the index of the named variable type from ANY structure, as well as the + ! structrue that it was found in + ! ******************************************************************************************************************* + subroutine get_ixUnknown(varName,typeName,vDex,err,message) + USE nrtype + USE globalData,only:structInfo ! information on the data structures + implicit none + + ! dummies + character(*),intent(in) :: varName ! variable name + character(*),intent(out) :: typeName ! variable type name + integer(i4b),intent(out) :: vDex ! variable index in structure + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + + ! internals + integer(i4b) :: iStruc ! index for looping through structure types + + ! error init + err=0 + message='get_ixUnknown/' + + ! loop through all structure types to find the one with the given variable name + ! pill 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 ('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)) + end select + if (vDex>0) then; typeName=trim(structInfo(iStruc)%structName); return; end if + end do + + ! 404 + err=20;message=trim(message)//'variable '//trim(varName)//' is not found in any structure'; return + + end subroutine get_ixUnknown + + ! *************************************************************************************************************** + ! 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 + implicit none + ! define dummy variables + integer(i4b), intent(in) :: istat ! stat type name + character(LEN=10) :: get_statName ! index of the named variable type list + ! 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' + ! get to here if cannot find the variable + case default + get_statName = 'unknown' + end select + end function get_statName + +end module get_ixname_module diff --git a/build/source/dshare/globalData.f90 b/build/source/dshare/globalData.f90 new file mode 100755 index 000000000..7e6576b3b --- /dev/null +++ b/build/source/dshare/globalData.f90 @@ -0,0 +1,176 @@ +! 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 globalData + ! data types + USE nrtype + 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: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:maxFreq ! maximum number of output files + implicit none + private + + ! define missing values + real(qp),parameter,public :: quadMissing = nr_quadMissing ! (from nrtype) missing quadruple precision number + real(dp),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 limit checks + real(dp),parameter,public :: verySmall=tiny(1.0_dp) ! a very small number + real(dp),parameter,public :: veryBig=1.e+20_dp ! a very big number + + ! define algorithmic control parameters + real(dp),parameter,public :: dx = 1.e-8_dp ! finite difference increment + + ! 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 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 :: 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=12 ! 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('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 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 + + ! define named variables to describe the state varible 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 + + ! 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=1 ! first layer of the Jacobian to print + integer(i4b),parameter,public :: iJac2=9 ! last layer of the Jacobian to print + + ! define mapping structures + type(gru2hru_map),allocatable,save,public :: gru_struc(:) ! gru2hru map ! NOTE: change variable name to be more self describing + type(hru2gru_map),allocatable,save,public :: index_map(:) ! hru2gru map ! NOTE: change variable name to be more self describing + + ! define common variables + integer(i4b),save,public :: numtim ! number of time steps + real(dp),save,public :: data_step ! time step of the data + real(dp),save,public :: refJulday ! reference time in fractional julian days + real(dp),save,public :: fracJulday ! fractional julian days since the start of year + real(dp),save,public :: dJulianStart ! julian day of start time of simulation + real(dp),save,public :: dJulianFinsh ! julian day of end time of simulation + 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 + + ! define ancillary data structures + type(var_i),save,public :: refTime ! reference time for the model simulation + type(var_i),save,public :: startTime ! start time for the model simulation + type(var_i),save,public :: finshTime ! end time for the model simulation + + ! output file information + integer(i4b),dimension(maxFreq),save,public :: ncid ! netcdf output file id + integer(i4b),save,public :: nFreq ! actual number of output files + integer(i4b),dimension(maxFreq),save,public :: outFreq ! frequency of all output files + + + +END MODULE globalData diff --git a/build/source/dshare/multiconst.f90 b/build/source/dshare/multiconst.f90 old mode 100644 new mode 100755 index 15a64a64f..c521c14f6 --- a/build/source/dshare/multiconst.f90 +++ b/build/source/dshare/multiconst.f90 @@ -21,33 +21,35 @@ MODULE multiconst USE nrtype ! define physical constants - REAL(DP), PARAMETER :: ave_slp = 101325.0_dp ! mean sea level pressure (Pa) - REAL(DP), PARAMETER :: vkc = 0.4_dp ! von Karman constant (-) - REAL(DP), PARAMETER :: satvpfrz = 610.8_dp ! sat vapour pressure at 273.16K (Pa) - REAL(DP), PARAMETER :: w_ratio = 0.622_dp ! molecular ratio water to dry air (-) - REAL(DP), PARAMETER :: R_da = 287.053_dp ! gas constant for dry air (Pa K-1 m3 kg-1; J kg-1 K-1) - REAL(DP), PARAMETER :: R_wv = 461.285_dp ! gas constant for water vapor (Pa K-1 m3 kg-1; J kg-1 K-1) - REAL(DP), PARAMETER :: gravity = 9.80616_dp ! acceleration of gravity (m s-2) - REAL(DP), PARAMETER :: Cp_air = 1005._dp ! specific heat of air (J kg-1 K-1) - REAL(DP), PARAMETER :: Cp_ice = 2114._dp ! specific heat of ice (J kg-1 K-1) - REAL(DP), PARAMETER :: Cp_soil = 850._dp ! specific heat of soil (J kg-1 K-1) - REAL(DP), PARAMETER :: Cp_water = 4181._dp ! specific heat of liquid water (J kg-1 K-1) - REAL(DP), PARAMETER :: Tfreeze = 273.16_dp ! temperature at freezing (K) - REAL(DP), PARAMETER :: TriplPt = 273.16_dp ! triple point of water (K) - REAL(DP), PARAMETER :: LH_fus = 333700.0_dp ! latent heat of fusion (J kg-1) - REAL(DP), PARAMETER :: LH_vap = 2501000.0_dp ! latent heat of vaporization (J kg-1) - REAL(DP), PARAMETER :: LH_sub = 2834700.0_dp ! latent heat of sublimation (J kg-1) - REAL(DP), PARAMETER :: sb = 5.6705d-8 ! Stefan Boltzman constant (W m-2 K-4) - REAL(DP), PARAMETER :: em_sno = 0.99_dp ! emissivity of snow (-) - REAL(DP), PARAMETER :: lambda_air = 0.026_dp ! thermal conductivity of air (W m-1 K-1) - REAL(DP), PARAMETER :: lambda_ice = 2.50_dp ! thermal conductivity of ice (W m-1 K-1) - REAL(DP), PARAMETER :: lambda_water = 0.60_dp ! thermal conductivity of liquid water (W m-1 K-1) - REAL(DP), PARAMETER :: iden_air = 1.293_dp ! intrinsic density of air (kg m-3) - REAL(DP), PARAMETER :: iden_ice = 917.0_dp ! intrinsic density of ice (kg m-3) - REAL(DP), PARAMETER :: iden_water = 1000.0_dp ! intrinsic density of liquid water (kg m-3) - REAL(DP), PARAMETER :: secprday = 86400._dp ! number of seconds in a day - REAL(DP), PARAMETER :: secprhour = 3600._dp ! number of seconds in an hour - REAL(DP), PARAMETER :: secprmin = 60._dp ! number of seconds in a minute - integer(i4b),parameter :: integerMissing = -9999 ! value for mising integer - + REAL(DP), PARAMETER :: ave_slp = 101325.0_dp ! mean sea level pressure (Pa) + REAL(DP), PARAMETER :: vkc = 0.4_dp ! von Karman constant (-) + REAL(DP), PARAMETER :: satvpfrz = 610.8_dp ! sat vapour pressure at 273.16K (Pa) + REAL(DP), PARAMETER :: w_ratio = 0.622_dp ! molecular ratio water to dry air (-) + REAL(DP), PARAMETER :: R_da = 287.053_dp ! gas constant for dry air (Pa K-1 m3 kg-1; J kg-1 K-1) + REAL(DP), PARAMETER :: R_wv = 461.285_dp ! gas constant for water vapor (Pa K-1 m3 kg-1; J kg-1 K-1) + !REAL(DP), PARAMETER :: Rgas = 8.314462_dp ! universal gas constant (J mol-1 K-1) + ! use same digits as Noah-MP -- chasing the difference + REAL(DP), PARAMETER :: Rgas = 8.314_dp ! universal gas constant (J mol-1 K-1) + REAL(DP), PARAMETER :: gravity = 9.80616_dp ! acceleration of gravity (m s-2) + REAL(DP), PARAMETER :: Cp_air = 1005._dp ! specific heat of air (J kg-1 K-1) + REAL(DP), PARAMETER :: Cp_ice = 2114._dp ! specific heat of ice (J kg-1 K-1) + REAL(DP), PARAMETER :: Cp_soil = 850._dp ! specific heat of soil (J kg-1 K-1) + REAL(DP), PARAMETER :: Cp_water = 4181._dp ! specific heat of liquid water (J kg-1 K-1) + REAL(DP), PARAMETER :: Tfreeze = 273.16_dp ! temperature at freezing (K) + REAL(DP), PARAMETER :: TriplPt = 273.16_dp ! triple point of water (K) + REAL(DP), PARAMETER :: LH_fus = 333700.0_dp ! latent heat of fusion (J kg-1) + REAL(DP), PARAMETER :: LH_vap = 2501000.0_dp ! latent heat of vaporization (J kg-1) + REAL(DP), PARAMETER :: LH_sub = 2834700.0_dp ! latent heat of sublimation (J kg-1) + REAL(DP), PARAMETER :: sb = 5.6705d-8 ! Stefan Boltzman constant (W m-2 K-4) + REAL(DP), PARAMETER :: em_sno = 0.99_dp ! emissivity of snow (-) + REAL(DP), PARAMETER :: lambda_air = 0.026_dp ! thermal conductivity of air (W m-1 K-1) + REAL(DP), PARAMETER :: lambda_ice = 2.50_dp ! thermal conductivity of ice (W m-1 K-1) + REAL(DP), PARAMETER :: lambda_water = 0.60_dp ! thermal conductivity of liquid water (W m-1 K-1) + REAL(DP), PARAMETER :: iden_air = 1.293_dp ! intrinsic density of air (kg m-3) + REAL(DP), PARAMETER :: iden_ice = 917.0_dp ! intrinsic density of ice (kg m-3) + REAL(DP), PARAMETER :: iden_water = 1000.0_dp ! intrinsic density of liquid water (kg m-3) + REAL(DP), PARAMETER :: secprday = 86400._dp ! number of seconds in a day + REAL(DP), PARAMETER :: secprhour = 3600._dp ! number of seconds in an hour + REAL(DP), PARAMETER :: secprmin = 60._dp ! number of seconds in a minute + REAL(DP), PARAMETER :: minprhour = 60._dp ! number of minutes in an hour END MODULE multiconst diff --git a/build/source/dshare/outpt_stat.f90 b/build/source/dshare/outpt_stat.f90 new file mode 100755 index 000000000..e91a5a8d6 --- /dev/null +++ b/build/source/dshare/outpt_stat.f90 @@ -0,0 +1,211 @@ +! 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 . + +! used to manage output statistics of the model and forcing variables +module output_stats +USE nrtype +implicit none +private +public :: calcStats +!public :: compileBasinStats +contains + + ! ****************************************************************************************************** + ! public subroutine calcStats is called at every model timestep to update/store output statistics + ! from model variables + ! ****************************************************************************************************** + subroutine calcStats(stat,dat,meta,iStep,err,message) + 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 + implicit none + + ! dummy variables + type(dlength) ,intent(inout) :: stat(:) ! statistics + class(*) ,intent(in) :: dat(:) ! data + type(extended_info),intent(in) :: meta(:) ! metadata + integer(i4b) ,intent(in) :: iStep ! timestep index to compare with oFreq of each variable + integer(i4b) ,intent(out) :: err ! error code + character(*) ,intent(out) :: message ! error message + + ! internals + character(256) :: cmessage ! error message + integer(i4b) :: iVar ! index for varaiable loop + integer(i4b) :: pVar ! index into parent structure + real(dp) :: tdata ! dummy for pulling info from dat structure + + ! initialize error control + err=0; message='calcStats/' + + do iVar = 1,size(meta) ! model variables + + ! don't do anything if var is not requested + if (meta(iVar)%outFreq<0) cycle + + ! only treat stats of scalars - all others handled separately + if (meta(iVar)%varType==iLookVarType%outstat) then + + ! index into parent structure + pVar = meta(iVar)%ixParent + + select type (dat) + type is (real(dp)); tdata = dat(pVar) + type is (dlength) ; tdata = dat(pVar)%dat(1) + type is (ilength) ; tdata = real(dat(pVar)%dat(1), kind(dp)) + class default;err=20;message=trim(message)//'dat type not found';return + end select + + ! claculate statistics + if (trim(meta(iVar)%varName)=='time') then + stat(iVar)%dat(iLookStat%inst) = tdata + else + call calc_stats(meta(iVar),stat(iVar),tdata,iStep,err,cmessage) + end if + + if(err/=0)then; message=trim(message)//trim(cmessage);return; end if + end if + end do ! model variables + + return + end subroutine calcStats + + + ! *********************************************************************************** + ! Private subroutine calc_stats is a generic fucntion to deal with any variable type. + ! Called from compile_stats + ! *********************************************************************************** + subroutine calc_stats(meta,stat,tdata,iStep,err,message) + USE nrtype + ! data structures + USE data_types,only:var_info,ilength,dlength ! type dec for meta data structures + USE var_lookup,only:maxVarStat ! # of output statistics + USE globalData,only:outFreq ! output frequencies + ! global variables + 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:iLookStat ! named variables for output statistics types + implicit none + ! dummy variables + class(var_info),intent(in) :: meta ! meta dat a structure + class(*) ,intent(inout) :: stat ! statistics structure + real(dp) ,intent(in) :: tdata ! data structure + integer(i4b) ,intent(in) :: iStep ! timestep + integer(i4b) ,intent(out) :: err ! error code + character(*) ,intent(out) :: message ! error message + ! internals + real(dp),dimension(maxvarStat+1) :: tstat ! temporary stats vector + integer(i4b) :: iStat ! statistics loop + integer(i4b) :: iFreq ! statistics loop + ! initialize error control + err=0; message='calc_stats/' + + ! pull current frequency for normalization + iFreq = meta%outFreq + if (iFreq<0) then; err=-20; message=trim(message)//'bad output file id# (outfreq)'; return; end if + + ! pack back into struc + select type (stat) + type is (ilength); tstat = real(stat%dat) + type is (dlength); tstat = stat%dat + class default;err=20;message=trim(message)//'stat type not found';return + end select + + ! --------------------------------------------- + ! reset statistics at new frequency period + ! --------------------------------------------- + if ((mod(iStep,outFreq(iFreq))==1).or.(outFreq(iFreq)==1)) then + do iStat = 1,maxVarStat ! loop through output statistics + if (.not.meta%statFlag(iStat)) cycle ! don't bother if output flag is off + if (meta%varType.ne.iLookVarType%outstat) cycle ! only calculate stats for scalars + select case(iStat) ! act depending on the statistic + case (iLookStat%totl) ! summation over period + tstat(iStat) = 0 ! resets stat at beginning of period + case (iLookStat%mean) ! mean over period + tstat(iStat) = 0. + case (iLookStat%vari) ! variance over period + tstat(iStat) = 0 ! resets E[X^2] term in var calc + tstat(maxVarStat+1) = 0 ! resets E[X]^2 term + case (iLookStat%mini) ! minimum over period + tstat(iStat) = huge(tstat(iStat)) ! resets stat at beginning of period + case (iLookStat%maxi) ! maximum over period + tstat(iStat) = -huge(tstat(iStat)) ! resets stat at beginning of period + case (iLookStat%mode) ! mode over period (does not work) + tstat(iStat) = -9999. + end select + end do ! iStat + end if + + ! --------------------------------------------- + ! Calculate each statistic that is requested by user + ! --------------------------------------------- + do iStat = 1,maxVarStat ! loop through output statistics + if (.not.meta%statFlag(iStat)) cycle ! do not bother if output flag is off + if (meta%varType.ne.iLookVarType%outstat) cycle ! only calculate stats for scalars + select case(iStat) ! act depending on the statistic + case (iLookStat%totl) ! summation over period + tstat(iStat) = tstat(iStat) + tdata ! into summation + case (iLookStat%inst) ! instantaneous + tstat(iStat) = tdata + case (iLookStat%mean) ! mean over period + tstat(iStat) = tstat(iStat) + tdata ! adds timestep to sum + case (iLookStat%vari) ! variance over period + tstat(iStat) = tstat(iStat) + tdata**2 ! sum into E[X^2] term + tstat(maxVarStat+1) = tstat(maxVarStat+1) + tdata ! sum into E[X]^2 term + case (iLookStat%mini) ! minimum over period + if (tdata.le.tstat(iStat)) tstat(iStat) = tdata! overwrites minimum iff + case (iLookStat%maxi) ! maximum over period + if (tdata.ge.tstat(iStat)) tstat(iStat) = tdata! overwrites maximum iff + case (iLookStat%mode) ! (does not work) + tstat(iStat) = -9999. + end select + end do ! iStat + + ! --------------------------------------------- + ! finalize statistics at end of frequenncy period + ! --------------------------------------------- + if (mod(iStep,outFreq(iFreq))==0) then + do iStat = 1,maxVarStat ! loop through output statistics + if (.not.meta%statFlag(iStat)) cycle ! do not bother if output flag is off + if (meta%vartype.ne.iLookVarType%outstat) cycle ! only calculate stats for scalars + select case(iStat) ! act depending on the statistic + case (iLookStat%totl) ! summation over period + tstat(iStat) = tstat(iStat)*data_step ! scale by seconds per timestep + case (iLookStat%mean) ! mean over period + tstat(iStat) = tstat(iStat)/outFreq(iFreq) ! normalize sum into mean + case (iLookStat%vari) ! variance over period + tstat(maxVarStat+1) = tstat(maxVarStat+1)/outFreq(iFreq) ! E[X] term + tstat(iStat) = tstat(iStat)/outFreq(iFreq) - tstat(maxVarStat+1)**2 ! full variance + end select + end do ! iStat + end if + + ! pack back into struc + select type (stat) + type is (ilength); stat%dat = int(tstat) + type is (dlength); stat%dat = tstat + class default;err=20;message=trim(message)//'stat type not found';return + end select + + return + end subroutine calc_stats + +end module output_stats diff --git a/build/source/dshare/popMetadat.f90 b/build/source/dshare/popMetadat.f90 old mode 100644 new mode 100755 index 7884d024f..07e3bd7a4 --- a/build/source/dshare/popMetadat.f90 +++ b/build/source/dshare/popMetadat.f90 @@ -1,22 +1,36 @@ module popMetadat_module +USE nrtype, integerMissing=>nr_integerMissing implicit none +! define indices in metadata structures +integer(i4b),parameter :: modelTime=1 ! to force index variables to be output at model timestep +integer(i4b),parameter :: nameIndex=1 ! index of the variable name +integer(i4b),parameter :: freqIndex=3 ! index of the output frequency +! define indices in flag vectors +integer(i4b),parameter :: indexMidSnow=1 ! index of flag vector: midSnow +integer(i4b),parameter :: indexMidSoil=2 ! index of flag vector: midSoil +integer(i4b),parameter :: indexMidToto=3 ! index of flag vector: midToto +integer(i4b),parameter :: indexIfcSnow=4 ! index of flag vector: ifcSnow +integer(i4b),parameter :: indexIfcSoil=5 ! index of flag vector: ifcSoil +integer(i4b),parameter :: indexIfcToto=6 ! index of flag vector: ifcToto private public::popMetadat contains - + subroutine popMetadat(err,message) - USE nrtype ! data structures - USE data_struc, only: var_info ! data type for metadata structure - USE data_struc, only: time_meta ! data structure for time metadata - USE data_struc, only: forc_meta ! data structure for forcing metadata - USE data_struc, only: type_meta ! data structure for categorical metadata - USE data_struc, only: attr_meta ! data structure for attribute metadata - USE data_struc, only: mpar_meta ! data structure for local parameter metadata - USE data_struc, only: bpar_meta ! data structure for basin parameter metadata - USE data_struc, only: mvar_meta ! data structure for local model variable metadata - USE data_struc, only: bvar_meta ! data structure for basin model variable metadata - USE data_struc, only: indx_meta ! data structure for index metadata + 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: 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 @@ -24,489 +38,947 @@ subroutine popMetadat(err,message) 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: iLookMVAR ! named variables for local model variable 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: maxvarStat ! size of arrays in structure constructor + 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 - ! local variables - character(LEN=256) :: cmessage ! error message of downwind routine + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! internals + character(256) :: cmessage ! error message + integer,dimension(maxVarStat) :: iMissArry ! arry of missing integers + logical,dimension(maxVarStat) :: lFalseArry ! arry of false logicals ! initialize error control err=0; message='popMetadat/' + ! init arrays for structure constructors + iMissArry = integerMissing + lFalseArry = .false. + ! ----- ! * model time structures... ! -------------------------- - time_meta(iLookTIME%iyyy) = var_info('iyyy', 'year' , '-', 'scalarv', .false.) - time_meta(iLookTIME%im) = var_info('im' , 'month' , '-', 'scalarv', .false.) - time_meta(iLookTIME%id) = var_info('id' , 'day' , '-', 'scalarv', .false.) - time_meta(iLookTIME%ih) = var_info('ih' , 'hour' , '-', 'scalarv', .false.) - time_meta(iLookTIME%imin) = var_info('imin', 'minute', '-', 'scalarv', .false.) + time_meta(iLookTIME%iyyy) = var_info('iyyy', 'year' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + time_meta(iLookTIME%im) = var_info('im' , 'month' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + time_meta(iLookTIME%id) = var_info('id' , 'day' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + time_meta(iLookTIME%ih) = var_info('ih' , 'hour' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + time_meta(iLookTIME%imin) = var_info('imin', 'minute', '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) ! ----- ! * 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', 'scalarv', .true.) - forc_meta(iLookFORCE%pptrate) = var_info('pptrate' , 'precipitation rate' , 'kg m-2 s-1' , 'scalarv', .true.) - forc_meta(iLookFORCE%SWRadAtm) = var_info('SWRadAtm', 'downward shortwave radiation at the upper boundary', 'W m-2' , 'scalarv', .true.) - forc_meta(iLookFORCE%LWRadAtm) = var_info('LWRadAtm', 'downward longwave radiation at the upper boundary' , 'W m-2' , 'scalarv', .true.) - forc_meta(iLookFORCE%airtemp) = var_info('airtemp' , 'air temperature at the measurement height' , 'K' , 'scalarv', .true.) - forc_meta(iLookFORCE%windspd) = var_info('windspd' , 'wind speed at the measurement height' , 'm s-1' , 'scalarv', .true.) - forc_meta(iLookFORCE%airpres) = var_info('airpres' , 'air pressure at the the measurement height' , 'Pa' , 'scalarv', .true.) - forc_meta(iLookFORCE%spechum) = var_info('spechum' , 'specific humidity at the measurement height' , 'g g-1' , 'scalarv', .true.) + 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'), lFalseArry, integerMissing, iMissArry) + forc_meta(iLookFORCE%pptrate) = var_info('pptrate' , 'precipitation rate' , 'kg m-2 s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + forc_meta(iLookFORCE%SWRadAtm) = var_info('SWRadAtm', 'downward shortwave radiation at the upper boundary', 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + forc_meta(iLookFORCE%LWRadAtm) = var_info('LWRadAtm', 'downward longwave radiation at the upper boundary' , 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + forc_meta(iLookFORCE%airtemp) = var_info('airtemp' , 'air temperature at the measurement height' , 'K' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + forc_meta(iLookFORCE%windspd) = var_info('windspd' , 'wind speed at the measurement height' , 'm s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + forc_meta(iLookFORCE%airpres) = var_info('airpres' , 'air pressure at the the measurement height' , 'Pa' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + forc_meta(iLookFORCE%spechum) = var_info('spechum' , 'specific humidity at the measurement height' , 'g g-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) ! ----- ! * categorical data... ! --------------------- - type_meta(iLookTYPE%hruIndex) = var_info('hruIndex' , 'index defining the hydrologic response unit', '-', 'scalarv', .true.) - type_meta(iLookTYPE%vegTypeIndex) = var_info('vegTypeIndex' , 'index defining vegetation type' , '-', 'scalarv', .true.) - type_meta(iLookTYPE%soilTypeIndex) = var_info('soilTypeIndex' , 'index defining soil type' , '-', 'scalarv', .true.) - type_meta(iLookTYPE%slopeTypeIndex) = var_info('slopeTypeIndex', 'index defining slope' , '-', 'scalarv', .true.) - type_meta(iLookTYPE%downHRUindex) = var_info('downHRUindex' , 'index of downslope HRU (0 = basin outlet)' , '-', 'scalarv', .true.) + type_meta(iLookTYPE%hruIndex) = var_info('hruIndex' , 'index defining the hydrologic response unit', '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + type_meta(iLookTYPE%vegTypeIndex) = var_info('vegTypeIndex' , 'index defining vegetation type' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + type_meta(iLookTYPE%soilTypeIndex) = var_info('soilTypeIndex' , 'index defining soil type' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + type_meta(iLookTYPE%slopeTypeIndex) = var_info('slopeTypeIndex', 'index defining slope' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + type_meta(iLookTYPE%downHRUindex) = var_info('downHRUindex' , 'index of downslope HRU (0 = basin outlet)' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) ! ----- ! * site characteristics... ! ------------------------- - attr_meta(iLookATTR%latitude) = var_info('latitude' , 'latitude' , 'degrees north', 'scalarv', .true.) - attr_meta(iLookATTR%longitude) = var_info('longitude' , 'longitude' , 'degrees east' , 'scalarv', .true.) - attr_meta(iLookATTR%elevation) = var_info('elevation' , 'elevation' , 'm' , 'scalarv', .true.) - attr_meta(iLookATTR%tan_slope) = var_info('tan_slope' , 'tan water table slope (tan local ground surface slope)', '-' , 'scalarv', .true.) - attr_meta(iLookATTR%contourLength) = var_info('contourLength' , 'length of contour at downslope edge of HRU' , 'm' , 'scalarv', .true.) - attr_meta(iLookATTR%HRUarea) = var_info('HRUarea' , 'area of each HRU' , 'm2' , 'scalarv', .true.) - attr_meta(iLookATTR%mHeight) = var_info('mHeight' , 'measurement height above bare ground' , 'm' , 'scalarv', .true.) + attr_meta(iLookATTR%latitude) = var_info('latitude' , 'latitude' , 'degrees north', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + attr_meta(iLookATTR%longitude) = var_info('longitude' , 'longitude' , 'degrees east' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + attr_meta(iLookATTR%elevation) = var_info('elevation' , 'elevation' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + attr_meta(iLookATTR%tan_slope) = var_info('tan_slope' , 'tan water table slope (tan local ground surface slope)', '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + attr_meta(iLookATTR%contourLength) = var_info('contourLength' , 'length of contour at downslope edge of HRU' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + attr_meta(iLookATTR%HRUarea) = var_info('HRUarea' , 'area of each HRU' , 'm2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + attr_meta(iLookATTR%mHeight) = var_info('mHeight' , 'measurement height above bare ground' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) ! ----- ! * local parameter data... - ! ------------------------- + ! ------------------------- ! boundary conditions - mpar_meta(iLookPARAM%upperBoundHead) = var_info('upperBoundHead' , 'matric head at the upper boundary' , 'm' , 'scalarv', .true.) - mpar_meta(iLookPARAM%lowerBoundHead) = var_info('lowerBoundHead' , 'matric head at the lower boundary' , 'm' , 'scalarv', .true.) - mpar_meta(iLookPARAM%upperBoundTheta) = var_info('upperBoundTheta' , 'volumetric liquid water content at the upper boundary' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%lowerBoundTheta) = var_info('lowerBoundTheta' , 'volumetric liquid water content at the lower boundary' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%upperBoundTemp) = var_info('upperBoundTemp' , 'temperature of the upper boundary' , 'K' , 'scalarv', .true.) - mpar_meta(iLookPARAM%lowerBoundTemp) = var_info('lowerBoundTemp' , 'temperature of the lower boundary' , 'K' , 'scalarv', .true.) + mpar_meta(iLookPARAM%upperBoundHead) = var_info('upperBoundHead' , 'matric head at the upper boundary' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%lowerBoundHead) = var_info('lowerBoundHead' , 'matric head at the lower boundary' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%upperBoundTheta) = var_info('upperBoundTheta' , 'volumetric liquid water content at the upper boundary' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%lowerBoundTheta) = var_info('lowerBoundTheta' , 'volumetric liquid water content at the lower boundary' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%upperBoundTemp) = var_info('upperBoundTemp' , 'temperature of the upper boundary' , 'K' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%lowerBoundTemp) = var_info('lowerBoundTemp' , 'temperature of the lower boundary' , 'K' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) ! precipitation partitioning - mpar_meta(iLookPARAM%tempCritRain) = var_info('tempCritRain' , 'critical temperature where precipitation is rain' , 'K' , 'scalarv', .true.) - mpar_meta(iLookPARAM%tempRangeTimestep) = var_info('tempRangeTimestep' , 'temperature range over the time step' , 'K' , 'scalarv', .true.) - mpar_meta(iLookPARAM%frozenPrecipMultip) = var_info('frozenPrecipMultip' , 'frozen precipitation multiplier' , '-' , 'scalarv', .true.) - ! freezing curve for snow - mpar_meta(iLookPARAM%snowfrz_scale) = var_info('snowfrz_scale' , 'scaling parameter for the freezing curve for snow' , 'K-1' , 'scalarv', .true.) + mpar_meta(iLookPARAM%tempCritRain) = var_info('tempCritRain' , 'critical temperature where precipitation is rain' , 'K' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%tempRangeTimestep) = var_info('tempRangeTimestep' , 'temperature range over the time step' , 'K' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%frozenPrecipMultip) = var_info('frozenPrecipMultip' , 'frozen precipitation multiplier' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + ! snow properties + mpar_meta(iLookPARAM%snowfrz_scale) = var_info('snowfrz_scale' , 'scaling parameter for the freezing curve for snow' , 'K-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%fixedThermalCond_snow) = var_info('fixedThermalCond_snow' , 'temporally constant thermal conductivity for snow' , 'W m-1 K-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) ! snow albedo - mpar_meta(iLookPARAM%albedoMax) = var_info('albedoMax' , 'maximum snow albedo (single spectral band)' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%albedoMinWinter) = var_info('albedoMinWinter' , 'minimum snow albedo during winter (single spectral band)' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%albedoMinSpring) = var_info('albedoMinSpring' , 'minimum snow albedo during spring (single spectral band)' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%albedoMaxVisible) = var_info('albedoMaxVisible' , 'maximum snow albedo in the visible part of the spectrum' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%albedoMinVisible) = var_info('albedoMinVisible' , 'minimum snow albedo in the visible part of the spectrum' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%albedoMaxNearIR) = var_info('albedoMaxNearIR' , 'maximum snow albedo in the near infra-red part of the spectrum' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%albedoMinNearIR) = var_info('albedoMinNearIR' , 'minimum snow albedo in the near infra-red part of the spectrum' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%albedoDecayRate) = var_info('albedoDecayRate' , 'albedo decay rate' , 's' , 'scalarv', .true.) - mpar_meta(iLookPARAM%albedoSootLoad) = var_info('albedoSootLoad' , 'soot load factor' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%albedoRefresh) = var_info('albedoRefresh' , 'critical mass necessary for albedo refreshment' , 'kg m-2' , 'scalarv', .true.) + mpar_meta(iLookPARAM%albedoMax) = var_info('albedoMax' , 'maximum snow albedo (single spectral band)' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%albedoMinWinter) = var_info('albedoMinWinter' , 'minimum snow albedo during winter (single spectral band)' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%albedoMinSpring) = var_info('albedoMinSpring' , 'minimum snow albedo during spring (single spectral band)' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%albedoMaxVisible) = var_info('albedoMaxVisible' , 'maximum snow albedo in the visible part of the spectrum' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%albedoMinVisible) = var_info('albedoMinVisible' , 'minimum snow albedo in the visible part of the spectrum' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%albedoMaxNearIR) = var_info('albedoMaxNearIR' , 'maximum snow albedo in the near infra-red part of the spectrum' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%albedoMinNearIR) = var_info('albedoMinNearIR' , 'minimum snow albedo in the near infra-red part of the spectrum' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%albedoDecayRate) = var_info('albedoDecayRate' , 'albedo decay rate' , 's' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%albedoSootLoad) = var_info('albedoSootLoad' , 'soot load factor' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%albedoRefresh) = var_info('albedoRefresh' , 'critical mass necessary for albedo refreshment' , 'kg m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) ! radiation transfer - mpar_meta(iLookPARAM%radExt_snow) = var_info('radExt_snow' , 'extinction coefficient for radiation penetration into snowpack' , 'm-1' , 'scalarv', .true.) - mpar_meta(iLookPARAM%directScale) = var_info('directScale' , 'scaling factor for fractional driect radiaion parameterization' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%Frad_direct) = var_info('Frad_direct' , 'fraction direct solar radiation' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%Frad_vis) = var_info('Frad_vis' , 'fraction radiation in visible part of spectrum' , '-' , 'scalarv', .true.) + mpar_meta(iLookPARAM%radExt_snow) = var_info('radExt_snow' , 'extinction coefficient for radiation penetration into snowpack' , 'm-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%directScale) = var_info('directScale' , 'scaling factor for fractional driect radiaion parameterization' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%Frad_direct) = var_info('Frad_direct' , 'fraction direct solar radiation' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%Frad_vis) = var_info('Frad_vis' , 'fraction radiation in visible part of spectrum' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) ! new snow density - mpar_meta(iLookPARAM%newSnowDenMin) = var_info('newSnowDenMin' , 'minimum new snow density' , 'kg m-3' , 'scalarv', .true.) - mpar_meta(iLookPARAM%newSnowDenMult) = var_info('newSnowDenMult' , 'multiplier for new snow density' , 'kg m-3' , 'scalarv', .true.) - mpar_meta(iLookPARAM%newSnowDenScal) = var_info('newSnowDenScal' , 'scaling factor for new snow density' , 'K' , 'scalarv', .true.) + mpar_meta(iLookPARAM%newSnowDenMin) = var_info('newSnowDenMin' , 'minimum new snow density' , 'kg m-3' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%newSnowDenMult) = var_info('newSnowDenMult' , 'multiplier for new snow density' , 'kg m-3' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%newSnowDenScal) = var_info('newSnowDenScal' , 'scaling factor for new snow density' , 'K' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%constSnowDen) = var_info('constSnowDen' , 'Constant new snow density' , 'kg m-3' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%newSnowDenAdd) = var_info('newSnowDenAdd' , 'Pahaut 1976, additive factor for new snow density' , 'kg m-3' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%newSnowDenMultAnd) = var_info('newSnowDenMultAnd' , 'Anderson 1976, multiplier for new snow density (Anderson func)' , 'K-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%newSnowDenBase) = var_info('newSnowDenBase' , 'Anderson 1976, base value that is rasied to the (3/2) power' , 'K' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) ! snow compaction - mpar_meta(iLookPARAM%densScalGrowth) = var_info('densScalGrowth' , 'density scaling factor for grain growth' , 'kg-1 m3' , 'scalarv', .true.) - mpar_meta(iLookPARAM%tempScalGrowth) = var_info('tempScalGrowth' , 'temperature scaling factor for grain growth' , 'K-1' , 'scalarv', .true.) - mpar_meta(iLookPARAM%grainGrowthRate) = var_info('grainGrowthRate' , 'rate of grain growth' , 's-1' , 'scalarv', .true.) - mpar_meta(iLookPARAM%densScalOvrbdn) = var_info('densScalOvrbdn' , 'density scaling factor for overburden pressure' , 'kg-1 m3' , 'scalarv', .true.) - mpar_meta(iLookPARAM%tempScalOvrbdn) = var_info('tempScalOvrbdn' , 'temperature scaling factor for overburden pressure' , 'K-1' , 'scalarv', .true.) - mpar_meta(iLookPARAM%base_visc) = var_info('base_visc' , 'viscosity coefficient at T=T_frz and snow density=0' , 'kg s m-2' , 'scalarv', .true.) + mpar_meta(iLookPARAM%densScalGrowth) = var_info('densScalGrowth' , 'density scaling factor for grain growth' , 'kg-1 m3' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%tempScalGrowth) = var_info('tempScalGrowth' , 'temperature scaling factor for grain growth' , 'K-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%grainGrowthRate) = var_info('grainGrowthRate' , 'rate of grain growth' , 's-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%densScalOvrbdn) = var_info('densScalOvrbdn' , 'density scaling factor for overburden pressure' , 'kg-1 m3' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%tempScalOvrbdn) = var_info('tempScalOvrbdn' , 'temperature scaling factor for overburden pressure' , 'K-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%baseViscosity ) = var_info('baseViscosity ' , 'viscosity coefficient at T=T_frz and snow density=0' , 'kg s m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) ! water flow through snow - mpar_meta(iLookPARAM%Fcapil) = var_info('Fcapil' , 'capillary retention (fraction of total pore volume)' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%k_snow) = var_info('k_snow' , 'hydraulic conductivity of snow' , 'm s-1' , 'scalarv', .true.) - mpar_meta(iLookPARAM%mw_exp) = var_info('mw_exp' , 'exponent for meltwater flow' , '-' , 'scalarv', .true.) + mpar_meta(iLookPARAM%Fcapil) = var_info('Fcapil' , 'capillary retention (fraction of total pore volume)' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%k_snow) = var_info('k_snow' , 'hydraulic conductivity of snow' , 'm s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%mw_exp) = var_info('mw_exp' , 'exponent for meltwater flow' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) ! turbulent heat fluxes - mpar_meta(iLookPARAM%z0Snow) = var_info('z0Snow' , 'roughness length of snow' , 'm' , 'scalarv', .true.) - mpar_meta(iLookPARAM%z0Soil) = var_info('z0Soil' , 'roughness length of bare soil below the canopy' , 'm' , 'scalarv', .true.) - mpar_meta(iLookPARAM%z0Canopy) = var_info('z0Canopy' , 'roughness length of the canopy' , 'm' , 'scalarv', .true.) - mpar_meta(iLookPARAM%zpdFraction) = var_info('zpdFraction' , 'zero plane displacement / canopy height' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%critRichNumber) = var_info('critRichNumber' , 'critical value for the bulk Richardson number' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%Louis79_bparam) = var_info('Louis79_bparam' , 'parameter in Louis (1979) stability function' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%Louis79_cStar) = var_info('Louis79_cStar' , 'parameter in Louis (1979) stability function' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%Mahrt87_eScale) = var_info('Mahrt87_eScale' , 'exponential scaling factor in the Mahrt (1987) stability function', '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%leafExchangeCoeff) = var_info('leafExchangeCoeff' , 'turbulent exchange coeff between canopy surface and canopy air' , 'm s-(1/2)' , 'scalarv', .true.) - mpar_meta(iLookPARAM%windReductionParam) = var_info('windReductionParam' , 'canopy wind reduction parameter' , '-' , 'scalarv', .true.) + mpar_meta(iLookPARAM%z0Snow) = var_info('z0Snow' , 'roughness length of snow' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%z0Soil) = var_info('z0Soil' , 'roughness length of bare soil below the canopy' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%z0Canopy) = var_info('z0Canopy' , 'roughness length of the canopy' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%zpdFraction) = var_info('zpdFraction' , 'zero plane displacement / canopy height' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%critRichNumber) = var_info('critRichNumber' , 'critical value for the bulk Richardson number' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%Louis79_bparam) = var_info('Louis79_bparam' , 'parameter in Louis (1979) stability function' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%Louis79_cStar) = var_info('Louis79_cStar' , 'parameter in Louis (1979) stability function' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%Mahrt87_eScale) = var_info('Mahrt87_eScale' , 'exponential scaling factor in the Mahrt (1987) stability function', '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%leafExchangeCoeff) = var_info('leafExchangeCoeff' , 'turbulent exchange coeff between canopy surface and canopy air' , 'm s-(1/2)' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%windReductionParam) = var_info('windReductionParam' , 'canopy wind reduction parameter' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) ! stomatal conductance - mpar_meta(iLookPARAM%Kc25) = var_info('Kc25' , 'Michaelis-Menten constant for CO2 at 25 degrees C' , 'umol mol-1' , 'scalarv', .true.) - mpar_meta(iLookPARAM%Ko25) = var_info('Ko25' , 'Michaelis-Menten constant for O2 at 25 degrees C' , 'mol mol-1' , 'scalarv', .true.) - mpar_meta(iLookPARAM%Kc_qFac) = var_info('Kc_qFac' , 'factor in the q10 function defining temperature controls on Kc' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%Ko_qFac) = var_info('Ko_qFac' , 'factor in the q10 function defining temperature controls on Ko' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%kc_Ha) = var_info('kc_Ha' , 'activation energy for the Michaelis-Menten constant for CO2' , 'J mol-1' , 'scalarv', .true.) - mpar_meta(iLookPARAM%ko_Ha) = var_info('ko_Ha' , 'activation energy for the Michaelis-Menten constant for O2' , 'J mol-1' , 'scalarv', .true.) - 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', 'scalarv', .true.) - mpar_meta(iLookPARAM%vcmax_qFac) = var_info('vcmax_qFac' , 'factor in the q10 function defining temperature controls on vcmax', '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%vcmax_Ha) = var_info('vcmax_Ha' , 'activation energy in the vcmax function' , 'J mol-1' , 'scalarv', .true.) - mpar_meta(iLookPARAM%vcmax_Hd) = var_info('vcmax_Hd' , 'deactivation energy in the vcmax function' , 'J mol-1' , 'scalarv', .true.) - mpar_meta(iLookPARAM%vcmax_Sv) = var_info('vcmax_Sv' , 'entropy term in the vcmax function' , 'J mol-1 K-1' , 'scalarv', .true.) - mpar_meta(iLookPARAM%vcmax_Kn) = var_info('vcmax_Kn' , 'foliage nitrogen decay coefficient' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%jmax25_scale) = var_info('jmax25_scale' , 'scaling factor to relate jmax25 to vcmax25' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%jmax_Ha) = var_info('jmax_Ha' , 'activation energy in the jmax function' , 'J mol-1' , 'scalarv', .true.) - mpar_meta(iLookPARAM%jmax_Hd) = var_info('jmax_Hd' , 'deactivation energy in the jmax function' , 'J mol-1' , 'scalarv', .true.) - mpar_meta(iLookPARAM%jmax_Sv) = var_info('jmax_Sv' , 'entropy term in the jmax function' , 'J mol-1 K-1' , 'scalarv', .true.) - mpar_meta(iLookPARAM%fractionJ) = var_info('fractionJ' , 'fraction of light lost by other than the chloroplast lamellae' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%quantamYield) = var_info('quantamYield' , 'quantam yield' , 'mol e mol-1 q' , 'scalarv', .true.) - mpar_meta(iLookPARAM%vpScaleFactor) = var_info('vpScaleFactor' , 'vapor pressure scaling factor in stomatal conductance function' , 'Pa' , 'scalarv', .true.) - mpar_meta(iLookPARAM%cond2photo_slope) = var_info('cond2photo_slope' , 'slope of conductance-photosynthesis relationship' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%minStomatalConductance)= var_info('minStomatalConductance', 'minimum stomatal conductance' , 'umol H2O m-2 s-1', 'scalarv', .true.) + mpar_meta(iLookPARAM%Kc25) = var_info('Kc25' , 'Michaelis-Menten constant for CO2 at 25 degrees C' , 'umol mol-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%Ko25) = var_info('Ko25' , 'Michaelis-Menten constant for O2 at 25 degrees C' , 'mol mol-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%Kc_qFac) = var_info('Kc_qFac' , 'factor in the q10 function defining temperature controls on Kc' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%Ko_qFac) = var_info('Ko_qFac' , 'factor in the q10 function defining temperature controls on Ko' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%kc_Ha) = var_info('kc_Ha' , 'activation energy for the Michaelis-Menten constant for CO2' , 'J mol-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%ko_Ha) = var_info('ko_Ha' , 'activation energy for the Michaelis-Menten constant for O2' , 'J mol-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%vcmax_qFac) = var_info('vcmax_qFac' , 'factor in the q10 function defining temperature controls on vcmax', '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%vcmax_Ha) = var_info('vcmax_Ha' , 'activation energy in the vcmax function' , 'J mol-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%vcmax_Hd) = var_info('vcmax_Hd' , 'deactivation energy in the vcmax function' , 'J mol-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%vcmax_Sv) = var_info('vcmax_Sv' , 'entropy term in the vcmax function' , 'J mol-1 K-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%vcmax_Kn) = var_info('vcmax_Kn' , 'foliage nitrogen decay coefficient' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%jmax25_scale) = var_info('jmax25_scale' , 'scaling factor to relate jmax25 to vcmax25' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%jmax_Ha) = var_info('jmax_Ha' , 'activation energy in the jmax function' , 'J mol-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%jmax_Hd) = var_info('jmax_Hd' , 'deactivation energy in the jmax function' , 'J mol-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%jmax_Sv) = var_info('jmax_Sv' , 'entropy term in the jmax function' , 'J mol-1 K-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%fractionJ) = var_info('fractionJ' , 'fraction of light lost by other than the chloroplast lamellae' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%quantamYield) = var_info('quantamYield' , 'quantam yield' , 'mol e mol-1 q' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%vpScaleFactor) = var_info('vpScaleFactor' , 'vapor pressure scaling factor in stomatal conductance function' , 'Pa' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%cond2photo_slope) = var_info('cond2photo_slope' , 'slope of conductance-photosynthesis relationship' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%minStomatalConductance)= var_info('minStomatalConductance', 'minimum stomatal conductance' , 'umol H2O m-2 s-1', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) ! vegetation properties - mpar_meta(iLookPARAM%winterSAI) = var_info('winterSAI' , 'stem area index prior to the start of the growing season' , 'm2 m-2' , 'scalarv', .true.) - mpar_meta(iLookPARAM%summerLAI) = var_info('summerLAI' , 'maximum leaf area index at the peak of the growing season' , 'm2 m-2' , 'scalarv', .true.) - mpar_meta(iLookPARAM%rootScaleFactor1) = var_info('rootScaleFactor1' , '1st scaling factor (a) in Y = 1 - 0.5*( exp(-aZ) + exp(-bZ) )' , 'm-1' , 'scalarv', .true.) - mpar_meta(iLookPARAM%rootScaleFactor2) = var_info('rootScaleFactor2' , '2nd scaling factor (b) in Y = 1 - 0.5*( exp(-aZ) + exp(-bZ) )' , 'm-1' , 'scalarv', .true.) - mpar_meta(iLookPARAM%rootingDepth) = var_info('rootingDepth' , 'rooting depth' , 'm' , 'scalarv', .true.) - mpar_meta(iLookPARAM%rootDistExp) = var_info('rootDistExp' , 'exponent for the vertical distribution of root density' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%plantWiltPsi) = var_info('plantWiltPsi' , 'matric head at wilting point' , 'm' , 'scalarv', .true.) - mpar_meta(iLookPARAM%soilStressParam) = var_info('soilStressParam' , 'parameter in the exponential soil stress function' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%critSoilWilting) = var_info('critSoilWilting' , 'critical vol. liq. water content when plants are wilting' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%critSoilTranspire) = var_info('critSoilTranspire' , 'critical vol. liq. water content when transpiration is limited' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%critAquiferTranspire) = var_info('critAquiferTranspire' , 'critical aquifer storage value when transpiration is limited' , 'm' , 'scalarv', .true.) - mpar_meta(iLookPARAM%minStomatalResistance) = var_info('minStomatalResistance' , 'minimum stomatal resistance' , 's m-1' , 'scalarv', .true.) - mpar_meta(iLookPARAM%leafDimension) = var_info('leafDimension' , 'characteristic leaf dimension' , 'm' , 'scalarv', .true.) - mpar_meta(iLookPARAM%heightCanopyTop) = var_info('heightCanopyTop' , 'height of top of the vegetation canopy above ground surface' , 'm' , 'scalarv', .true.) - mpar_meta(iLookPARAM%heightCanopyBottom) = var_info('heightCanopyBottom' , 'height of bottom of the vegetation canopy above ground surface' , 'm' , 'scalarv', .true.) - mpar_meta(iLookPARAM%specificHeatVeg) = var_info('specificHeatVeg' , 'specific heat of vegetation' , 'J kg-1 K-1' , 'scalarv', .true.) - mpar_meta(iLookPARAM%maxMassVegetation) = var_info('maxMassVegetation' , 'maximum mass of vegetation (full foliage)' , 'kg m-2' , 'scalarv', .true.) - mpar_meta(iLookPARAM%throughfallScaleSnow) = var_info('throughfallScaleSnow' , 'scaling factor for throughfall (snow)' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%throughfallScaleRain) = var_info('throughfallScaleRain' , 'scaling factor for throughfall (rain)' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%refInterceptCapSnow) = var_info('refInterceptCapSnow' , 'reference canopy interception capacity per unit leaf area (snow)' , 'kg m-2' , 'scalarv', .true.) - mpar_meta(iLookPARAM%refInterceptCapRain) = var_info('refInterceptCapRain' , 'canopy interception capacity per unit leaf area (rain)' , 'kg m-2' , 'scalarv', .true.) - mpar_meta(iLookPARAM%snowUnloadingCoeff) = var_info('snowUnloadingCoeff' , 'time constant for unloading of snow from the forest canopy' , 's-1' , 'scalarv', .true.) - mpar_meta(iLookPARAM%canopyDrainageCoeff) = var_info('canopyDrainageCoeff' , 'time constant for drainage of liquid water from the forest canopy', 's-1' , 'scalarv', .true.) - mpar_meta(iLookPARAM%ratioDrip2Unloading) = var_info('ratioDrip2Unloading' , 'ratio of canopy drip to unloading of snow from the forest canopy' , '-' , 'scalarv', .true.) + mpar_meta(iLookPARAM%winterSAI) = var_info('winterSAI' , 'stem area index prior to the start of the growing season' , 'm2 m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%summerLAI) = var_info('summerLAI' , 'maximum leaf area index at the peak of the growing season' , 'm2 m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%rootingDepth) = var_info('rootingDepth' , 'rooting depth' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%rootDistExp) = var_info('rootDistExp' , 'exponent for the vertical distribution of root density' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%plantWiltPsi) = var_info('plantWiltPsi' , 'matric head at wilting point' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%soilStressParam) = var_info('soilStressParam' , 'parameter in the exponential soil stress function' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%critSoilWilting) = var_info('critSoilWilting' , 'critical vol. liq. water content when plants are wilting' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%critSoilTranspire) = var_info('critSoilTranspire' , 'critical vol. liq. water content when transpiration is limited' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%critAquiferTranspire) = var_info('critAquiferTranspire' , 'critical aquifer storage value when transpiration is limited' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%minStomatalResistance) = var_info('minStomatalResistance' , 'minimum stomatal resistance' , 's m-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%leafDimension) = var_info('leafDimension' , 'characteristic leaf dimension' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%heightCanopyTop) = var_info('heightCanopyTop' , 'height of top of the vegetation canopy above ground surface' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%heightCanopyBottom) = var_info('heightCanopyBottom' , 'height of bottom of the vegetation canopy above ground surface' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%specificHeatVeg) = var_info('specificHeatVeg' , 'specific heat of vegetation' , 'J kg-1 K-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%maxMassVegetation) = var_info('maxMassVegetation' , 'maximum mass of vegetation (full foliage)' , 'kg m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%throughfallScaleSnow) = var_info('throughfallScaleSnow' , 'scaling factor for throughfall (snow)' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%throughfallScaleRain) = var_info('throughfallScaleRain' , 'scaling factor for throughfall (rain)' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%refInterceptCapSnow) = var_info('refInterceptCapSnow' , 'reference canopy interception capacity per unit leaf area (snow)' , 'kg m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%refInterceptCapRain) = var_info('refInterceptCapRain' , 'canopy interception capacity per unit leaf area (rain)' , 'kg m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%snowUnloadingCoeff) = var_info('snowUnloadingCoeff' , 'time constant for unloading of snow from the forest canopy' , 's-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%canopyDrainageCoeff) = var_info('canopyDrainageCoeff' , 'time constant for drainage of liquid water from the forest canopy', 's-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%ratioDrip2Unloading) = var_info('ratioDrip2Unloading' , 'ratio of canopy drip to unloading of snow from the forest canopy' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%canopyWettingFactor) = var_info('canopyWettingFactor' , 'maximum wetted fraction of the canopy' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%canopyWettingExp) = var_info('canopyWettingExp' , 'exponent in canopy wetting function' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) ! soil properties - mpar_meta(iLookPARAM%soil_dens_intr) = var_info('soil_dens_intr' , 'intrinsic soil density' , 'kg m-3' , 'scalarv', .true.) - mpar_meta(iLookPARAM%thCond_soil) = var_info('thCond_soil' , 'thermal conductivity of soil (includes quartz and other minerals)', 'W m-1 K-1' , 'scalarv', .true.) - mpar_meta(iLookPARAM%frac_sand) = var_info('frac_sand' , 'fraction of sand' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%frac_silt) = var_info('frac_silt' , 'fraction of silt' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%frac_clay) = var_info('frac_clay' , 'fraction of clay' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%fieldCapacity) = var_info('fieldCapacity' , 'soil field capacity (vol liq water content when baseflow begins)' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%wettingFrontSuction) = var_info('wettingFrontSuction' , 'Green-Ampt wetting front suction' , 'm' , 'scalarv', .true.) - mpar_meta(iLookPARAM%theta_mp) = var_info('theta_mp' , 'volumetric liquid water content when macropore flow begins' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%theta_sat) = var_info('theta_sat' , 'soil porosity' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%theta_res) = var_info('theta_res' , 'volumetric residual water content' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%vGn_alpha) = var_info('vGn_alpha' , 'van Genuchten "alpha" parameter' , 'm-1' , 'scalarv', .true.) - mpar_meta(iLookPARAM%vGn_n) = var_info('vGn_n' , 'van Genuchten "n" parameter' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%mpExp) = var_info('mpExp' , 'empirical exponent in macropore flow equation' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%k_soil) = var_info('k_soil' , 'saturated hydraulic conductivity' , 'm s-1' , 'scalarv', .true.) - mpar_meta(iLookPARAM%k_macropore) = var_info('k_macropore' , 'saturated hydraulic conductivity for macropores' , 'm s-1' , 'scalarv', .true.) - mpar_meta(iLookPARAM%kAnisotropic) = var_info('kAnisotropic' , 'anisotropy factor for lateral hydraulic conductivity' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%zScale_TOPMODEL) = var_info('zScale_TOPMODEL' , 'TOPMODEL scaling factor used in lower boundary condition for soil', 'm' , 'scalarv', .true.) - mpar_meta(iLookPARAM%compactedDepth) = var_info('compactedDepth' , 'depth where k_soil reaches the compacted value given by CH78' , 'm' , 'scalarv', .true.) - mpar_meta(iLookPARAM%aquiferScaleFactor) = var_info('aquiferScaleFactor' , 'scaling factor for aquifer storage in the big bucket' , 'm' , 'scalarv', .true.) - mpar_meta(iLookPARAM%aquiferBaseflowExp) = var_info('aquiferBaseflowExp' , 'baseflow exponent' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%qSurfScale) = var_info('qSurfScale' , 'scaling factor in the surface runoff parameterization' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%specificYield) = var_info('specificYield' , 'specific yield' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%specificStorage) = var_info('specificStorage' , 'specific storage coefficient' , 'm-1' , 'scalarv', .true.) - mpar_meta(iLookPARAM%f_impede) = var_info('f_impede' , 'ice impedence factor' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%soilIceScale) = var_info('soilIceScale' , 'scaling factor for depth of soil ice, used to get frozen fraction', 'm' , 'scalarv', .true.) - mpar_meta(iLookPARAM%soilIceCV) = var_info('soilIceCV' , 'CV of depth of soil ice, used to get frozen fraction' , '-' , 'scalarv', .true.) + mpar_meta(iLookPARAM%soil_dens_intr) = var_info('soil_dens_intr' , 'intrinsic soil density' , 'kg m-3' , get_ixVarType('parSoil'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%frac_sand) = var_info('frac_sand' , 'fraction of sand' , '-' , get_ixVarType('parSoil'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%frac_silt) = var_info('frac_silt' , 'fraction of silt' , '-' , get_ixVarType('parSoil'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%frac_clay) = var_info('frac_clay' , 'fraction of clay' , '-' , get_ixVarType('parSoil'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%theta_sat) = var_info('theta_sat' , 'soil porosity' , '-' , get_ixVarType('parSoil'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%theta_res) = var_info('theta_res' , 'volumetric residual water content' , '-' , get_ixVarType('parSoil'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%vGn_alpha) = var_info('vGn_alpha' , 'van Genuchten "alpha" parameter' , 'm-1' , get_ixVarType('parSoil'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%vGn_n) = var_info('vGn_n' , 'van Genuchten "n" parameter' , '-' , get_ixVarType('parSoil'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%k_soil) = var_info('k_soil' , 'saturated hydraulic conductivity' , 'm s-1' , get_ixVarType('parSoil'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%k_macropore) = var_info('k_macropore' , 'saturated hydraulic conductivity for macropores' , 'm s-1' , get_ixVarType('parSoil'), lFalseArry, integerMissing, iMissArry) + ! scalar soil properties + mpar_meta(iLookPARAM%fieldCapacity) = var_info('fieldCapacity' , 'soil field capacity (vol liq water content when baseflow begins)' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%wettingFrontSuction) = var_info('wettingFrontSuction' , 'Green-Ampt wetting front suction' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%theta_mp) = var_info('theta_mp' , 'volumetric liquid water content when macropore flow begins' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%mpExp) = var_info('mpExp' , 'empirical exponent in macropore flow equation' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%kAnisotropic) = var_info('kAnisotropic' , 'anisotropy factor for lateral hydraulic conductivity' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%zScale_TOPMODEL) = var_info('zScale_TOPMODEL' , 'TOPMODEL scaling factor used in lower boundary condition for soil', 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%compactedDepth) = var_info('compactedDepth' , 'depth where k_soil reaches the compacted value given by CH78' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%aquiferScaleFactor) = var_info('aquiferScaleFactor' , 'scaling factor for aquifer storage in the big bucket' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%aquiferBaseflowExp) = var_info('aquiferBaseflowExp' , 'baseflow exponent' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%qSurfScale) = var_info('qSurfScale' , 'scaling factor in the surface runoff parameterization' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%specificYield) = var_info('specificYield' , 'specific yield' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%specificStorage) = var_info('specificStorage' , 'specific storage coefficient' , 'm-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%f_impede) = var_info('f_impede' , 'ice impedence factor' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%soilIceScale) = var_info('soilIceScale' , 'scaling factor for depth of soil ice, used to get frozen fraction', 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%soilIceCV) = var_info('soilIceCV' , 'CV of depth of soil ice, used to get frozen fraction' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) ! algorithmic control parameters - mpar_meta(iLookPARAM%minwind) = var_info('minwind' , 'minimum wind speed' , 'm s-1' , 'scalarv', .false.) - mpar_meta(iLookPARAM%minstep) = var_info('minstep' , 'minimum length of the time step' , 's' , 'scalarv', .false.) - mpar_meta(iLookPARAM%maxstep) = var_info('maxstep' , 'maximum length of the time step' , 's' , 'scalarv', .false.) - mpar_meta(iLookPARAM%wimplicit) = var_info('wimplicit' , 'weight assigned to the start-of-step fluxes (alpha)' , '-' , 'scalarv', .true.) - mpar_meta(iLookPARAM%maxiter) = var_info('maxiter' , 'maximum number of iterations' , '-' , 'scalarv', .false.) - mpar_meta(iLookPARAM%relConvTol_liquid) = var_info('relConvTol_liquid' , 'relative convergence tolerance for vol frac liq water' , '-' , 'scalarv', .false.) - mpar_meta(iLookPARAM%absConvTol_liquid) = var_info('absConvTol_liquid' , 'absolute convergence tolerance for vol frac liq water' , '-' , 'scalarv', .false.) - mpar_meta(iLookPARAM%relConvTol_matric) = var_info('relConvTol_matric' , 'relative convergence tolerance for matric head' , '-' , 'scalarv', .false.) - mpar_meta(iLookPARAM%absConvTol_matric) = var_info('absConvTol_matric' , 'absolute convergence tolerance for matric head' , 'm' , 'scalarv', .false.) - mpar_meta(iLookPARAM%relConvTol_energy) = var_info('relConvTol_energy' , 'relative convergence tolerance for energy' , '-' , 'scalarv', .false.) - mpar_meta(iLookPARAM%absConvTol_energy) = var_info('absConvTol_energy' , 'absolute convergence tolerance for energy' , 'J m-3' , 'scalarv', .false.) - mpar_meta(iLookPARAM%relConvTol_aquifr) = var_info('relConvTol_aquifr' , 'relative convergence tolerance for aquifer storage' , '-' , 'scalarv', .false.) - mpar_meta(iLookPARAM%absConvTol_aquifr) = var_info('absConvTol_aquifr' , 'absolute convergence tolerance for aquifer storage' , 'm' , 'scalarv', .false.) - mpar_meta(iLookPARAM%zmin) = var_info('zmin' , 'minimum layer depth' , 'm' , 'scalarv', .false.) - mpar_meta(iLookPARAM%zmax) = var_info('zmax' , 'maximum layer depth' , 'm' , 'scalarv', .false.) - mpar_meta(iLookPARAM%zminLayer1) = var_info('zminLayer1' , 'minimum layer depth for the 1st (top) layer' , 'm' , 'scalarv', .false.) - mpar_meta(iLookPARAM%zminLayer2) = var_info('zminLayer2' , 'minimum layer depth for the 2nd layer' , 'm' , 'scalarv', .false.) - mpar_meta(iLookPARAM%zminLayer3) = var_info('zminLayer3' , 'minimum layer depth for the 3rd layer' , 'm' , 'scalarv', .false.) - mpar_meta(iLookPARAM%zminLayer4) = var_info('zminLayer4' , 'minimum layer depth for the 4th layer' , 'm' , 'scalarv', .false.) - mpar_meta(iLookPARAM%zminLayer5) = var_info('zminLayer5' , 'minimum layer depth for the 5th (bottom) layer' , 'm' , 'scalarv', .false.) - mpar_meta(iLookPARAM%zmaxLayer1_lower) = var_info('zmaxLayer1_lower' , 'maximum layer depth for the 1st (top) layer when only 1 layer' , 'm' , 'scalarv', .false.) - mpar_meta(iLookPARAM%zmaxLayer2_lower) = var_info('zmaxLayer2_lower' , 'maximum layer depth for the 2nd layer when only 2 layers' , 'm' , 'scalarv', .false.) - mpar_meta(iLookPARAM%zmaxLayer3_lower) = var_info('zmaxLayer3_lower' , 'maximum layer depth for the 3rd layer when only 3 layers' , 'm' , 'scalarv', .false.) - mpar_meta(iLookPARAM%zmaxLayer4_lower) = var_info('zmaxLayer4_lower' , 'maximum layer depth for the 4th layer when only 4 layers' , 'm' , 'scalarv', .false.) - mpar_meta(iLookPARAM%zmaxLayer1_upper) = var_info('zmaxLayer1_upper' , 'maximum layer depth for the 1st (top) layer when > 1 layer' , 'm' , 'scalarv', .false.) - mpar_meta(iLookPARAM%zmaxLayer2_upper) = var_info('zmaxLayer2_upper' , 'maximum layer depth for the 2nd layer when > 2 layers' , 'm' , 'scalarv', .false.) - mpar_meta(iLookPARAM%zmaxLayer3_upper) = var_info('zmaxLayer3_upper' , 'maximum layer depth for the 3rd layer when > 3 layers' , 'm' , 'scalarv', .false.) - mpar_meta(iLookPARAM%zmaxLayer4_upper) = var_info('zmaxLayer3_upper' , 'maximum layer depth for the 4th layer when > 4 layers' , 'm' , 'scalarv', .false.) + mpar_meta(iLookPARAM%minwind) = var_info('minwind' , 'minimum wind speed' , 'm s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%minstep) = var_info('minstep' , 'minimum length of the time step' , 's' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%maxstep) = var_info('maxstep' , 'maximum length of the time step' , 's' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%wimplicit) = var_info('wimplicit' , 'weight assigned to the start-of-step fluxes (alpha)' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%maxiter) = var_info('maxiter' , 'maximum number of iterations' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%relConvTol_liquid) = var_info('relConvTol_liquid' , 'relative convergence tolerance for vol frac liq water' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%absConvTol_liquid) = var_info('absConvTol_liquid' , 'absolute convergence tolerance for vol frac liq water' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%relConvTol_matric) = var_info('relConvTol_matric' , 'relative convergence tolerance for matric head' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%absConvTol_matric) = var_info('absConvTol_matric' , 'absolute convergence tolerance for matric head' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%relConvTol_energy) = var_info('relConvTol_energy' , 'relative convergence tolerance for energy' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%absConvTol_energy) = var_info('absConvTol_energy' , 'absolute convergence tolerance for energy' , 'J m-3' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%relConvTol_aquifr) = var_info('relConvTol_aquifr' , 'relative convergence tolerance for aquifer storage' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%absConvTol_aquifr) = var_info('absConvTol_aquifr' , 'absolute convergence tolerance for aquifer storage' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%zmin) = var_info('zmin' , 'minimum layer depth' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%zmax) = var_info('zmax' , 'maximum layer depth' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%zminLayer1) = var_info('zminLayer1' , 'minimum layer depth for the 1st (top) layer' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%zminLayer2) = var_info('zminLayer2' , 'minimum layer depth for the 2nd layer' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%zminLayer3) = var_info('zminLayer3' , 'minimum layer depth for the 3rd layer' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%zminLayer4) = var_info('zminLayer4' , 'minimum layer depth for the 4th layer' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%zminLayer5) = var_info('zminLayer5' , 'minimum layer depth for the 5th (bottom) layer' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%zmaxLayer2_lower) = var_info('zmaxLayer2_lower' , 'maximum layer depth for the 2nd layer when only 2 layers' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%zmaxLayer3_lower) = var_info('zmaxLayer3_lower' , 'maximum layer depth for the 3rd layer when only 3 layers' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%zmaxLayer4_lower) = var_info('zmaxLayer4_lower' , 'maximum layer depth for the 4th layer when only 4 layers' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%zmaxLayer1_upper) = var_info('zmaxLayer1_upper' , 'maximum layer depth for the 1st (top) layer when > 1 layer' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%zmaxLayer2_upper) = var_info('zmaxLayer2_upper' , 'maximum layer depth for the 2nd layer when > 2 layers' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%zmaxLayer3_upper) = var_info('zmaxLayer3_upper' , 'maximum layer depth for the 3rd layer when > 3 layers' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + mpar_meta(iLookPARAM%zmaxLayer4_upper) = var_info('zmaxLayer4_upper' , 'maximum layer depth for the 4th layer when > 4 layers' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) ! ----- ! * basin parameter data... ! ------------------------- - bpar_meta(iLookBPAR%basin__aquiferHydCond) = var_info('basin__aquiferHydCond' , 'hydraulic conductivity of the aquifer' , 'm s-1', 'scalarv', .true.) - bpar_meta(iLookBPAR%basin__aquiferScaleFactor) = var_info('basin__aquiferScaleFactor', 'scaling factor for aquifer storage in the big bucket' , 'm' , 'scalarv', .true.) - bpar_meta(iLookBPAR%basin__aquiferBaseflowExp) = var_info('basin__aquiferBaseflowExp', 'baseflow exponent for the big bucket' , '-' , 'scalarv', .true.) - bpar_meta(iLookBPAR%routingGammaShape) = var_info('routingGammaShape' , 'shape parameter in Gamma distribution used for sub-grid routing', '-' , 'scalarv', .true.) - bpar_meta(iLookBPAR%routingGammaScale) = var_info('routingGammaScale' , 'scale parameter in Gamma distribution used for sub-grid routing', 's' , 'scalarv', .true.) + bpar_meta(iLookBPAR%basin__aquiferHydCond) = var_info('basin__aquiferHydCond' , 'hydraulic conductivity of the aquifer' , 'm s-1', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + bpar_meta(iLookBPAR%basin__aquiferScaleFactor) = var_info('basin__aquiferScaleFactor', 'scaling factor for aquifer storage in the big bucket' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + bpar_meta(iLookBPAR%basin__aquiferBaseflowExp) = var_info('basin__aquiferBaseflowExp', 'baseflow exponent for the big bucket' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + bpar_meta(iLookBPAR%routingGammaShape) = var_info('routingGammaShape' , 'shape parameter in Gamma distribution used for sub-grid routing', '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + bpar_meta(iLookBPAR%routingGammaScale) = var_info('routingGammaScale' , 'scale parameter in Gamma distribution used for sub-grid routing', 's' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) ! ----- - ! * local model variables... - ! -------------------------- - ! timestep-average fluxes for a few key variables - mvar_meta(iLookMVAR%totalSoilCompress) = var_info('totalSoilCompress' , 'change in total soil storage due to compression of soil matrix' , 'kg m-2' , 'scalarv', .false.) - mvar_meta(iLookMVAR%averageThroughfallSnow) = var_info('averageThroughfallSnow' , 'snow that reaches the ground without ever touching the canopy' , 'kg m-2 s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%averageThroughfallRain) = var_info('averageThroughfallRain' , 'rain that reaches the ground without ever touching the canopy' , 'kg m-2 s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%averageCanopySnowUnloading) = var_info('averageCanopySnowUnloading' , 'unloading of snow from the vegetion canopy' , 'kg m-2 s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%averageCanopyLiqDrainage) = var_info('averageCanopyLiqDrainage' , 'drainage of liquid water from the vegetation canopy' , 'kg m-2 s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%averageCanopyMeltFreeze) = var_info('averageCanopyMeltFreeze' , 'melt/freeze of water stored in the canopy' , 'kg m-2 s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%averageCanopyTranspiration) = var_info('averageCanopyTranspiration' , 'canopy transpiration' , 'kg m-2 s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%averageCanopyEvaporation) = var_info('averageCanopyEvaporation' , 'canopy evaporation/condensation' , 'kg m-2 s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%averageCanopySublimation) = var_info('averageCanopySublimation' , 'canopy sublimation/frost' , 'kg m-2 s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%averageSnowSublimation) = var_info('averageSnowSublimation' , 'snow sublimation/frost (below canopy or non-vegetated)' , 'kg m-2 s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%averageGroundEvaporation) = var_info('averageGroundEvaporation' , 'ground evaporation/condensation (below canopy or non-vegetated)' , 'kg m-2 s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%averageRainPlusMelt) = var_info('averageRainPlusMelt' , 'rain plus melt input to soil before calculating surface runoff' , 'm s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%averageSurfaceRunoff) = var_info('averageSurfaceRunoff' , 'surface runoff' , 'm s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%averageSoilInflux) = var_info('averageSoilInflux' , 'influx of water at the top of the soil profile' , 'm s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%averageSoilBaseflow) = var_info('averageSoilBaseflow' , 'total baseflow from throughout the soil profile' , 'm s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%averageSoilDrainage) = var_info('averageSoilDrainage' , 'drainage from the bottom of the soil profile' , 'm s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%averageAquiferRecharge) = var_info('averageAquiferRecharge' , 'recharge to the aquifer' , 'm s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%averageAquiferBaseflow) = var_info('averageAquiferBaseflow' , 'baseflow from the aquifer' , 'm s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%averageAquiferTranspire) = var_info('averageAquiferTranspire' , 'transpiration from the aquifer' , 'm s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%averageColumnOutflow) = var_info('averageColumnOutflow' , 'outflow from each layer in the soil profile' , 'm3 s-1' , 'midSoil', .false.) - ! scalar variables (forcing) - mvar_meta(iLookMVAR%scalarCosZenith) = var_info('scalarCosZenith' , 'cosine of the solar zenith angle' , '-' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarFractionDirect) = var_info('scalarFractionDirect' , 'fraction of direct radiation (0-1)' , '-' , 'scalarv', .false.) - mvar_meta(iLookMVAR%spectralIncomingDirect) = var_info('spectralIncomingDirect' , 'incoming direct solar radiation in each wave band' , 'W m-2' , 'wLength', .false.) - mvar_meta(iLookMVAR%spectralIncomingDiffuse) = var_info('spectralIncomingDiffuse' , 'incoming diffuse solar radiation in each wave band' , 'W m-2' , 'wLength', .false.) - mvar_meta(iLookMVAR%scalarVPair) = var_info('scalarVPair' , 'vapor pressure of the air above the vegetation canopy' , 'Pa' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarTwetbulb) = var_info('scalarTwetbulb' , 'wet bulb temperature' , 'K' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarRainfall) = var_info('scalarRainfall' , 'computed rainfall rate' , 'kg m-2 s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarSnowfall) = var_info('scalarSnowfall' , 'computed snowfall rate' , 'kg m-2 s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarSnowfallTemp) = var_info('scalarSnowfallTemp' , 'temperature of fresh snow' , 'K' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarNewSnowDensity) = var_info('scalarNewSnowDensity' , 'density of fresh snow (should snow be falling in this time step)' , 'kg m-3' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarO2air) = var_info('scalarO2air' , 'atmospheric o2 concentration' , 'Pa' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarCO2air) = var_info('scalarCO2air' , 'atmospheric co2 concentration' , 'Pa' , 'scalarv', .false.) - ! scalar variables (state variables) - mvar_meta(iLookMVAR%scalarCanopyIce) = var_info('scalarCanopyIce' , 'mass of ice on the vegetation canopy' , 'kg m-2' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarCanopyLiq) = var_info('scalarCanopyLiq' , 'mass of liquid water on the vegetation canopy' , 'kg m-2' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarCanairTemp) = var_info('scalarCanairTemp' , 'temperature of the canopy air space' , 'K' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarCanopyTemp) = var_info('scalarCanopyTemp' , 'temperature of the vegetation canopy' , 'K' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarSnowAge) = var_info('scalarSnowAge' , 'non-dimensional snow age' , '-' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarSnowAlbedo) = var_info('scalarSnowAlbedo' , 'snow albedo for the entire spectral band' , '-' , 'scalarv', .false.) - mvar_meta(iLookMVAR%spectralSnowAlbedoDirect) = var_info('spectralSnowAlbedoDirect' , 'direct snow albedo for individual spectral bands' , '-' , 'wLength', .false.) - mvar_meta(iLookMVAR%spectralSnowAlbedoDiffuse) = var_info('spectralSnowAlbedoDiffuse' , 'diffuse snow albedo for individual spectral bands' , '-' , 'wLength', .false.) - mvar_meta(iLookMVAR%scalarSnowDepth) = var_info('scalarSnowDepth' , 'total snow depth' , 'm' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarSWE) = var_info('scalarSWE' , 'snow water equivalent' , 'kg m-2' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarSfcMeltPond) = var_info('scalarSfcMeltPond' , 'ponded water caused by melt of the "snow without a layer"' , 'kg m-2' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarAquiferStorage) = var_info('scalarAquiferStorage' , 'water required to bring aquifer to the bottom of the soil profile', 'm' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarSurfaceTemp) = var_info('scalarSurfaceTemp' , 'surface temperature (just a copy of the upper-layer temperature)' , 'K' , 'scalarv', .true.) - ! vegetation variables (general) - mvar_meta(iLookMVAR%scalarGreenVegFraction) = var_info('scalarGreenVegFraction' , 'green vegetation fraction (used to compute LAI)' , '-' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarBulkVolHeatCapVeg) = var_info('scalarBulkVolHeatCapVeg' , 'bulk volumetric heat capacity of vegetation' , 'J m-3 K-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarRootZoneTemp) = var_info('scalarRootZoneTemp' , 'average temperature of the root zone' , 'K' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarLAI) = var_info('scalarLAI' , 'one-sided leaf area index' , 'm2 m-2' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarSAI) = var_info('scalarSAI' , 'one-sided stem area index' , 'm2 m-2' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarExposedLAI) = var_info('scalarExposedLAI' , 'exposed leaf area index (after burial by snow)' , 'm2 m-2' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarExposedSAI) = var_info('scalarExposedSAI' , 'exposed stem area index (after burial by snow)' , 'm2 m-2' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarCanopyIceMax) = var_info('scalarCanopyIceMax' , 'maximum interception storage capacity for ice' , 'kg m-2' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarCanopyLiqMax) = var_info('scalarCanopyLiqMax' , 'maximum interception storage capacity for liquid water' , 'kg m-2' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarGrowingSeasonIndex) = var_info('scalarGrowingSeasonIndex' , 'growing season index (0=off, 1=on)' , '-' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarVP_CanopyAir) = var_info('scalarVP_CanopyAir' , 'vapor pressure of the canopy air space' , 'Pa' , 'scalarv', .false.) - ! vegetation variables (shortwave radiation) - mvar_meta(iLookMVAR%scalarCanopySunlitFraction) = var_info('scalarCanopySunlitFraction' , 'sunlit fraction of canopy' , '-' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarCanopySunlitLAI) = var_info('scalarCanopySunlitLAI' , 'sunlit leaf area' , '-' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarCanopyShadedLAI) = var_info('scalarCanopyShadedLAI' , 'shaded leaf area' , '-' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarCanopySunlitPAR) = var_info('scalarCanopySunlitPAR' , 'average absorbed par for sunlit leaves' , 'W m-2' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarCanopyShadedPAR) = var_info('scalarCanopyShadedPAR' , 'average absorbed par for shaded leaves' , 'W m-2' , 'scalarv', .false.) - mvar_meta(iLookMVAR%spectralBelowCanopyDirect) = var_info('spectralBelowCanopyDirect' , 'downward direct flux below veg layer for each spectral band' , 'W m-2' , 'wLength', .false.) - mvar_meta(iLookMVAR%spectralBelowCanopyDiffuse) = var_info('spectralBelowCanopyDiffuse' , 'downward diffuse flux below veg layer for each spectral band' , 'W m-2' , 'wLength', .false.) - mvar_meta(iLookMVAR%scalarBelowCanopySolar) = var_info('scalarBelowCanopySolar' , 'solar radiation transmitted below the canopy' , 'W m-2' , 'scalarv', .false.) - mvar_meta(iLookMVAR%spectralAlbGndDirect) = var_info('spectralAlbGndDirect' , 'direct albedo of underlying surface for each spectral band' , '-' , 'wLength', .false.) - mvar_meta(iLookMVAR%spectralAlbGndDiffuse) = var_info('spectralAlbGndDiffuse' , 'diffuse albedo of underlying surface for each spectral band' , '-' , 'wLength', .false.) - mvar_meta(iLookMVAR%scalarGroundAlbedo) = var_info('scalarGroundAlbedo' , 'albedo of the ground surface' , '-' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarCanopyAbsorbedSolar) = var_info('scalarCanopyAbsorbedSolar' , 'solar radiation absorbed by canopy' , 'W m-2' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarGroundAbsorbedSolar) = var_info('scalarGroundAbsorbedSolar' , 'solar radiation absorbed by ground' , 'W m-2' , 'scalarv', .true.) - ! vegetation variables (longwave radiation) - mvar_meta(iLookMVAR%scalarCanopyEmissivity) = var_info('scalarCanopyEmissivity' , 'effective canopy emissivity' , '-' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarLWRadCanopy) = var_info('scalarLWRadCanopy' , 'longwave radiation emitted from the canopy' , 'W m-2' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarLWRadGround) = var_info('scalarLWRadGround' , 'longwave radiation emitted at the ground surface' , 'W m-2' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarLWRadUbound2Canopy) = var_info('scalarLWRadUbound2Canopy' , 'downward atmospheric longwave radiation absorbed by the canopy' , 'W m-2' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarLWRadUbound2Ground) = var_info('scalarLWRadUbound2Ground' , 'downward atmospheric longwave radiation absorbed by the ground' , 'W m-2' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarLWRadUbound2Ubound) = var_info('scalarLWRadUbound2Ubound' , 'atmospheric radiation refl by ground + lost thru upper boundary' , 'W m-2' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarLWRadCanopy2Ubound) = var_info('scalarLWRadCanopy2Ubound' , 'longwave radiation emitted from canopy lost thru upper boundary' , 'W m-2' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarLWRadCanopy2Ground) = var_info('scalarLWRadCanopy2Ground' , 'longwave radiation emitted from canopy absorbed by the ground' , 'W m-2' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarLWRadCanopy2Canopy) = var_info('scalarLWRadCanopy2Canopy' , 'canopy longwave reflected from ground and absorbed by the canopy' , 'W m-2' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarLWRadGround2Ubound) = var_info('scalarLWRadGround2Ubound' , 'longwave radiation emitted from ground lost thru upper boundary' , 'W m-2' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarLWRadGround2Canopy) = var_info('scalarLWRadGround2Canopy' , 'longwave radiation emitted from ground and absorbed by the canopy', 'W m-2' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarLWNetCanopy) = var_info('scalarLWNetCanopy' , 'net longwave radiation at the canopy' , 'W m-2' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarLWNetGround) = var_info('scalarLWNetGround' , 'net longwave radiation at the ground surface' , 'W m-2' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarLWNetUbound) = var_info('scalarLWNetUbound' , 'net longwave radiation at the upper atmospheric boundary' , 'W m-2' , 'scalarv', .false.) - ! vegetation variables (turbulent heat transfer) - mvar_meta(iLookMVAR%scalarLatHeatSubVapCanopy) = var_info('scalarLatHeatSubVapCanopy' , 'latent heat of sublimation/vaporization used for veg canopy' , 'J kg-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarLatHeatSubVapGround) = var_info('scalarLatHeatSubVapGround' , 'latent heat of sublimation/vaporization used for ground surface' , 'J kg-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarSatVP_CanopyTemp) = var_info('scalarSatVP_CanopyTemp' , 'saturation vapor pressure at the temperature of vegetation canopy', 'Pa' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarSatVP_GroundTemp) = var_info('scalarSatVP_GroundTemp' , 'saturation vapor pressure at the temperature of the ground' , 'Pa' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarZ0Canopy) = var_info('scalarZ0Canopy' , 'roughness length of the canopy' , 'm' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarWindReductionFactor) = var_info('scalarWindReductionFactor' , 'canopy wind reduction factor' , '-' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarZeroPlaneDisplacement) = var_info('scalarZeroPlaneDisplacement' , 'zero plane displacement' , 'm' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarRiBulkCanopy) = var_info('scalarRiBulkCanopy' , 'bulk Richardson number for the canopy' , '-' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarRiBulkGround) = var_info('scalarRiBulkGround' , 'bulk Richardson number for the ground surface' , '-' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarCanopyStabilityCorrection) = var_info('scalarCanopyStabilityCorrection', 'stability correction for the canopy' , '-' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarGroundStabilityCorrection) = var_info('scalarGroundStabilityCorrection', 'stability correction for the ground surface' , '-' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarEddyDiffusCanopyTop) = var_info('scalarEddyDiffusCanopyTop' , 'eddy diffusivity for heat at the top of the canopy' , 'm2 s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarFrictionVelocity) = var_info('scalarFrictionVelocity' , 'friction velocity (canopy momentum sink)' , 'm s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarWindspdCanopyTop) = var_info('scalarWindspdCanopyTop' , 'windspeed at the top of the canopy' , 'm s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarWindspdCanopyBottom) = var_info('scalarWindspdCanopyBottom' , 'windspeed at the height of the bottom of the canopy' , 'm s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarGroundResistance) = var_info('scalarGroundResistance' , 'below canopy aerodynamic resistance' , 's m-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarCanopyResistance) = var_info('scalarCanopyResistance' , 'above canopy aerodynamic resistance' , 's m-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarLeafResistance) = var_info('scalarLeafResistance' , 'mean leaf boundary layer resistance per unit leaf area' , 's m-1' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarSoilResistance) = var_info('scalarSoilResistance' , 'soil surface resistance' , 's m-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarSoilRelHumidity) = var_info('scalarSoilRelHumidity' , 'relative humidity in the soil pores in the upper-most soil layer' , '-' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarSenHeatTotal) = var_info('scalarSenHeatTotal' , 'sensible heat from the canopy air space to the atmosphere' , 'W m-2' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarSenHeatCanopy) = var_info('scalarSenHeatCanopy' , 'sensible heat from the canopy to the canopy air space' , 'W m-2' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarSenHeatGround) = var_info('scalarSenHeatGround' , 'sensible heat from the ground (below canopy or non-vegetated)' , 'W m-2' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarLatHeatTotal) = var_info('scalarLatHeatTotal' , 'latent heat from the canopy air space to the atmosphere' , 'W m-2' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarLatHeatCanopyEvap) = var_info('scalarLatHeatCanopyEvap' , 'evaporation latent heat from the canopy to the canopy air space' , 'W m-2' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarLatHeatCanopyTrans) = var_info('scalarLatHeatCanopyTrans' , 'transpiration latent heat from the canopy to the canopy air space', 'W m-2' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarLatHeatGround) = var_info('scalarLatHeatGround' , 'latent heat from the ground (below canopy or non-vegetated)' , 'W m-2' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarCanopyAdvectiveHeatFlux) = var_info('scalarCanopyAdvectiveHeatFlux' , 'heat advected to the canopy with precipitation (snow + rain)' , 'W m-2' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarGroundAdvectiveHeatFlux) = var_info('scalarGroundAdvectiveHeatFlux' , 'heat advected to the ground with throughfall + unloading/drainage', 'W m-2' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarCanopyTranspiration) = var_info('scalarCanopyTranspiration' , 'canopy transpiration' , 'kg m-2 s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarCanopyEvaporation) = var_info('scalarCanopyEvaporation' , 'canopy evaporation/condensation' , 'kg m-2 s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarCanopySublimation) = var_info('scalarCanopySublimation' , 'canopy sublimation/frost' , 'kg m-2 s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarGroundEvaporation) = var_info('scalarGroundEvaporation' , 'ground evaporation/condensation (below canopy or non-vegetated)' , 'kg m-2 s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarSnowSublimation) = var_info('scalarSnowSublimation' , 'snow sublimation/frost (below canopy or non-vegetated)' , 'kg m-2 s-1' , 'scalarv', .false.) - ! vegetation variables (transpiration) - mvar_meta(iLookMVAR%scalarTranspireLim) = var_info('scalarTranspireLim' , 'aggregate soil moisture and aquifer control on transpiration' , '-' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarTranspireLimAqfr) = var_info('scalarTranspireLimAqfr' , 'aquifer storage control on transpiration' , '-' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarFoliageNitrogenFactor) = var_info('scalarFoliageNitrogenFactor' , 'foliage nitrogen concentration (1=saturated)' , '-' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarStomResistSunlit) = var_info('scalarStomResistSunlit' , 'stomatal resistance for sunlit leaves' , 's m-1' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarStomResistShaded) = var_info('scalarStomResistShaded' , 'stomatal resistance for shaded leaves' , 's m-1' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarPhotosynthesisSunlit) = var_info('scalarPhotosynthesisSunlit' , 'sunlit photosynthesis' , 'umolco2 m-2 s-1' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarPhotosynthesisShaded) = var_info('scalarPhotosynthesisShaded' , 'shaded photosynthesis' , 'umolco2 m-2 s-1' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarIntercellularCO2Sunlit) = var_info('scalarIntercellularCO2Sunlit' , 'carbon dioxide partial pressure of leaf interior (sunlit leaves)' , 'Pa' , 'scalarv', .true.) - mvar_meta(iLookMVAR%scalarIntercellularCO2Shaded) = var_info('scalarIntercellularCO2Shaded' , 'carbon dioxide partial pressure of leaf interior (shaded leaves)' , 'Pa' , 'scalarv', .true.) - ! vegetation variables (canopy water) - mvar_meta(iLookMVAR%scalarCanopyWetFraction) = var_info('scalarCanopyWetFraction' , 'fraction canopy that is wet' , '-' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarGroundSnowFraction) = var_info('scalarGroundSnowFraction' , 'fraction ground that is covered with snow' , '-' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarThroughfallSnow) = var_info('scalarThroughfallSnow' , 'snow that reaches the ground without ever touching the canopy' , 'kg m-2 s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarThroughfallRain) = var_info('scalarThroughfallRain' , 'rain that reaches the ground without ever touching the canopy' , 'kg m-2 s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarCanopySnowUnloading) = var_info('scalarCanopySnowUnloading' , 'unloading of snow from the vegetation canopy' , 'kg m-2 s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarCanopyLiqDrainage) = var_info('scalarCanopyLiqDrainage' , 'drainage of liquid water from the vegetation canopy' , 'kg m-2 s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarCanopyMeltFreeze) = var_info('scalarCanopyMeltFreeze' , 'melt/freeze of water stored in the canopy' , 'kg m-2 s-1' , 'scalarv', .false.) - ! scalar variables (soil and aquifer fluxes) - mvar_meta(iLookMVAR%scalarRainPlusMelt) = var_info('scalarRainPlusMelt' , 'rain plus melt, used as input to soil before surface runoff' , 'm s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarInfilArea) = var_info('scalarInfilArea' , 'fraction of unfrozen area where water can infiltrate' , '-' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarFrozenArea) = var_info('scalarFrozenArea' , 'fraction of area that is considered impermeable due to soil ice' , '-' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarInfiltration) = var_info('scalarInfiltration' , 'infiltration of water into the soil profile' , 'm s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarExfiltration) = var_info('scalarExfiltration' , 'exfiltration of water from the top of the soil profile' , 'm s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarSurfaceRunoff) = var_info('scalarSurfaceRunoff' , 'surface runoff' , 'm s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarInitAquiferRecharge) = var_info('scalarInitAquiferRecharge' , 'recharge to the aquifer at the start-of-step' , 'm s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarAquiferRecharge) = var_info('scalarAquiferRecharge' , 'recharge to the aquifer at the end-of-step' , 'm s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarInitAquiferTranspire) = var_info('scalarInitAquiferTranspire' , 'transpiration loss from the aquifer at the start-of-step' , 'm s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarAquiferTranspire) = var_info('scalarAquiferTranspire' , 'transpiration loss from the aquifer at the end-of-step' , 'm s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarInitAquiferBaseflow) = var_info('scalarInitAquiferBaseflow' , 'baseflow from the aquifer at the start-of-step' , 'm s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarAquiferBaseflow) = var_info('scalarAquiferBaseflow' , 'baseflow from the aquifer at the end-of-step' , 'm s-1' , 'scalarv', .false.) - ! scalar variables (sub-step average fluxes for the soil zone) - mvar_meta(iLookMVAR%scalarSoilInflux) = var_info('scalarSoilInflux' , 'sub-step average: influx of water at the top of the soil profile' , 'm s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarSoilCompress) = var_info('scalarSoilCompress' , 'change in total soil storage due to compression of soil matrix' , 'kg m-2' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarSoilBaseflow) = var_info('scalarSoilBaseflow' , 'sub-step average: total baseflow from the soil profile' , 'm s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarSoilDrainage) = var_info('scalarSoilDrainage' , 'sub-step average: drainage from the bottom of the soil profile' , 'm s-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarSoilTranspiration) = var_info('scalarSoilTranspiration' , 'sub-step average: total transpiration from the soil' , 'm s-1' , 'scalarv', .false.) - ! scalar variables (mass balance check) - mvar_meta(iLookMVAR%scalarSoilWatBalError) = var_info('scalarSoilWatBalError' , 'error in the total soil water balance' , 'kg m-2' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarAquiferBalError) = var_info('scalarAquiferBalError' , 'error in the aquifer water balance' , 'kg m-2' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarTotalSoilLiq) = var_info('scalarTotalSoilLiq' , 'total mass of liquid water in the soil' , 'kg m-2' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarTotalSoilIce) = var_info('scalarTotalSoilIce' , 'total mass of ice in the soil' , 'kg m-2' , 'scalarv', .false.) - ! variables at the mid-point of each layer -- domain geometry - mvar_meta(iLookMVAR%mLayerDepth) = var_info('mLayerDepth' , 'depth of each layer' , 'm' , 'midToto', .false.) - mvar_meta(iLookMVAR%mLayerHeight) = var_info('mLayerHeight' , 'height of the layer mid-point (top of soil = 0)' , 'm' , 'midToto', .false.) - mvar_meta(iLookMVAR%mLayerRootDensity) = var_info('mLayerRootDensity' , 'fraction of roots in each soil layer' , '-' , 'midSoil', .false.) - ! variables at the mid-point of each layer coupled energy and mass - mvar_meta(iLookMVAR%mLayerTemp) = var_info('mLayerTemp' , 'temperature of each layer' , 'K' , 'midToto', .true.) - mvar_meta(iLookMVAR%mLayerVolFracAir) = var_info('mLayerVolFracAir' , 'volumetric fraction of air in each layer' , '-' , 'midToto', .false.) - mvar_meta(iLookMVAR%mLayerVolFracIce) = var_info('mLayerVolFracIce' , 'volumetric fraction of ice in each layer' , '-' , 'midToto', .false.) - mvar_meta(iLookMVAR%mLayerVolFracLiq) = var_info('mLayerVolFracLiq' , 'volumetric fraction of liquid water in each layer' , '-' , 'midToto', .true.) - mvar_meta(iLookMVAR%mLayerVolHtCapBulk) = var_info('mLayerVolHtCapBulk' , 'volumetric heat capacity in each layer' , 'J m-3 K-1' , 'midToto', .false.) - mvar_meta(iLookMVAR%mLayerTcrit) = var_info('mLayerTcrit' , 'critical soil temperature above which all water is unfrozen' , 'K' , 'midSoil', .false.) - mvar_meta(iLookMVAR%mLayerdTheta_dTk) = var_info('mLayerdTheta_dTk' , 'derivative in volumetric liquid water content wrt temperature' , 'K-1' , 'midToto', .false.) - mvar_meta(iLookMVAR%mLayerThermalC) = var_info('mLayerThermalC' , 'thermal conductivity at the mid-point of each layer' , 'W m-1 K-1' , 'midToto', .false.) - mvar_meta(iLookMVAR%mLayerRadCondFlux) = var_info('mLayerRadCondFlux' , 'temporal derivative in energy of radiative and conductive flux' , 'J m-3 s-1' , 'midToto', .false.) - mvar_meta(iLookMVAR%mLayerMeltFreeze) = var_info('mLayerMeltFreeze' , 'ice content change from melt/freeze in each layer' , 'kg m-3' , 'midToto', .false.) - mvar_meta(iLookMVAR%mLayerInfilFreeze) = var_info('mLayerInfilFreeze' , 'ice content change by freezing infiltrating flux' , 'kg m-3' , 'midToto', .false.) - mvar_meta(iLookMVAR%mLayerSatHydCond) = var_info('mLayerSatHydCond' , 'saturated hydraulic conductivity in each layer' , 'm s-1' , 'midSoil', .false.) - mvar_meta(iLookMVAR%mLayerSatHydCondMP) = var_info('mLayerSatHydCondMP' , 'saturated hydraulic conductivity of macropores in each layer' , 'm s-1' , 'midSoil', .false.) - mvar_meta(iLookMVAR%mLayerMatricHead) = var_info('mLayerMatricHead' , 'matric head of water in the soil' , 'm' , 'midSoil', .false.) - mvar_meta(iLookMVAR%mLayerdTheta_dPsi) = var_info('mLayerdTheta_dPsi' , 'derivative in the soil water characteristic w.r.t. psi' , 'm-1' , 'midSoil', .false.) - mvar_meta(iLookMVAR%mLayerdPsi_dTheta) = var_info('mLayerdPsi_dTheta' , 'derivative in the soil water characteristic w.r.t. theta' , 'm' , 'midSoil', .false.) - mvar_meta(iLookMVAR%mLayerThetaResid) = var_info('mLayerThetaResid' , 'residual volumetric water content in each snow layer' , '-' , 'midSnow', .false.) - mvar_meta(iLookMVAR%mLayerPoreSpace) = var_info('mLayerPoreSpace' , 'total pore space in each snow layer' , '-' , 'midSnow', .false.) - mvar_meta(iLookMVAR%mLayerCompress) = var_info('mLayerCompress' , 'change in volumetric water content due to compression of soil' , '-' , 'midSoil', .false.) - mvar_meta(iLookMVAR%mLayerTranspireLim) = var_info('mLayerTranspireLim' , 'soil moist & veg limit on transpiration for each layer' , '-' , 'midSoil', .false.) - mvar_meta(iLookMVAR%mLayerInitTranspire) = var_info('mLayerInitTranspire' , 'transpiration loss from each soil layer at the start-of-step' , 'm s-1' , 'midSoil', .false.) - mvar_meta(iLookMVAR%mLayerTranspire) = var_info('mLayerTranspire' , 'transpiration loss from each soil layer' , 'm s-1' , 'midSoil', .false.) - mvar_meta(iLookMVAR%mLayerInitQMacropore) = var_info('mLayerInitQMacropore' , 'liquid flux from micropores to macropores at the start-of-step' , 'm s-1' , 'midSoil', .false.) - mvar_meta(iLookMVAR%mLayerQMacropore) = var_info('mLayerQMacropore' , 'liquid flux from micropores to macropores' , 'm s-1' , 'midSoil', .false.) - mvar_meta(iLookMVAR%mLayerInitBaseflow) = var_info('mLayerInitBaseflow' , 'baseflow from each soil layer at the start of the time step' , 'm s-1' , 'midSoil', .false.) - mvar_meta(iLookMVAR%mLayerBaseflow) = var_info('mLayerBaseflow' , 'baseflow from each soil layer' , 'm s-1' , 'midSoil', .false.) - mvar_meta(iLookMVAR%mLayerColumnInflow) = var_info('mLayerColumnInflow' , 'total inflow to each layer in a given soil column' , 'm3 s-1' , 'midSoil', .false.) - mvar_meta(iLookMVAR%mLayerColumnOutflow) = var_info('mLayerColumnOutflow' , 'total outflow from each layer in a given soil column' , 'm3 s-1' , 'midSoil', .false.) - ! variables at the interface of each layer - mvar_meta(iLookMVAR%iLayerHeight) = var_info('iLayerHeight' , 'height of the layer interface (top of soil = 0)' , 'm' , 'ifcToto', .true.) - mvar_meta(iLookMVAR%iLayerThermalC) = var_info('iLayerThermalC' , 'thermal conductivity at the interface of each layer' , 'W m-1 K-1' , 'ifcToto', .false.) - mvar_meta(iLookMVAR%iLayerConductiveFlux) = var_info('iLayerConductiveFlux' , 'conductive energy flux at layer interfaces at end of time step' , 'W m-2' , 'ifcToto', .false.) - mvar_meta(iLookMVAR%iLayerAdvectiveFlux) = var_info('iLayerAdvectiveFlux' , 'advective energy flux at layer interfaces at end of time step' , 'W m-2' , 'ifcToto', .false.) - mvar_meta(iLookMVAR%iLayerInitNrgFlux) = var_info('iLayerInitNrgFlux' , 'energy flux at layer interfaces at the start of the time step' , 'W m-2' , 'ifcToto', .false.) - mvar_meta(iLookMVAR%iLayerNrgFlux) = var_info('iLayerNrgFlux' , 'energy flux at layer interfaces at end of the time step' , 'W m-2' , 'ifcToto', .true.) - mvar_meta(iLookMVAR%iLayerSatHydCond) = var_info('iLayerSatHydCond' , 'saturated hydraulic conductivity in each layer interface' , 'm s-1' , 'ifcSoil', .false.) - mvar_meta(iLookMVAR%iLayerInitLiqFluxSnow) = var_info('iLayerInitLiqFluxSnow' , 'liquid flux at snow layer interfaces at start of the time step' , 'm s-1' , 'ifcSnow', .false.) - mvar_meta(iLookMVAR%iLayerInitLiqFluxSoil) = var_info('iLayerInitLiqFluxSoil' , 'liquid flux at soil layer interfaces at start of the time step' , 'm s-1' , 'ifcSoil', .false.) - mvar_meta(iLookMVAR%iLayerInitFluxReversal) = var_info('iLayerInitFluxReversal' , 'start of step liquid flux at soil layer interfaces from impedance', 'm s-1' , 'ifcSoil', .false.) - mvar_meta(iLookMVAR%iLayerLiqFluxSnow) = var_info('iLayerLiqFluxSnow' , 'liquid flux at snow layer interfaces at end of the time step' , 'm s-1' , 'ifcSnow', .false.) - mvar_meta(iLookMVAR%iLayerLiqFluxSoil) = var_info('iLayerLiqFluxSoil' , 'liquid flux at soil layer interfaces at end of the time step' , 'm s-1' , 'ifcSoil', .false.) - mvar_meta(iLookMVAR%iLayerFluxReversal) = var_info('iLayerFluxReversal' , 'end of step liquid flux at soil layer interfaces from impedance' , 'm s-1' , 'ifcSoil', .false.) - ! time steppin, - mvar_meta(iLookMVAR%dt_init) = var_info('dt_init' , 'length of initial time step at start of next data interval' , 's' , 'scalarv', .false.) - ! "short-cut" variables - mvar_meta(iLookMVAR%scalarVGn_m) = var_info('scalarVGn_m' , 'van Genuchten "m" parameter' , '-' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarKappa) = var_info('scalarKappa' , 'constant in the freezing curve function' , 'm K-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarVolHtCap_air) = var_info('scalarVolHtCap_air' , 'volumetric heat capacity air' , 'J m-3 K-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarVolHtCap_ice) = var_info('scalarVolHtCap_ice' , 'volumetric heat capacity ice' , 'J m-3 K-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarVolHtCap_soil) = var_info('scalarVolHtCap_soil' , 'volumetric heat capacity dry soil' , 'J m-3 K-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarVolHtCap_water) = var_info('scalarVolHtCap_water' , 'volumetric heat capacity liquid wat' , 'J m-3 K-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarLambda_drysoil) = var_info('scalarLambda_drysoil' , 'thermal conductivity of dry soil' , 'W m-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarLambda_wetsoil) = var_info('scalarLambda_wetsoil' , 'thermal conductivity of wet soil' , 'W m-1' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarVolLatHt_fus) = var_info('scalarVolLatHt_fus' , 'volumetric latent heat of fusion' , 'J m-3' , 'scalarv', .false.) - mvar_meta(iLookMVAR%scalarAquiferRootFrac) = var_info('scalarAquiferRootFrac' , 'fraction of roots below the soil profile (in the aquifer)' , '-' , 'scalarv', .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'), lFalseArry, integerMissing, iMissArry) + ! state variables for vegetation + prog_meta(iLookPROG%scalarCanopyIce) = var_info('scalarCanopyIce' , 'mass of ice on the vegetation canopy' , 'kg m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + prog_meta(iLookPROG%scalarCanopyLiq) = var_info('scalarCanopyLiq' , 'mass of liquid water on the vegetation canopy' , 'kg m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + prog_meta(iLookPROG%scalarCanopyWat) = var_info('scalarCanopyWat' , 'mass of total water on the vegetation canopy' , 'kg m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + prog_meta(iLookPROG%scalarCanairTemp) = var_info('scalarCanairTemp' , 'temperature of the canopy air space' , 'K' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + prog_meta(iLookPROG%scalarCanopyTemp) = var_info('scalarCanopyTemp' , 'temperature of the vegetation canopy' , 'K' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + ! state variables for snow + prog_meta(iLookPROG%spectralSnowAlbedoDiffuse) = var_info('spectralSnowAlbedoDiffuse' , 'diffuse snow albedo for individual spectral bands' , '-' , get_ixVarType('wLength'), lFalseArry, integerMissing, iMissArry) + prog_meta(iLookPROG%scalarSnowAlbedo) = var_info('scalarSnowAlbedo' , 'snow albedo for the entire spectral band' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + prog_meta(iLookPROG%scalarSnowDepth) = var_info('scalarSnowDepth' , 'total snow depth' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + prog_meta(iLookPROG%scalarSWE) = var_info('scalarSWE' , 'snow water equivalent' , 'kg m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + prog_meta(iLookPROG%scalarSfcMeltPond) = var_info('scalarSfcMeltPond' , 'ponded water caused by melt of the "snow without a layer"' , 'kg m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + ! define state variables for the snow+soil domain + prog_meta(iLookPROG%mLayerTemp) = var_info('mLayerTemp' , 'temperature of each layer' , 'K' , get_ixVarType('midToto'), lFalseArry, integerMissing, iMissArry) + prog_meta(iLookPROG%mLayerVolFracIce) = var_info('mLayerVolFracIce' , 'volumetric fraction of ice in each layer' , '-' , get_ixVarType('midToto'), lFalseArry, integerMissing, iMissArry) + prog_meta(iLookPROG%mLayerVolFracLiq) = var_info('mLayerVolFracLiq' , 'volumetric fraction of liquid water in each layer' , '-' , get_ixVarType('midToto'), lFalseArry, integerMissing, iMissArry) + prog_meta(iLookPROG%mLayerVolFracWat) = var_info('mLayerVolFracWat' , 'volumetric fraction of total water in each layer' , '-' , get_ixVarType('midToto'), lFalseArry, integerMissing, iMissArry) + prog_meta(iLookPROG%mLayerMatricHead) = var_info('mLayerMatricHead' , 'matric head of water in the soil' , 'm' , get_ixVarType('midSoil'), lFalseArry, integerMissing, iMissArry) + ! 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'), lFalseArry, integerMissing, iMissArry) + prog_meta(iLookPROG%scalarSurfaceTemp) = var_info('scalarSurfaceTemp' , 'surface temperature (just a copy of the upper-layer temperature)' , 'K' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + ! define coordinate variables + prog_meta(iLookPROG%mLayerDepth) = var_info('mLayerDepth' , 'depth of each layer' , 'm' , get_ixVarType('midToto'), lFalseArry, integerMissing, iMissArry) + prog_meta(iLookPROG%mLayerHeight) = var_info('mLayerHeight' , 'height of the layer mid-point (top of soil = 0)' , 'm' , get_ixVarType('midToto'), lFalseArry, integerMissing, iMissArry) + prog_meta(iLookPROG%iLayerHeight) = var_info('iLayerHeight' , 'height of the layer interface (top of soil = 0)' , 'm' , get_ixVarType('ifcToto'), lFalseArry, integerMissing, iMissArry) + + ! ----- + ! * local model diagnostic variables... + ! ------------------------------------- + ! local properties + diag_meta(iLookDIAG%scalarCanopyDepth) = var_info('scalarCanopyDepth' , 'canopy depth' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarGreenVegFraction) = var_info('scalarGreenVegFraction' , 'green vegetation fraction (used to compute LAI)' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarBulkVolHeatCapVeg) = var_info('scalarBulkVolHeatCapVeg' , 'bulk volumetric heat capacity of vegetation' , 'J m-3 K-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarCanopyEmissivity) = var_info('scalarCanopyEmissivity' , 'effective canopy emissivity' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarRootZoneTemp) = var_info('scalarRootZoneTemp' , 'average temperature of the root zone' , 'K' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarLAI) = var_info('scalarLAI' , 'one-sided leaf area index' , 'm2 m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarSAI) = var_info('scalarSAI' , 'one-sided stem area index' , 'm2 m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarExposedLAI) = var_info('scalarExposedLAI' , 'exposed leaf area index (after burial by snow)' , 'm2 m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarExposedSAI) = var_info('scalarExposedSAI' , 'exposed stem area index (after burial by snow)' , 'm2 m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarCanopyIceMax) = var_info('scalarCanopyIceMax' , 'maximum interception storage capacity for ice' , 'kg m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarCanopyLiqMax) = var_info('scalarCanopyLiqMax' , 'maximum interception storage capacity for liquid water' , 'kg m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarGrowingSeasonIndex) = var_info('scalarGrowingSeasonIndex' , 'growing season index (0=off, 1=on)' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarVolHtCap_air) = var_info('scalarVolHtCap_air' , 'volumetric heat capacity air' , 'J m-3 K-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarVolHtCap_ice) = var_info('scalarVolHtCap_ice' , 'volumetric heat capacity ice' , 'J m-3 K-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarVolHtCap_soil) = var_info('scalarVolHtCap_soil' , 'volumetric heat capacity dry soil' , 'J m-3 K-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarVolHtCap_water) = var_info('scalarVolHtCap_water' , 'volumetric heat capacity liquid wat' , 'J m-3 K-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%mLayerVolHtCapBulk) = var_info('mLayerVolHtCapBulk' , 'volumetric heat capacity in each layer' , 'J m-3 K-1' , get_ixVarType('midToto'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarLambda_drysoil) = var_info('scalarLambda_drysoil' , 'thermal conductivity of dry soil' , 'W m-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarLambda_wetsoil) = var_info('scalarLambda_wetsoil' , 'thermal conductivity of wet soil' , 'W m-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%mLayerThermalC) = var_info('mLayerThermalC' , 'thermal conductivity at the mid-point of each layer' , 'W m-1 K-1' , get_ixVarType('midToto'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%iLayerThermalC) = var_info('iLayerThermalC' , 'thermal conductivity at the interface of each layer' , 'W m-1 K-1' , get_ixVarType('ifcToto'), lFalseArry, integerMissing, iMissArry) + ! forcing + diag_meta(iLookDIAG%scalarVPair) = var_info('scalarVPair' , 'vapor pressure of the air above the vegetation canopy' , 'Pa' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarVP_CanopyAir) = var_info('scalarVP_CanopyAir' , 'vapor pressure of the canopy air space' , 'Pa' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarTwetbulb) = var_info('scalarTwetbulb' , 'wet bulb temperature' , 'K' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarSnowfallTemp) = var_info('scalarSnowfallTemp' , 'temperature of fresh snow' , 'K' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarNewSnowDensity) = var_info('scalarNewSnowDensity' , 'density of fresh snow' , 'kg m-3' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarO2air) = var_info('scalarO2air' , 'atmospheric o2 concentration' , 'Pa' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarCO2air) = var_info('scalarCO2air' , 'atmospheric co2 concentration' , 'Pa' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + ! shortwave radiation + diag_meta(iLookDIAG%scalarCosZenith) = var_info('scalarCosZenith' , 'cosine of the solar zenith angle' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarFractionDirect) = var_info('scalarFractionDirect' , 'fraction of direct radiation (0-1)' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarCanopySunlitFraction) = var_info('scalarCanopySunlitFraction' , 'sunlit fraction of canopy' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarCanopySunlitLAI) = var_info('scalarCanopySunlitLAI' , 'sunlit leaf area' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarCanopyShadedLAI) = var_info('scalarCanopyShadedLAI' , 'shaded leaf area' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%spectralAlbGndDirect) = var_info('spectralAlbGndDirect' , 'direct albedo of underlying surface for each spectral band' , '-' , get_ixVarType('wLength'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%spectralAlbGndDiffuse) = var_info('spectralAlbGndDiffuse' , 'diffuse albedo of underlying surface for each spectral band' , '-' , get_ixVarType('wLength'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarGroundAlbedo) = var_info('scalarGroundAlbedo' , 'albedo of the ground surface' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + ! 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'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarLatHeatSubVapGround) = var_info('scalarLatHeatSubVapGround' , 'latent heat of sublimation/vaporization used for ground surface' , 'J kg-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarSatVP_CanopyTemp) = var_info('scalarSatVP_CanopyTemp' , 'saturation vapor pressure at the temperature of vegetation canopy', 'Pa' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarSatVP_GroundTemp) = var_info('scalarSatVP_GroundTemp' , 'saturation vapor pressure at the temperature of the ground' , 'Pa' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarZ0Canopy) = var_info('scalarZ0Canopy' , 'roughness length of the canopy' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarWindReductionFactor) = var_info('scalarWindReductionFactor' , 'canopy wind reduction factor' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarZeroPlaneDisplacement) = var_info('scalarZeroPlaneDisplacement' , 'zero plane displacement' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarRiBulkCanopy) = var_info('scalarRiBulkCanopy' , 'bulk Richardson number for the canopy' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarRiBulkGround) = var_info('scalarRiBulkGround' , 'bulk Richardson number for the ground surface' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarCanopyStabilityCorrection) = var_info('scalarCanopyStabilityCorrection', 'stability correction for the canopy' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarGroundStabilityCorrection) = var_info('scalarGroundStabilityCorrection', 'stability correction for the ground surface' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + ! evapotranspiration + diag_meta(iLookDIAG%scalarIntercellularCO2Sunlit) = var_info('scalarIntercellularCO2Sunlit' , 'carbon dioxide partial pressure of leaf interior (sunlit leaves)' , 'Pa' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarIntercellularCO2Shaded) = var_info('scalarIntercellularCO2Shaded' , 'carbon dioxide partial pressure of leaf interior (shaded leaves)' , 'Pa' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarTranspireLim) = var_info('scalarTranspireLim' , 'aggregate soil moisture and aquifer control on transpiration' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarTranspireLimAqfr) = var_info('scalarTranspireLimAqfr' , 'aquifer storage control on transpiration' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarFoliageNitrogenFactor) = var_info('scalarFoliageNitrogenFactor' , 'foliage nitrogen concentration (1=saturated)' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarSoilRelHumidity) = var_info('scalarSoilRelHumidity' , 'relative humidity in the soil pores in the upper-most soil layer' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%mLayerTranspireLim) = var_info('mLayerTranspireLim' , 'soil moist & veg limit on transpiration for each layer' , '-' , get_ixVarType('midSoil'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%mLayerRootDensity) = var_info('mLayerRootDensity' , 'fraction of roots in each soil layer' , '-' , get_ixVarType('midSoil'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarAquiferRootFrac) = var_info('scalarAquiferRootFrac' , 'fraction of roots below the soil profile (in the aquifer)' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + ! canopy hydrology + diag_meta(iLookDIAG%scalarFracLiqVeg) = var_info('scalarFracLiqVeg' , 'fraction of liquid water on vegetation' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarCanopyWetFraction) = var_info('scalarCanopyWetFraction' , 'fraction canopy that is wet' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + ! snow hydrology + diag_meta(iLookDIAG%scalarSnowAge) = var_info('scalarSnowAge' , 'non-dimensional snow age' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarGroundSnowFraction) = var_info('scalarGroundSnowFraction' , 'fraction ground that is covered with snow' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%spectralSnowAlbedoDirect) = var_info('spectralSnowAlbedoDirect' , 'direct snow albedo for individual spectral bands' , '-' , get_ixVarType('wLength'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%mLayerFracLiqSnow) = var_info('mLayerFracLiqSnow' , 'fraction of liquid water in each snow layer' , '-' , get_ixVarType('midSnow'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%mLayerThetaResid) = var_info('mLayerThetaResid' , 'residual volumetric water content in each snow layer' , '-' , get_ixVarType('midSnow'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%mLayerPoreSpace) = var_info('mLayerPoreSpace' , 'total pore space in each snow layer' , '-' , get_ixVarType('midSnow'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%mLayerMeltFreeze) = var_info('mLayerMeltFreeze' , 'ice content change from melt/freeze in each layer' , 'kg m-3' , get_ixVarType('midToto'), lFalseArry, integerMissing, iMissArry) + ! soil hydrology + diag_meta(iLookDIAG%scalarInfilArea) = var_info('scalarInfilArea' , 'fraction of unfrozen area where water can infiltrate' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarFrozenArea) = var_info('scalarFrozenArea' , 'fraction of area that is considered impermeable due to soil ice' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarSoilControl) = var_info('scalarSoilControl' , 'soil control on infiltration (1=controlling; 0=not)' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%mLayerVolFracAir) = var_info('mLayerVolFracAir' , 'volumetric fraction of air in each layer' , '-' , get_ixVarType('midToto'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%mLayerTcrit) = var_info('mLayerTcrit' , 'critical soil temperature above which all water is unfrozen' , 'K' , get_ixVarType('midSoil'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%mLayerCompress) = var_info('mLayerCompress' , 'change in volumetric water content due to compression of soil' , '-' , get_ixVarType('midSoil'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarSoilCompress) = var_info('scalarSoilCompress' , 'change in total soil storage due to compression of soil matrix' , 'kg m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%mLayerMatricHeadLiq) = var_info('mLayerMatricHeadLiq' , 'matric potential of liquid water' , 'm' , get_ixVarType('midSoil'), lFalseArry, integerMissing, iMissArry) + ! mass balance check + diag_meta(iLookDIAG%scalarSoilWatBalError) = var_info('scalarSoilWatBalError' , 'error in the total soil water balance' , 'kg m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarAquiferBalError) = var_info('scalarAquiferBalError' , 'error in the aquifer water balance' , 'kg m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarTotalSoilLiq) = var_info('scalarTotalSoilLiq' , 'total mass of liquid water in the soil' , 'kg m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarTotalSoilIce) = var_info('scalarTotalSoilIce' , 'total mass of ice in the soil' , 'kg m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + ! variable shortcuts + diag_meta(iLookDIAG%scalarVGn_m) = var_info('scalarVGn_m' , 'van Genuchten "m" parameter' , '-' , get_ixVarType('midSoil'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarKappa) = var_info('scalarKappa' , 'constant in the freezing curve function' , 'm K-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + diag_meta(iLookDIAG%scalarVolLatHt_fus) = var_info('scalarVolLatHt_fus' , 'volumetric latent heat of fusion' , 'J m-3' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + ! number of function evaluations + diag_meta(iLookDIAG%numFluxCalls) = var_info('numFluxCalls' , 'number of flux calls' , '-' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + + ! ----- + ! * 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'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarCanopyNetNrgFlux) = var_info('scalarCanopyNetNrgFlux' , 'net energy flux for the vegetation canopy' , 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarGroundNetNrgFlux) = var_info('scalarGroundNetNrgFlux' , 'net energy flux for the ground surface' , 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarCanopyNetLiqFlux) = var_info('scalarCanopyNetLiqFlux' , 'net liquid water flux for the vegetation canopy' , 'kg m-2 s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + ! forcing + flux_meta(iLookFLUX%scalarRainfall) = var_info('scalarRainfall' , 'computed rainfall rate' , 'kg m-2 s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarSnowfall) = var_info('scalarSnowfall' , 'computed snowfall rate' , 'kg m-2 s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + ! shortwave radiation + flux_meta(iLookFLUX%spectralIncomingDirect) = var_info('spectralIncomingDirect' , 'incoming direct solar radiation in each wave band' , 'W m-2' , get_ixVarType('wLength'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%spectralIncomingDiffuse) = var_info('spectralIncomingDiffuse' , 'incoming diffuse solar radiation in each wave band' , 'W m-2' , get_ixVarType('wLength'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarCanopySunlitPAR) = var_info('scalarCanopySunlitPAR' , 'average absorbed par for sunlit leaves' , 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarCanopyShadedPAR) = var_info('scalarCanopyShadedPAR' , 'average absorbed par for shaded leaves' , 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%spectralBelowCanopyDirect) = var_info('spectralBelowCanopyDirect' , 'downward direct flux below veg layer for each spectral band' , 'W m-2' , get_ixVarType('wLength'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%spectralBelowCanopyDiffuse) = var_info('spectralBelowCanopyDiffuse' , 'downward diffuse flux below veg layer for each spectral band' , 'W m-2' , get_ixVarType('wLength'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarBelowCanopySolar) = var_info('scalarBelowCanopySolar' , 'solar radiation transmitted below the canopy' , 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarCanopyAbsorbedSolar) = var_info('scalarCanopyAbsorbedSolar' , 'solar radiation absorbed by canopy' , 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarGroundAbsorbedSolar) = var_info('scalarGroundAbsorbedSolar' , 'solar radiation absorbed by ground' , 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + ! longwave radiation + flux_meta(iLookFLUX%scalarLWRadCanopy) = var_info('scalarLWRadCanopy' , 'longwave radiation emitted from the canopy' , 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarLWRadGround) = var_info('scalarLWRadGround' , 'longwave radiation emitted at the ground surface' , 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarLWRadUbound2Canopy) = var_info('scalarLWRadUbound2Canopy' , 'downward atmospheric longwave radiation absorbed by the canopy' , 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarLWRadUbound2Ground) = var_info('scalarLWRadUbound2Ground' , 'downward atmospheric longwave radiation absorbed by the ground' , 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarLWRadUbound2Ubound) = var_info('scalarLWRadUbound2Ubound' , 'atmospheric radiation refl by ground + lost thru upper boundary' , 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarLWRadCanopy2Ubound) = var_info('scalarLWRadCanopy2Ubound' , 'longwave radiation emitted from canopy lost thru upper boundary' , 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarLWRadCanopy2Ground) = var_info('scalarLWRadCanopy2Ground' , 'longwave radiation emitted from canopy absorbed by the ground' , 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarLWRadCanopy2Canopy) = var_info('scalarLWRadCanopy2Canopy' , 'canopy longwave reflected from ground and absorbed by the canopy' , 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarLWRadGround2Ubound) = var_info('scalarLWRadGround2Ubound' , 'longwave radiation emitted from ground lost thru upper boundary' , 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarLWRadGround2Canopy) = var_info('scalarLWRadGround2Canopy' , 'longwave radiation emitted from ground and absorbed by the canopy', 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarLWNetCanopy) = var_info('scalarLWNetCanopy' , 'net longwave radiation at the canopy' , 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarLWNetGround) = var_info('scalarLWNetGround' , 'net longwave radiation at the ground surface' , 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarLWNetUbound) = var_info('scalarLWNetUbound' , 'net longwave radiation at the upper atmospheric boundary' , 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + ! 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'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarFrictionVelocity) = var_info('scalarFrictionVelocity' , 'friction velocity (canopy momentum sink)' , 'm s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarWindspdCanopyTop) = var_info('scalarWindspdCanopyTop' , 'windspeed at the top of the canopy' , 'm s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarWindspdCanopyBottom) = var_info('scalarWindspdCanopyBottom' , 'windspeed at the height of the bottom of the canopy' , 'm s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarGroundResistance) = var_info('scalarGroundResistance' , 'below canopy aerodynamic resistance' , 's m-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarCanopyResistance) = var_info('scalarCanopyResistance' , 'above canopy aerodynamic resistance' , 's m-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarLeafResistance) = var_info('scalarLeafResistance' , 'mean leaf boundary layer resistance per unit leaf area' , 's m-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarSoilResistance) = var_info('scalarSoilResistance' , 'soil surface resistance' , 's m-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarSenHeatTotal) = var_info('scalarSenHeatTotal' , 'sensible heat from the canopy air space to the atmosphere' , 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarSenHeatCanopy) = var_info('scalarSenHeatCanopy' , 'sensible heat from the canopy to the canopy air space' , 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarSenHeatGround) = var_info('scalarSenHeatGround' , 'sensible heat from the ground (below canopy or non-vegetated)' , 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarLatHeatTotal) = var_info('scalarLatHeatTotal' , 'latent heat from the canopy air space to the atmosphere' , 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarLatHeatCanopyEvap) = var_info('scalarLatHeatCanopyEvap' , 'evaporation latent heat from the canopy to the canopy air space' , 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarLatHeatCanopyTrans) = var_info('scalarLatHeatCanopyTrans' , 'transpiration latent heat from the canopy to the canopy air space', 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarLatHeatGround) = var_info('scalarLatHeatGround' , 'latent heat from the ground (below canopy or non-vegetated)' , 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarCanopyAdvectiveHeatFlux) = var_info('scalarCanopyAdvectiveHeatFlux' , 'heat advected to the canopy with precipitation (snow + rain)' , 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarGroundAdvectiveHeatFlux) = var_info('scalarGroundAdvectiveHeatFlux' , 'heat advected to the ground with throughfall + unloading/drainage', 'W m-2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarCanopySublimation) = var_info('scalarCanopySublimation' , 'canopy sublimation/frost' , 'kg m-2 s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarSnowSublimation) = var_info('scalarSnowSublimation' , 'snow sublimation/frost (below canopy or non-vegetated)' , 'kg m-2 s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + ! liquid water fluxes associated with evapotranspiration + flux_meta(iLookFLUX%scalarStomResistSunlit) = var_info('scalarStomResistSunlit' , 'stomatal resistance for sunlit leaves' , 's m-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarStomResistShaded) = var_info('scalarStomResistShaded' , 'stomatal resistance for shaded leaves' , 's m-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarPhotosynthesisSunlit) = var_info('scalarPhotosynthesisSunlit' , 'sunlit photosynthesis' , 'umolco2 m-2 s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarPhotosynthesisShaded) = var_info('scalarPhotosynthesisShaded' , 'shaded photosynthesis' , 'umolco2 m-2 s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarCanopyTranspiration) = var_info('scalarCanopyTranspiration' , 'canopy transpiration' , 'kg m-2 s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarCanopyEvaporation) = var_info('scalarCanopyEvaporation' , 'canopy evaporation/condensation' , 'kg m-2 s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarGroundEvaporation) = var_info('scalarGroundEvaporation' , 'ground evaporation/condensation (below canopy or non-vegetated)' , 'kg m-2 s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%mLayerTranspire) = var_info('mLayerTranspire' , 'transpiration loss from each soil layer' , 'm s-1' , get_ixVarType('midSoil'), lFalseArry, integerMissing, iMissArry) + ! 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'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarCanopySnowUnloading) = var_info('scalarCanopySnowUnloading' , 'unloading of snow from the vegetation canopy' , 'kg m-2 s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarCanopyLiqDrainage) = var_info('scalarCanopyLiqDrainage' , 'drainage of liquid water from the vegetation canopy' , 'kg m-2 s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarCanopyMeltFreeze) = var_info('scalarCanopyMeltFreeze' , 'melt/freeze of water stored in the canopy' , 'kg m-2 s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + ! 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'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%iLayerAdvectiveFlux) = var_info('iLayerAdvectiveFlux' , 'advective energy flux at layer interfaces' , 'W m-2' , get_ixVarType('ifcToto'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%iLayerNrgFlux) = var_info('iLayerNrgFlux' , 'energy flux at layer interfaces' , 'W m-2' , get_ixVarType('ifcToto'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + ! 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'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%iLayerLiqFluxSnow) = var_info('iLayerLiqFluxSnow' , 'liquid flux at snow layer interfaces' , 'm s-1' , get_ixVarType('ifcSnow'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%mLayerLiqFluxSnow) = var_info('mLayerLiqFluxSnow' , 'net liquid water flux for each snow layer' , 's-1' , get_ixVarType('midSnow'), lFalseArry, integerMissing, iMissArry) + ! 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'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarMaxInfilRate) = var_info('scalarMaxInfilRate' , 'maximum infiltration rate' , 'm s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarInfiltration) = var_info('scalarInfiltration' , 'infiltration of water into the soil profile' , 'm s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarExfiltration) = var_info('scalarExfiltration' , 'exfiltration of water from the top of the soil profile' , 'm s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarSurfaceRunoff) = var_info('scalarSurfaceRunoff' , 'surface runoff' , 'm s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%mLayerSatHydCondMP) = var_info('mLayerSatHydCondMP' , 'saturated hydraulic conductivity of macropores in each layer' , 'm s-1' , get_ixVarType('midSoil'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%mLayerSatHydCond) = var_info('mLayerSatHydCond' , 'saturated hydraulic conductivity in each layer' , 'm s-1' , get_ixVarType('midSoil'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%iLayerSatHydCond) = var_info('iLayerSatHydCond' , 'saturated hydraulic conductivity in each layer interface' , 'm s-1' , get_ixVarType('ifcSoil'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%mLayerHydCond) = var_info('mLayerHydCond' , 'hydraulic conductivity in each layer' , 'm s-1' , get_ixVarType('midSoil'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%iLayerLiqFluxSoil) = var_info('iLayerLiqFluxSoil' , 'liquid flux at soil layer interfaces' , 'm s-1' , get_ixVarType('ifcSoil'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%mLayerLiqFluxSoil) = var_info('mLayerLiqFluxSoil' , 'net liquid water flux for each soil layer' , 's-1' , get_ixVarType('midSoil'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%mLayerBaseflow) = var_info('mLayerBaseflow' , 'baseflow from each soil layer' , 'm s-1' , get_ixVarType('midSoil'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%mLayerColumnInflow) = var_info('mLayerColumnInflow' , 'total inflow to each layer in a given soil column' , 'm3 s-1' , get_ixVarType('midSoil'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%mLayerColumnOutflow) = var_info('mLayerColumnOutflow' , 'total outflow from each layer in a given soil column' , 'm3 s-1' , get_ixVarType('midSoil'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarSoilBaseflow) = var_info('scalarSoilBaseflow' , 'total baseflow from the soil profile' , 'm s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarSoilDrainage) = var_info('scalarSoilDrainage' , 'drainage from the bottom of the soil profile' , 'm s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarAquiferRecharge) = var_info('scalarAquiferRecharge' , 'recharge to the aquifer' , 'm s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarAquiferTranspire) = var_info('scalarAquiferTranspire' , 'transpiration loss from the aquifer' , 'm s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + flux_meta(iLookFLUX%scalarAquiferBaseflow) = var_info('scalarAquiferBaseflow' , 'baseflow from the aquifer' , 'm s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + + ! ----- + ! * 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'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + ! 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'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + ! 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'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + ! 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'), lFalseArry, integerMissing, iMissArry) + deriv_meta(iLookDERIV%scalarThroughfallRainDeriv) = var_info('scalarThroughfallRainDeriv' , 'derivative in throughfall w.r.t. canopy liquid water' , 's-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + deriv_meta(iLookDERIV%scalarCanopyLiqDrainageDeriv) = var_info('scalarCanopyLiqDrainageDeriv' , 'derivative in canopy drainage w.r.t. canopy liquid water' , 's-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + ! 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'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + ! 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'), lFalseArry, integerMissing, iMissArry) + ! 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'), lFalseArry, integerMissing, iMissArry) + deriv_meta(iLookDERIV%dCompress_dPsi) = var_info('dCompress_dPsi' , 'derivative in compressibility w.r.t matric head' , 'm-1' , get_ixVarType('midSoil'), lFalseArry, integerMissing, iMissArry) + deriv_meta(iLookDERIV%mLayerdTheta_dPsi) = var_info('mLayerdTheta_dPsi' , 'derivative in the soil water characteristic w.r.t. psi' , 'm-1' , get_ixVarType('midSoil'), lFalseArry, integerMissing, iMissArry) + deriv_meta(iLookDERIV%mLayerdPsi_dTheta) = var_info('mLayerdPsi_dTheta' , 'derivative in the soil water characteristic w.r.t. theta' , 'm' , get_ixVarType('midSoil'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + ! 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'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + deriv_meta(iLookDERIV%mLayerdTheta_dTk) = var_info('mLayerdTheta_dTk' , 'derivative of volumetric liquid water content w.r.t. temperature' , 'K-1' , get_ixVarType('midToto'), lFalseArry, integerMissing, iMissArry) + 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'), lFalseArry, integerMissing, iMissArry) + deriv_meta(iLookDERIV%dPsiLiq_dPsi0) = var_info('dPsiLiq_dPsi0' , 'derivative in liquid matric potential w.r.t. total matric potential' , '-' , get_ixVarType('midSoil'), lFalseArry, integerMissing, iMissArry) ! ----- ! * basin-wide runoff and aquifer fluxes... ! ----------------------------------------- - bvar_meta(iLookBVAR%basin__totalArea) = var_info('basin__totalArea' , 'total basin area' , 'm2' , 'scalarv', .true.) - bvar_meta(iLookBVAR%basin__SurfaceRunoff) = var_info('basin__SurfaceRunoff' , 'surface runoff' , 'm s-1' , 'scalarv', .true.) - bvar_meta(iLookBVAR%basin__ColumnOutflow) = var_info('basin__ColumnOutflow' , 'outflow from all "outlet" HRUs (with no downstream HRU)', 'm3 s-1', 'scalarv', .true.) - bvar_meta(iLookBVAR%basin__AquiferStorage) = var_info('basin__AquiferStorage' , 'aquifer storage' , 'm' , 'scalarv', .true.) - bvar_meta(iLookBVAR%basin__AquiferRecharge) = var_info('basin__AquiferRecharge' , 'recharge to the aquifer' , 'm s-1' , 'scalarv', .true.) - bvar_meta(iLookBVAR%basin__AquiferBaseflow) = var_info('basin__AquiferBaseflow' , 'baseflow from the aquifer' , 'm s-1' , 'scalarv', .true.) - bvar_meta(iLookBVAR%basin__AquiferTranspire) = var_info('basin__AquiferTranspire', 'transpiration loss from the aquifer' , 'm s-1' , 'scalarv', .true.) - bvar_meta(iLookBVAR%routingRunoffFuture) = var_info('routingRunoffFuture' , 'runoff in future time steps' , 'm s-1' , 'routing', .false.) - bvar_meta(iLookBVAR%routingFractionFuture) = var_info('routingFractionFuture' , 'fraction of runoff in future time steps' , '-' , 'routing', .false.) - bvar_meta(iLookBVAR%averageInstantRunoff) = var_info('averageInstantRunoff' , 'instantaneous runoff' , 'm s-1' , 'scalarv', .true.) - bvar_meta(iLookBVAR%averageRoutedRunoff) = var_info('averageRoutedRunoff' , 'routed runoff' , 'm s-1' , 'scalarv', .true.) + bvar_meta(iLookBVAR%basin__TotalArea) = var_info('basin__TotalArea' , 'total basin area' , 'm2' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + bvar_meta(iLookBVAR%basin__SurfaceRunoff) = var_info('basin__SurfaceRunoff' , 'surface runoff' , 'm s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + bvar_meta(iLookBVAR%basin__ColumnOutflow) = var_info('basin__ColumnOutflow' , 'outflow from all "outlet" HRUs (with no downstream HRU)', 'm3 s-1', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + bvar_meta(iLookBVAR%basin__AquiferStorage) = var_info('basin__AquiferStorage' , 'aquifer storage' , 'm' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + bvar_meta(iLookBVAR%basin__AquiferRecharge) = var_info('basin__AquiferRecharge' , 'recharge to the aquifer' , 'm s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + bvar_meta(iLookBVAR%basin__AquiferBaseflow) = var_info('basin__AquiferBaseflow' , 'baseflow from the aquifer' , 'm s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + bvar_meta(iLookBVAR%basin__AquiferTranspire) = var_info('basin__AquiferTranspire', 'transpiration loss from the aquifer' , 'm s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + bvar_meta(iLookBVAR%routingRunoffFuture) = var_info('routingRunoffFuture' , 'runoff in future time steps' , 'm s-1' , get_ixVarType('routing'), lFalseArry, integerMissing, iMissArry) + bvar_meta(iLookBVAR%routingFractionFuture) = var_info('routingFractionFuture' , 'fraction of runoff in future time steps' , '-' , get_ixVarType('routing'), lFalseArry, integerMissing, iMissArry) + bvar_meta(iLookBVAR%averageInstantRunoff) = var_info('averageInstantRunoff' , 'instantaneous runoff' , 'm s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + bvar_meta(iLookBVAR%averageRoutedRunoff) = var_info('averageRoutedRunoff' , 'routed runoff' , 'm s-1' , get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) ! ----- - ! * run time indices... - ! --------------------- - indx_meta(iLookINDEX%nSnow) = var_info('nSnow' , 'number of snow layers' , '-', 'scalarv', .true.) - indx_meta(iLookINDEX%nSoil) = var_info('nSoil' , 'number of soil layers' , '-', 'scalarv', .false.) - indx_meta(iLookINDEX%nLayers) = var_info('nLayers' , 'total number of layers' , '-', 'scalarv', .true.) - indx_meta(iLookINDEX%midSnowStartIndex) = var_info('midSnowStartIndex', 'start index of the midSnow vector for a given timestep', '-', 'scalarv', .false.) - indx_meta(iLookINDEX%midSoilStartIndex) = var_info('midSoilStartIndex', 'start index of the midSoil vector for a given timestep', '-', 'scalarv', .false.) - indx_meta(iLookINDEX%midTotoStartIndex) = var_info('midTotoStartIndex', 'start index of the midToto vector for a given timestep', '-', 'scalarv', .true.) - indx_meta(iLookINDEX%ifcSnowStartIndex) = var_info('ifcSnowStartIndex', 'start index of the ifcSnow vector for a given timestep', '-', 'scalarv', .false.) - indx_meta(iLookINDEX%ifcSoilStartIndex) = var_info('ifcSoilStartIndex', 'start index of the ifcSoil vector for a given timestep', '-', 'scalarv', .false.) - indx_meta(iLookINDEX%ifcTotoStartIndex) = var_info('ifcTotoStartIndex', 'start index of the ifcToto vector for a given timestep', '-', 'scalarv', .true.) - indx_meta(iLookINDEX%layerType) = var_info('layerType' , 'index defining type of layer (soil or snow)' , '-', 'midToto', .false.) + ! * model indices... + ! ------------------ + + ! number of model layers, and layer indices + indx_meta(iLookINDEX%nSnow) = var_info('nSnow' , 'number of snow layers' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%nSoil) = var_info('nSoil' , 'number of soil layers' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%nLayers) = var_info('nLayers' , 'total number of layers' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%layerType) = var_info('layerType' , 'index defining type of layer (snow or soil)' , '-', get_ixVarType('midToto'), lFalseArry, integerMissing, iMissArry) + ! 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'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%nVegNrg) = var_info('nVegNrg' , 'number of energy state variables for the vegetation canopy' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%nVegMass) = var_info('nVegMass' , 'number of hydrology states for vegetation (mass of water)' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%nVegState) = var_info('nVegState' , 'number of vegetation state variables' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%nNrgState) = var_info('nNrgState' , 'number of energy state variables' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%nWatState) = var_info('nWatState' , 'number of "total water" states (vol. total water content)' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%nMatState) = var_info('nMatState' , 'number of matric head state variables' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%nMassState) = var_info('nMassState' , 'number of hydrology state variables (mass of water)' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%nState) = var_info('nState' , 'total number of model state variables' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + ! 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'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%nSnowOnlyNrg) = var_info('nSnowOnlyNrg' , 'number of energy states in the snow domain' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%nSoilOnlyNrg) = var_info('nSoilOnlyNrg' , 'number of energy states in the soil domain' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%nSnowSoilHyd) = var_info('nSnowSoilHyd' , 'number of hydrology states in the snow+soil domain' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%nSnowOnlyHyd) = var_info('nSnowOnlyHyd' , 'number of hydrology states in the snow domain' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%nSoilOnlyHyd) = var_info('nSoilOnlyHyd' , 'number of hydrology states in the soil domain' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + ! 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'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%ixDomainType) = var_info('ixDomainType' , 'index of the type of domain (iname_veg, iname_snow, iname_soil)' , '-', get_ixVarType('unknown'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%ixStateType) = var_info('ixStateType' , 'index of the type of every state variable (iname_nrgCanair, ...)' , '-', get_ixVarType('unknown'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%ixHydType) = var_info('ixHydType' , 'index of the type of hydrology states in snow+soil domain' , '-', get_ixVarType('midToto'), lFalseArry, integerMissing, iMissArry) + ! 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'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%ixStateType_subset) = var_info('ixStateType_subset' , '[state subset] type of desired model state variables' , '-', get_ixVarType('unknown'), lFalseArry, integerMissing, iMissArry) + ! 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'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%ixMapSubset2Full) = var_info('ixMapSubset2Full' , 'list of indices of the full state vector in the state subset' , '-', get_ixVarType('unknown'), lFalseArry, integerMissing, iMissArry) + ! indices of model specific state variables + indx_meta(iLookINDEX%ixCasNrg) = var_info('ixCasNrg' , 'index of canopy air space energy state variable' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%ixVegNrg) = var_info('ixVegNrg' , 'index of canopy energy state variable' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%ixVegHyd) = var_info('ixVegHyd' , 'index of canopy hydrology state variable (mass)' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%ixTopNrg) = var_info('ixTopNrg' , 'index of upper-most energy state in the snow+soil subdomain' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%ixTopHyd) = var_info('ixTopHyd' , 'index of upper-most hydrology state in the snow+soil subdomain' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + ! 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'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%ixHydOnly) = var_info('ixHydOnly' , 'indices IN THE STATE SUBSET for hydrology states in the snow+soil domain', '-', get_ixVarType('unknown'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%ixMatOnly) = var_info('ixMatOnly' , 'indices IN THE STATE SUBSET for matric head state variables' , '-', get_ixVarType('unknown'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%ixMassOnly) = var_info('ixMassOnly' , 'indices IN THE STATE SUBSET for hydrology states (mass of water)' , '-', get_ixVarType('unknown'), lFalseArry, integerMissing, iMissArry) + ! 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'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%ixSnowOnlyNrg) = var_info('ixSnowOnlyNrg' , 'indices IN THE STATE SUBSET for energy states in the snow domain' , '-', get_ixVarType('midSnow'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%ixSoilOnlyNrg) = var_info('ixSoilOnlyNrg' , 'indices IN THE STATE SUBSET for energy states in the soil domain' , '-', get_ixVarType('midSoil'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%ixSnowSoilHyd) = var_info('ixSnowSoilHyd' , 'indices IN THE STATE SUBSET for hydrology states in the snow+soil domain', '-', get_ixVarType('midToto'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%ixSnowOnlyHyd) = var_info('ixSnowOnlyHyd' , 'indices IN THE STATE SUBSET for hydrology states in the snow domain' , '-', get_ixVarType('midSnow'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%ixSoilOnlyHyd) = var_info('ixSoilOnlyHyd' , 'indices IN THE STATE SUBSET for hydrology states in the soil domain' , '-', get_ixVarType('midSoil'), lFalseArry, integerMissing, iMissArry) + ! 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'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%ixNrgCanopy) = var_info('ixNrgCanopy' , 'indices IN THE FULL VECTOR for energy states in the canopy domain' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%ixHydCanopy) = var_info('ixHydCanopy' , 'indices IN THE FULL VECTOR for hydrology states in the canopy domain' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%ixNrgLayer) = var_info('ixNrgLayer' , 'indices IN THE FULL VECTOR for energy states in the snow+soil domain' , '-', get_ixVarType('midToto'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%ixHydLayer) = var_info('ixHydLayer' , 'indices IN THE FULL VECTOR for hydrology states in the snow+soil domain' , '-', get_ixVarType('midToto'), lFalseArry, integerMissing, iMissArry) + ! 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'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%ixMatricHead) = var_info('ixMatricHead' , 'indices IN THE SOIL VECTOR for hyd states' , '-', get_ixVarType('unknown'), lFalseArry, integerMissing, iMissArry) + ! indices within state vectors + indx_meta(iLookINDEX%ixAllState) = var_info('ixAllState' , 'list of indices for all model state variables' , '-', get_ixVarType('unknown'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%ixSoilState) = var_info('ixSoilState' , 'list of indices for all soil layers' , '-', get_ixVarType('midSoil'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%ixLayerState) = var_info('ixLayerState' , 'list of indices for all model layers' , '-', get_ixVarType('midToto'), lFalseArry, integerMissing, iMissArry) + ! indices for the model output files + indx_meta(iLookINDEX%midSnowStartIndex) = var_info('midSnowStartIndex' , 'start index of the midSnow vector for a given timestep' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%midSoilStartIndex) = var_info('midSoilStartIndex' , 'start index of the midSoil vector for a given timestep' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%midTotoStartIndex) = var_info('midTotoStartIndex' , 'start index of the midToto vector for a given timestep' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%ifcSnowStartIndex) = var_info('ifcSnowStartIndex' , 'start index of the ifcSnow vector for a given timestep' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%ifcSoilStartIndex) = var_info('ifcSoilStartIndex' , 'start index of the ifcSoil vector for a given timestep' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + indx_meta(iLookINDEX%ifcTotoStartIndex) = var_info('ifcTotoStartIndex' , 'start index of the ifcToto vector for a given timestep' , '-', get_ixVarType('scalarv'), lFalseArry, integerMissing, iMissArry) + + ! 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 get_ixName_module,only:get_ixUnknown + + ! some dimensional parameters + USE globalData, only: outFreq,nFreq ! output frequencies + + ! data 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 + + ! structures of named variables + 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 + + ! to get name of output control file from user + USE summaFileManager,only:SETNGS_PATH ! path for metadata files + USE summaFileManager,only:OUTPUT_CONTROL ! file with output controls + + ! modules for smart file reading + USE ascii_util_module,only:get_vlines ! get a vector of non-comment lines + USE ascii_util_module,only:file_open ! open file + 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 + + ! 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=512),allocatable :: charlines(:) ! vector of character strings + character(LEN=64),allocatable :: lineWords(:) ! vector to parse textline + integer(i4b) :: nWords ! number of words in line + integer(i4b) :: oFreq ! output frequencies read from file + character(LEN=5) :: structName ! name of structure + + ! indices + integer(i4b) :: vLine ! index for loop through variables + integer(i4b) :: vDex ! index into type lists + + ! flags + logical(lgt),dimension(6) :: indexFlags ! logical flags to turn on index variables + + ! initialize error control + err=0; message='read_output_file/' + + ! ********************************************************************************************** + ! (1) open file and read variable data + ! ********************************************************************************************** + outfile = trim(SETNGS_PATH)//trim(OUTPUT_CONTROL) ! build filename + print '(2A)','Name of Model Output control file: ',trim(outfile) + 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 + ! ********************************************************************************************** + ! flag whether or not the user has requested an output variable that requires output of layer information + indexFlags(:) = .false. + + ! initialize output frequency + nFreq = 1 + outFreq(1) = modelTime + + ! 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) + + ! user cannot control time output + if (trim(lineWords(1))=='time') cycle + + ! read output frequency + read(lineWords(freqIndex),*,iostat=err) oFreq + if(err/=0)then + message=trim(message)//'problem reading the output frequency: check format of model control file "'//trim(outfile)//'"' + err=20; return + endif + + ! --- variables with multiple statistics options -------------------------- + + ! idenify the data structure for the given variable (structName) and the variable index (vDex) + call get_ixUnknown(trim(lineWords(nameIndex)),structName,vDex,err,cmessage) + if (err/=0) then; message=trim(message)//trim(cmessage)//trim(linewords(nameIndex)); return; end if; + + ! populate the metadata that controls the model output + select case (trim(structName)) + + ! temporally constant structures + case('time' ); if (oFreq/=0) time_meta(vDex)%statFlag(iLookStat%inst)=.true.; time_meta(vDex)%outFreq=modelTime ! timing data + case('bpar' ); if (oFreq/=0) bpar_meta(vDex)%statFlag(iLookStat%inst)=.true.; bpar_meta(vDex)%outFreq=modelTime ! basin parameters + case('attr' ); if (oFreq/=0) attr_meta(vDex)%statFlag(iLookStat%inst)=.true.; attr_meta(vDex)%outFreq=modelTime ! local attributes + case('type' ); if (oFreq/=0) type_meta(vDex)%statFlag(iLookStat%inst)=.true.; type_meta(vDex)%outFreq=modelTime ! local classification + case('mpar' ); if (oFreq/=0) mpar_meta(vDex)%statFlag(iLookStat%inst)=.true.; mpar_meta(vDex)%outFreq=modelTime ! model parameters + + ! index structures -- can only be output at the model time step + case('indx' ) + if (oFreq==modelTime) indx_meta(vDex)%statFlag(iLookStat%inst)=.true.; indx_meta(vDex)%outFreq=modelTime ! indexex + if (oFreq>modelTime) then; err=20; message=trim(message)//'index variables can only be output at model timestep'; return; end if + + ! temporally varying structures + case('forc' ); call popStat(forc_meta(vDex) ,lineWords,indexFlags,err,cmessage) ! model forcing data + case('prog' ); call popStat(prog_meta(vDex) ,lineWords,indexFlags,err,cmessage) ! model prognostics + case('diag' ); call popStat(diag_meta(vDex) ,lineWords,indexFlags,err,cmessage) ! model diagnostics + case('flux' ); call popStat(flux_meta(vDex) ,lineWords,indexFlags,err,cmessage) ! model fluxes + case('bvar' ); call popStat(bvar_meta(vDex) ,lineWords,indexFlags,err,cmessage) ! basin variables + case('deriv'); call popStat(deriv_meta(vDex),lineWords,indexFlags,err,cmessage) ! model derivs + + ! error control + case default; err=20;message=trim(message)//'unable to identify lookup structure';return + end select ! select data structure + if (err/=0) then; message=trim(message)//trim(cmessage);return; end if + + ! Ensure that time is turned on: it doens't matter what this value is as long as it is >0. + forc_meta(iLookForce%time)%outFreq = abs(integerMissing) + + end do ! loop through file lines with vline + + ! ********************************************************************************************** + ! (4) see if we need any index variables + ! ********************************************************************************************** + + ! if any layered variables at all, then output the number of layers + if(any(indexFlags))then + ! (snow layers) + indx_meta(iLookINDEX%nSnow)%statFlag(iLookStat%inst) = .true. + indx_meta(iLookINDEX%nSnow)%outFreq = modelTime + ! (soil layers) + indx_meta(iLookINDEX%nSoil)%statFlag(iLookStat%inst) = .true. + indx_meta(iLookINDEX%nSoil)%outFreq = modelTime + ! (total layers) + indx_meta(iLookINDEX%nLayers)%statFlag(iLookStat%inst) = .true. + indx_meta(iLookINDEX%nLayers)%outFreq = modelTime + endif ! if any layered variables at all + + ! output the start index in the ragged arrays + if (indexFlags(indexMidSnow)) then + indx_meta(iLookINDEX%midSnowStartIndex)%statFlag(iLookStat%inst) = .true. + indx_meta(iLookINDEX%midSnowStartIndex)%outFreq = modelTime + end if + if (indexFlags(indexMidSoil)) then + indx_meta(iLookINDEX%midSoilStartIndex)%statFlag(iLookStat%inst) = .true. + indx_meta(iLookINDEX%midSoilStartIndex)%outFreq = modelTime + end if + if (indexFlags(indexMidToto)) then + indx_meta(iLookINDEX%midTotoStartIndex)%statFlag(iLookStat%inst) = .true. + indx_meta(iLookINDEX%midTotoStartIndex)%outFreq = modelTime + end if + if (indexFlags(indexIfcSnow)) then + indx_meta(iLookINDEX%ifcSnowStartIndex)%statFlag(iLookStat%inst) = .true. + indx_meta(iLookINDEX%ifcSnowStartIndex)%outFreq = modelTime + end if + if (indexFlags(indexIfcSoil)) then + indx_meta(iLookINDEX%ifcSoilStartIndex)%statFlag(iLookStat%inst) = .true. + indx_meta(iLookINDEX%ifcSoilStartIndex)%outFreq = modelTime + end if + if (indexFlags(indexIfcToto)) then + indx_meta(iLookINDEX%ifcTotoStartIndex)%statFlag(iLookStat%inst) = .true. + indx_meta(iLookINDEX%ifcTotoStartIndex)%outFreq = modelTime + end if + + return + 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,lineWords,indexFlags,err,message) + USE globalData,only:outFreq,nFreq ! maximum number of output files + USE data_types,only:var_info ! meta_data type declaration + USE var_lookup,only:maxFreq ! maximum number of output files + USE var_lookup,only:maxvarStat ! number of possible output statistics + USE var_lookup,only:iLookVarType ! variable type lookup structure + USE var_lookup,only:iLookStat ! output statistic lookup structure + USE f2008funcs_module,only:findIndex ! finds the index of the first value within a vector + implicit none + ! dummy variables + class(var_info),intent(inout) :: meta ! dummy meta_data structure + character(*),intent(in) :: lineWords(:) ! vector to parse textline + logical(lgt),dimension(6),intent(inout) :: indexFlags ! logical flags to turn on index variables + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! internals + integer(i4b) :: oFreq ! output frequency + integer(i4b) :: nWords ! number of words in a line + ! indexes + integer(i4b) :: cFreq ! current index into frequency vector + integer(i4b) :: iStat ! index of statistics vector + + ! initiate error handling + err=0; message='popStat/' + + ! get the number of words in a line + nWords = size(lineWords) + + ! make sure the variable only has one output frequency + if(count(meta%statFlag)>0)then + message=trim(message)//'model output for variable '//trim(meta%varName)//' already defined (can only be defined once)' + err=20; return + endif + + ! check to make sure there are sufficient statistics flags + read(lineWords(freqIndex),*) oFreq + if (oFreq <0)then + message=trim(message)//'expect output frequency to be positive for variable: '//trim(lineWords(nameIndex)) + err=20; return + end if + if (oFreq==0) return + + ! check to make sure there are sufficient statistics flags + ! varName | outFreq | inst | sum | mean | var | min | max | mode + if (oFreq>modelTime .and. (nWords /= freqIndex + 2*maxVarStat)) then + message=trim(message)//'wrong number of stats flags in Model Output file for variable: '//trim(lineWords(nameIndex)) + err=-20; return + endif + + ! check to make sure non-scalar variables have the correct number of elements + if (meta%varType/=iLookVarType%scalarv)then + ! (ensure that statistics flags are not defined for non-scalar variables) + if(nWords/=freqIndex) then ! format = "varName | outFreq" + message=trim(message)//'wrong number of stats flags in Model Output file for variable: '//trim(lineWords(nameIndex)) + err=-20; return + endif + ! (check that the output frequency is equal to one) + if(oFreq/=modelTime)then + message=trim(message)//'expect the output frequency in Model output file to equal modelTime for non-scalar variables: '//trim(lineWords(nameIndex)) + err=-20; return + endif + end if ! if non-scalar variables + + ! define a new output frequency + ! scalar variables can have multiple statistics + if (oFreq>modelTime) then + + ! identify index of oFreq witin outFreq (cFreq=0 if oFreq is not in outfreq) + if(nFreq>0)then + cFreq=findIndex(outFreq(1:nFreq),oFreq) ! index of oFreq, cFreq=0 if not in oFreq + else + cFreq=0 + endif + + ! index not found: define index + if(cFreq==0)then + + ! check that there is room in the vector + if(nFreq==maxFreq)then + message=trim(message)//'too many output frequencies - variable:'//trim(lineWords(nameIndex)) + err=20; return + endif + + ! add indices + nFreq = nFreq + 1 + cFreq = nFreq + outFreq(nFreq) = oFreq + + endif ! if the index is not found (creating a new output frequency) + + ! pull the stats flags + do iStat = 1,maxVarStat + if (lineWords(freqIndex + 2*iStat)=='1') then + meta%statFlag(iStat)=.true. + meta%outFreq = cFreq + end if + end do + + ! if requested output at frequency of model timestep + elseif (oFreq==modelTime) then + + ! set the stat flag + meta%statFlag(iLookStat%inst) = .true. + meta%outFreq = modelTime + + ! force appropriate layer indexes + select case(meta%varType) + case (iLookVarType%midSnow); indexFlags(indexMidSnow) = .true. + case (iLookVarType%midSoil); indexFlags(indexMidSoil) = .true. + case (iLookVarType%midToto); indexFlags(indexMidToto) = .true. + case (iLookVarType%ifcSnow); indexFlags(indexIfcSnow) = .true. + case (iLookVarType%ifcSoil); indexFlags(indexIfcSoil) = .true. + case (iLookVarType%ifcToto); indexFlags(indexIfcToto) = .true. + case (iLookVarType%scalarv) ! do nothing + case (iLookVarType%wLength) ! do nothing + case (iLookVarType%routing) ! do nothing + case default + err=20; message=trim(message)//trim(meta%varName)//':variable type not found' + end select ! variable type + + ! if requested any other output frequency + else + message=trim(message)//'wrong output frequency for variable: '//trim(meta%varName) + err=-20; return + end if + + return + end subroutine popStat + end module popMetadat_module diff --git a/build/source/dshare/var_lookup.f90 b/build/source/dshare/var_lookup.f90 old mode 100644 new mode 100755 index d8273a280..182c08c4a --- a/build/source/dshare/var_lookup.f90 +++ b/build/source/dshare/var_lookup.f90 @@ -20,557 +20,733 @@ MODULE var_lookup ! defines named variables used to index array elements - USE nrtype + USE nrtype, integerMissing=>nr_integerMissing implicit none private - ! define missing value - integer(i4b),parameter :: imiss = -999 ! used to initialize named variables - ! *********************************************************************************************************** + ! local variables + integer(i4b),parameter,public :: numStats = 7 ! number of output stats + integer(i4b),parameter,public :: maxFreq = 10 ! maximum number of output streams + integer(i4b),parameter :: ixVal=1 ! an example integer + integer(i4b),parameter :: iLength=storage_size(ixVal) ! size of the example integer + + ! *************************************************************************************** ! (0) define model decisions - ! *********************************************************************************************************** + ! *************************************************************************************** type, public :: iLook_decision - integer(i4b) :: simulStart = 1 ! simulation start time - integer(i4b) :: simulFinsh = 2 ! simulation end time - integer(i4b) :: soilCatTbl = 3 ! soil-category dateset - integer(i4b) :: vegeParTbl = 4 ! vegetation category dataset - integer(i4b) :: soilStress = 5 ! choice of function for the soil moisture control on stomatal resistance - integer(i4b) :: stomResist = 6 ! choice of function for stomatal resistance - integer(i4b) :: bbTempFunc = 7 ! Ball-Berry: leaf temperature controls on photosynthesis + stomatal resistance - integer(i4b) :: bbHumdFunc = 8 ! Ball-Berry: humidity controls on stomatal resistance - integer(i4b) :: bbElecFunc = 9 ! Ball-Berry: dependence of photosynthesis on PAR - integer(i4b) :: bbCO2point = 10 ! Ball-Berry: use of CO2 compensation point to calculate stomatal resistance - integer(i4b) :: bbNumerics = 11 ! Ball-Berry: iterative numerical solution method - integer(i4b) :: bbAssimFnc = 12 ! Ball-Berry: controls on carbon assimilation - integer(i4b) :: bbCanIntg8 = 13 ! Ball-Berry: scaling of photosynthesis from the leaf to the canopy - integer(i4b) :: num_method = 14 ! choice of numerical method - integer(i4b) :: fDerivMeth = 15 ! method used to calculate flux derivatives - integer(i4b) :: LAI_method = 16 ! method used to determine LAI and SAI - integer(i4b) :: cIntercept = 17 ! choice of parameterization for canopy interception - integer(i4b) :: f_Richards = 18 ! form of richards' equation - integer(i4b) :: groundwatr = 19 ! choice of groundwater parameterization - integer(i4b) :: hc_profile = 20 ! choice of hydraulic conductivity profile - integer(i4b) :: bcUpprTdyn = 21 ! type of upper boundary condition for thermodynamics - integer(i4b) :: bcLowrTdyn = 22 ! type of lower boundary condition for thermodynamics - integer(i4b) :: bcUpprSoiH = 23 ! type of upper boundary condition for soil hydrology - integer(i4b) :: bcLowrSoiH = 24 ! type of lower boundary condition for soil hydrology - integer(i4b) :: veg_traits = 25 ! choice of parameterization for vegetation roughness length and displacement height - integer(i4b) :: rootProfil = 26 ! choice of parameterization for the rooting profile - integer(i4b) :: canopyEmis = 27 ! choice of parameterization for canopy emissivity - integer(i4b) :: snowIncept = 28 ! choice of parameterization for snow interception - integer(i4b) :: windPrfile = 29 ! choice of canopy wind profile - integer(i4b) :: astability = 30 ! choice of stability function - integer(i4b) :: canopySrad = 31 ! choice of method for canopy shortwave radiation - integer(i4b) :: alb_method = 32 ! choice of albedo representation - integer(i4b) :: snowLayers = 33 ! choice of method to combine and sub-divide snow layers - integer(i4b) :: compaction = 34 ! choice of compaction routine - integer(i4b) :: thCondSnow = 35 ! choice of thermal conductivity representation for snow - integer(i4b) :: thCondSoil = 36 ! choice of thermal conductivity representation for soil - integer(i4b) :: spatial_gw = 37 ! choice of method for spatial representation of groundwater - integer(i4b) :: subRouting = 38 ! choice of method for sub-grid routing + integer(i4b) :: simulStart = integerMissing ! simulation start time + integer(i4b) :: simulFinsh = integerMissing ! simulation end time + integer(i4b) :: soilCatTbl = integerMissing ! soil-category dateset + 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 + integer(i4b) :: bbTempFunc = integerMissing ! Ball-Berry: leaf temperature controls on photosynthesis + stomatal resistance + integer(i4b) :: bbHumdFunc = integerMissing ! Ball-Berry: humidity controls on stomatal resistance + integer(i4b) :: bbElecFunc = integerMissing ! Ball-Berry: dependence of photosynthesis on PAR + integer(i4b) :: bbCO2point = integerMissing ! Ball-Berry: use of CO2 compensation point to calculate stomatal resistance + integer(i4b) :: bbNumerics = integerMissing ! Ball-Berry: iterative numerical solution method + integer(i4b) :: bbAssimFnc = integerMissing ! Ball-Berry: controls on carbon assimilation + integer(i4b) :: bbCanIntg8 = integerMissing ! Ball-Berry: scaling of photosynthesis from the leaf to the canopy + integer(i4b) :: num_method = integerMissing ! choice of numerical method + integer(i4b) :: fDerivMeth = integerMissing ! method used to calculate flux derivatives + integer(i4b) :: LAI_method = integerMissing ! method used to determine LAI and SAI + integer(i4b) :: cIntercept = integerMissing ! choice of parameterization for canopy interception + integer(i4b) :: f_Richards = integerMissing ! form of richards' equation + integer(i4b) :: groundwatr = integerMissing ! choice of groundwater parameterization + integer(i4b) :: hc_profile = integerMissing ! choice of hydraulic conductivity profile + integer(i4b) :: bcUpprTdyn = integerMissing ! type of upper boundary condition for thermodynamics + integer(i4b) :: bcLowrTdyn = integerMissing ! type of lower boundary condition for thermodynamics + integer(i4b) :: bcUpprSoiH = integerMissing ! type of upper boundary condition for soil hydrology + integer(i4b) :: bcLowrSoiH = integerMissing ! type of lower boundary condition for soil hydrology + integer(i4b) :: veg_traits = integerMissing ! choice of parameterization for vegetation roughness length and displacement height + integer(i4b) :: rootProfil = integerMissing ! choice of parameterization for the rooting profile + integer(i4b) :: canopyEmis = integerMissing ! choice of parameterization for canopy emissivity + integer(i4b) :: snowIncept = integerMissing ! choice of parameterization for snow interception + integer(i4b) :: windPrfile = integerMissing ! choice of canopy wind profile + integer(i4b) :: astability = integerMissing ! choice of stability function + integer(i4b) :: canopySrad = integerMissing ! choice of method for canopy shortwave radiation + integer(i4b) :: alb_method = integerMissing ! choice of albedo representation + integer(i4b) :: snowLayers = integerMissing ! choice of method to combine and sub-divide snow layers + integer(i4b) :: compaction = integerMissing ! choice of compaction routine + integer(i4b) :: thCondSnow = integerMissing ! choice of thermal conductivity representation for snow + integer(i4b) :: thCondSoil = integerMissing ! choice of thermal conductivity representation for soil + 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 endtype iLook_decision + ! *********************************************************************************************************** ! (1) define model time ! *********************************************************************************************************** type, public :: iLook_time - integer(i4b) :: iyyy = 1 ! year - integer(i4b) :: im = 2 ! month - integer(i4b) :: id = 3 ! day - integer(i4b) :: ih = 4 ! hour - integer(i4b) :: imin = 5 ! minute + integer(i4b) :: iyyy = integerMissing ! year + integer(i4b) :: im = integerMissing ! month + integer(i4b) :: id = integerMissing ! day + integer(i4b) :: ih = integerMissing ! hour + integer(i4b) :: imin = integerMissing ! minute endtype iLook_time + ! *********************************************************************************************************** ! (2) define model forcing data ! *********************************************************************************************************** type, public :: iLook_force - integer(i4b) :: time = 1 ! time since time reference (s) - integer(i4b) :: pptrate = 2 ! precipitation rate (kg m-2 s-1) - integer(i4b) :: airtemp = 3 ! air temperature (K) - integer(i4b) :: spechum = 4 ! specific humidity (g/g) - integer(i4b) :: windspd = 5 ! windspeed (m/s) - integer(i4b) :: SWRadAtm = 6 ! downwelling shortwave radiaiton (W m-2) - integer(i4b) :: LWRadAtm = 7 ! downwelling longwave radiation (W m-2) - integer(i4b) :: airpres = 8 ! pressure (Pa) + integer(i4b) :: time = integerMissing ! time since time reference (s) + integer(i4b) :: pptrate = integerMissing ! precipitation rate (kg m-2 s-1) + integer(i4b) :: airtemp = integerMissing ! air temperature (K) + integer(i4b) :: spechum = integerMissing ! specific humidity (g/g) + integer(i4b) :: windspd = integerMissing ! windspeed (m/s) + integer(i4b) :: SWRadAtm = integerMissing ! downwelling shortwave radiaiton (W m-2) + integer(i4b) :: LWRadAtm = integerMissing ! downwelling longwave radiation (W m-2) + integer(i4b) :: airpres = integerMissing ! pressure (Pa) endtype iLook_force + ! *********************************************************************************************************** ! (3) define local attributes ! *********************************************************************************************************** type, public :: iLook_attr - integer(i4b) :: latitude = 1 ! latitude (degrees north) - integer(i4b) :: longitude = 2 ! longitude (degrees east) - integer(i4b) :: elevation = 3 ! elevation (m) - integer(i4b) :: tan_slope = 4 ! tan water table slope, taken as tan local ground surface slope (-) - integer(i4b) :: contourLength = 5 ! length of contour at downslope edge of HRU (m) - integer(i4b) :: HRUarea = 6 ! area of each HRU (m2) - integer(i4b) :: mHeight = 7 ! measurement height above bare ground (m) + integer(i4b) :: latitude = integerMissing ! latitude (degrees north) + integer(i4b) :: longitude = integerMissing ! longitude (degrees east) + integer(i4b) :: elevation = integerMissing ! elevation (m) + integer(i4b) :: tan_slope = integerMissing ! tan water table slope, taken as tan local ground surface slope (-) + integer(i4b) :: contourLength = integerMissing ! length of contour at downslope edge of HRU (m) + integer(i4b) :: HRUarea = integerMissing ! area of each HRU (m2) + integer(i4b) :: mHeight = integerMissing ! measurement height above bare ground (m) end type iLook_attr + ! *********************************************************************************************************** ! (4) define local classification of veg, soil, etc. ! *********************************************************************************************************** type, public :: iLook_type - integer(i4b) :: hruIndex = 1 ! index defining hydrologic response unit (-) - integer(i4b) :: vegTypeIndex = 2 ! index defining vegetation type (-) - integer(i4b) :: soilTypeIndex = 3 ! index defining soil type (-) - integer(i4b) :: slopeTypeIndex = 4 ! index defining slope (-) - integer(i4b) :: downHRUindex = 5 ! index of downslope HRU (0 = basin outlet) + integer(i4b) :: hruIndex = integerMissing ! index defining hydrologic response unit (-) + integer(i4b) :: vegTypeIndex = integerMissing ! index defining vegetation type (-) + integer(i4b) :: soilTypeIndex = integerMissing ! index defining soil type (-) + integer(i4b) :: slopeTypeIndex= integerMissing ! index defining slope (-) + integer(i4b) :: downHRUindex = integerMissing ! index of downslope HRU (0 = basin outlet) end type iLook_type + ! *********************************************************************************************************** ! (5) define model parameters ! *********************************************************************************************************** type, public :: iLook_param ! boundary conditions - integer(i4b) :: upperBoundHead = 1 ! matric head of the upper boundary (m) - integer(i4b) :: lowerBoundHead = 2 ! matric head of the lower boundary (m) - integer(i4b) :: upperBoundTheta = 3 ! volumetric liquid water content of the upper boundary (-) - integer(i4b) :: lowerBoundTheta = 4 ! volumetric liquid water content of the lower boundary (-) - integer(i4b) :: upperBoundTemp = 5 ! temperature of the upper boundary (K) - integer(i4b) :: lowerBoundTemp = 6 ! temperature of the lower boundary (K) + integer(i4b) :: upperBoundHead = integerMissing ! matric head of the upper boundary (m) + integer(i4b) :: lowerBoundHead = integerMissing ! matric head of the lower boundary (m) + integer(i4b) :: upperBoundTheta = integerMissing ! volumetric liquid water content of the upper boundary (-) + integer(i4b) :: lowerBoundTheta = integerMissing ! volumetric liquid water content of the lower boundary (-) + integer(i4b) :: upperBoundTemp = integerMissing ! temperature of the upper boundary (K) + integer(i4b) :: lowerBoundTemp = integerMissing ! temperature of the lower boundary (K) ! precipitation partitioning - integer(i4b) :: tempCritRain = 7 ! critical temperature where precipitation is rain (K) - integer(i4b) :: tempRangeTimestep = 8 ! temperature range over the time step (K) - integer(i4b) :: frozenPrecipMultip = 9 ! frozen precipitation multiplier (-) - ! freezing curve for snow - integer(i4b) :: snowfrz_scale = 10 ! scaling parameter for the freezing curve for snow (K-1) + integer(i4b) :: tempCritRain = integerMissing ! critical temperature where precipitation is rain (K) + integer(i4b) :: tempRangeTimestep = integerMissing ! temperature range over the time step (K) + integer(i4b) :: frozenPrecipMultip = integerMissing ! frozen precipitation multiplier (-) + ! snow properties + integer(i4b) :: snowfrz_scale = integerMissing ! scaling parameter for the freezing curve for snow (K-1) + integer(i4b) :: fixedThermalCond_snow = integerMissing ! fixed thermal conductivity for snow (W m-1 K-1) ! snow albedo - integer(i4b) :: albedoMax = 11 ! maximum snow albedo for a single spectral band (-) - integer(i4b) :: albedoMinWinter = 12 ! minimum snow albedo during winter for a single spectral band (-) - integer(i4b) :: albedoMinSpring = 13 ! minimum snow albedo during spring for a single spectral band (-) - integer(i4b) :: albedoMaxVisible = 14 ! maximum snow albedo in the visible part of the spectrum (-) - integer(i4b) :: albedoMinVisible = 15 ! minimum snow albedo in the visible part of the spectrum (-) - integer(i4b) :: albedoMaxNearIR = 16 ! maximum snow albedo in the near infra-red part of the spectrum (-) - integer(i4b) :: albedoMinNearIR = 17 ! minimum snow albedo in the near infra-red part of the spectrum (-) - integer(i4b) :: albedoDecayRate = 18 ! albedo decay rate (s) - integer(i4b) :: albedoSootLoad = 19 ! soot load factor (-) - integer(i4b) :: albedoRefresh = 20 ! critical mass necessary for albedo refreshment (kg m-2) + integer(i4b) :: albedoMax = integerMissing ! maximum snow albedo for a single spectral band (-) + integer(i4b) :: albedoMinWinter = integerMissing ! minimum snow albedo during winter for a single spectral band (-) + integer(i4b) :: albedoMinSpring = integerMissing ! minimum snow albedo during spring for a single spectral band (-) + integer(i4b) :: albedoMaxVisible = integerMissing ! maximum snow albedo in the visible part of the spectrum (-) + integer(i4b) :: albedoMinVisible = integerMissing ! minimum snow albedo in the visible part of the spectrum (-) + integer(i4b) :: albedoMaxNearIR = integerMissing ! maximum snow albedo in the near infra-red part of the spectrum (-) + integer(i4b) :: albedoMinNearIR = integerMissing ! minimum snow albedo in the near infra-red part of the spectrum (-) + integer(i4b) :: albedoDecayRate = integerMissing ! albedo decay rate (s) + integer(i4b) :: albedoSootLoad = integerMissing ! soot load factor (-) + integer(i4b) :: albedoRefresh = integerMissing ! critical mass necessary for albedo refreshment (kg m-2) ! radiation transfer within snow - integer(i4b) :: radExt_snow = 21 ! extinction coefficient for radiation penetration into the snowpack (m-1) - integer(i4b) :: directScale = 22 ! scaling factor for fractional driect radiaion parameterization (-) - integer(i4b) :: Frad_direct = 23 ! maximum fraction of direct solar radiation (-) - integer(i4b) :: Frad_vis = 24 ! fraction of radiation in the visible part of the spectrum (-) + integer(i4b) :: radExt_snow = integerMissing ! extinction coefficient for radiation penetration into the snowpack (m-1) + integer(i4b) :: directScale = integerMissing ! scaling factor for fractional driect radiaion parameterization (-) + integer(i4b) :: Frad_direct = integerMissing ! maximum fraction of direct solar radiation (-) + integer(i4b) :: Frad_vis = integerMissing ! fraction of radiation in the visible part of the spectrum (-) ! new snow density - integer(i4b) :: newSnowDenMin = 25 ! minimum new snow density (kg m-3) - integer(i4b) :: newSnowDenMult = 26 ! multiplier for new snow density (kg m-3) - integer(i4b) :: newSnowDenScal = 27 ! scaling factor for new snow density (K) + integer(i4b) :: newSnowDenMin = integerMissing ! minimum new snow density (kg m-3) + integer(i4b) :: newSnowDenMult = integerMissing ! multiplier for new snow density (kg m-3) + integer(i4b) :: newSnowDenScal = integerMissing ! scaling factor for new snow density (K) + integer(i4b) :: constSnowDen = integerMissing ! constDens, Constant new snow density (kg m-3) + integer(i4b) :: newSnowDenAdd = integerMissing ! Pahaut 1976, additive factor for new snow density (kg m-3) + integer(i4b) :: newSnowDenMultTemp = integerMissing ! Pahaut 1976, multiplier for new snow density applied to air temperature (kg m-3 K-1) + integer(i4b) :: newSnowDenMultWind = integerMissing ! Pahaut 1976, multiplier for new snow density applied to wind speed (kg m-7/2 s-1/2) + integer(i4b) :: newSnowDenMultAnd = integerMissing ! Anderson 1976, multiplier for new snow density for Anderson function (K-1) + integer(i4b) :: newSnowDenBase = integerMissing ! Anderson 1976, base value that is rasied to the (3/2) power (K) ! snow compaction - integer(i4b) :: densScalGrowth = 28 ! density scaling factor for grain growth (kg-1 m3) - integer(i4b) :: tempScalGrowth = 29 ! temperature scaling factor for grain growth (K-1) - integer(i4b) :: grainGrowthRate = 30 ! rate of grain growth (s-1) - integer(i4b) :: densScalOvrbdn = 31 ! density scaling factor for overburden pressure (kg-1 m3) - integer(i4b) :: tempScalOvrbdn = 32 ! temperature scaling factor for overburden pressure (K-1) - integer(i4b) :: base_visc = 33 ! viscosity coefficient at T=T_frz and snow density=0 (kg s m-2) + integer(i4b) :: densScalGrowth = integerMissing ! density scaling factor for grain growth (kg-1 m3) + integer(i4b) :: tempScalGrowth = integerMissing ! temperature scaling factor for grain growth (K-1) + integer(i4b) :: grainGrowthRate = integerMissing ! rate of grain growth (s-1) + integer(i4b) :: densScalOvrbdn = integerMissing ! density scaling factor for overburden pressure (kg-1 m3) + integer(i4b) :: tempScalOvrbdn = integerMissing ! temperature scaling factor for overburden pressure (K-1) + integer(i4b) :: baseViscosity = integerMissing ! viscosity coefficient at T=T_frz and snow density=0 (kg s m-2) ! water flow within snow - integer(i4b) :: Fcapil = 34 ! capillary retention as a fraction of the total pore volume (-) - integer(i4b) :: k_snow = 35 ! hydraulic conductivity of snow (m s-1), 0.0055 = approx. 20 m/hr, from UEB - integer(i4b) :: mw_exp = 36 ! exponent for meltwater flow (-) + integer(i4b) :: Fcapil = integerMissing ! capillary retention as a fraction of the total pore volume (-) + integer(i4b) :: k_snow = integerMissing ! hydraulic conductivity of snow (m s-1), 0.0055 = approx. 20 m/hr, from UEB + integer(i4b) :: mw_exp = integerMissing ! exponent for meltwater flow (-) ! turbulent heat fluxes - integer(i4b) :: z0Snow = 37 ! roughness length of snow (m) - integer(i4b) :: z0Soil = 38 ! roughness length of bare soil below the canopy (m) - integer(i4b) :: z0Canopy = 39 ! roughness length of the canopy (m) - integer(i4b) :: zpdFraction = 40 ! zero plane displacement / canopy height (-) - integer(i4b) :: critRichNumber = 41 ! critical value for the bulk Richardson number (-) - integer(i4b) :: Louis79_bparam = 42 ! parameter in Louis (1979) stability function (-) - integer(i4b) :: Louis79_cStar = 43 ! parameter in Louis (1979) stability function (-) - integer(i4b) :: Mahrt87_eScale = 44 ! exponential scaling factor in the Mahrt (1987) stability function (-) - integer(i4b) :: leafExchangeCoeff = 45 ! turbulent exchange coeff between canopy surface and canopy air ( m s-(1/2) ) - integer(i4b) :: windReductionParam = 46 ! canopy wind reduction parameter (-) + 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) :: 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 (-) + integer(i4b) :: Louis79_cStar = integerMissing ! parameter in Louis (1979) stability function (-) + integer(i4b) :: Mahrt87_eScale = integerMissing ! exponential scaling factor in the Mahrt (1987) stability function (-) + integer(i4b) :: leafExchangeCoeff = integerMissing ! turbulent exchange coeff between canopy surface and canopy air ( m s-(1/2) ) + integer(i4b) :: windReductionParam = integerMissing ! canopy wind reduction parameter (-) ! stomatal conductance - integer(i4b) :: Kc25 = 47 ! Michaelis-Menten constant for CO2 at 25 degrees C (umol mol-1) - integer(i4b) :: Ko25 = 48 ! Michaelis-Menten constant for O2 at 25 degrees C (mol mol-1) - integer(i4b) :: Kc_qFac = 49 ! factor in the q10 function defining temperature controls on Kc (-) - integer(i4b) :: Ko_qFac = 50 ! factor in the q10 function defining temperature controls on Ko (-) - integer(i4b) :: kc_Ha = 51 ! activation energy for the Michaelis-Menten constant for CO2 (J mol-1) - integer(i4b) :: ko_Ha = 52 ! activation energy for the Michaelis-Menten constant for O2 (J mol-1) - integer(i4b) :: vcmax25_canopyTop = 53 ! potential carboxylation rate at 25 degrees C at the canopy top (umol co2 m-2 s-1) - integer(i4b) :: vcmax_qFac = 54 ! factor in the q10 function defining temperature controls on vcmax (-) - integer(i4b) :: vcmax_Ha = 55 ! activation energy in the vcmax function (J mol-1) - integer(i4b) :: vcmax_Hd = 56 ! deactivation energy in the vcmax function (J mol-1) - integer(i4b) :: vcmax_Sv = 57 ! entropy term in the vcmax function (J mol-1 K-1) - integer(i4b) :: vcmax_Kn = 58 ! foliage nitrogen decay coefficient (-) - integer(i4b) :: jmax25_scale = 59 ! scaling factor to relate jmax25 to vcmax25 (-) - integer(i4b) :: jmax_Ha = 60 ! activation energy in the jmax function (J mol-1) - integer(i4b) :: jmax_Hd = 61 ! deactivation energy in the jmax function (J mol-1) - integer(i4b) :: jmax_Sv = 62 ! entropy term in the jmax function (J mol-1 K-1) - integer(i4b) :: fractionJ = 63 ! fraction of light lost by other than the chloroplast lamellae (-) - integer(i4b) :: quantamYield = 64 ! quantam yield (mol e mol-1 q) - integer(i4b) :: vpScaleFactor = 65 ! vapor pressure scaling factor in stomatal conductance function (Pa) - integer(i4b) :: cond2photo_slope = 66 ! slope of conductance-photosynthesis relationship (-) - integer(i4b) :: minStomatalConductance = 67 ! minimum stomatal conductance (umol H2O m-2 s-1) + integer(i4b) :: Kc25 = integerMissing ! Michaelis-Menten constant for CO2 at 25 degrees C (umol mol-1) + integer(i4b) :: Ko25 = integerMissing ! Michaelis-Menten constant for O2 at 25 degrees C (mol mol-1) + integer(i4b) :: Kc_qFac = integerMissing ! factor in the q10 function defining temperature controls on Kc (-) + integer(i4b) :: Ko_qFac = integerMissing ! factor in the q10 function defining temperature controls on Ko (-) + integer(i4b) :: kc_Ha = integerMissing ! activation energy for the Michaelis-Menten constant for CO2 (J mol-1) + integer(i4b) :: ko_Ha = integerMissing ! activation energy for the Michaelis-Menten constant for O2 (J mol-1) + integer(i4b) :: vcmax25_canopyTop = integerMissing ! potential carboxylation rate at 25 degrees C at the canopy top (umol co2 m-2 s-1) + integer(i4b) :: vcmax_qFac = integerMissing ! factor in the q10 function defining temperature controls on vcmax (-) + integer(i4b) :: vcmax_Ha = integerMissing ! activation energy in the vcmax function (J mol-1) + integer(i4b) :: vcmax_Hd = integerMissing ! deactivation energy in the vcmax function (J mol-1) + integer(i4b) :: vcmax_Sv = integerMissing ! entropy term in the vcmax function (J mol-1 K-1) + integer(i4b) :: vcmax_Kn = integerMissing ! foliage nitrogen decay coefficient (-) + integer(i4b) :: jmax25_scale = integerMissing ! scaling factor to relate jmax25 to vcmax25 (-) + integer(i4b) :: jmax_Ha = integerMissing ! activation energy in the jmax function (J mol-1) + integer(i4b) :: jmax_Hd = integerMissing ! deactivation energy in the jmax function (J mol-1) + integer(i4b) :: jmax_Sv = integerMissing ! entropy term in the jmax function (J mol-1 K-1) + integer(i4b) :: fractionJ = integerMissing ! fraction of light lost by other than the chloroplast lamellae (-) + integer(i4b) :: quantamYield = integerMissing ! quantam yield (mol e mol-1 q) + integer(i4b) :: vpScaleFactor = integerMissing ! vapor pressure scaling factor in stomatal conductance function (Pa) + integer(i4b) :: cond2photo_slope = integerMissing ! slope of conductance-photosynthesis relationship (-) + integer(i4b) :: minStomatalConductance= integerMissing ! minimum stomatal conductance (umol H2O m-2 s-1) ! vegetation properties - integer(i4b) :: winterSAI = 68 ! stem area index prior to the start of the growing season (m2 m-2) - integer(i4b) :: summerLAI = 69 ! maximum leaf area index at the peak of the growing season (m2 m-2) - integer(i4b) :: rootScaleFactor1 = 70 ! 1st scaling factor (a) in Y = 1 - 0.5*( exp(-aZ) + exp(-bZ) ) (m-1) - integer(i4b) :: rootScaleFactor2 = 71 ! 2nd scaling factor (b) in Y = 1 - 0.5*( exp(-aZ) + exp(-bZ) ) (m-1) - integer(i4b) :: rootingDepth = 72 ! rooting depth (m) - integer(i4b) :: rootDistExp = 73 ! exponent controlling the vertical distribution of root density (-) - integer(i4b) :: plantWiltPsi = 74 ! matric head at wilting point (m) - integer(i4b) :: soilStressParam = 75 ! parameter in the exponential soil stress function - integer(i4b) :: critSoilWilting = 76 ! critical vol. liq. water content when plants are wilting (-) - integer(i4b) :: critSoilTranspire = 77 ! critical vol. liq. water content when transpiration is limited (-) - integer(i4b) :: critAquiferTranspire = 78 ! critical aquifer storage value when transpiration is limited (m) - integer(i4b) :: minStomatalResistance = 79 ! minimum canopy resistance (s m-1) - integer(i4b) :: leafDimension = 80 ! characteristic leaf dimension (m) - integer(i4b) :: heightCanopyTop = 81 ! height of top of the vegetation canopy above ground surface (m) - integer(i4b) :: heightCanopyBottom = 82 ! height of bottom of the vegetation canopy above ground surface (m) - integer(i4b) :: specificHeatVeg = 83 ! specific heat of vegetation (J kg-1 K-1) - integer(i4b) :: maxMassVegetation = 84 ! maximum mass of vegetation (full foliage) (kg m-2) - integer(i4b) :: throughfallScaleSnow = 85 ! scaling factor for throughfall (snow) (-) - integer(i4b) :: throughfallScaleRain = 86 ! scaling factor for throughfall (rain) (-) - integer(i4b) :: refInterceptCapSnow = 87 ! reference canopy interception capacity per unit leaf area (snow) (kg m-2) - integer(i4b) :: refInterceptCapRain = 88 ! canopy interception capacity per unit leaf area (rain) (kg m-2) - integer(i4b) :: snowUnloadingCoeff = 89 ! time constant for unloading of snow from the forest canopy (s-1) - integer(i4b) :: canopyDrainageCoeff = 90 ! time constant for drainage of liquid water from the forest canopy (s-1) - integer(i4b) :: ratioDrip2Unloading = 91 ! ratio of canopy drip to unloading of snow from the forest canopy (-) - integer(i4b) :: canopyWettingFactor = 92 ! maximum wetted fraction of the canopy (-) - integer(i4b) :: canopyWettingExp = 93 ! exponent in canopy wetting function (-) + integer(i4b) :: winterSAI = integerMissing ! stem area index prior to the start of the growing season (m2 m-2) + integer(i4b) :: summerLAI = integerMissing ! maximum leaf area index at the peak of the growing season (m2 m-2) + integer(i4b) :: rootScaleFactor1 = integerMissing ! 1st scaling factor (a) in Y = 1 - 0.5*( exp(-aZ) + exp(-bZ) ) (m-1) + integer(i4b) :: rootScaleFactor2 = integerMissing ! 2nd scaling factor (b) in Y = 1 - 0.5*( exp(-aZ) + exp(-bZ) ) (m-1) + integer(i4b) :: rootingDepth = integerMissing ! rooting depth (m) + integer(i4b) :: rootDistExp = integerMissing ! exponent controlling the vertical distribution of root density (-) + integer(i4b) :: plantWiltPsi = integerMissing ! matric head at wilting point (m) + integer(i4b) :: soilStressParam = integerMissing ! parameter in the exponential soil stress function + integer(i4b) :: critSoilWilting = integerMissing ! critical vol. liq. water content when plants are wilting (-) + integer(i4b) :: critSoilTranspire = integerMissing ! critical vol. liq. water content when transpiration is limited (-) + integer(i4b) :: critAquiferTranspire = integerMissing ! critical aquifer storage value when transpiration is limited (m) + integer(i4b) :: minStomatalResistance = integerMissing ! minimum canopy resistance (s m-1) + integer(i4b) :: leafDimension = integerMissing ! characteristic leaf dimension (m) + integer(i4b) :: heightCanopyTop = integerMissing ! height of top of the vegetation canopy above ground surface (m) + integer(i4b) :: heightCanopyBottom = integerMissing ! height of bottom of the vegetation canopy above ground surface (m) + integer(i4b) :: specificHeatVeg = integerMissing ! specific heat of vegetation (J kg-1 K-1) + integer(i4b) :: maxMassVegetation = integerMissing ! maximum mass of vegetation (full foliage) (kg m-2) + integer(i4b) :: throughfallScaleSnow = integerMissing ! scaling factor for throughfall (snow) (-) + integer(i4b) :: throughfallScaleRain = integerMissing ! scaling factor for throughfall (rain) (-) + integer(i4b) :: refInterceptCapSnow = integerMissing ! reference canopy interception capacity per unit leaf area (snow) (kg m-2) + integer(i4b) :: refInterceptCapRain = integerMissing ! canopy interception capacity per unit leaf area (rain) (kg m-2) + integer(i4b) :: snowUnloadingCoeff = integerMissing ! time constant for unloading of snow from the forest canopy (s-1) + integer(i4b) :: canopyDrainageCoeff = integerMissing ! time constant for drainage of liquid water from the forest canopy (s-1) + integer(i4b) :: ratioDrip2Unloading = integerMissing ! ratio of canopy drip to unloading of snow from the forest canopy (-) + integer(i4b) :: canopyWettingFactor = integerMissing ! maximum wetted fraction of the canopy (-) + integer(i4b) :: canopyWettingExp = integerMissing ! exponent in canopy wetting function (-) ! soil properties - integer(i4b) :: soil_dens_intr = 94 ! intrinsic soil density (kg m-3) - integer(i4b) :: thCond_soil = 95 ! thermal conductivity of soil (W m-1 K-1) - integer(i4b) :: frac_sand = 96 ! fraction of sand (-) - integer(i4b) :: frac_silt = 97 ! fraction of silt (-) - integer(i4b) :: frac_clay = 98 ! fraction of clay (-) - integer(i4b) :: fieldCapacity = 99 ! field capacity (-) - integer(i4b) :: wettingFrontSuction = 100 ! Green-Ampt wetting front suction (m) - integer(i4b) :: theta_mp = 101 ! volumetric liquid water content when macropore flow begins (-) - integer(i4b) :: theta_sat = 102 ! porosity (-) - integer(i4b) :: theta_res = 103 ! volumetric residual water content (-) - integer(i4b) :: vGn_alpha = 104 ! van Genuchten "alpha" parameter (m-1) - integer(i4b) :: vGn_n = 105 ! van Genuchten "n" parameter (-) - integer(i4b) :: mpExp = 106 ! empirical exponent in macropore flow equation (-) - integer(i4b) :: k_soil = 107 ! hydraulic conductivity of soil (m s-1) - integer(i4b) :: k_macropore = 108 ! saturated hydraulic conductivity for macropores (m s-1) - integer(i4b) :: kAnisotropic = 109 ! anisotropy factor for lateral hydraulic conductivity (-) - integer(i4b) :: zScale_TOPMODEL = 110 ! TOPMODEL scaling factor used in lower boundary condition for soil (m) - integer(i4b) :: compactedDepth = 111 ! depth where k_soil reaches the compacted value given by CH78 (m) - integer(i4b) :: aquiferScaleFactor = 112 ! scaling factor for aquifer storage in the big bucket (m) - integer(i4b) :: aquiferBaseflowExp = 113 ! baseflow exponent (-) - integer(i4b) :: qSurfScale = 114 ! scaling factor in the surface runoff parameterization (-) - integer(i4b) :: specificYield = 115 ! specific yield (-) - integer(i4b) :: specificStorage = 116 ! specific storage coefficient (m-1) - integer(i4b) :: f_impede = 117 ! ice impedence factor (-) - integer(i4b) :: soilIceScale = 118 ! scaling factor for depth of soil ice, used to get frozen fraction (m) - integer(i4b) :: soilIceCV = 119 ! CV of depth of soil ice, used to get frozen fraction (-) + integer(i4b) :: soil_dens_intr = integerMissing ! intrinsic soil density (kg m-3) + integer(i4b) :: thCond_soil = integerMissing ! thermal conductivity of soil (W m-1 K-1) + integer(i4b) :: frac_sand = integerMissing ! fraction of sand (-) + integer(i4b) :: frac_silt = integerMissing ! fraction of silt (-) + integer(i4b) :: frac_clay = integerMissing ! fraction of clay (-) + integer(i4b) :: fieldCapacity = integerMissing ! field capacity (-) + integer(i4b) :: wettingFrontSuction = integerMissing ! Green-Ampt wetting front suction (m) + integer(i4b) :: theta_mp = integerMissing ! volumetric liquid water content when macropore flow begins (-) + integer(i4b) :: theta_sat = integerMissing ! porosity (-) + integer(i4b) :: theta_res = integerMissing ! volumetric residual water content (-) + integer(i4b) :: vGn_alpha = integerMissing ! van Genuchten "alpha" parameter (m-1) + integer(i4b) :: vGn_n = integerMissing ! van Genuchten "n" parameter (-) + integer(i4b) :: mpExp = integerMissing ! empirical exponent in macropore flow equation (-) + integer(i4b) :: k_soil = integerMissing ! hydraulic conductivity of soil (m s-1) + integer(i4b) :: k_macropore = integerMissing ! saturated hydraulic conductivity for macropores (m s-1) + integer(i4b) :: kAnisotropic = integerMissing ! anisotropy factor for lateral hydraulic conductivity (-) + integer(i4b) :: zScale_TOPMODEL = integerMissing ! TOPMODEL scaling factor used in lower boundary condition for soil (m) + integer(i4b) :: compactedDepth = integerMissing ! depth where k_soil reaches the compacted value given by CH78 (m) + integer(i4b) :: aquiferScaleFactor = integerMissing ! scaling factor for aquifer storage in the big bucket (m) + integer(i4b) :: aquiferBaseflowExp = integerMissing ! baseflow exponent (-) + integer(i4b) :: qSurfScale = integerMissing ! scaling factor in the surface runoff parameterization (-) + integer(i4b) :: specificYield = integerMissing ! specific yield (-) + integer(i4b) :: specificStorage = integerMissing ! specific storage coefficient (m-1) + 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 (-) ! algorithmic control parameters - integer(i4b) :: minwind = 120 ! minimum wind speed (m s-1) - integer(i4b) :: minstep = 121 ! minimum length of the time step - integer(i4b) :: maxstep = 122 ! maximum length of the time step - integer(i4b) :: wimplicit = 123 ! weight assigned to the start-of-step fluxes - integer(i4b) :: maxiter = 124 ! maximum number of iteration - integer(i4b) :: relConvTol_liquid = 125 ! relative convergence tolerance for vol frac liq water (-) - integer(i4b) :: absConvTol_liquid = 126 ! absolute convergence tolerance for vol frac liq water (-) - integer(i4b) :: relConvTol_matric = 127 ! relative convergence tolerance for matric head (-) - integer(i4b) :: absConvTol_matric = 128 ! absolute convergence tolerance for matric head (m) - integer(i4b) :: relConvTol_energy = 129 ! relative convergence tolerance for energy (-) - integer(i4b) :: absConvTol_energy = 130 ! absolute convergence tolerance for energy (J m-3) - integer(i4b) :: relConvTol_aquifr = 131 ! relative convergence tolerance for aquifer storage (-) - integer(i4b) :: absConvTol_aquifr = 132 ! absolute convergence tolerance for aquifer storage (J m-3) - integer(i4b) :: zmin = 133 ! minimum layer depth (m) - integer(i4b) :: zmax = 134 ! maximum layer depth (m) - integer(i4b) :: zminLayer1 = 135 ! minimum layer depth for the 1st (top) layer (m) - integer(i4b) :: zminLayer2 = 136 ! minimum layer depth for the 2nd layer (m) - integer(i4b) :: zminLayer3 = 137 ! minimum layer depth for the 3rd layer (m) - integer(i4b) :: zminLayer4 = 138 ! minimum layer depth for the 4th layer (m) - integer(i4b) :: zminLayer5 = 139 ! minimum layer depth for the 5th (bottom) layer (m) - integer(i4b) :: zmaxLayer1_lower = 140 ! maximum layer depth for the 1st (top) layer when only 1 layer (m) - integer(i4b) :: zmaxLayer2_lower = 141 ! maximum layer depth for the 2nd layer when only 2 layers (m) - integer(i4b) :: zmaxLayer3_lower = 142 ! maximum layer depth for the 3rd layer when only 3 layers (m) - integer(i4b) :: zmaxLayer4_lower = 143 ! maximum layer depth for the 4th layer when only 4 layers (m) - integer(i4b) :: zmaxLayer1_upper = 144 ! maximum layer depth for the 1st (top) layer when > 1 layer (m) - integer(i4b) :: zmaxLayer2_upper = 145 ! maximum layer depth for the 2nd layer when > 2 layers (m) - integer(i4b) :: zmaxLayer3_upper = 146 ! maximum layer depth for the 3rd layer when > 3 layers (m) - integer(i4b) :: zmaxLayer4_upper = 147 ! maximum layer depth for the 4th layer when > 4 layers (m) + 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) :: 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) :: 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) + integer(i4b) :: zminLayer2 = integerMissing ! minimum layer depth for the 2nd layer (m) + integer(i4b) :: zminLayer3 = integerMissing ! minimum layer depth for the 3rd layer (m) + integer(i4b) :: zminLayer4 = integerMissing ! minimum layer depth for the 4th layer (m) + integer(i4b) :: zminLayer5 = integerMissing ! minimum layer depth for the 5th (bottom) layer (m) + integer(i4b) :: zmaxLayer1_lower = integerMissing ! maximum layer depth for the 1st (top) layer when only 1 layer (m) + integer(i4b) :: zmaxLayer2_lower = integerMissing ! maximum layer depth for the 2nd layer when only 2 layers (m) + integer(i4b) :: zmaxLayer3_lower = integerMissing ! maximum layer depth for the 3rd layer when only 3 layers (m) + integer(i4b) :: zmaxLayer4_lower = integerMissing ! maximum layer depth for the 4th layer when only 4 layers (m) + integer(i4b) :: zmaxLayer1_upper = integerMissing ! maximum layer depth for the 1st (top) layer when > 1 layer (m) + 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 + + + ! *********************************************************************************************************** + ! (6) define model prognostic (state) variables + ! *********************************************************************************************************** + type, public :: iLook_prog + ! variables for time stepping + integer(i4b) :: dt_init = integerMissing ! length of initial time step at start of next data interval (s) + ! state variables for vegetation + integer(i4b) :: scalarCanopyIce = integerMissing ! mass of ice on the vegetation canopy (kg m-2) + integer(i4b) :: scalarCanopyLiq = integerMissing ! mass of liquid water on the vegetation canopy (kg m-2) + integer(i4b) :: scalarCanopyWat = integerMissing ! mass of total water on the vegetation canopy (kg m-2) + integer(i4b) :: scalarCanairTemp = integerMissing ! temperature of the canopy air space (Pa) + integer(i4b) :: scalarCanopyTemp = integerMissing ! temperature of the vegetation canopy (K) + ! state variables for snow + integer(i4b) :: spectralSnowAlbedoDiffuse = integerMissing ! diffuse snow albedo for individual spectral bands (-) + integer(i4b) :: scalarSnowAlbedo = integerMissing ! snow albedo for the entire spectral band (-) + integer(i4b) :: scalarSnowDepth = integerMissing ! total snow depth (m) + integer(i4b) :: scalarSWE = integerMissing ! snow water equivalent (kg m-2) + integer(i4b) :: scalarSfcMeltPond = integerMissing ! ponded water caused by melt of the "snow without a layer" (kg m-2) + ! state variables for the snow+soil domain + integer(i4b) :: mLayerTemp = integerMissing ! temperature of each layer (K) + integer(i4b) :: mLayerVolFracIce = integerMissing ! volumetric fraction of ice in each layer (-) + 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) + ! other state variables + integer(i4b) :: scalarAquiferStorage = integerMissing ! relative aquifer storage -- above bottom of the soil profile (m) + integer(i4b) :: scalarSurfaceTemp = integerMissing ! surface temperature (K) + ! coordinate variables + integer(i4b) :: mLayerDepth = integerMissing ! depth of each layer (m) + integer(i4b) :: mLayerHeight = integerMissing ! height at the mid-point of each layer (m) + integer(i4b) :: iLayerHeight = integerMissing ! height of the layer interface; top of soil = 0 (m) + endtype iLook_prog + + ! *********************************************************************************************************** + ! (7) define diagnostic variables + ! *********************************************************************************************************** + 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) :: 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) + integer(i4b) :: scalarSAI = integerMissing ! one-sided stem area index (m2 m-2) + integer(i4b) :: scalarExposedLAI = integerMissing ! exposed leaf area index after burial by snow (m2 m-2) + integer(i4b) :: scalarExposedSAI = integerMissing ! exposed stem area index after burial by snow(m2 m-2) + integer(i4b) :: scalarCanopyIceMax = integerMissing ! maximum interception storage capacity for ice (kg m-2) + integer(i4b) :: scalarCanopyLiqMax = integerMissing ! maximum interception storage capacity for liquid water (kg m-2) + integer(i4b) :: scalarGrowingSeasonIndex = integerMissing ! growing season index (0=off, 1=on) + integer(i4b) :: scalarVolHtCap_air = integerMissing ! volumetric heat capacity air (J m-3 K-1) + integer(i4b) :: scalarVolHtCap_ice = integerMissing ! volumetric heat capacity ice (J m-3 K-1) + 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) :: 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) + ! 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) + integer(i4b) :: scalarTwetbulb = integerMissing ! wet bulb temperature (K) + integer(i4b) :: scalarSnowfallTemp = integerMissing ! temperature of fresh snow (K) + 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) + ! shortwave radiation + integer(i4b) :: scalarCosZenith = integerMissing ! cosine of the solar zenith angle (0-1) + integer(i4b) :: scalarFractionDirect = integerMissing ! fraction of direct radiation (0-1) + integer(i4b) :: scalarCanopySunlitFraction = integerMissing ! sunlit fraction of canopy (-) + integer(i4b) :: scalarCanopySunlitLAI = integerMissing ! sunlit leaf area (-) + integer(i4b) :: scalarCanopyShadedLAI = integerMissing ! shaded leaf area (-) + integer(i4b) :: spectralAlbGndDirect = integerMissing ! direct albedo of underlying surface for each spectral band (-) + integer(i4b) :: spectralAlbGndDiffuse = integerMissing ! diffuse albedo of underlying surface for each spectral band (-) + integer(i4b) :: scalarGroundAlbedo = integerMissing ! albedo of the ground surface (-) + ! turbulent heat transfer + integer(i4b) :: scalarLatHeatSubVapCanopy = integerMissing ! latent heat of sublimation/vaporization used for veg canopy (J kg-1) + integer(i4b) :: scalarLatHeatSubVapGround = integerMissing ! latent heat of sublimation/vaporization used for ground surface (J kg-1) + integer(i4b) :: scalarSatVP_CanopyTemp = integerMissing ! saturation vapor pressure at the temperature of vegetation canopy (Pa) + integer(i4b) :: scalarSatVP_GroundTemp = integerMissing ! saturation vapor pressure at the temperature of the ground (Pa) + integer(i4b) :: scalarZ0Canopy = integerMissing ! roughness length of the canopy (m) + integer(i4b) :: scalarWindReductionFactor = integerMissing ! canopy wind reduction factor (-) + integer(i4b) :: scalarZeroPlaneDisplacement = integerMissing ! zero plane displacement (m) + integer(i4b) :: scalarRiBulkCanopy = integerMissing ! bulk Richardson number for the canopy (-) + integer(i4b) :: scalarRiBulkGround = integerMissing ! bulk Richardson number for the ground surface (-) + integer(i4b) :: scalarCanopyStabilityCorrection = integerMissing ! stability correction for the canopy (-) + integer(i4b) :: scalarGroundStabilityCorrection = integerMissing ! stability correction for the ground surface (-) + ! evapotranspiration + integer(i4b) :: scalarIntercellularCO2Sunlit = integerMissing ! carbon dioxide partial pressure of leaf interior (sunlit leaves) (Pa) + integer(i4b) :: scalarIntercellularCO2Shaded = integerMissing ! carbon dioxide partial pressure of leaf interior (shaded leaves) (Pa) + integer(i4b) :: scalarTranspireLim = integerMissing ! aggregate soil moisture + aquifer storage limit on transpiration (-) + integer(i4b) :: scalarTranspireLimAqfr = integerMissing ! aquifer storage limit on transpiration (-) + integer(i4b) :: scalarFoliageNitrogenFactor = integerMissing ! foliage nitrogen concentration, 1=saturated (-) + integer(i4b) :: scalarSoilRelHumidity = integerMissing ! relative humidity in the soil pores in the upper-most soil layer (-) + integer(i4b) :: mLayerTranspireLim = integerMissing ! soil moist & veg limit on transpiration for each layer (-) + integer(i4b) :: mLayerRootDensity = integerMissing ! fraction of roots in each soil layer (-) + integer(i4b) :: scalarAquiferRootFrac = integerMissing ! fraction of roots below the soil profile (-) + ! canopy hydrology + integer(i4b) :: scalarFracLiqVeg = integerMissing ! fraction of liquid water on vegetation (-) + integer(i4b) :: scalarCanopyWetFraction = integerMissing ! fraction of canopy that is wet + ! snow hydrology + integer(i4b) :: scalarSnowAge = integerMissing ! non-dimensional snow age (-) + integer(i4b) :: scalarGroundSnowFraction = integerMissing ! fraction of ground that is covered with snow (-) + integer(i4b) :: spectralSnowAlbedoDirect = integerMissing ! direct snow albedo for individual spectral bands (-) + integer(i4b) :: mLayerFracLiqSnow = integerMissing ! fraction of liquid water in each snow layer (-) + integer(i4b) :: mLayerThetaResid = integerMissing ! residual volumetric water content in each snow layer (-) + 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) :: 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) :: 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) :: 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) + ! variable shortcuts + 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) + ! number of function evaluations + integer(i4b) :: numFluxCalls = integerMissing ! number of flux calls (-) + endtype iLook_diag + + ! *********************************************************************************************************** + ! (8) define model fluxes + ! *********************************************************************************************************** + type, public :: iLook_flux + ! net energy and mass fluxes for the vegetation domain + integer(i4b) :: scalarCanairNetNrgFlux = integerMissing ! net energy flux for the canopy air space (W m-2) + integer(i4b) :: scalarCanopyNetNrgFlux = integerMissing ! net energy flux for the vegetation canopy (W m-2) + integer(i4b) :: scalarGroundNetNrgFlux = integerMissing ! net energy flux for the ground surface (W m-2) + integer(i4b) :: scalarCanopyNetLiqFlux = integerMissing ! net liquid water flux for the vegetation canopy (kg m-2 s-1) + ! forcing + integer(i4b) :: scalarRainfall = integerMissing ! computed rainfall rate (kg m-2 s-1) + integer(i4b) :: scalarSnowfall = integerMissing ! computed snowfall rate (kg m-2 s-1) + ! shortwave radiation + integer(i4b) :: spectralIncomingDirect = integerMissing ! incoming direct solar radiation in each wave band (W m-2) + integer(i4b) :: spectralIncomingDiffuse = integerMissing ! incoming diffuse solar radiation in each wave band (W m-2) + integer(i4b) :: scalarCanopySunlitPAR = integerMissing ! average absorbed par for sunlit leaves (W m-2) + integer(i4b) :: scalarCanopyShadedPAR = integerMissing ! average absorbed par for shaded leaves (W m-2) + integer(i4b) :: spectralBelowCanopyDirect = integerMissing ! downward direct flux below veg layer for each spectral band (W m-2) + integer(i4b) :: spectralBelowCanopyDiffuse = integerMissing ! downward diffuse flux below veg layer for each spectral band (W m-2) + integer(i4b) :: scalarBelowCanopySolar = integerMissing ! solar radiation transmitted below the canopy (W m-2) + integer(i4b) :: scalarCanopyAbsorbedSolar = integerMissing ! solar radiation absorbed by canopy (W m-2) + integer(i4b) :: scalarGroundAbsorbedSolar = integerMissing ! solar radiation absorbed by ground (W m-2) + ! longwave radiation + integer(i4b) :: scalarLWRadCanopy = integerMissing ! longwave radiation emitted from the canopy (W m-2) + integer(i4b) :: scalarLWRadGround = integerMissing ! longwave radiation emitted at the ground surface (W m-2) + integer(i4b) :: scalarLWRadUbound2Canopy = integerMissing ! downward atmospheric longwave radiation absorbed by the canopy (W m-2) + integer(i4b) :: scalarLWRadUbound2Ground = integerMissing ! downward atmospheric longwave radiation absorbed by the ground (W m-2) + integer(i4b) :: scalarLWRadUbound2Ubound = integerMissing ! atmospheric radiation refl by ground + lost thru upper boundary (W m-2) + integer(i4b) :: scalarLWRadCanopy2Ubound = integerMissing ! longwave radiation emitted from canopy lost thru upper boundary (W m-2) + integer(i4b) :: scalarLWRadCanopy2Ground = integerMissing ! longwave radiation emitted from canopy absorbed by the ground (W m-2) + integer(i4b) :: scalarLWRadCanopy2Canopy = integerMissing ! canopy longwave reflected from ground and absorbed by the canopy (W m-2) + integer(i4b) :: scalarLWRadGround2Ubound = integerMissing ! longwave radiation emitted from ground lost thru upper boundary (W m-2) + integer(i4b) :: scalarLWRadGround2Canopy = integerMissing ! longwave radiation emitted from ground and absorbed by the canopy (W m-2) + integer(i4b) :: scalarLWNetCanopy = integerMissing ! net longwave radiation at the canopy (W m-2) + integer(i4b) :: scalarLWNetGround = integerMissing ! net longwave radiation at the ground surface (W m-2) + integer(i4b) :: scalarLWNetUbound = integerMissing ! net longwave radiation at the upper atmospheric boundary (W m-2) + ! turbulent heat transfer + integer(i4b) :: scalarEddyDiffusCanopyTop = integerMissing ! eddy diffusivity for heat at the top of the canopy (m2 s-1) + integer(i4b) :: scalarFrictionVelocity = integerMissing ! friction velocity - canopy momentum sink (m s-1) + integer(i4b) :: scalarWindspdCanopyTop = integerMissing ! windspeed at the top of the canopy (m s-1) + integer(i4b) :: scalarWindspdCanopyBottom = integerMissing ! windspeed at the height of the bottom of the canopy (m s-1) + integer(i4b) :: scalarGroundResistance = integerMissing ! below canopy aerodynamic resistance (s m-1) + integer(i4b) :: scalarCanopyResistance = integerMissing ! above canopy aerodynamic resistance (s m-1) + integer(i4b) :: scalarLeafResistance = integerMissing ! mean leaf boundary layer resistance per unit leaf area (s m-1) + integer(i4b) :: scalarSoilResistance = integerMissing ! soil surface resistance (s m-1) + integer(i4b) :: scalarSenHeatTotal = integerMissing ! sensible heat from the canopy air space to the atmosphere (W m-2) + integer(i4b) :: scalarSenHeatCanopy = integerMissing ! sensible heat from the canopy to the canopy air space (W m-2) + integer(i4b) :: scalarSenHeatGround = integerMissing ! sensible heat from the ground (below canopy or non-vegetated) (W m-2) + integer(i4b) :: scalarLatHeatTotal = integerMissing ! latent heat from the canopy air space to the atmosphere (W m-2) + integer(i4b) :: scalarLatHeatCanopyEvap = integerMissing ! evaporation latent heat from the canopy to the canopy air space (W m-2) + integer(i4b) :: scalarLatHeatCanopyTrans = integerMissing ! transpiration latent heat from the canopy to the canopy air space (W m-2) + integer(i4b) :: scalarLatHeatGround = integerMissing ! latent heat from the ground (below canopy or non-vegetated) (W m-2) + integer(i4b) :: scalarCanopyAdvectiveHeatFlux = integerMissing ! heat advected to the canopy surface with rain + snow (W m-2) + integer(i4b) :: scalarGroundAdvectiveHeatFlux = integerMissing ! heat advected to the ground surface with throughfall and unloading/drainage (W m-2) + integer(i4b) :: scalarCanopySublimation = integerMissing ! canopy sublimation/frost (kg m-2 s-1) + integer(i4b) :: scalarSnowSublimation = integerMissing ! snow sublimation/frost (below canopy or non-vegetated) (kg m-2 s-1) + ! liquid water fluxes associated with evapotranspiration + integer(i4b) :: scalarStomResistSunlit = integerMissing ! stomatal resistance for sunlit leaves (s m-1) + integer(i4b) :: scalarStomResistShaded = integerMissing ! stomatal resistance for shaded leaves (s m-1) + integer(i4b) :: scalarPhotosynthesisSunlit = integerMissing ! sunlit photosynthesis (umolco2 m-2 s-1) + integer(i4b) :: scalarPhotosynthesisShaded = integerMissing ! shaded photosynthesis (umolco2 m-2 s-1) + integer(i4b) :: scalarCanopyTranspiration = integerMissing ! canopy transpiration (kg m-2 s-1) + integer(i4b) :: scalarCanopyEvaporation = integerMissing ! canopy evaporation/condensation (kg m-2 s-1) + integer(i4b) :: scalarGroundEvaporation = integerMissing ! ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) + integer(i4b) :: mLayerTranspire = integerMissing ! transpiration loss from each soil layer (kg m-2 s-1) + ! liquid and solid water fluxes through the canopy + integer(i4b) :: scalarThroughfallSnow = integerMissing ! snow that reaches the ground without ever touching the canopy (kg m-2 s-1) + integer(i4b) :: scalarThroughfallRain = integerMissing ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) + integer(i4b) :: scalarCanopySnowUnloading = integerMissing ! unloading of snow from the vegetion canopy (kg m-2 s-1) + integer(i4b) :: scalarCanopyLiqDrainage = integerMissing ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) + integer(i4b) :: scalarCanopyMeltFreeze = integerMissing ! melt/freeze of water stored in the canopy (kg m-2 s-1) + ! energy fluxes and for the snow and soil domains + integer(i4b) :: iLayerConductiveFlux = integerMissing ! conductive energy flux at layer interfaces (W m-2) + integer(i4b) :: iLayerAdvectiveFlux = integerMissing ! advective energy flux at layer interfaces (W m-2) + integer(i4b) :: iLayerNrgFlux = integerMissing ! energy flux at layer interfaces (W m-2) + integer(i4b) :: mLayerNrgFlux = integerMissing ! net energy flux for each layer in the snow+soil domain (J m-3 s-1) + ! liquid water fluxes for the snow domain + integer(i4b) :: scalarSnowDrainage = integerMissing ! drainage from the bottom of the snow profile (m s-1) + integer(i4b) :: iLayerLiqFluxSnow = integerMissing ! liquid flux at snow layer interfaces (m s-1) + integer(i4b) :: mLayerLiqFluxSnow = integerMissing ! net liquid water flux for each snow layer (s-1) + ! liquid water fluxes for the soil domain + integer(i4b) :: scalarRainPlusMelt = integerMissing ! rain plus melt, as input to soil before calculating surface runoff (m s-1) + integer(i4b) :: scalarMaxInfilRate = integerMissing ! maximum infiltration rate (m s-1) + 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) :: 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) + integer(i4b) :: mLayerHydCond = integerMissing ! hydraulic conductivity in each soil layer (m s-1) + integer(i4b) :: iLayerLiqFluxSoil = integerMissing ! liquid flux at soil layer interfaces (m s-1) + integer(i4b) :: mLayerLiqFluxSoil = integerMissing ! net liquid water flux for each soil layer (s-1) + integer(i4b) :: mLayerBaseflow = integerMissing ! baseflow from each soil layer (m s-1) + integer(i4b) :: mLayerColumnInflow = integerMissing ! total inflow to each layer in a given soil column (m3 s-1) + integer(i4b) :: mLayerColumnOutflow = integerMissing ! total outflow from each layer in a given soil column (m3 s-1) + integer(i4b) :: scalarSoilBaseflow = integerMissing ! total baseflow from throughout the soil profile (m s-1) + integer(i4b) :: scalarSoilDrainage = integerMissing ! drainage from the bottom of the soil profile (m s-1) + integer(i4b) :: scalarAquiferRecharge = integerMissing ! recharge to the aquifer (m s-1) + integer(i4b) :: scalarAquiferTranspire = integerMissing ! transpiration from the aquifer (m s-1) + integer(i4b) :: scalarAquiferBaseflow = integerMissing ! baseflow from the aquifer (m s-1) + endtype iLook_flux + + ! *********************************************************************************************************** + ! (9) define derivatives ! *********************************************************************************************************** - ! (6) define model variables - ! *********************************************************************************************************** - type, public :: iLook_mvar - ! define timestep-average fluxes for a few key variables - integer(i4b) :: totalSoilCompress = 1 ! change in total soil storage due to compression of the soil matrix (kg m-2) - integer(i4b) :: averageThroughfallSnow = 2 ! snow that reaches the ground without ever touching the canopy (kg m-2 s-1) - integer(i4b) :: averageThroughfallRain = 3 ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) - integer(i4b) :: averageCanopySnowUnloading = 4 ! unloading of snow from the vegetion canopy (kg m-2 s-1) - integer(i4b) :: averageCanopyLiqDrainage = 5 ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) - integer(i4b) :: averageCanopyMeltFreeze = 6 ! melt/freeze of water stored in the canopy (kg m-2 s-1) - integer(i4b) :: averageCanopyTranspiration = 7 ! canopy transpiration (kg m-2 s-1) - integer(i4b) :: averageCanopyEvaporation = 8 ! canopy evaporation/condensation (kg m-2 s-1) - integer(i4b) :: averageCanopySublimation = 9 ! canopy sublimation/frost (kg m-2 s-1) - integer(i4b) :: averageSnowSublimation = 10 ! snow sublimation/frost - below canopy or non-vegetated (kg m-2 s-1) - integer(i4b) :: averageGroundEvaporation = 11 ! ground evaporation/condensation - below canopy or non-vegetated (kg m-2 s-1) - integer(i4b) :: averageRainPlusMelt = 12 ! rain plus melt, as input to soil before calculating surface runoff (m s-1) - integer(i4b) :: averageSurfaceRunoff = 13 ! surface runoff (m s-1) - integer(i4b) :: averageSoilInflux = 14 ! influx of water at the top of the soil profile (m s-1) - integer(i4b) :: averageSoilBaseflow = 15 ! total baseflow from throughout the soil profile (m s-1) - integer(i4b) :: averageSoilDrainage = 16 ! drainage from the bottom of the soil profile (m s-1) - integer(i4b) :: averageAquiferRecharge = 17 ! recharge to the aquifer (m s-1) - integer(i4b) :: averageAquiferBaseflow = 18 ! baseflow from the aquifer (m s-1) - integer(i4b) :: averageAquiferTranspire = 19 ! transpiration from the aquifer (m s-1) - integer(i4b) :: averageColumnOutflow = 20 ! outflow from each layer in the soil profile (m3 s-1) - ! define scalar variables -- forcing - integer(i4b) :: scalarCosZenith = 21 ! cosine of the solar zenith angle (0-1) - integer(i4b) :: scalarFractionDirect = 22 ! fraction of direct radiation (0-1) - integer(i4b) :: spectralIncomingDirect = 23 ! incoming direct solar radiation in each wave band (W m-2) - integer(i4b) :: spectralIncomingDiffuse = 24 ! incoming diffuse solar radiation in each wave band (W m-2) - integer(i4b) :: scalarVPair = 25 ! vapor pressure of the air above the vegetation canopy (Pa) - integer(i4b) :: scalarTwetbulb = 26 ! wet bulb temperature (K) - integer(i4b) :: scalarRainfall = 27 ! computed rainfall rate (kg m-2 s-1) - integer(i4b) :: scalarSnowfall = 28 ! computed snowfall rate (kg m-2 s-1) - integer(i4b) :: scalarSnowfallTemp = 29 ! temperature of fresh snow (K) - integer(i4b) :: scalarNewSnowDensity = 30 ! density of fresh snow, should snow be falling in this time step (kg m-3) - integer(i4b) :: scalarO2air = 31 ! atmospheric o2 concentration (Pa) - integer(i4b) :: scalarCO2air = 32 ! atmospheric co2 concentration (Pa) - ! define scalar variables -- state variables - integer(i4b) :: scalarCanopyIce = 33 ! mass of ice on the vegetation canopy (kg m-2) - integer(i4b) :: scalarCanopyLiq = 34 ! mass of liquid water on the vegetation canopy (kg m-2) - integer(i4b) :: scalarCanairTemp = 35 ! temperature of the canopy air space (Pa) - integer(i4b) :: scalarCanopyTemp = 36 ! temperature of the vegetation canopy (K) - integer(i4b) :: scalarSnowAge = 37 ! non-dimensional snow age (-) - integer(i4b) :: scalarSnowAlbedo = 38 ! snow albedo for the entire spectral band (-) - integer(i4b) :: spectralSnowAlbedoDirect = 39 ! direct snow albedo for individual spectral bands (-) - integer(i4b) :: spectralSnowAlbedoDiffuse = 40 ! diffuse snow albedo for individual spectral bands (-) - integer(i4b) :: scalarSnowDepth = 41 ! total snow depth (m) - integer(i4b) :: scalarSWE = 42 ! snow water equivalent (kg m-2) - integer(i4b) :: scalarSfcMeltPond = 43 ! ponded water caused by melt of the "snow without a layer" (kg m-2) - integer(i4b) :: scalarAquiferStorage = 44 ! relative aquifer storage -- above bottom of the soil profile (m) - integer(i4b) :: scalarSurfaceTemp = 45 ! surface temperature (K) - ! define NOAH-MP vegetation variables -- general - integer(i4b) :: scalarGreenVegFraction = 46 ! green vegetation fraction used to compute LAI (-) - integer(i4b) :: scalarBulkVolHeatCapVeg = 47 ! bulk volumetric heat capacity of vegetation (J m-3 K-1) - integer(i4b) :: scalarRootZoneTemp = 48 ! average temperature of the root zone (K) - integer(i4b) :: scalarLAI = 49 ! one-sided leaf area index (m2 m-2) - integer(i4b) :: scalarSAI = 50 ! one-sided stem area index (m2 m-2) - integer(i4b) :: scalarExposedLAI = 51 ! exposed leaf area index after burial by snow (m2 m-2) - integer(i4b) :: scalarExposedSAI = 52 ! exposed stem area index after burial by snow(m2 m-2) - integer(i4b) :: scalarCanopyIceMax = 53 ! maximum interception storage capacity for ice (kg m-2) - integer(i4b) :: scalarCanopyLiqMax = 54 ! maximum interception storage capacity for liquid water (kg m-2) - integer(i4b) :: scalarGrowingSeasonIndex = 55 ! growing season index (0=off, 1=on) - integer(i4b) :: scalarVP_CanopyAir = 56 ! vapor pressure of the canopy air space (Pa) - ! define NOAH-MP vegetation variables -- shortwave radiation - integer(i4b) :: scalarCanopySunlitFraction = 57 ! sunlit fraction of canopy (-) - integer(i4b) :: scalarCanopySunlitLAI = 58 ! sunlit leaf area (-) - integer(i4b) :: scalarCanopyShadedLAI = 59 ! shaded leaf area (-) - integer(i4b) :: scalarCanopySunlitPAR = 60 ! average absorbed par for sunlit leaves (w m-2) - integer(i4b) :: scalarCanopyShadedPAR = 61 ! average absorbed par for shaded leaves (w m-2) - integer(i4b) :: spectralBelowCanopyDirect = 62 ! downward direct flux below veg layer for each spectral band W m-2) - integer(i4b) :: spectralBelowCanopyDiffuse = 63 ! downward diffuse flux below veg layer for each spectral band (W m-2) - integer(i4b) :: scalarBelowCanopySolar = 64 ! solar radiation transmitted below the canopy (W m-2) - integer(i4b) :: spectralAlbGndDirect = 65 ! direct albedo of underlying surface for each spectral band (-) - integer(i4b) :: spectralAlbGndDiffuse = 66 ! diffuse albedo of underlying surface for each spectral band (-) - integer(i4b) :: scalarGroundAlbedo = 67 ! albedo of the ground surface (-) - integer(i4b) :: scalarCanopyAbsorbedSolar = 68 ! solar radiation absorbed by canopy (W m-2) - integer(i4b) :: scalarGroundAbsorbedSolar = 69 ! solar radiation absorbed by ground (W m-2) - ! define NOAH-MP vegetation variables -- longwave radiation - integer(i4b) :: scalarCanopyEmissivity = 70 ! effective canopy emissivity (-) - integer(i4b) :: scalarLWRadCanopy = 71 ! longwave radiation emitted from the canopy (W m-2) - integer(i4b) :: scalarLWRadGround = 72 ! longwave radiation emitted at the ground surface (W m-2) - integer(i4b) :: scalarLWRadUbound2Canopy = 73 ! downward atmospheric longwave radiation absorbed by the canopy (W m-2) - integer(i4b) :: scalarLWRadUbound2Ground = 74 ! downward atmospheric longwave radiation absorbed by the ground (W m-2) - integer(i4b) :: scalarLWRadUbound2Ubound = 75 ! atmospheric radiation refl by ground + lost thru upper boundary (W m-2) - integer(i4b) :: scalarLWRadCanopy2Ubound = 76 ! longwave radiation emitted from canopy lost thru upper boundary (W m-2) - integer(i4b) :: scalarLWRadCanopy2Ground = 77 ! longwave radiation emitted from canopy absorbed by the ground (W m-2) - integer(i4b) :: scalarLWRadCanopy2Canopy = 78 ! canopy longwave reflected from ground and absorbed by the canopy (W m-2) - integer(i4b) :: scalarLWRadGround2Ubound = 79 ! longwave radiation emitted from ground lost thru upper boundary (W m-2) - integer(i4b) :: scalarLWRadGround2Canopy = 80 ! longwave radiation emitted from ground and absorbed by the canopy (W m-2) - integer(i4b) :: scalarLWNetCanopy = 81 ! net longwave radiation at the canopy (W m-2) - integer(i4b) :: scalarLWNetGround = 82 ! net longwave radiation at the ground surface (W m-2) - integer(i4b) :: scalarLWNetUbound = 83 ! net longwave radiation at the upper atmospheric boundary (W m-2) - ! define NOAH-MP vegetation variables -- turbulent heat transfer - integer(i4b) :: scalarLatHeatSubVapCanopy = 84 ! latent heat of sublimation/vaporization used for veg canopy (J kg-1) - integer(i4b) :: scalarLatHeatSubVapGround = 85 ! latent heat of sublimation/vaporization used for ground surface (J kg-1) - integer(i4b) :: scalarSatVP_CanopyTemp = 86 ! saturation vapor pressure at the temperature of vegetation canopy (Pa) - integer(i4b) :: scalarSatVP_GroundTemp = 87 ! saturation vapor pressure at the temperature of the ground (Pa) - integer(i4b) :: scalarZ0Canopy = 88 ! roughness length of the canopy (m) - integer(i4b) :: scalarWindReductionFactor = 89 ! canopy wind reduction factor (-) - integer(i4b) :: scalarZeroPlaneDisplacement = 90 ! zero plane displacement (m) - integer(i4b) :: scalarRiBulkCanopy = 91 ! bulk Richardson number for the canopy (-) - integer(i4b) :: scalarRiBulkGround = 92 ! bulk Richardson number for the ground surface (-) - integer(i4b) :: scalarCanopyStabilityCorrection = 93 ! stability correction for the canopy (-) - integer(i4b) :: scalarGroundStabilityCorrection = 94 ! stability correction for the ground surface (-) - integer(i4b) :: scalarEddyDiffusCanopyTop = 95 ! eddy diffusivity for heat at the top of the canopy (m2 s-1) - integer(i4b) :: scalarFrictionVelocity = 96 ! friction velocity - canopy momentum sink (m s-1) - integer(i4b) :: scalarWindspdCanopyTop = 97 ! windspeed at the top of the canopy (m s-1) - integer(i4b) :: scalarWindspdCanopyBottom = 98 ! windspeed at the height of the bottom of the canopy (m s-1) - integer(i4b) :: scalarGroundResistance = 99 ! below canopy aerodynamic resistance (s m-1) - integer(i4b) :: scalarCanopyResistance = 100 ! above canopy aerodynamic resistance (s m-1) - integer(i4b) :: scalarLeafResistance = 101 ! mean leaf boundary layer resistance per unit leaf area (s m-1) - integer(i4b) :: scalarSoilResistance = 102 ! soil surface resistance (s m-1) - integer(i4b) :: scalarSoilRelHumidity = 103 ! relative humidity in the soil pores in the upper-most soil layer (-) - integer(i4b) :: scalarSenHeatTotal = 104 ! sensible heat from the canopy air space to the atmosphere (W m-2) - integer(i4b) :: scalarSenHeatCanopy = 105 ! sensible heat from the canopy to the canopy air space (W m-2) - integer(i4b) :: scalarSenHeatGround = 106 ! sensible heat from the ground (below canopy or non-vegetated) (W m-2) - integer(i4b) :: scalarLatHeatTotal = 107 ! latent heat from the canopy air space to the atmosphere (W m-2) - integer(i4b) :: scalarLatHeatCanopyEvap = 108 ! evaporation latent heat from the canopy to the canopy air space (W m-2) - integer(i4b) :: scalarLatHeatCanopyTrans = 109 ! transpiration latent heat from the canopy to the canopy air space (W m-2) - integer(i4b) :: scalarLatHeatGround = 110 ! latent heat from the ground (below canopy or non-vegetated) (W m-2) - integer(i4b) :: scalarCanopyAdvectiveHeatFlux = 111 ! heat advected to the canopy surface with rain + snow (W m-2) - integer(i4b) :: scalarGroundAdvectiveHeatFlux = 112 ! heat advected to the ground surface with throughfall and unloading/drainage (W m-2) - integer(i4b) :: scalarCanopyTranspiration = 113 ! canopy transpiration (kg m-2 s-1) - integer(i4b) :: scalarCanopyEvaporation = 114 ! canopy evaporation/condensation (kg m-2 s-1) - integer(i4b) :: scalarCanopySublimation = 115 ! canopy sublimation/frost (kg m-2 s-1) - integer(i4b) :: scalarGroundEvaporation = 116 ! ground evaporation/condensation (below canopy or non-vegetated) (kg m-2 s-1) - integer(i4b) :: scalarSnowSublimation = 117 ! snow sublimation/frost (below canopy or non-vegetated) (kg m-2 s-1) - ! define NOAH-MP vegetation variables -- transpiration - integer(i4b) :: scalarTranspireLim = 118 ! aggregate soil moisture + aquifer storage limit on transpiration (-) - integer(i4b) :: scalarTranspireLimAqfr = 119 ! aquifer storage limit on transpiration (-) - integer(i4b) :: scalarFoliageNitrogenFactor = 120 ! foliage nitrogen concentration, 1=saturated (-) - integer(i4b) :: scalarStomResistSunlit = 121 ! stomatal resistance for sunlit leaves (s m-1) - integer(i4b) :: scalarStomResistShaded = 122 ! stomatal resistance for shaded leaves (s m-1) - integer(i4b) :: scalarPhotosynthesisSunlit = 123 ! sunlit photosynthesis (umolco2 m-2 s-1) - integer(i4b) :: scalarPhotosynthesisShaded = 124 ! shaded photosynthesis (umolco2 m-2 s-1) - integer(i4b) :: scalarIntercellularCO2Sunlit = 125 ! carbon dioxide partial pressure of leaf interior (sunlit leaves) (Pa) - integer(i4b) :: scalarIntercellularCO2Shaded = 126 ! carbon dioxide partial pressure of leaf interior (shaded leaves) (Pa) - ! define vegetation variables -- canopy water - integer(i4b) :: scalarCanopyWetFraction = 127 ! fraction of canopy that is wet - integer(i4b) :: scalarGroundSnowFraction = 128 ! fraction of ground that is covered with snow (-) - integer(i4b) :: scalarThroughfallSnow = 129 ! snow that reaches the ground without ever touching the canopy (kg m-2 s-1) - integer(i4b) :: scalarThroughfallRain = 130 ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) - integer(i4b) :: scalarCanopySnowUnloading = 131 ! unloading of snow from the vegetion canopy (kg m-2 s-1) - integer(i4b) :: scalarCanopyLiqDrainage = 132 ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) - integer(i4b) :: scalarCanopyMeltFreeze = 133 ! melt/freeze of water stored in the canopy (kg m-2 s-1) - ! define scalar variables -- soil and aquifer fluxes - integer(i4b) :: scalarRainPlusMelt = 134 ! rain plus melt, as input to soil before calculating surface runoff (m s-1) - integer(i4b) :: scalarInfilArea = 135 ! fraction of unfrozen area where water can infiltrate (-) - integer(i4b) :: scalarFrozenArea = 136 ! fraction of area that is considered impermeable due to soil ice (-) - integer(i4b) :: scalarInfiltration = 137 ! infiltration of water into the soil profile (m s-1) - integer(i4b) :: scalarExfiltration = 138 ! exfiltration of water from the top of the soil profile (m s-1) - integer(i4b) :: scalarSurfaceRunoff = 139 ! surface runoff (m s-1) - integer(i4b) :: scalarInitAquiferRecharge = 140 ! recharge to the aquifer at the start of the step (m s-1) - integer(i4b) :: scalarAquiferRecharge = 141 ! recharge to the aquifer (m s-1) - integer(i4b) :: scalarInitAquiferTranspire = 142 ! transpiration from the aquifer at the start of the step (m s-1) - integer(i4b) :: scalarAquiferTranspire = 143 ! transpiration from the aquifer (m s-1) - integer(i4b) :: scalarInitAquiferBaseflow = 144 ! baseflow from the aquifer at the start of the step (m s-1) - integer(i4b) :: scalarAquiferBaseflow = 145 ! baseflow from the aquifer (m s-1) - ! scalar variables -- sub-step average fluxes for the soil zone - integer(i4b) :: scalarSoilInflux = 146 ! influx of water at the top of the soil profile (m s-1) - integer(i4b) :: scalarSoilCompress = 147 ! change in total soil storage due to compression of the soil matrix (kg m-2) - integer(i4b) :: scalarSoilBaseflow = 148 ! sub-step average: total baseflow from throughout the soil profile (m s-1) - integer(i4b) :: scalarSoilDrainage = 149 ! sub-step average: drainage from the bottom of the soil profile (m s-1) - integer(i4b) :: scalarSoilTranspiration = 150 ! sub-step average: total transpiration from the soil (m s-1) - ! define scalar variables -- mass balance check - integer(i4b) :: scalarSoilWatBalError = 151 ! error in the total soil water balance (kg m-2) - integer(i4b) :: scalarAquiferBalError = 152 ! error in the aquifer water balance (kg m-2) - integer(i4b) :: scalarTotalSoilLiq = 153 ! total mass of liquid water in the soil (kg m-2) - integer(i4b) :: scalarTotalSoilIce = 154 ! total mass of ice in the soil (kg m-2) - ! define variables at the mid-point of each layer -- domain geometry - integer(i4b) :: mLayerDepth = 155 ! depth of each layer (m) - integer(i4b) :: mLayerHeight = 156 ! height at the mid-point of each layer (m) - integer(i4b) :: mLayerRootDensity = 157 ! fraction of roots in each soil layer (-) - ! define variables at the mid-point of each layer -- coupled energy and mass - integer(i4b) :: mLayerTemp = 158 ! temperature of each layer (K) - integer(i4b) :: mLayerVolFracAir = 159 ! volumetric fraction of air in each layer (-) - integer(i4b) :: mLayerVolFracIce = 160 ! volumetric fraction of ice water in each layer (-) - integer(i4b) :: mLayerVolFracLiq = 161 ! volumetric fraction of liquid water in each layer (-) - integer(i4b) :: mLayerVolHtCapBulk = 162 ! volumetric heat capacity in each layer (J m-3 K-1) - integer(i4b) :: mLayerTcrit = 163 ! critical soil temperature above which all water is unfrozen (K) - integer(i4b) :: mLayerdTheta_dTk = 164 ! derivative in volumetric liquid water content wrt temperature (K-1) - integer(i4b) :: mLayerThermalC = 165 ! thermal conductivity at the mid-point of each layer (W m-1 K-1) - integer(i4b) :: mLayerRadCondFlux = 166 ! temporal derivative in energy from radiative and conductive flux (J m-2 s-1) - integer(i4b) :: mLayerMeltFreeze = 167 ! rate of ice content change from melt/freeze in each layer (kg m-3 s-1) - integer(i4b) :: mLayerInfilFreeze = 168 ! rate of ice content change by freezing infiltrating flux (kg m-3 s-1) - integer(i4b) :: mLayerSatHydCond = 169 ! saturated hydraulic conductivity in each layer (m s-1) - integer(i4b) :: mLayerSatHydCondMP = 170 ! saturated hydraulic conductivity of macropores in each layer (m s-1) - integer(i4b) :: mLayerMatricHead = 171 ! matric head of water in the soil (m) - integer(i4b) :: mLayerdTheta_dPsi = 172 ! derivative in the soil water characteristic (m-1) - integer(i4b) :: mLayerdPsi_dTheta = 173 ! derivative in the soil water characteristic (m) - integer(i4b) :: mLayerThetaResid = 174 ! residual volumetric water content in each snow layer (-) - integer(i4b) :: mLayerPoreSpace = 175 ! total pore space in each snow layer (-) - integer(i4b) :: mLayerCompress = 176 ! change in volumetric water content due to compression of soil (-) - integer(i4b) :: mLayerTranspireLim = 177 ! soil moist & veg limit on transpiration for each layer (-) - integer(i4b) :: mLayerInitTranspire = 178 ! transpiration loss from each soil layer at the start of the step (kg m-2 s-1) - integer(i4b) :: mLayerTranspire = 179 ! transpiration loss from each soil layer (kg m-2 s-1) - integer(i4b) :: mLayerInitQMacropore = 180 ! liquid flux from micropores to macropores at the start-of-step (m s-1) - integer(i4b) :: mLayerQMacropore = 181 ! liquid flux from micropores to macropores (m s-1) - integer(i4b) :: mLayerInitBaseflow = 182 ! baseflow from each soil layer at the start of the time step (m s-1) - integer(i4b) :: mLayerBaseflow = 183 ! baseflow from each soil layer (m s-1) - integer(i4b) :: mLayerColumnInflow = 184 ! total inflow to each layer in a given soil column (m3 s-1) - integer(i4b) :: mLayerColumnOutflow = 185 ! total outflow from each layer in a given soil column (m3 s-1) - ! define variables at the interface of each layer - integer(i4b) :: iLayerHeight = 186 ! height of the layer interface; top of soil = 0 (m) - integer(i4b) :: iLayerThermalC = 187 ! thermal conductivity at the interface of each layer (W m-1 K-1) - integer(i4b) :: iLayerConductiveFlux = 188 ! conductive energy flux at layer interfaces at end of time step (W m-2) - integer(i4b) :: iLayerAdvectiveFlux = 189 ! advective energy flux at layer interfaces at end of time step (W m-2) - integer(i4b) :: iLayerInitNrgFlux = 190 ! energy flux at layer interfaces at the start of the time step (W m-2) - integer(i4b) :: iLayerNrgFlux = 191 ! energy flux at layer interfaces at the end of the time step (W m-2) - integer(i4b) :: iLayerSatHydCond = 192 ! saturated hydraulic conductivity at each layer interface (m s-1) - integer(i4b) :: iLayerInitLiqFluxSnow = 193 ! liquid flux at snow layer interfaces at the start of the time step (m s-1) - integer(i4b) :: iLayerInitLiqFluxSoil = 194 ! liquid flux at soil layer interfaces at the start of the time step (m s-1) - integer(i4b) :: iLayerInitFluxReversal = 195 ! start of step liquid flux at soil layer interfaces from impedance (m s-1) - integer(i4b) :: iLayerLiqFluxSnow = 196 ! liquid flux at snow layer interfaces at the end of the time step (m s-1) - integer(i4b) :: iLayerLiqFluxSoil = 197 ! liquid flux at soil layer interfaces at the end of the time step (m s-1) - integer(i4b) :: iLayerFluxReversal = 198 ! end of step liquid flux at soil layer interfaces from impedance (m s-1) - ! define variables for time stepping - integer(i4b) :: dt_init = 199 ! length of initial time step at start of next data interval (s) - ! define derived variable - integer(i4b) :: scalarVGn_m = 200 ! van Genuchten "m" parameter (-) - integer(i4b) :: scalarKappa = 201 ! constant in the freezing curve function (m K-1) - integer(i4b) :: scalarVolHtCap_air = 202 ! volumetric heat capacity air (J m-3 K-1) - integer(i4b) :: scalarVolHtCap_ice = 203 ! volumetric heat capacity ice (J m-3 K-1) - integer(i4b) :: scalarVolHtCap_soil = 204 ! volumetric heat capacity dry soil (J m-3 K-1) - integer(i4b) :: scalarVolHtCap_water = 205 ! volumetric heat capacity liquid wat (J m-3 K-1) - integer(i4b) :: scalarLambda_drysoil = 206 ! thermal conductivity of dry soil (W m-1) - integer(i4b) :: scalarLambda_wetsoil = 207 ! thermal conductivity of wet soil (W m-1) - integer(i4b) :: scalarVolLatHt_fus = 208 ! volumetric latent heat of fusion (J m-3) - integer(i4b) :: scalarAquiferRootFrac = 209 ! fraction of roots below the soil profile (-) - endtype iLook_mvar - - ! *********************************************************************************************************** - ! (6) define model indices + type, public :: iLook_deriv + ! derivatives in net vegetation energy fluxes w.r.t. relevant state variables + integer(i4b) :: dCanairNetFlux_dCanairTemp = integerMissing ! derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) + integer(i4b) :: dCanairNetFlux_dCanopyTemp = integerMissing ! derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) + integer(i4b) :: dCanairNetFlux_dGroundTemp = integerMissing ! derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) + 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) :: 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) + ! 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) :: 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) :: dTheta_dTkCanopy = integerMissing ! derivative of volumetric liquid water content w.r.t. temperature (K-1) + integer(i4b) :: dCanLiq_dTcanopy = integerMissing ! derivative of canopy liquid storage w.r.t. temperature (kg m-2 K-1) + ! 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) + ! 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) + ! 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) :: 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) :: 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) + ! 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) :: 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 (-) + endtype iLook_deriv + + ! *********************************************************************************************************** + ! (10) define model indices ! *********************************************************************************************************** type, public :: iLook_index - integer(i4b) :: nSnow = 1 ! number of snow layers - integer(i4b) :: nSoil = 2 ! number of soil layers - integer(i4b) :: nLayers = 3 ! total number of layers - integer(i4b) :: midSnowStartIndex = 4 ! start index of the midSnow vector for a given timestep - integer(i4b) :: midSoilStartIndex = 5 ! start index of the midSoil vector for a given timestep - integer(i4b) :: midTotoStartIndex = 6 ! start index of the midToto vector for a given timestep - integer(i4b) :: ifcSnowStartIndex = 7 ! start index of the ifcSnow vector for a given timestep - integer(i4b) :: ifcSoilStartIndex = 8 ! start index of the ifcSoil vector for a given timestep - integer(i4b) :: ifcTotoStartIndex = 9 ! start index of the ifcToto vector for a given timestep - integer(i4b) :: layerType = 10 ! type of layer (soil or snow) + ! number of model layers, and layer indices + integer(i4b) :: nSnow = integerMissing ! number of snow layers (-) + integer(i4b) :: nSoil = integerMissing ! number of soil layers (-) + integer(i4b) :: nLayers = integerMissing ! total number of layers (-) + integer(i4b) :: layerType = integerMissing ! index defining type of layer (snow or soil) (-) + ! number of state variables of different type + integer(i4b) :: nCasNrg = integerMissing ! number of energy state variables for the canopy air space (-) + integer(i4b) :: nVegNrg = integerMissing ! number of energy state variables for the vegetation canopy (-) + integer(i4b) :: nVegMass = integerMissing ! number of hydrology states for vegetation (mass of water) (-) + integer(i4b) :: nVegState = integerMissing ! number of vegetation state variables (-) + integer(i4b) :: nNrgState = integerMissing ! number of energy state variables (-) + integer(i4b) :: nWatState = integerMissing ! number of "total water" states (vol. total water content) (-) + integer(i4b) :: nMatState = integerMissing ! number of matric head state variables (-) + integer(i4b) :: nMassState = integerMissing ! number of hydrology state variables (mass of water) (-) + integer(i4b) :: nState = integerMissing ! total number of model state variables (-) + ! number of state variables within different domains in the snow+soil system + integer(i4b) :: nSnowSoilNrg = integerMissing ! number of energy states in the snow+soil domain (-) + integer(i4b) :: nSnowOnlyNrg = integerMissing ! number of energy states in the snow domain (-) + integer(i4b) :: nSoilOnlyNrg = integerMissing ! number of energy states in the soil domain (-) + integer(i4b) :: nSnowSoilHyd = integerMissing ! number of hydrology states in the snow+soil domain (-) + integer(i4b) :: nSnowOnlyHyd = integerMissing ! number of hydrology states in the snow domain (-) + integer(i4b) :: nSoilOnlyHyd = integerMissing ! number of hydrology states in the soil domain (-) + ! type of model state variables + integer(i4b) :: ixControlVolume = integerMissing ! index of the control volume for different domains (veg, snow, soil) (-) + integer(i4b) :: ixDomainType = integerMissing ! index of the type of domain (iname_veg, iname_snow, iname_soil) (-) + integer(i4b) :: ixStateType = integerMissing ! index of the type of every state variable (iname_nrgCanair, ...) (-) + integer(i4b) :: ixHydType = integerMissing ! index of the type of hydrology states in snow+soil domain (-) + ! type of model state variables (state subset) + integer(i4b) :: ixDomainType_subset= integerMissing ! [state subset] id of domain for desired model state variables (-) + integer(i4b) :: ixStateType_subset = integerMissing ! [state subset] type of desired model state variables (-) + ! mapping between state subset and the full state vector + integer(i4b) :: ixMapFull2Subset = integerMissing ! list of indices of the state subset in the full state vector (-) + integer(i4b) :: ixMapSubset2Full = integerMissing ! list of indices of the full state vector in the state subset (-) + ! indices of model specific state variables + integer(i4b) :: ixCasNrg = integerMissing ! index IN THE STATE SUBSET of canopy air space energy state variable (-) + integer(i4b) :: ixVegNrg = integerMissing ! index IN THE STATE SUBSET of canopy energy state variable (-) + integer(i4b) :: ixVegHyd = integerMissing ! index IN THE STATE SUBSET of canopy hydrology state variable (mass) (-) + integer(i4b) :: ixTopNrg = integerMissing ! index IN THE STATE SUBSET of upper-most energy state in snow+soil domain (-) + integer(i4b) :: ixTopHyd = integerMissing ! index IN THE STATE SUBSET of upper-most hydrol state in snow+soil domain (-) + ! vectors of indices for specific state types + integer(i4b) :: ixNrgOnly = integerMissing ! indices IN THE STATE SUBSET for all energy states (-) + integer(i4b) :: ixHydOnly = integerMissing ! indices IN THE STATE SUBSET for hydrology states in the snow+soil domain (-) + integer(i4b) :: ixMatOnly = integerMissing ! indices IN THE STATE SUBSET for matric head state variables (-) + integer(i4b) :: ixMassOnly = integerMissing ! indices IN THE STATE SUBSET for hydrology states (mass of water) (-) + ! vectors of indices for specific state types within specific sub-domains + integer(i4b) :: ixSnowSoilNrg = integerMissing ! indices IN THE STATE SUBSET for energy states in the snow+soil domain (-) + integer(i4b) :: ixSnowOnlyNrg = integerMissing ! indices IN THE STATE SUBSET for energy states in the snow domain (-) + integer(i4b) :: ixSoilOnlyNrg = integerMissing ! indices IN THE STATE SUBSET for energy states in the soil domain (-) + integer(i4b) :: ixSnowSoilHyd = integerMissing ! indices IN THE STATE SUBSET for hydrology states in the snow+soil domain (-) + integer(i4b) :: ixSnowOnlyHyd = integerMissing ! indices IN THE STATE SUBSET for hydrology states in the snow domain (-) + integer(i4b) :: ixSoilOnlyHyd = integerMissing ! indices IN THE STATE SUBSET for hydrology states in the soil domain (-) + ! vectors of indices for specfic state types within specific sub-domains + integer(i4b) :: ixNrgCanair = integerMissing ! indices IN THE FULL VECTOR for energy states in canopy air space domain (-) + integer(i4b) :: ixNrgCanopy = integerMissing ! indices IN THE FULL VECTOR for energy states in the canopy domain (-) + integer(i4b) :: ixHydCanopy = integerMissing ! indices IN THE FULL VECTOR for hydrology states in the canopy domain (-) + integer(i4b) :: ixNrgLayer = integerMissing ! indices IN THE FULL VECTOR for energy states in the snow+soil domain (-) + integer(i4b) :: ixHydLayer = integerMissing ! indices IN THE FULL VECTOR for hydrology states in the snow+soil domain (-) + ! vectors of indices for specific state types IN SPECIFIC SUB-DOMAINS + integer(i4b) :: ixVolFracWat = integerMissing ! indices IN THE SNOW+SOIL VECTOR for hyd states (-) + integer(i4b) :: ixMatricHead = integerMissing ! indices IN THE SOIL VECTOR for hyd states (-) + ! indices within state vectors + integer(i4b) :: ixAllState = integerMissing ! list of indices for all model state variables (-) + integer(i4b) :: ixSoilState = integerMissing ! list of indices for all soil layers (-) + integer(i4b) :: ixLayerState = integerMissing ! list of indices for all model layers (-) + ! indices for the model output files + integer(i4b) :: midSnowStartIndex = integerMissing ! start index of the midSnow vector for a given timestep (-) + integer(i4b) :: midSoilStartIndex = integerMissing ! start index of the midSoil vector for a given timestep (-) + integer(i4b) :: midTotoStartIndex = integerMissing ! start index of the midToto vector for a given timestep (-) + integer(i4b) :: ifcSnowStartIndex = integerMissing ! start index of the ifcSnow vector for a given timestep (-) + integer(i4b) :: ifcSoilStartIndex = integerMissing ! start index of the ifcSoil vector for a given timestep (-) + integer(i4b) :: ifcTotoStartIndex = integerMissing ! start index of the ifcToto vector for a given timestep (-) endtype iLook_index ! *********************************************************************************************************** - ! (7) define basin-average model parameters + ! (11) define basin-average model parameters ! *********************************************************************************************************** type, public :: iLook_bpar ! baseflow - integer(i4b) :: basin__aquiferHydCond = 1 ! hydraulic conductivity for the aquifer (m s-1) - integer(i4b) :: basin__aquiferScaleFactor = 2 ! scaling factor for aquifer storage in the big bucket (m) - integer(i4b) :: basin__aquiferBaseflowExp = 3 ! baseflow exponent for the big bucket (-) + integer(i4b) :: basin__aquiferHydCond = integerMissing ! hydraulic conductivity for the aquifer (m s-1) + integer(i4b) :: basin__aquiferScaleFactor = integerMissing ! scaling factor for aquifer storage in the big bucket (m) + integer(i4b) :: basin__aquiferBaseflowExp = integerMissing ! baseflow exponent for the big bucket (-) ! within-grid routing - integer(i4b) :: routingGammaShape = 4 ! shape parameter in Gamma distribution used for sub-grid routing (-) - integer(i4b) :: routingGammaScale = 5 ! scale parameter in Gamma distribution used for sub-grid routing (s) + integer(i4b) :: routingGammaShape = integerMissing ! shape parameter in Gamma distribution used for sub-grid routing (-) + integer(i4b) :: routingGammaScale = integerMissing ! scale parameter in Gamma distribution used for sub-grid routing (s) endtype iLook_bpar ! *********************************************************************************************************** - ! (8) define basin-average model variables + ! (12) define basin-average model variables ! *********************************************************************************************************** type, public :: iLook_bvar ! define derived variables - integer(i4b) :: basin__totalArea = 1 ! total basin area (m2) + integer(i4b) :: basin__totalArea = integerMissing ! total basin area (m2) ! define fluxes - integer(i4b) :: basin__SurfaceRunoff = 2 ! surface runoff (m s-1) - integer(i4b) :: basin__ColumnOutflow = 3 ! outflow from all "outlet" HRUs (those with no downstream HRU) - integer(i4b) :: basin__AquiferStorage = 4 ! aquifer storage (m s-1) - integer(i4b) :: basin__AquiferRecharge = 5 ! recharge to the aquifer (m s-1) - integer(i4b) :: basin__AquiferBaseflow = 6 ! baseflow from the aquifer (m s-1) - integer(i4b) :: basin__AquiferTranspire = 7 ! transpiration from the aquifer (m s-1) + integer(i4b) :: basin__SurfaceRunoff = integerMissing ! surface runoff (m s-1) + integer(i4b) :: basin__ColumnOutflow = integerMissing ! outflow from all "outlet" HRUs (those with no downstream HRU) + integer(i4b) :: basin__AquiferStorage = integerMissing ! aquifer storage (m s-1) + integer(i4b) :: basin__AquiferRecharge = integerMissing ! recharge to the aquifer (m s-1) + integer(i4b) :: basin__AquiferBaseflow = integerMissing ! baseflow from the aquifer (m s-1) + integer(i4b) :: basin__AquiferTranspire = integerMissing ! transpiration from the aquifer (m s-1) ! define variables for runoff - integer(i4b) :: routingRunoffFuture = 8 ! runoff in future time steps (m s-1) - integer(i4b) :: routingFractionFuture = 9 ! fraction of runoff in future time steps (-) - integer(i4b) :: averageInstantRunoff = 10 ! instantaneous runoff (m s-1) - integer(i4b) :: averageRoutedRunoff = 11 ! routed runoff (m s-1) + integer(i4b) :: routingRunoffFuture = integerMissing ! runoff in future time steps (m s-1) + integer(i4b) :: routingFractionFuture = integerMissing ! fraction of runoff in future time steps (-) + integer(i4b) :: averageInstantRunoff = integerMissing ! instantaneous runoff (m s-1) + integer(i4b) :: averageRoutedRunoff = integerMissing ! routed runoff (m s-1) endtype iLook_bvar + ! *********************************************************************************************************** + ! (10) structure for looking up the type of a model variable (this is only needed for backward + ! compatability, and should be removed eventually) + ! *********************************************************************************************************** + type, public :: iLook_varType + integer(i4b) :: scalarv = integerMissing ! scalar variables + integer(i4b) :: wLength = integerMissing ! # spectral bands + integer(i4b) :: midSnow = integerMissing ! mid-layer snow variables + integer(i4b) :: midSoil = integerMissing ! mid-layer soil variables + integer(i4b) :: midToto = integerMissing ! mid-layer, both snow and soil + integer(i4b) :: ifcSnow = integerMissing ! interface snow variables + integer(i4b) :: ifcSoil = integerMissing ! interface soil variables + integer(i4b) :: ifcToto = integerMissing ! interface, snow and soil + integer(i4b) :: parSoil = integerMissing ! soil depth + integer(i4b) :: routing = integerMissing ! routing variables + integer(i4b) :: outstat = integerMissing ! output statistic + integer(i4b) :: unknown = integerMissing ! cath-cal alternative type + endtype iLook_varType + + ! *********************************************************************************************************** + ! (11) structure for looking up statistics + ! *********************************************************************************************************** + type, public :: iLook_stat + integer(i4b) :: totl = integerMissing ! summation + integer(i4b) :: inst = integerMissing ! instantaneous + integer(i4b) :: mean = integerMissing ! mean over period + integer(i4b) :: vari = integerMissing ! variance over period + integer(i4b) :: mini = integerMissing ! minimum over period + integer(i4b) :: maxi = integerMissing ! maximum over period + integer(i4b) :: mode = integerMissing ! mode over period + endtype iLook_stat + ! *********************************************************************************************************** ! (X) define data structures and maximum number of variables of each type ! *********************************************************************************************************** - ! define look-up structures + + ! named variables: model decisions 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) + + ! named variables: model time type(iLook_time), public,parameter :: iLookTIME =iLook_time ( 1, 2, 3, 4, 5) + + ! 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) + + ! named variables: soil and vegetation types type(iLook_type), public,parameter :: iLookTYPE =iLook_type ( 1, 2, 3, 4, 5) + + ! 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,& 21, 22, 23, 24, 25, 26, 27, 28, 29, 30,& @@ -585,8 +761,16 @@ MODULE var_lookup 111,112,113,114,115,116,117,118,119,120,& 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) - type(iLook_mvar), public,parameter :: iLookMVAR =ilook_mvar ( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,& + 141,142,143,144,145,146,147,148,149,150,& + 151,152,153,154) + + ! 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) + + ! 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,& 21, 22, 23, 24, 25, 26, 27, 28, 29, 30,& 31, 32, 33, 34, 35, 36, 37, 38, 39, 40,& @@ -594,34 +778,68 @@ 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, 90,& - 91, 92, 93, 94, 95, 96, 97, 98, 99,100,& - 101,102,103,104,105,106,107,108,109,110,& - 111,112,113,114,115,116,117,118,119,120,& - 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,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,190,& - 191,192,193,194,195,196,197,198,199,200,& - 201,202,203,204,205,206,207,208,209) - type(iLook_index), public,parameter :: iLookINDEX =ilook_index ( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10) + 81) + ! 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,& + 21, 22, 23, 24, 25, 26, 27, 28, 29, 30,& + 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, 83, 84, 85, 86) + + ! 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) + + ! 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,& + 21, 22, 23, 24, 25, 26, 27, 28, 29, 30,& + 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) + + ! 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) + 11) + + ! 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) + ! define maximum number of variables of each type - integer(i4b),parameter,public :: maxvarDecisions= 38 - integer(i4b),parameter,public :: maxvarTime = 5 - integer(i4b),parameter,public :: maxvarForc = 8 - integer(i4b),parameter,public :: maxvarAttr = 7 - integer(i4b),parameter,public :: maxvarType = 5 - integer(i4b),parameter,public :: maxvarMpar = 147 - integer(i4b),parameter,public :: maxvarMvar = 209 - integer(i4b),parameter,public :: maxvarIndx = 10 - integer(i4b),parameter,public :: maxvarBpar = 5 - integer(i4b),parameter,public :: maxvarBvar = 11 + integer(i4b),parameter,public :: maxvarDecisions = storage_size(iLookDECISIONS)/iLength + integer(i4b),parameter,public :: maxvarTime = storage_size(iLookTIME)/iLength + integer(i4b),parameter,public :: maxvarForc = storage_size(iLookFORCE)/iLength + integer(i4b),parameter,public :: maxvarAttr = storage_size(iLookATTR)/iLength + integer(i4b),parameter,public :: maxvarType = storage_size(iLookTYPE)/iLength + integer(i4b),parameter,public :: maxvarMpar = storage_size(iLookPARAM)/iLength + integer(i4b),parameter,public :: maxvarProg = storage_size(iLookPROG)/iLength + integer(i4b),parameter,public :: maxvarDiag = storage_size(iLookDIAG)/iLength + integer(i4b),parameter,public :: maxvarFlux = storage_size(iLookFLUX)/iLength + integer(i4b),parameter,public :: maxvarDeriv = storage_size(iLookDERIV)/iLength + integer(i4b),parameter,public :: maxvarIndx = storage_size(iLookINDEX)/iLength + 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 + + ! *********************************************************************************************************** + ! (Y) define ancillary look-up structures + ! *********************************************************************************************************** + + 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 100644 new mode 100755 index 318baab00..6330402bd --- a/build/source/engine/allocspace.f90 +++ b/build/source/engine/allocspace.f90 @@ -19,405 +19,616 @@ ! along with this program. If not, see . module allocspace_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_d, & ! x%var(:) (dp) + var_ilength, & ! x%var(:)%dat (i4b) + var_dlength, & ! x%var(:)%dat (dp) + ! gru dimension + gru_int, & ! x%gru(:)%var(:) (i4b) + 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_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 double precision number + implicit none private -public::init_metad -public::alloc_stim -public::alloc_time -public::alloc_forc -public::alloc_attr -public::alloc_type -public::alloc_mpar -public::alloc_mvar -public::alloc_indx -public::alloc_bpar -public::alloc_bvar -! define missing values -integer(i4b),parameter :: missingInteger=-9999 -real(dp),parameter :: missingDouble=-9999._dp -contains +public::allocGlobal +public::allocLocal +public::resizeData +! define fixed dimensions +integer(i4b),parameter :: nBand=2 ! number of spectral bands +integer(i4b),parameter :: nTimeDelay=2000 ! number of elements in the time delay histogram +! ----------------------------------------------------------------------------------------------------------------------------------- +contains ! ************************************************************************************************ - ! public subroutine init_metad: initialize metadata structures + ! public subroutine allocGlobal: allocate space for global data structures ! ************************************************************************************************ - subroutine init_metad(err,message) - ! used to initialize the metadata structures - USE var_lookup,only:maxvarTime,maxvarForc,maxvarAttr,maxvarType ! maximum number variables in each data structure - USE var_lookup,only:maxvarMpar,maxvarMvar,maxvarIndx ! maximum number variables in each data structure - USE var_lookup,only:maxvarBpar,maxvarBvar ! maximum number variables in each data structure - USE data_struc,only:time_meta,forc_meta,attr_meta,type_meta ! metadata structures - USE data_struc,only:mpar_meta,mvar_meta,indx_meta ! metadata structures - USE data_struc,only:bpar_meta,bvar_meta ! metadata structures + subroutine allocGlobal(metaStruct,dataStruct,err,message) + USE globalData,only: gru_struc ! gru-hru mapping structures implicit none - ! declare variables - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! initialize errors - err=0; message="init_model/" - ! ensure metadata structures are deallocated - if (associated(time_meta)) deallocate(time_meta) - if (associated(forc_meta)) deallocate(forc_meta) - if (associated(attr_meta)) deallocate(attr_meta) - if (associated(type_meta)) deallocate(type_meta) - if (associated(mpar_meta)) deallocate(mpar_meta) - if (associated(mvar_meta)) deallocate(mvar_meta) - if (associated(indx_meta)) deallocate(indx_meta) - if (associated(bpar_meta)) deallocate(bpar_meta) - if (associated(bvar_meta)) deallocate(bvar_meta) - ! allocate metadata structures - allocate(time_meta(maxvarTime),forc_meta(maxvarForc),attr_meta(maxvarAttr),type_meta(maxvarType),& - mpar_meta(maxvarMpar),mvar_meta(maxvarMvar),indx_meta(maxvarIndx),& - bpar_meta(maxvarBpar),bvar_meta(maxvarBvar),stat=err) - if(err/=0)then; err=20; message=trim(message)//"problemAllocateMetadata"; return; endif - end subroutine init_metad + ! input + type(var_info),intent(in) :: metaStruct(:) ! metadata structure + ! 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 through HRUs + integer(i4b) :: iGRU ! loop 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/' + + ! initialize allocation check + check=.false. + + ! get the number of GRUs + nGRU = size(gru_struc) + + ! * allocate GRU dimension + select type(dataStruct) + ! gru dimension only + type is (gru_int); if(allocated(dataStruct%gru))then; check=.true.; else; allocate(dataStruct%gru(nGRU),stat=err); end if + type is (gru_intVec); if(allocated(dataStruct%gru))then; check=.true.; else; allocate(dataStruct%gru(nGRU),stat=err); end if + type is (gru_double); if(allocated(dataStruct%gru))then; check=.true.; else; allocate(dataStruct%gru(nGRU),stat=err); end if + type is (gru_doubleVec); if(allocated(dataStruct%gru))then; check=.true.; else; allocate(dataStruct%gru(nGRU),stat=err); end if + ! gru+hru dimensions + type is (gru_hru_int); if(allocated(dataStruct%gru))then; check=.true.; else; allocate(dataStruct%gru(nGRU),stat=err); end if + type is (gru_hru_intVec); if(allocated(dataStruct%gru))then; check=.true.; else; allocate(dataStruct%gru(nGRU),stat=err); end if + type is (gru_hru_double); if(allocated(dataStruct%gru))then; check=.true.; else; allocate(dataStruct%gru(nGRU),stat=err); end if + type 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) + type 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 + type 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 + type 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 + type 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) + type is (gru_hru_int); call allocLocal(metaStruct,dataStruct%gru(iGRU)%hru(iHRU),nSnow,nSoil,err,cmessage); spatial=.true. + type is (gru_hru_intVec); call allocLocal(metaStruct,dataStruct%gru(iGRU)%hru(iHRU),nSnow,nSoil,err,cmessage); spatial=.true. + type is (gru_hru_double); call allocLocal(metaStruct,dataStruct%gru(iGRU)%hru(iHRU),nSnow,nSoil,err,cmessage); spatial=.true. + type 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) + type is (gru_double); call allocLocal(metaStruct,dataStruct%gru(iGRU),nSnow=0,nSoil=0,err=err,message=cmessage); spatial=.true. + type 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) + type is (var_i); call allocLocal(metaStruct,dataStruct,err=err,message=cmessage) + type is (var_d); call allocLocal(metaStruct,dataStruct,err=err,message=cmessage) + type is (var_ilength); call allocLocal(metaStruct,dataStruct,err=err,message=cmessage) + type 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 ! ************************************************************************************************ - ! public subroutine alloc_stim: initialize data structures for scalar time structures + ! public subroutine allocLocal: allocate space for local data structures ! ************************************************************************************************ - subroutine alloc_stim(datastr,err,message) - ! used to initialize structure components for model variables - USE data_struc,only:var_i,time_meta ! data structures + subroutine allocLocal(metaStruct,dataStruct,nSnow,nSoil,err,message) implicit none - ! dummy variables - type(var_i),intent(out),pointer :: datastr ! data structure to allocate - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! initialize errors - err=0; message="alloc_stim/" - ! check that the metadata structure is allocated - if(.not.associated(time_meta))then - err=10; message=trim(message)//"metadataNotInitialized"; return - endif - ! initialize top-level data structure - if(associated(datastr)) deallocate(datastr) - allocate(datastr,stat=err) - if(err/=0)then; err=20; message=trim(message)//"problemAllocateDataTopLevel"; return; endif - ! initialize second level data structure - allocate(datastr%var(size(time_meta)),stat=err) - if(err/=0)then; err=20; message=trim(message)//"problemAllocateData2ndLevel"; return; endif - ! set values to missing - datastr%var(:) = missingInteger - end subroutine alloc_stim + ! input-output + type(var_info),intent(in) :: metaStruct(:) ! metadata structure + class(*),intent(inout) :: dataStruct ! data structure + ! optional input + integer(i4b),intent(in),optional :: nSnow ! number of snow layers + integer(i4b),intent(in),optional :: nSoil ! number of soil layers + ! output + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! local + logical(lgt) :: check ! .true. if the variables are allocated + integer(i4b) :: nVars ! number of variables in the metadata structure + integer(i4b) :: nLayers ! total number of layers + character(len=256) :: cmessage ! error message of the downwind routine + ! initialize error control + err=0; message='allocLocal/' + + ! get the number of variables in the metadata structure + nVars = size(metaStruct) + + ! check if nSnow and nSoil are present + if(present(nSnow) .or. present(nSoil))then + ! check both are present + if(.not.present(nSoil))then; err=20; message=trim(message)//'expect nSoil to be present when nSnow is present'; return; end if + if(.not.present(nSnow))then; err=20; message=trim(message)//'expect nSnow to be present when nSoil is present'; return; end if + nLayers = nSnow+nSoil + + ! It is possible that nSnow and nSoil are actually needed here, so we return an error if the optional arguments are missing when needed + else + select type(dataStruct) + type is (var_ilength); err=20 + type is (var_dlength); err=20 + end select + if(err/=0)then; message=trim(message)//'expect nSnow and nSoil to be present for variable-length data structures'; return; end if + end if + + ! initialize allocation check + check=.false. + + ! allocate the dimension for model variables + select type(dataStruct) + type is (var_i); if(allocated(dataStruct%var))then; check=.true.; else; allocate(dataStruct%var(nVars),stat=err); end if; return + type is (var_d); if(allocated(dataStruct%var))then; check=.true.; else; allocate(dataStruct%var(nVars),stat=err); end if; return + type is (var_ilength); if(allocated(dataStruct%var))then; check=.true.; else; allocate(dataStruct%var(nVars),stat=err); end if + type is (var_dlength); if(allocated(dataStruct%var))then; check=.true.; else; allocate(dataStruct%var(nVars),stat=err); end if + class default; err=20; message=trim(message)//'unable to identify derived data type for the variable dimension'; return + end select + ! check errors + if(check) then; err=20; message=trim(message)//'structure was unexpectedly allocated already'; return; end if + if(err/=0)then; err=20; message=trim(message)//'problem allocating'; return; end if + + ! allocate the dimension for model data + select type(dataStruct) + type is (var_ilength); call allocateDat_int(metaStruct,nSnow,nSoil,nLayers,dataStruct,err,cmessage) + type is (var_dlength); call allocateDat_dp( metaStruct,nSnow,nSoil,nLayers,dataStruct,err,cmessage) + class default; err=20; message=trim(message)//'unable to identify derived data type for the data dimension'; return + end select + + ! check errors + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + + end subroutine allocLocal ! ************************************************************************************************ - ! public subroutine alloc_time: initialize data structures for time structures + ! public subroutine resizeData: resize data structure ! ************************************************************************************************ - subroutine alloc_time(nHRU,err,message) - ! used to initialize structure components for model variables - USE data_struc,only:time_hru,time_meta ! data structures + subroutine resizeData(metaStruct,dataStructOrig,dataStructNew,copy,err,message) implicit none - ! dummy variables - integer(i4b),intent(in) :: nHRU ! number of HRUs - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! local variables - integer(i4b) :: iHRU ! loop through HRUs - integer(i4b) :: nVar ! number of variables - ! initialize errors - err=0; message="alloc_time/" - ! check that the metadata structure is allocated - if(.not.associated(time_meta))then - err=10; message=trim(message)//"metadataNotInitialized"; return + ! input + type(var_info),intent(in) :: metaStruct(:) ! metadata structure + class(*) ,intent(in) :: dataStructOrig ! original data structure + ! output + class(*) ,intent(inout) :: dataStructNew ! new data structure + ! control + logical(lgt) ,intent(in) ,optional :: copy ! flag to copy data + integer(i4b) ,intent(out) :: err ! error code + character(*) ,intent(out) :: message ! error message + ! local + integer(i4b) :: iVar ! number of variables in the structure + integer(i4b) :: nVars ! number of variables in the structure + logical(lgt) :: isCopy ! flag to copy data (handles absence of optional argument) + character(len=256) :: cmessage ! error message of the downwind routine + ! initialize error control + err=0; message='resizeData/' + + ! get the copy flag + if(present(copy))then + isCopy = copy + else + isCopy = .false. endif - ! initialize top-level data structure - if(associated(time_hru)) deallocate(time_hru) - allocate(time_hru(nHRU),stat=err) - if(err/=0)then; err=20; message=trim(message)//"problemAllocateDataTopLevel"; return; endif - ! initialize second level data structure - nVar = size(time_meta) - do iHRU=1,nHRU - allocate(time_hru(iHRU)%var(nVar),stat=err) - if(err/=0)then; err=20; message=trim(message)//"problemAllocateData2ndLevel"; return; endif - ! set values to missing - time_hru(iHRU)%var(:) = missingInteger - end do - end subroutine alloc_time + ! get the number of variables in the data structure + nVars = size(metaStruct) + + ! check that the input data structure is allocated + select type(dataStructOrig) + type is (var_ilength); err=merge(0, 20, allocated(dataStructOrig%var)) + type is (var_dlength); err=merge(0, 20, allocated(dataStructOrig%var)) + class default; err=20; message=trim(message)//'unable to identify type of data structure'; return + end select + if(err/=0)then; message=trim(message)//'input data structure dataStructOrig%var'; return; end if + + ! allocate the dimension for model variables + select type(dataStructNew) + type is (var_ilength); if(.not.allocated(dataStructNew%var)) allocate(dataStructNew%var(nVars),stat=err) + type is (var_dlength); if(.not.allocated(dataStructNew%var)) allocate(dataStructNew%var(nVars),stat=err) + class default; err=20; message=trim(message)//'unable to identify derived data type for the variable dimension'; return + end select + if(err/=0)then; message=trim(message)//'problem allocating space for dataStructNew%var'; return; end if + + ! loop through variables + do iVar=1,nVars + + ! resize and copy data structures + select type(dataStructOrig) + + ! double precision + type is (var_dlength) + select type(dataStructNew) + type is (var_dlength); call copyStruct_dp( dataStructOrig%var(iVar),dataStructNew%var(iVar),isCopy,err,cmessage) + class default; err=20; message=trim(message)//'mismatch data structure for variable'//trim(metaStruct(iVar)%varname); return + end select + + ! integer + type is (var_ilength) + select type(dataStructNew) + type is (var_ilength); call copyStruct_i4b(dataStructOrig%var(iVar),dataStructNew%var(iVar),isCopy,err,cmessage) + class default; err=20; message=trim(message)//'mismatch data structure for variable'//trim(metaStruct(iVar)%varname); return + end select + + ! check + class default; err=20; message=trim(message)//'unable to identify type of data structure'; return + end select + if(err/=0)then; message=trim(message)//trim(cmessage)//' ('//trim(metaStruct(iVar)%varname)//')'; return; end if + + end do ! looping through variables in the data structure + + end subroutine resizeData ! ************************************************************************************************ - ! public subroutine alloc_forc: initialize data structures for model forcing data + ! private subroutine copyStruct_dp: copy a given data structure ! ************************************************************************************************ - subroutine alloc_forc(nHRU,err,message) - ! used to initialize structure components for model variables - USE data_struc,only:forc_hru,forc_meta ! data structures - implicit none + subroutine copyStruct_dp(varOrig,varNew,copy,err,message) ! dummy variables - integer(i4b),intent(in) :: nHRU ! number of HRUs - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! local variables - integer(i4b) :: iHRU ! loop through HRUs - integer(i4b) :: nVar ! number of variables - ! initialize errors - err=0; message="alloc_forc/" - ! check that the metadata structure is allocated - if(.not.associated(forc_meta))then - err=10; message=trim(message)//"metadataNotInitialized"; return + type(dlength),intent(in) :: varOrig ! original data structure + type(dlength),intent(inout) :: varNew ! new data structure + logical(lgt) ,intent(in) :: copy ! flag to copy data + integer(i4b) ,intent(out) :: err ! error code + character(*) ,intent(out) :: message ! error message + ! local + logical(lgt) :: allocatedOrig ! flag to denote if a given variable in the original data structure is allocated + logical(lgt) :: allocatedNew ! flag to denote if a given variable in the new data structure is allocated + integer(i4b) :: lowerBoundOrig ! lower bound of a given variable in the original data structure + integer(i4b) :: upperBoundOrig ! upper bound of a given variable in the original data structure + integer(i4b) :: lowerBoundNew ! lower bound of a given variable in the new data structure + integer(i4b) :: upperBoundNew ! upper bound of a given variable in the new data structure + ! initialize error control + err=0; message='copyStruct_dp/' + + ! get the information from the data structures + call getVarInfo(varOrig,allocatedOrig,lowerBoundOrig,upperBoundOrig) + call getVarInfo(varNew, allocatedNew, lowerBoundNew, upperBoundNew) + + ! check that the variable of the original data structure is allocated + if(.not.allocatedOrig)then + message=trim(message)//'variable in the original data structure is not allocated' + err=20; return endif - ! initialize top-level data structure - if(associated(forc_hru)) deallocate(forc_hru) - allocate(forc_hru(nHRU),stat=err) - if(err/=0)then; err=20; message=trim(message)//"problemAllocateDataTopLevel"; return; endif - ! initialize second level data structure - nVar = size(forc_meta) - do iHRU=1,nHRU - allocate(forc_hru(iHRU)%var(nVar),stat=err) - if(err/=0)then; err=20; message=trim(message)//"problemAllocateData2ndLevel"; return; endif - ! set values to missing - forc_hru(iHRU)%var(:) = missingDouble - end do - end subroutine alloc_forc + ! re-size data structure if necessary + if(lowerBoundOrig/=lowerBoundNew .or. upperBoundOrig/=upperBoundNew .or. .not.allocatedNew)then + + ! deallocate space (if necessary) + if(allocatedNew) deallocate(varNew%dat) + + ! allocate space + allocate(varNew%dat(lowerBoundOrig:upperBoundOrig), stat=err) + if(err/=0)then; message=trim(message)//'problem allocating'; return; endif + + endif ! if need to resize + + ! copy the data structure + if(copy)then + varNew%dat(:) = varOrig%dat(:) + + ! initialize the data structure to missing values + else + varNew%dat(:) = realMissing + endif + + ! internal routines + contains + + ! internal subroutine getVarInfo: get information from a given data structure + subroutine getVarInfo(var,isAllocated,lowerBound,upperBound) + ! input + type(dlength),intent(in) :: var ! data vector for a given variable + ! output + logical(lgt),intent(out) :: isAllocated ! flag to denote if the data vector is allocated + integer(i4b),intent(out) :: lowerBound ! lower bound + integer(i4b),intent(out) :: upperBound ! upper bound + ! local + integer(i4b),dimension(1) :: lowerBoundVec ! lower bound vector + integer(i4b),dimension(1) :: upperBoundVec ! upper bound vector + ! initialize error control + err=0; message='getVarInfo/' + + ! check that the input data structure is allocated + isAllocated = allocated(var%dat) + + ! if allocated then get the bounds + ! NOTE: also convert vector to scalar + if(isAllocated)then + lowerBoundVec=lbound(var%dat); lowerBound=lowerBoundVec(1) + upperBoundVec=ubound(var%dat); upperBound=upperBoundVec(1) + + ! if not allocated then return zero bounds + else + lowerBound=0 + upperBound=0 + endif ! (check allocation) + + end subroutine getVarInfo + + end subroutine copyStruct_dp ! ************************************************************************************************ - ! public subroutine alloc_attr: initialize data structures for local attributes + ! private subroutine copyStruct_i4b: copy a given data structure ! ************************************************************************************************ - subroutine alloc_attr(nHRU,err,message) - ! used to initialize structure components for model variables - USE data_struc,only:attr_meta,attr_hru ! data structures - implicit none + subroutine copyStruct_i4b(varOrig,varNew,copy,err,message) ! dummy variables - integer(i4b),intent(in) :: nHRU ! number of HRUs - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! local variables - integer(i4b) :: iHRU ! loop through HRUs - integer(i4b) :: nVar ! number of variables - ! initialize errors - err=0; message="alloc_attr/" - ! check that the metadata structure is allocated - if(.not.associated(attr_meta))then - err=10; message=trim(message)//"metadataNotInitialized"; return - endif - ! initialize top-level data structure - if(associated(attr_hru)) deallocate(attr_hru) - allocate(attr_hru(nHRU),stat=err) - if(err/=0)then; err=20; message=trim(message)//"problemAllocateDataTopLevel"; return; endif - ! initialize second level data structure - nVar = size(attr_meta) - do iHRU=1,nHRU - allocate(attr_hru(iHRU)%var(nVar),stat=err) - if(err/=0)then; err=20; message=trim(message)//"problemAllocateData2ndLevel"; return; endif - ! fill data with missing values - attr_hru(iHRU)%var(:) = missingDouble - end do - end subroutine alloc_attr + type(ilength),intent(in) :: varOrig ! original data structure + type(ilength),intent(inout) :: varNew ! new data structure + logical(lgt) ,intent(in) :: copy ! flag to copy data + integer(i4b) ,intent(out) :: err ! error code + character(*) ,intent(out) :: message ! error message + ! local + logical(lgt) :: allocatedOrig ! flag to denote if a given variable in the original data structure is allocated + logical(lgt) :: allocatedNew ! flag to denote if a given variable in the new data structure is allocated + integer(i4b) :: lowerBoundOrig ! lower bound of a given variable in the original data structure + integer(i4b) :: upperBoundOrig ! upper bound of a given variable in the original data structure + integer(i4b) :: lowerBoundNew ! lower bound of a given variable in the new data structure + integer(i4b) :: upperBoundNew ! upper bound of a given variable in the new data structure + ! initialize error control + err=0; message='copyStruct_i4b/' + ! get the information from the data structures + call getVarInfo(varOrig,allocatedOrig,lowerBoundOrig,upperBoundOrig) + call getVarInfo(varNew, allocatedNew, lowerBoundNew, upperBoundNew) - ! ************************************************************************************************* - ! public subroutine alloc_type: initialize data structures for local classification of veg, soil, etc. - ! ************************************************************************************************* - subroutine alloc_type(nHRU,err,message) - ! used to initialize structure components for model variables - USE data_struc,only:type_hru,type_meta ! data structures - implicit none - ! dummy variables - integer(i4b),intent(in) :: nHRU ! number of HRUs - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! local variables - integer(i4b) :: iHRU ! loop through HRUs - integer(i4b) :: nVar ! number of variables - ! initialize errors - err=0; message="f-alloc_type/" - ! check that the metadata structure is allocated - if(.not.associated(type_meta))then - err=10; message=trim(message)//"metadataNotInitialized"; return + ! check that the variable of the original data structure is allocated + if(.not.allocatedOrig)then + message=trim(message)//'variable in the original data structure is not allocated' + err=20; return endif - ! initialize top-level data structure - if(associated(type_hru)) deallocate(type_hru) - allocate(type_hru(nHRU),stat=err) - if(err/=0)then; err=20; message=trim(message)//"problemAllocateDataTopLevel"; return; endif - ! initialize second level data structure - nVar = size(type_meta) - do iHRU=1,nHRU - allocate(type_hru(iHRU)%var(nVar),stat=err) - if(err/=0)then; err=20; message=trim(message)//"problemAllocateData2ndLevel"; return; endif - ! fill data with missing values - type_hru(iHRU)%var(:) = missingInteger - end do - end subroutine alloc_type + ! re-size data structure if necessary + if(lowerBoundOrig/=lowerBoundNew .or. upperBoundOrig/=upperBoundNew .or. .not.allocatedNew)then - ! ************************************************************************************************* - ! public subroutine alloc_mpar: initialize data structures for model parameters - ! ************************************************************************************************* - subroutine alloc_mpar(nHRU,err,message) - ! used to initialize structure components for model variables - USE data_struc,only:mpar_hru,mpar_meta ! data structures - implicit none - ! dummy variables - integer(i4b),intent(in) :: nHRU ! number of HRUs - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! local variables - integer(i4b) :: iHRU ! loop through HRUs - integer(i4b) :: nPar ! number of parameters - ! initialize errors - err=0; message="f-alloc_mpar/" - ! check that the metadata structure is allocated - if(.not.associated(mpar_meta))then - err=10; message=trim(message)//"metadataNotInitialized"; return - endif - ! initialize top-level data structure - if(associated(mpar_hru)) deallocate(mpar_hru) - allocate(mpar_hru(nHRU),stat=err) - if(err/=0)then; err=20; message=trim(message)//"problemAllocateDataTopLevel"; return; endif - ! get the number of parameters - nPar = size(mpar_meta) - ! loop through HRUs - do iHRU=1,nHRU - ! initialize second level data structure - allocate(mpar_hru(iHRU)%var(nPar),stat=err) - if(err/=0)then; err=20; message=trim(message)//"problemAllocateData2ndLevel"; return; endif - ! set values to missing - mpar_hru(iHRU)%var(:) = missingDouble - end do ! looping through HRUs - end subroutine alloc_mpar - - - ! ************************************************************************************************* - ! public subroutine alloc_mvar: initialize data structures for model variables - ! ************************************************************************************************* - subroutine alloc_mvar(nHRU,err,message) - ! used to initialize structure components for model variables - USE data_struc,only:mvar_hru,mvar_meta ! data structures - implicit none - ! dummy variables - integer(i4b),intent(in) :: nHRU ! number of HRUs - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! local variables - integer(i4b) :: iHRU ! loop through HRUs - integer(i4b) :: nVar ! number of variables - ! initialize errors - err=0; message="alloc_mvar/" - ! check that the metadata structure is allocated - if(.not.associated(mvar_meta))then - err=10; message=trim(message)//"metadataNotInitialized"; return - endif - ! initialize top-level data structure - if(associated(mvar_hru)) deallocate(mvar_hru) - allocate(mvar_hru(nHRU),stat=err) - if(err/=0)then; err=20; message=trim(message)//"problemAllocateDataTopLevel"; return; endif - ! initialize second level data structure - nVar = size(mvar_meta) - do iHRU=1,nHRU - allocate(mvar_hru(iHRU)%var(nVar),stat=err) - if(err/=0)then; err=20; message=trim(message)//"problemAllocateData2ndLevel"; return; endif - end do ! (looping through the HRUs) - end subroutine alloc_mvar - - - ! ************************************************************************************************* - ! public subroutine alloc_indx: initialize structure components for model indices - ! ************************************************************************************************* - subroutine alloc_indx(nHRU,err,message) - ! used to initialize structure components for model variables - USE data_struc,only:indx_hru,indx_meta ! data structures - implicit none - ! dummy variables - integer(i4b),intent(in) :: nHRU ! number of HRUs - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! local variables - integer(i4b) :: iHRU ! loop through HRUs - integer(i4b) :: nVar ! number of variables - ! initialize errors - err=0; message="alloc_indx/" - ! check that the metadata structure is allocated - if(.not.associated(indx_meta))then - err=10; message=trim(message)//"metadataNotInitialized"; return + ! deallocate space (if necessary) + if(allocatedNew) deallocate(varNew%dat) + + ! allocate space + allocate(varNew%dat(lowerBoundOrig:upperBoundOrig), stat=err) + if(err/=0)then; message=trim(message)//'problem allocating'; return; endif + + endif ! if need to resize + + ! copy the data structure + if(copy)then + varNew%dat(:) = varOrig%dat(:) + + ! initialize the data structure to missing values + else + varNew%dat(:) = integerMissing endif - ! initialize top-level data structure - if(associated(indx_hru)) deallocate(indx_hru) - allocate(indx_hru(nHRU),stat=err) - if(err/=0)then; err=20; message=trim(message)//"problemAllocateDataTopLevel"; return; endif - ! initialize second level data structure - nVar = size(indx_meta) - do iHRU=1,nHRU - allocate(indx_hru(iHRU)%var(nVar),stat=err) - if(err/=0)then; err=20; message=trim(message)//"problemAllocateData2ndLevel"; return; endif - end do ! (looping through HRUs in the data structure) - end subroutine alloc_indx - - - ! ************************************************************************************************* - ! public subroutine alloc_bpar: initialize data structures for basin-average model parameters - ! ************************************************************************************************* - subroutine alloc_bpar(err,message) - ! used to initialize structure components for model variables - USE data_struc,only:bpar_data,bpar_meta ! data structures + + ! internal routines + contains + + ! internal subroutine getVarInfo: get information from a given data structure + subroutine getVarInfo(var,isAllocated,lowerBound,upperBound) + ! input + type(ilength),intent(in) :: var ! data vector for a given variable + ! output + logical(lgt),intent(out) :: isAllocated ! flag to denote if the data vector is allocated + integer(i4b),intent(out) :: lowerBound ! lower bound + integer(i4b),intent(out) :: upperBound ! upper bound + ! local + integer(i4b),dimension(1) :: lowerBoundVec ! lower bound vector + integer(i4b),dimension(1) :: upperBoundVec ! upper bound vector + ! initialize error control + err=0; message='getVarInfo/' + + ! check that the input data structure is allocated + isAllocated = allocated(var%dat) + + ! if allocated then get the bounds + ! NOTE: also convert vector to scalar + if(isAllocated)then + lowerBoundVec=lbound(var%dat); lowerBound=lowerBoundVec(1) + upperBoundVec=ubound(var%dat); upperBound=upperBoundVec(1) + + ! if not allocated then return zero bounds + else + lowerBound=0 + upperBound=0 + endif ! (check allocation) + + end subroutine getVarInfo + + end subroutine copyStruct_i4b + + + ! ************************************************************************************************ + ! private subroutine allocateDat_dp: initialize data dimension of the data structures + ! ************************************************************************************************ + subroutine allocateDat_dp(metadata,nSnow,nSoil,nLayers, & ! input + varData,err,message) ! output + USE var_lookup,only:iLookVarType ! look up structure for variable typed + USE var_lookup,only:maxvarStat ! allocation dimension (stats) + USE get_ixName_module,only:get_varTypeName ! to access type strings for error messages implicit none - ! dummy variables - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + ! input variables + type(var_info),intent(in) :: metadata(:) ! metadata structure + 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 soil layers in the snow+soil domian (nSnow+nSoil) + ! output variables + type(var_dlength),intent(inout) :: varData ! model variables for a local HRU + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message ! local variables - integer(i4b) :: nPar ! number of parameters - ! initialize errors - err=0; message="alloc_bpar/" - ! check that the metadata structure is allocated - if(.not.associated(bpar_meta))then - err=10; message=trim(message)//"metadataNotInitialized"; return - endif - ! initialize top-level data structure - if(associated(bpar_data)) deallocate(bpar_data) - allocate(bpar_data,stat=err) - if(err/=0)then; err=20; message=trim(message)//"problemAllocateDataTopLevel"; return; endif - ! get the number of parameters - nPar = size(bpar_meta) - ! initialize second level data structure - allocate(bpar_data%var(nPar),stat=err) - if(err/=0)then; err=20; message=trim(message)//"problemAllocateData2ndLevel"; return; endif - ! set values to missing - bpar_data%var(:) = missingDouble - end subroutine alloc_bpar - - - ! ************************************************************************************************* - ! public subroutine alloc_bvar: initialize data structures for basin-average model variables - ! ************************************************************************************************* - subroutine alloc_bvar(err,message) - ! used to initialize structure components for model variables - USE data_struc,only:bvar_data,bvar_meta ! data structures + integer(i4b) :: iVar ! variable index + integer(i4b) :: nVars ! number of variables in the metadata structure + ! initialize error control + err=0; message='allocateDat_dp/' + + ! get the number of variables in the metadata structure + nVars = size(metadata) + + ! loop through variables in the data structure + do iVar=1,nVars + + ! check allocated + if(allocated(varData%var(iVar)%dat))then + message=trim(message)//'variable '//trim(metadata(iVar)%varname)//' is unexpectedly allocated' + err=20; return + + ! allocate structures + ! NOTE: maxvarStats is the number of possible output statistics, but this vector must store two values for the variance calculation, thus the +1 in this allocate. + 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%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) + case(iLookVarType%ifcSnow); allocate(varData%var(iVar)%dat(0:nSnow),stat=err) + case(iLookVarType%ifcSoil); allocate(varData%var(iVar)%dat(0:nSoil),stat=err) + case(iLookVarType%ifcToto); allocate(varData%var(iVar)%dat(0:nLayers),stat=err) + case(iLookVarType%parSoil); allocate(varData%var(iVar)%dat(nSoil),stat=err) + case(iLookVarType%routing); allocate(varData%var(iVar)%dat(nTimeDelay),stat=err) + case(iLookVarType%outstat); allocate(varData%var(iVar)%dat(maxvarStat+1),stat=err) + case(iLookVarType%unknown); allocate(varData%var(iVar)%dat(0),stat=err) ! unknown = special (and valid) case that is allocated later (initialize with zero-length vector) + case default + err=40; message=trim(message)//"1. unknownVariableType[name='"//trim(metadata(iVar)%varname)//"'; type='"//trim(get_varTypeName(metadata(iVar)%vartype))//"']" + return + end select + ! check error + if(err/=0)then; err=20; message=trim(message)//'problem allocating variable '//trim(metadata(iVar)%varname); return; end if + ! set to missing + varData%var(iVar)%dat(:) = realMissing + end if ! if not allocated + + end do ! looping through variables + + end subroutine allocateDat_dp + + ! ************************************************************************************************ + ! private subroutine allocateDat_int: initialize data dimension of the data structures + ! ************************************************************************************************ + subroutine allocateDat_int(metadata,nSnow,nSoil,nLayers, & ! input + varData,err,message) ! output + USE var_lookup,only:iLookVarType ! look up structure for variable typed + USE var_lookup,only:maxvarStat ! allocation dimension (stats) + USE get_ixName_module,only:get_varTypeName ! to access type strings for error messages implicit none - ! dummy variables - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + ! input variables + type(var_info),intent(in) :: metadata(:) ! metadata structure + 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 soil layers in the snow+soil domian (nSnow+nSoil) + ! output variables + type(var_ilength),intent(inout) :: varData ! model variables for a local HRU + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message ! local variables - integer(i4b) :: iVar ! index of variables - integer(i4b) :: nVar ! number of variables - integer(i4b),parameter :: nTimeDelay=2000 ! number of elements in the time delay histogram - ! initialize errors - err=0; message="alloc_bvar/" - ! check that the metadata structure is allocated - if(.not.associated(bvar_meta))then - err=10; message=trim(message)//"metadataNotInitialized"; return - endif - ! initialize top-level data structure - if(associated(bvar_data)) deallocate(bvar_data) - allocate(bvar_data,stat=err) - if(err/=0)then; err=20; message=trim(message)//"problemAllocateDataTopLevel"; return; endif - ! get the number of parameters - nVar = size(bvar_meta) - ! initialize second level data structure - allocate(bvar_data%var(nVar),stat=err) - if(err/=0)then; err=20; message=trim(message)//"problemAllocateData2ndLevel"; return; endif - ! initialize third-level data structures - do iVar=1,nVar - select case(bvar_meta(ivar)%vartype) - case('scalarv'); allocate(bvar_data%var(ivar)%dat(1),stat=err) - case('routing'); allocate(bvar_data%var(ivar)%dat(nTimeDelay),stat=err) - case default - err=40; message=trim(message)//"unknownVariableType[name='"//trim(bvar_meta(ivar)%varname)//"'; & - &type='"//trim(bvar_meta(ivar)%vartype)//"']"; return - endselect - bvar_data%var(ivar)%dat(:) = missingDouble - end do ! (looping through model variables) - end subroutine alloc_bvar + integer(i4b) :: iVar ! variable index + integer(i4b) :: nVars ! number of variables in the metadata structure + ! initialize error control + err=0; message='allocateDat_int/' + + ! get the number of variables in the metadata structure + nVars = size(metadata) + + ! loop through variables in the data structure + do iVar=1,nVars + + ! check allocated + if(allocated(varData%var(iVar)%dat))then + message=trim(message)//'variable '//trim(metadata(iVar)%varname)//' is unexpectedly allocated' + err=20; return + + ! allocate structures + ! NOTE: maxvarStats is the number of possible output statistics, but this vector must store two values for the variance calculation, thus the +1 in this allocate. + 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%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) + case(iLookVarType%ifcSnow); allocate(varData%var(iVar)%dat(0:nSnow),stat=err) + case(iLookVarType%ifcSoil); allocate(varData%var(iVar)%dat(0:nSoil),stat=err) + case(iLookVarType%ifcToto); allocate(varData%var(iVar)%dat(0:nLayers),stat=err) + case(iLookVarType%routing); allocate(varData%var(iVar)%dat(nTimeDelay),stat=err) + case(iLookVarType%outstat); allocate(varData%var(iVar)%dat(maxvarStat+1),stat=err) + case(iLookVarType%unknown); allocate(varData%var(iVar)%dat(0),stat=err) ! unknown=special (and valid) case that is allocated later (initialize with zero-length vector) + case default; err=40; message=trim(message)//"unknownVariableType[name='"//trim(metadata(iVar)%varname)//"'; type='"//trim(get_varTypeName(metadata(iVar)%vartype))//"']"; return + end select + ! check error + if(err/=0)then; err=20; message=trim(message)//'problem allocating variable '//trim(metadata(iVar)%varname); return; end if + ! set to missing + varData%var(iVar)%dat(:) = integerMissing + end if ! if not allocated + + end do ! looping through variables + end subroutine allocateDat_int end module allocspace_module diff --git a/build/source/engine/canopySnow.f90 b/build/source/engine/canopySnow.f90 old mode 100644 new mode 100755 index af63a71b5..7ab00fdb8 --- a/build/source/engine/canopySnow.f90 +++ b/build/source/engine/canopySnow.f90 @@ -46,19 +46,21 @@ subroutine canopySnow(& model_decisions, & ! intent(in): model decisions forc_data, & ! intent(in): model forcing data mpar_data, & ! intent(in): model parameters - mvar_data, & ! intent(inout): model variables for a local HRU + 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,message) ! intent(out): error control ! ------------------------------------------------------------------------------------------------ ! provide access to the derived types to define the data structures - USE data_struc,only:& + USE data_types,only:& var_i, & ! data vector (i4b) var_d, & ! data vector (dp) var_dlength, & ! data vector with variable length dimension (dp) model_options ! defines the model decisions ! provide access to named variables defining elements in the data structures - USE var_lookup,only:iLookTIME,iLookTYPE,iLookATTR,iLookFORCE,iLookPARAM,iLookMVAR,iLookBVAR,iLookINDEX ! named variables for structure elements - USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure + USE var_lookup,only:iLookFORCE,iLookPARAM,iLookDIAG,iLookPROG,iLookFLUX ! named variables for structure elements + USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure implicit none ! ------------------------------------------------------------------------------------------------ ! input: model control @@ -68,8 +70,10 @@ subroutine canopySnow(& ! 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_d),intent(in) :: mpar_data ! model parameters - type(var_dlength),intent(inout) :: mvar_data ! model variables for a local HRU + 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 @@ -103,22 +107,23 @@ subroutine canopySnow(& scalarAirtemp => forc_data%var(iLookFORCE%airtemp), & ! intent(in): [dp] air temperature (K) ! model parameters - refInterceptCapSnow => mpar_data%var(iLookPARAM%refInterceptCapSnow), & ! intent(in): [dp] reference canopy interception capacity for snow per unit leaf area (kg m-2) - ratioDrip2Unloading => mpar_data%var(iLookPARAM%ratioDrip2Unloading), & ! intent(in): [dp] ratio of canopy drip to snow unloading (-) - snowUnloadingCoeff => mpar_data%var(iLookPARAM%snowUnloadingCoeff), & ! intent(in): [dp] time constant for unloading of snow from the forest canopy (s-1) + 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) - ! model variables (input) - scalarSnowfall => mvar_data%var(iLookMVAR%scalarSnowfall)%dat(1), & ! intent(in): [dp] computed snowfall rate (kg m-2 s-1) - scalarNewSnowDensity => mvar_data%var(iLookMVAR%scalarNewSnowDensity)%dat(1), & ! intent(in): [dp] density of new snow (kg m-3) - scalarCanopyLiqDrainage => mvar_data%var(iLookMVAR%scalarCanopyLiqDrainage)%dat(1), & ! intent(in): [dp] liquid drainage from the vegetation canopy (kg m-2 s-1) + ! model diagnostic variables + scalarNewSnowDensity => diag_data%var(iLookDIAG%scalarNewSnowDensity)%dat(1), & ! intent(in): [dp] density of new snow (kg m-3) - ! model variables (input/output) - scalarCanopyIce => mvar_data%var(iLookMVAR%scalarCanopyIce)%dat(1), & ! intent(inout): [dp] mass of ice on the vegetation canopy (kg m-2) + ! 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 variables (output) - scalarThroughfallSnow => mvar_data%var(iLookMVAR%scalarThroughfallSnow)%dat(1), & ! intent(out): [dp] snow that reaches the ground without ever touching the canopy (kg m-2 s-1) - scalarCanopySnowUnloading => mvar_data%var(iLookMVAR%scalarCanopySnowUnloading)%dat(1) & ! intent(out): [dp] unloading of snow from the vegetion canopy (kg m-2 s-1) + ! model fluxes (input) + 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) + ! 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) ) ! associate variables in the data structures ! ----------------------------------------------------------------------------------------------------------------------------------------------------- @@ -130,7 +135,7 @@ subroutine canopySnow(& unloading_melt = min(ratioDrip2Unloading*scalarCanopyLiqDrainage, scalarCanopyIce/dt) ! kg m-2 s-1 else unloading_melt = 0._dp - endif + end if scalarCanopyIce = scalarCanopyIce - unloading_melt*dt ! ***** @@ -142,7 +147,7 @@ subroutine canopySnow(& scalarThroughfallSnow = scalarSnowfall ! throughfall of snow through the canopy (kg m-2 s-1) scalarCanopySnowUnloading = unloading_melt ! unloading of snow from the canopy (kg m-2 s-1) return - endif + end if ! get a trial value for canopy storage scalarCanopyIceIter = scalarCanopyIce @@ -172,7 +177,7 @@ subroutine canopySnow(& ! * option 1: maximum interception capacity an inverse function of new snow density (e.g., Mahat and Tarboton, HydProc 2013) case(lightSnow) ! (check new snow density is valid) - if(scalarNewSnowDensity < 0._dp)then; err=20; message=trim(message)//'invalid new snow density'; return; endif + if(scalarNewSnowDensity < 0._dp)then; err=20; message=trim(message)//'invalid new snow density'; return; end if ! (compute storage capacity of new snow) leafScaleFactor = 0.27_dp + 46._dp/scalarNewSnowDensity leafInterceptCapSnow = refInterceptCapSnow*leafScaleFactor ! per unit leaf area (kg m-2) @@ -183,7 +188,7 @@ subroutine canopySnow(& if (airtemp_degC > -1._dp)then; leafScaleFactor = 4.0_dp elseif(airtemp_degC > -3._dp)then; leafScaleFactor = 1.5_dp*airtemp_degC + 5.5_dp else; leafScaleFactor = 1.0_dp - endif + end if leafInterceptCapSnow = refInterceptCapSnow*leafScaleFactor !write(*,'(a,1x,2(f20.10,1x))') 'airtemp_degC, leafInterceptCapSnow = ', airtemp_degC, leafInterceptCapSnow !pause 'in stickysnow' @@ -205,7 +210,7 @@ subroutine canopySnow(& !write(*,'(a,1x,10(e20.10,1x))') 'scalarSnowfall, scalarNewSnowDensity, refInterceptCapSnow, leafScaleFactor, leafInterceptCapSnow, exposedVAI, canopyIceScaleFactor = ', & ! scalarSnowfall, scalarNewSnowDensity, refInterceptCapSnow, leafScaleFactor, leafInterceptCapSnow, exposedVAI, canopyIceScaleFactor - endif ! (if snow is falling) + end if ! (if snow is falling) !write(*,'(a,1x,10(e20.10,1x))') 'scalarThroughfallSnow, scalarCanopySnowUnloading, unloading_melt = ', & ! scalarThroughfallSnow, scalarCanopySnowUnloading, unloading_melt @@ -221,7 +226,7 @@ subroutine canopySnow(& if(abs(resMass) < convTolerMass)exit ! ** check for non-convengence - if(iter==maxiter)then; err=20; message=trim(message)//'failed to converge [mass]'; return; endif + if(iter==maxiter)then; err=20; message=trim(message)//'failed to converge [mass]'; return; end if ! ** update value scalarCanopyIceIter = scalarCanopyIceIter + delS @@ -235,6 +240,9 @@ subroutine canopySnow(& ! update mass of ice on the canopy (kg m-2) scalarCanopyIce = scalarCanopyIceIter + !print*, 'scalarCanopySnowUnloading = ', scalarCanopySnowUnloading + !print*, 'scalarCanopySnowUnloading*dt = ', scalarCanopySnowUnloading*dt + ! end association to variables in the data structure end associate diff --git a/build/source/engine/checkStruc.f90 b/build/source/engine/checkStruc.f90 new file mode 100755 index 000000000..5d177f351 --- /dev/null +++ b/build/source/engine/checkStruc.f90 @@ -0,0 +1,189 @@ +! 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 checkStruc_module +USE nrtype +USE globalData,only:integerMissing +implicit none +private +public::checkStruc +contains + + + ! ************************************************************************************************ + ! public subroutine checkStruc: check data structures + ! ************************************************************************************************ + subroutine checkStruc(err,message) + ! ascii utilities + USE ascii_util_module,only:split_line + ! summary of data structures + USE globalData,only:structInfo + ! metadata structures + USE globalData,only:time_meta,forc_meta,attr_meta,type_meta ! metadata structures + 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 var_lookup,only:iLookTIME,iLookFORCE,iLookATTR,iLookTYPE ! 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 + implicit none + ! dummy variables + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! local variables + integer(i4b) :: iStruct ! index of data structure + integer(i4b),parameter :: nStruct=size(structInfo) ! number of data structures + character(len=8192) :: longString ! string containing the indices defined in the structure constructor + character(len=32),allocatable :: words(:) ! vector of words extracted from the long string + integer(i4b) :: ix ! index of the variable in the data structure + integer(i4b) :: ixTest ! test the structure constructor = (1,2,3,...,nVar) + character(len=256) :: cmessage ! error message of downwind routine + ! ----------------------------------------------------------------------------------------------------------------------------------- + ! initialize errors + err=0; message="checkStruc/" + + ! ----- + ! * check that the structure constructors are correct... + ! ------------------------------------------------------ + + ! loop through data structures + do iStruct=1,nStruct + ! 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('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 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 + call split_line(longString,words,err,cmessage) ! convert the long character string to a vector of "words" + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + if(size(words)/=structInfo(iStruct)%nVar)then; err=20; message=trim(message)//'unexpected number of elements'; return; end if + ! check that the elements in the lookup structure are sequential integers (1,2,3,...,n) + do ix=1,structInfo(iStruct)%nVar + read(words(ix),*) ixTest ! convert character to integer; store in ixTest + if(ixTest/=ix)then ! expect that the ix-th word is equal to ix + write(message,'(a,i0,a)')trim(message)//'problem with structure constructor iLook'//trim(structInfo(iStruct)%lookName)//' [element=',ix,']' + err=20; return + end if + end do + end do ! looping through data structures + + ! ----- + ! * check that the metadata is fully populated... + ! ----------------------------------------------- + + ! loop through data structures + 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('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 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) + end do ! looping through data structures + + + contains + + ! ************************************************************************************************ + ! internal subroutine checkPopulated: check that the metadata is fully populated... + ! ************************************************************************************************ + subroutine checkPopulated(iStruct,metadata,err,message) + ! access the data type for the metadata structures + USE data_types,only:var_info + ! get index from character string + USE get_ixname_module,only: get_ixUnknown! variable lookup structure + implicit none + ! dummy variables + integer(i4b),intent(in) :: iStruct ! index of data structure + type(var_info) :: metadata(:) ! metadata structure + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! local variables + integer(i4b) :: iVar ! index of variable within a data structure + integer(i4b) :: jVar ! index of variable within a data structure (returned from the variable name) + character(LEN=100) :: typeName ! name of variable type to be returned by get_ixUnknown + character(len=256) :: cmessage ! error message of downwind routine + ! initialize error control + err=0; message='checkPopulated/' + + ! loop through variables + do iVar=1,size(metadata) + + ! check that this variable is populated + if (trim(metadata(iVar)%varname)=='empty') then + write(message,'(a,i0,a)') trim(message)//trim(structInfo(iStruct)%structName)//'_meta structure is not populated for named variable # ',iVar, ' in structure iLook'//trim(structInfo(iStruct)%lookName) + err=20; return + end if + + ! look for the populated variable + call get_ixUnknown(trim(metadata(iVar)%varname),typeName,jVar,err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) + + ! 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) + err=20; return + end if + + ! check that the variable was found in the correct structure + if (trim(structInfo(iStruct)%structName)/=typeName) then + message=trim(message)//'variable '//trim(metadata(iVar)%varname)//' from structure '//trim(structInfo(iStruct)%structName)//'_meta is in structure '//trim(typeName)//'_meta' + err=20; return + end if + + ! 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' + err=20; return + end if + + end do ! looping through variables in structure iStruct + + end subroutine checkPopulated + + end subroutine checkStruc + +end module checkStruc_module diff --git a/build/source/engine/check_icond.f90 b/build/source/engine/check_icond.f90 new file mode 100755 index 000000000..7282f8121 --- /dev/null +++ b/build/source/engine/check_icond.f90 @@ -0,0 +1,285 @@ +! 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 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 + +implicit none +private +public::check_icond +contains + + ! ************************************************************************************************ + ! 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 + ! -------------------------------------------------------------------------------------------------------- + ! 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 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 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) + gravity, & ! gravitational acceleration (m s-2) + Tfreeze ! freezing point of pure water (K) + 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 + 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 + + ! locals + character(len=256) :: cmessage ! downstream error message + integer(i4b) :: iGRU ! loop index + integer(i4b) :: iHRU ! loop index + + ! temporary variables for realism checks + integer(i4b) :: iLayer ! index of model layer + integer(i4b) :: iSoil ! index of soil layer + real(dp) :: fLiq ! fraction of liquid water on the vegetation canopy (-) + real(dp) :: vGn_m ! van Genutchen "m" parameter (-) + real(dp) :: tWat ! total water on the vegetation canopy (kg m-2) + real(dp) :: scalarTheta ! liquid water equivalent of total water [liquid water + ice] (-) + real(dp) :: h1,h2 ! used to check depth and height are consistent + integer(i4b) :: nLayers ! total number of layers + real(dp) :: kappa ! constant in the freezing curve function (m K-1) + integer(i4b) :: nSnow ! number of snow layers + + ! -------------------------------------------------------------------------------------------------------- + + ! Start procedure here + err=0; message="check_icond/" + + ! -------------------------------------------------------------------------------------------------------- + ! Check that the initial conditions do not conflict with parameters, structure, etc. + ! -------------------------------------------------------------------------------------------------------- + do iGRU = 1,nGRU + do iHRU = 1,gru_struc(iGRU)%hruCount + ! ensure the spectral average albedo is realistic + if(progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarSnowAlbedo)%dat(1) > mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%albedoMax)%dat(1)) & + progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarSnowAlbedo)%dat(1) = mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%albedoMax)%dat(1) + if(progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarSnowAlbedo)%dat(1) < mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%albedoMinWinter)%dat(1)) & + progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%scalarSnowAlbedo)%dat(1) = mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%albedoMinWinter)%dat(1) + ! ensure the visible albedo is realistic + if(progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(1) > mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%albedoMaxVisible)%dat(1)) & + progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(1) = mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%albedoMaxVisible)%dat(1) + if(progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(1) < mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%albedoMinVisible)%dat(1)) & + progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(1) = mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%albedoMinVisible)%dat(1) + ! ensure the nearIR albedo is realistic + if(progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(2) > mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%albedoMaxNearIR)%dat(1)) & + progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(2) = mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%albedoMaxNearIR)%dat(1) + if(progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(2) < mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%albedoMinNearIR)%dat(1)) & + progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(2) = mparData%gru(iGRU)%hru(iHRU)%var(iLookPARAM%albedoMinNearIR)%dat(1) + end do + end do + + ! ensure the initial conditions are consistent with the constitutive functions + do iGRU = 1,nGRU + do iHRU = 1,gru_struc(iGRU)%hruCount + + ! associate local variables with variables in the data structures + associate(& + ! 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) + ! 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) + ! 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 (-) + ! 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 (-) + ) ! (associate local variables with model parameters) + + ! compute the constant in the freezing curve function (m K-1) + kappa = (iden_ice/iden_water)*(LH_fus/(gravity*Tfreeze)) ! NOTE: J = kg m2 s-2 + + ! modify the liquid water and ice in the canopy + if(scalarCanopyIce > 0._dp .and. scalarCanopyTemp > Tfreeze)then + message=trim(message)//'canopy ice > 0 when canopy temperature > Tfreeze' + err=20; return + end if + fLiq = fracliquid(scalarCanopyTemp,snowfrz_scale) ! fraction of liquid water (-) + tWat = scalarCanopyLiq + scalarCanopyIce ! total water (kg m-2) + scalarCanopyLiq = fLiq*tWat ! mass of liquid water on the canopy (kg m-2) + scalarCanopyIce = (1._dp - fLiq)*tWat ! mass of ice on the canopy (kg m-2) + + ! number of layers + nLayers = gru_struc(iGRU)%hruInfo(iHRU)%nSnow + gru_struc(iGRU)%hruInfo(iHRU)%nSoil + nSnow = gru_struc(iGRU)%hruInfo(iHRU)%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._dp - 1._dp/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)) + + ! ***** snow + case(iname_snow) + ! (check liquid water) + if(mLayerVolFracLiq(iLayer) < 0._dp)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._dp)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 + ! (check ice) + if(mLayerVolFracIce(iLayer) > 0.80_dp)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice > 0.80: layer = ',iLayer; err=20; return; end if + if(mLayerVolFracIce(iLayer) < 0.05_dp)then; write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice < 0.05: layer = ',iLayer; err=20; return; end if + ! check total water + if(scalarTheta > 0.80_dp)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_dp)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 + case(iname_soil) + ! (check liquid water) + if(mLayerVolFracLiq(iLayer) < theta_res(iSoil) )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) )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._dp )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) )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) )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) )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 + 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)) + + ! ** snow + case(iname_snow) + + ! check that snow temperature is less than freezing + if(mLayerTemp(iLayer) > Tfreeze)then + message=trim(message)//'initial snow temperature is greater than freezing' + err=20; return + end if + + ! 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 + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) + + ! ** 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) + 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) + + 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) ) + end if ! if snow layers exist + + ! check that the layering is consistent + do iLayer=1,nLayers + h1 = sum(progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerDepth)%dat(1:iLayer)) ! sum of the depths up to the current layer + h2 = progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%iLayerHeight)%dat(iLayer) - progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%iLayerHeight)%dat(0) ! difference between snow-atm interface and bottom of layer + if(abs(h1 - h2) > 1.e-12_dp)then + write(message,'(a,1x,i0)') trim(message)//'mis-match between layer depth and layer height [suggest round numbers in initial conditions file]; layer = ', iLayer + err=20; return + end if + end do + + end do ! iHRU + end do ! iGRU + + end subroutine check_icond + +end module check_icond_module diff --git a/build/source/engine/childStruc.f90 b/build/source/engine/childStruc.f90 new file mode 100755 index 000000000..21e0de92b --- /dev/null +++ b/build/source/engine/childStruc.f90 @@ -0,0 +1,85 @@ +! 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 childStruc_module +USE nrtype +USE globalData,only:integerMissing ! missing value +USE nr_utility_module,only:arth ! get a sequence of numbers + +implicit none +private +public::childStruc +contains + + + ! ************************************************************************************************ + ! public subroutine childStruc: create a child data structure + ! ************************************************************************************************ + subroutine childStruc(metaParent,mask, & ! input + metaChild,parent2child_map,err,message) ! output + USE data_types,only:var_info ! data type for the metadata structure + USE data_types,only:extended_info ! data type for the extended metadata structure + implicit none + ! input variables + type(var_info),intent(in) :: metaParent(:) ! parent metadata structure + logical(lgt),intent(in) :: mask(:) ! variables desired + ! output variables + type(extended_info),allocatable,intent(out) :: metaChild(:) ! child metadata structure + integer(i4b),allocatable,intent(out) :: parent2child_map(:) ! index of the child variable + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! local variables + integer(i4b) :: nParent ! number of elements in the parent data structure + integer(i4b) :: nChild ! number of elements in the child data structure + ! ----------------------------------------------------------------------------------------------------------------------------------- + ! initialize errors + err=0; message="childStruc/" + + ! check the size of the input structures + nParent = size(metaParent) + if(size(mask)/=nParent)then + message=trim(message)//'size of mask vector does not match the size of the parent structure' + err=20; return + end if + + ! allocate space for the child metadata structure + nChild = count(mask) + if(allocated(metaChild)) deallocate(metaChild) + allocate(metaChild(nChild),stat=err) + if(err/=0)then + message=trim(message)//'problem allocating space for the child metadata structure' + err=20; return + end if + + ! define mapping with the parent data structure + metaChild(:)%ixParent = pack(arth(1,1,nParent), mask) + + ! copy across the metadata from the parent structure + metaChild(:)%var_info = metaParent(metaChild(:)%ixParent) + + ! allows to map from the parent to the child - must carry this around outside + if(allocated(parent2child_map)) then; err=20; message=trim(message)//'child map already allocated'; return; end if; + allocate(parent2child_map(nParent)) + parent2child_map(:) = integerMissing + if(nChild>0) parent2child_map(metaChild(:)%ixParent) = arth(1,1,nChild) + + end subroutine childStruc + +end module childStruc_module diff --git a/build/source/engine/computFlux.f90 b/build/source/engine/computFlux.f90 new file mode 100755 index 000000000..3e95829c9 --- /dev/null +++ b/build/source/engine/computFlux.f90 @@ -0,0 +1,857 @@ +! 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 computFlux_module + +! data types +USE nrtype + +! access missing values +USE globalData,only:integerMissing ! missing integer +USE globalData,only:realMissing ! missing real number + +! layer types +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) + +! 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 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 + +! 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 boundary conditions for hydrology +USE mDecisions_module,only: & + 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 + +implicit none +private +public::computFlux +public::soilCmpres +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 + 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) + ! 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 soil utilities + !USE snow_utils_module,only:dFracLiq_dTk ! differentiate the freezing curve w.r.t. temperature (snow) + !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:dTheta_dTk ! differentiate the freezing curve w.r.t. temperature (soil) + !USE soil_utils_module,only:matricHead ! compute the matric head based on volumetric water content + ! 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 + ! provide access to 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:iLookFORCE ! 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 + 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 + real(dp),intent(in) :: drainageMeltPond ! drainage from the surface melt pond (kg m-2 s-1) + ! input: state variables + real(dp),intent(in) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) + real(dp),intent(in) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) + real(dp),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) + real(dp),intent(in) :: mLayerMatricHeadLiqTrial(:) ! trial value for the liquid water matric potential (m) + ! input: diagnostic variables + real(dp),intent(in) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) + real(dp),intent(in) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) + real(dp),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) + real(dp),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(dp),intent(out) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + real(dp),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 + real(dp),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 + + ! 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) + + ! 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 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... + ! ****************** + + ! 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._dp + iLayerLiqFluxSoil(0:nSoil) = 0._dp + end if + + ! ***** + ! * CALCULATE ENERGY FLUXES OVER VEGETATION... + ! ********************************************* + + ! check if there is a need to calculate the energy fluxes over vegetation + if(ixCasNrg/=integerMissing .or. ixVegNrg/=integerMissing .or. ixTopNrg/=integerMissing .or. firstFluxCall)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 + attr_data, & ! intent(in): spatial attributes + 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 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,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 .or. firstFluxCall)then + + ! calculate energy fluxes at layer interfaces through the snow and soil domain + call ssdNrgFlux(& + ! 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 < 3) 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 .or. firstFluxCall)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 .or. firstFluxCall)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) + ! 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 + 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(out): vertical liquid water flux at layer interfaces (m s-1) + iLayerLiqFluxSnowDeriv(0:nSnow), & ! intent(out): 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 + + ! 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 + 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) + endif ! if no snow layers + + endif + + ! ***** + ! * CALCULATE THE LIQUID FLUX THROUGH SOIL... + ! ******************************************** + + ! check the need to calculate the liquid flux through soil + if(nSoilOnlyHyd>0 .or. firstFluxCall)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 + .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(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 + ! 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(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 + scalarInfiltration, & ! intent(out): surface infiltration rate (m s-1) -- controls on infiltration only computed for iter==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 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(out): derivatives in the flux w.r.t. matric head in the layer above (s-1) + dq_dHydStateBelow, & ! intent(out): 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(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,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) + !print*, 'iLayerLiqFluxSoil(iLayer-1), mLayerLiqFluxSoil(iLayer) = ', iLayerLiqFluxSoil(iLayer-1), mLayerLiqFluxSoil(iLayer) + 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._dp - scalarFrozenArea)*scalarInfilArea + else + scalarSoilControl = 0._dp ! (scalarRainPlusMelt exceeds maximum infiltration rate + endif + else + ! * case of infiltration into snow + scalarSoilControl = 1._dp + 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 .or. firstFluxCall)then + + ! set baseflow fluxes to zero if the baseflow routine is not used + if(local_ixGroundwater/=qbaseTopmodel)then + ! (diagnostic variables in the data structures) + scalarExfiltration = 0._dp ! exfiltration from the soil profile (m s-1) + mLayerColumnOutflow(:) = 0._dp ! column outflow from each soil layer (m3 s-1) + ! (variables needed for the numerical solution) + mLayerBaseflow(:) = 0._dp ! baseflow from each soil layer (m s-1) + + ! 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) + + endif ! if computing soil hydrology + + ! ***** + ! (7) CALCUALTE FLUXES FOR THE DEEP AQUIFER... + ! ******************************************** + + ! identify modeling decision + if(local_ixGroundwater==bigBucket)then + ! deep aquifer is not yet transferred from old code structure + message=trim(message)//'bigBucket groundwater parameterization is not yet transfered from old code structure' + err=20; return + else + ! if no aquifer, then fluxes are zero + scalarAquiferTranspire = 0._dp ! transpiration loss from the aquifer (m s-1 + scalarAquiferRecharge = 0._dp ! recharge to the aquifer (m s-1) + scalarAquiferBaseflow = 0._dp ! total baseflow from the aquifer (m s-1) + end if + + ! ***** + ! (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 + + ! 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 + 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 (-) + mLayerdTheta_dPsi, & ! intent(in): derivative in the soil water characteristic (m-1) + 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 + real(dp),intent(in) :: mLayerMatricHead(:) ! matric head at the start of the time step (m) + real(dp),intent(in) :: mLayerMatricHeadTrial(:) ! trial value for matric head (m) + real(dp),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) + real(dp),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) + real(dp),intent(in) :: mLayerdTheta_dPsi(:) ! derivative in the soil water characteristic (m-1) + real(dp),intent(in) :: specificStorage ! specific storage coefficient (m-1) + real(dp),intent(in) :: theta_sat(:) ! soil porosity (-) + ! output: + real(dp),intent(out) :: compress(:) ! soil compressibility (-) + real(dp),intent(out) :: 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 + real(dp) :: volFracWat ! total volumetric fraction of water (-) + real(dp) :: fPart1,fPart2 ! different parts of the function + real(dp) :: dPart1,dPart2 ! derivatives for different parts of the function + 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) + ! compute the total volumetric fraction of water (-) + volFracWat = mLayerVolFracLiqTrial(iLayer) + mLayerVolFracIceTrial(iLayer) + ! compute the compressibility term (-) + compress(iLayer) = (specificStorage*volFracWat/theta_sat(iLayer)) * (mLayerMatricHeadTrial(iLayer) - mLayerMatricHead(iLayer)) + ! compute the derivative for the compressibility term (m-1) + fPart1 = specificStorage*(volFracWat/theta_sat(iLayer)) ! function for the 1st part (m-1) + fPart2 = mLayerMatricHeadTrial(iLayer) - mLayerMatricHead(iLayer) ! function for the 2nd part (m) + dPart1 = mLayerdTheta_dPsi(iLayer)*specificStorage/theta_sat(iLayer) ! derivative for the 1st part (m-2) + dPart2 = 1._dp ! derivative for the 2nd part (-) + dCompress_dPsi(iLayer) = fPart1*dPart2 + dPart1*fPart2 ! m-1 + end do + else + compress(:) = 0._dp + dCompress_dPsi(:) = 0._dp + end if + end subroutine soilCmpres + +end module computFlux_module diff --git a/build/source/engine/computJacob.f90 b/build/source/engine/computJacob.f90 new file mode 100755 index 000000000..635490e22 --- /dev/null +++ b/build/source/engine/computJacob.f90 @@ -0,0 +1,774 @@ +! 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 computJacob_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 + +! 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 + +! 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: 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_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_ilength, & ! data vector with variable length dimension (i4b) + var_dlength ! data vector with variable length dimension (dp) + +implicit none +! define constants +real(dp),parameter :: verySmall=tiny(1.0_dp) ! a very small number +integer(i4b),parameter :: ixBandOffset=kl+ku+1 ! offset in the band Jacobian matrix + +private +public::computJacob +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 + ! 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:iLookDERIV ! named variables for structure elements + ! ----------------------------------------------------------------------------------------------------------------- + implicit none + ! input: model control + real(dp),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(dp),intent(in) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + ! input-output: Jacobian and its diagonal + real(dp),intent(inout) :: dMat(:) ! diagonal of the Jacobian matrix + real(dp),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(dp) :: 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 + ! 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 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._dp ! 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._dp ! 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._dp - 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) + 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._dp + 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._dp ! 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._dp - 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) + + ! ----- + ! * 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(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) + 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 + else + aJac(ixOffDiag(nrgState,watState),watState) = 0._dp + 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 + + ! compute upper-diagonal elements + if(iLayer0)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._dp + 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._dp ! 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._dp - 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) + 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._dp + 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 + endif + + ! compute upper-diagonal elements + if(iLayer. + +module computResid_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 + +! 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) + +! provide access to the 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) + +implicit none +private +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 + ! 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 + ! -------------------------------------------------------------------------------------------------------------------------------- + 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 + implicit none + ! input: model control + real(dp),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(qp),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) + real(dp),intent(in) :: fVec(:) ! flux vector + ! input: state variables (already disaggregated into scalars and vectors) + real(dp),intent(in) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) + real(dp),intent(in) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) + real(dp),intent(in) :: scalarCanopyHydTrial ! trial value for canopy water (kg m-2), either liquid water content or total water content + real(dp),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) + real(dp),intent(in) :: mLayerVolFracHydTrial(:) ! trial vector of volumetric water content (-), either liquid water content or total water content + ! input: diagnostic variables defining the liquid water and ice content (function of state variables) + real(dp),intent(in) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) + real(dp),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(dp),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(dp) :: scalarCanopyHyd ! canopy water content (kg m-2), either liquid water content or total water content + real(dp),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 (-) + ! 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) + 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... + ! ----------------------- + + ! intialize additional terms on the RHS as zero + rAdd(:) = 0._dp + + ! 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 + + ! 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 + + ! --- + ! * 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) ) + ! --> 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) + 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) + 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 + + ! 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 + + ! check + if(any(isNan(rVec)))then + message=trim(message)//'we found some Indian bread (NaN)' + err=20; return + endif + + ! end association with the necessary variabiles for the residual calculations + end associate + + end subroutine computResid + +end module computResid_module diff --git a/build/source/engine/convE2Temp.f90 b/build/source/engine/convE2Temp.f90 old mode 100644 new mode 100755 index e3f070d1a..76ac6f026 --- a/build/source/engine/convE2Temp.f90 +++ b/build/source/engine/convE2Temp.f90 @@ -35,14 +35,15 @@ module convE2Temp_module ! ************************************************************************************************************************ ! public subroutine E2T_lookup: define a look-up table to compute specific enthalpy based on temperature, assuming no soil ! ************************************************************************************************************************ - subroutine E2T_lookup(err,message) + 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 USE multiconst,only:Tfreeze ! freezing point (K) - USE data_struc,only:mpar_data ! model parameter structures (use snowfrz_scale) USE var_lookup,only:iLookPARAM ! named variables to define structure element + USE data_types,only:var_dlength ! data vector with variable length dimension (dp): x%var(:)%dat(:) 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 @@ -57,9 +58,7 @@ subroutine E2T_lookup(err,message) ! initialize error control err=0; message="E2T_lookup/" ! associate - associate(& - snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale) & - ) + associate( snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1) ) ! define initial temperature vector T_incr = (Tfreeze - T_start) / real(nlook-1, kind(dp)) ! temperature increment Tk = arth(T_start,T_incr,nlook) @@ -72,10 +71,10 @@ subroutine E2T_lookup(err,message) 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_dp,1.e30_dp,T2deriv,err,cmessage) ! get the second derivatives - if(err/=0) then; message=trim(message)//trim(cmessage); return; endif + 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; endif + 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 @@ -87,9 +86,7 @@ end subroutine E2T_lookup ! ************************************************************************************************************************ subroutine E2T_nosoil(Ey,BulkDenWater,fc_param,Tk,err,message) ! compute temperature based on enthalpy -- appropriate when no dry mass, as in snow - 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) + USE multiconst, only: Cp_ice ! specific heat of ice (J kg-1 K-1) implicit none ! declare dummy variables real(dp),intent(in) :: Ey ! total enthalpy (J m-3) @@ -139,14 +136,14 @@ subroutine E2T_nosoil(Ey,BulkDenWater,fc_param,Tk,err,message) if(E_spec < E_lookup(i0) .or. 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 - endif + 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 - endif + end if ! compute initial derivative dh = (f1 - f0) / (Tg1 - Tg0) @@ -157,7 +154,7 @@ subroutine E2T_nosoil(Ey,BulkDenWater,fc_param,Tk,err,message) if(abs(dT). module coupled_em_module + ! numerical recipes data types USE nrtype -! access the number of snow and soil layers -USE data_struc,only:& - nSnow, & ! number of snow layers - nSoil, & ! number of soil layers - nLayers ! total number of layers + ! physical constants USE multiconst,only:& Tfreeze, & ! temperature at freezing (K) LH_fus, & ! latent heat of fusion (J kg-1) + LH_sub, & ! latent heat of sublimation (J kg-1) iden_ice, & ! intrinsic density of ice (kg m-3) iden_water ! intrinsic density of liquid water (kg m-3) + +! access the global print flag +USE globalData,only:globalPrintFlag + implicit none private public::coupled_em @@ -40,21 +42,62 @@ module coupled_em_module real(dp),parameter :: verySmall=1.e-6_dp ! used as an additive constant to check if substantial difference among real numbers real(dp),parameter :: mpe=1.e-6_dp ! prevents overflow error if division by zero real(dp),parameter :: dx=1.e-6_dp ! finite difference increment +! number of variables +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 contains ! ************************************************************************************************ ! public subroutine coupled_em: run the coupled energy-mass model for one timestep ! ************************************************************************************************ - subroutine coupled_em(printRestart,output_fileSuffix,dt_init,err,message) - ! data structures and named variables - USE data_struc,only:data_step ! time step of forcing data (s) - USE data_struc,only:model_decisions ! model decision structure - USE data_struc,only:type_data,attr_data,forc_data,mpar_data ! data structures - USE data_struc,only:bvar_data,mvar_data,indx_data,time_data ! data structures - USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure - USE data_struc,only:ix_soil,ix_snow ! named variables for snow and soil - USE var_lookup,only:iLookTYPE,iLookATTR,iLookFORCE,iLookPARAM,iLookMVAR,iLookINDEX ! named variables for structure elements + subroutine coupled_em(& + ! model control + hruId, & ! intent(in): hruId + dt_init, & ! intent(inout): used to initialize the size of the sub-step + computeVegFlux, & ! intent(inout): flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) + ! data structures (input) + type_data, & ! intent(in): local classification of soil veg etc. for each HRU + attr_data, & ! intent(in): local attributes for each HRU + forc_data, & ! intent(in): model forcing data + mpar_data, & ! intent(in): model parameters + bvar_data, & ! intent(in): basin-average variables + ! data structures (input-output) + indx_data, & ! intent(inout): model indices + prog_data, & ! intent(inout): prognostic variables for a local HRU + diag_data, & ! intent(inout): diagnostic variables for a local HRU + flux_data, & ! intent(inout): model fluxes for a local HRU + ! error control + err,message) ! intent(out): error control + ! 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) + ! 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 + ! named variables for child structures + USE var_lookup,only:childFLUX_MEAN + ! global data + USE globalData,only:data_step ! time step of forcing data (s) + USE globalData,only:model_decisions ! model decision structure + ! structure allocations + USE globalData,only:indx_meta ! metadata on the model index variables + 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:averageFlux_meta ! metadata on the timestep-average model flux structure + USE allocspace_module,only:allocLocal ! allocate local data structures + USE allocspace_module,only:resizeData ! clone a data structure ! preliminary subroutines USE vegPhenlgy_module,only:vegPhenlgy ! (1) compute vegetation phenology USE vegNrgFlux_module,only:wettedFrac ! (2) compute wetted fraction of the canopy (used in sw radiation fluxes) @@ -65,7 +108,8 @@ subroutine coupled_em(printRestart,output_fileSuffix,dt_init,err,message) USE volicePack_module,only:volicePack ! (7) merge and sub-divide snow layers, if necessary USE diagn_evar_module,only:diagn_evar ! (8) compute diagnostic energy variables -- thermal conductivity and heat capacity ! the model solver - USE systemSolv_module,only:systemSolv ! solve the system of thermodynamic and hydrology equations for a given substep + USE indexState_module,only:indexState ! define indices for all model state variables and layers + USE opSplittin_module,only:opSplittin ! solve the system of thermodynamic and hydrology equations for a given substep ! additional subroutines USE tempAdjust_module,only:tempAdjust ! adjust snow temperature associated with new snowfall USE snwDensify_module,only:snwDensify ! snow densification (compaction and cavitation) @@ -80,65 +124,74 @@ subroutine coupled_em(printRestart,output_fileSuffix,dt_init,err,message) stickySnow, & ! maximum interception capacity an increasing function of temerature lightSnow ! maximum interception capacity an inverse function of new snow density implicit none - ! define output - character(*),intent(in) :: output_fileSuffix ! suffix for the output file (used to write re-start files) - logical(lgt),intent(in) :: printRestart ! flag to print a re-start file + ! model control + integer(i4b),intent(in) :: hruId ! hruId real(dp),intent(inout) :: dt_init ! used to initialize the size of the sub-step + logical(lgt),intent(inout) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) + ! data structures (input) + 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_dlength),intent(in) :: bvar_data ! basin-average model variables + ! data structures (input-output) + type(var_ilength),intent(inout) :: indx_data ! state vector geometry + 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 + ! error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message - ! control the length of the sub-step - real(dp),pointer :: minstep ! minimum time step (seconds) - real(dp),pointer :: maxstep ! maximum time step (seconds) - real(dp) :: dt ! length of time step (seconds) - real(dp) :: dt_sub ! length of the sub-step (seconds) - real(dp) :: dt_done ! length of time step completed (seconds) - integer(i4b) :: nsub ! number of sub-steps - integer(i4b) :: niter ! number of iterations - 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(dp),parameter :: F_inc = 1.25_dp ! factor used to increase time step - real(dp),parameter :: F_dec = 0.90_dp ! factor used to decrease time step - integer(i4b) :: maxiter ! maxiumum number of iterations - integer(i4b) :: iSnow ! index for snow layers - ! check SWE - real(dp) :: oldSWE ! SWE at the start of the substep - real(dp) :: newSWE ! SWE at the end of the substep - real(dp) :: delSWE ! change in SWE over the subtep - real(dp) :: effRainfall ! effective rainfall (kg m-2 s-1) - real(dp) :: effSnowfall ! effective snowfall (kg m-2 s-1) - real(dp) :: sublimation ! sublimation of ice from the snowpack (kg m-2 s-1) - real(dp) :: snwDrainage ! drainage of liquid water from the snowpack (m s-1 -> kg m-2 s-1) - real(dp) :: sfcMeltPond ! surface melt pond (kg m-2) - real(dp) :: massBalance ! mass balance error (kg m-2) - ! define other local variables + ! ===================================================================================================================================================== + ! ===================================================================================================================================================== + ! local variables character(len=256) :: cmessage ! error message - logical(lgt) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) + real(dp) :: dtSave ! length of last input model sub-step (seconds) + real(dp) :: dt_sub ! length of model sub-step (seconds) + real(dp) :: dt_wght ! weight applied to model sub-step (dt_sub/data_step) + real(dp) :: dt_solv ! seconds in the data step that have been completed + real(dp) :: dtMultiplier ! time step multiplier (-) based on what happenned in "opSplittin" + real(dp) :: minstep,maxstep ! minimum and maximum time step length (seconds) + integer(i4b) :: nsub ! number of substeps + logical(lgt) :: computeVegFluxOld ! flag to indicate if we are computing fluxes over vegetation on the previous sub step + logical(lgt) :: modifiedLayers ! flag to denote that snow layers were modified + logical(lgt) :: modifiedVegState ! flag to denote that vegetation states were modified + type(var_dlength) :: flux_mean ! timestep-average model fluxes for a local HRU integer(i4b) :: nLayersRoots ! number of soil layers that contain roots - real(dp) :: scalarCanopyWater ! total canopy water (kg m-2) - real(dp) :: canopyDepth ! canopy depth (m) real(dp) :: exposedVAI ! exposed vegetation area index - real(dp) :: dt_wght ! weight applied to each sub-step, to compute time step average real(dp) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) real(dp) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) real(dp),parameter :: varNotUsed1=-9999._dp ! variables used to calculate derivatives (not needed here) real(dp),parameter :: varNotUsed2=-9999._dp ! variables used to calculate derivatives (not needed here) + integer(i4b) :: iSnow ! index of snow layers integer(i4b) :: iLayer ! index of model layers - real(dp) :: volSub ! volumetric sublimation (kg m-3) - real(dp),parameter :: tinyNumber=tiny(1._dp) ! a tiny number - real(dp) :: dt_solv ! progress towards dt_sub - real(dp) :: dt_temp ! temporary sub-step length - real(dp) :: dt_prog ! progress of time step (s) - real(dp) :: dt_frac ! fraction of time step (-) - integer(i4b) :: nTemp ! number of temporary sub-steps - integer(i4b) :: nTrial ! number of trial sub-steps - logical(lgt) :: rejectedStep ! flag to denote if the sub-step is rejected (convergence problem, etc.) + real(dp) :: subLoss ! sublimation loss (kg m-2) + real(dp) :: superflousSub ! superflous sublimation (kg m-2 s-1) + real(dp) :: superflousNrg ! superflous energy that cannot be used for sublimation (W m-2 [J m-2 s-1]) + integer(i4b) :: ixSolution ! solution method used by opSplitting + logical(lgt) :: firstSubStep ! flag to denote if the first time step + logical(lgt) :: stepFailure ! flag to denote the need to reduce length of the coupled step and try again + logical(lgt) :: tooMuchMelt ! flag to denote that there was too much melt in a given time step + logical(lgt) :: doLayerMerge ! flag to denote the need to merge snow layers + logical(lgt) :: pauseFlag ! flag to pause execution + logical(lgt),parameter :: backwardsCompatibility=.true. ! flag to denote a desire to ensure backwards compatibility with previous branches. + type(var_ilength) :: indx_temp ! temporary model index variables + type(var_dlength) :: prog_temp ! temporary model prognostic variables + type(var_dlength) :: diag_temp ! temporary model diagnostic variables + ! check SWE + real(dp) :: oldSWE ! SWE at the start of the substep + real(dp) :: newSWE ! SWE at the end of the substep + real(dp) :: delSWE ! change in SWE over the subtep + real(dp) :: effRainfall ! effective rainfall (kg m-2 s-1) + real(dp) :: effSnowfall ! effective snowfall (kg m-2 s-1) + real(dp) :: sfcMeltPond ! surface melt pond (kg m-2) + real(dp) :: massBalance ! mass balance error (kg m-2) ! balance checks - real(dp),pointer :: scalarSnowfall ! snowfall rate - real(dp),pointer :: scalarRainfall ! rainfall rate + integer(i4b) :: iVar ! loop through model variables real(dp) :: scalarCanopyWatBalError ! water balance error for the vegetation canopy (kg m-2) real(dp) :: scalarSoilWatBalError ! water balance error (kg m-2) - real(dp) :: scalarTotalSoilLiq ! total liquid water in the soil column (kg m-2) - real(dp) :: scalarTotalSoilIce ! total ice in the soil column (kg m-2) + real(dp) :: scalarInitCanopyLiq ! initial liquid water on the vegetation canopy (kg m-2) + real(dp) :: scalarInitCanopyIce ! initial ice on the vegetation canopy (kg m-2) real(dp) :: balanceCanopyWater0 ! total water stored in the vegetation canopy at the start of the step (kg m-2) real(dp) :: balanceCanopyWater1 ! total water stored in the vegetation canopy at the end of the step (kg m-2) real(dp) :: balanceSoilWater0 ! total soil storage at the start of the step (kg m-2) @@ -146,759 +199,859 @@ subroutine coupled_em(printRestart,output_fileSuffix,dt_init,err,message) real(dp) :: balanceSoilInflux ! input to the soil zone real(dp) :: balanceSoilBaseflow ! output from the soil zone real(dp) :: balanceSoilDrainage ! output from the soil zone - real(dp) :: balanceSoilTranspiration ! output from the soil zone + real(dp) :: balanceSoilET ! output from the soil zone real(dp) :: balanceAquifer0 ! total aquifer storage at the start of the step (kg m-2) real(dp) :: balanceAquifer1 ! total aquifer storage at the end of the step (kg m-2) - real(dp) :: xCompress ! compression in a given layer (m) - real(dp) :: xFlux0,xFlux1 ! fluxes at the layer boundaries (m) - ! ---------------------------------------------------------------------------------------------------------------------------------------------- - ! ** local pointers to model state variables - ! ---------------------------------------------------------------------------------------------------------------------------------------------- - real(dp),pointer :: mLayerDepth(:) ! depth of each soil layer (m) - real(dp),pointer :: mLayerVolFracIce(:) ! volumetric ice content in each soil layer (-) - real(dp),pointer :: mLayerVolFracLiq(:) ! volumetric liquid water content in each soil layer (-) - real(dp),pointer :: scalarAquiferStorage ! aquifer storage (m) - real(dp),pointer :: scalarCanopyLiq ! canopy liquid water content (kg m-2) - real(dp),pointer :: scalarCanopyIce ! canopy ice content (kg m-2) - ! ---------------------------------------------------------------------------------------------------------------------------------------------- - ! ** local pointers to increment fluxes - ! ---------------------------------------------------------------------------------------------------------------------------------------------- - ! local pointers to flux variables - real(dp),pointer :: scalarThroughfallSnow ! snow that reaches the ground without ever touching the canopy (kg m-2 s-1) - real(dp),pointer :: scalarThroughfallRain ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) - real(dp),pointer :: scalarCanopySnowUnloading ! unloading of snow from the vegetion canopy (kg m-2 s-1) - real(dp),pointer :: scalarCanopyLiqDrainage ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) - real(dp),pointer :: scalarCanopyMeltFreeze ! melt/freeze of water stored in the canopy (kg m-2 s-1) - real(dp),pointer :: scalarCanopyTranspiration ! canopy transpiration (kg m-2 s-1) - real(dp),pointer :: scalarCanopyEvaporation ! canopy evaporation/condensation (kg m-2 s-1) - real(dp),pointer :: scalarCanopySublimation ! canopy sublimation/frost (kg m-2 s-1) - real(dp),pointer :: scalarSnowSublimation ! snow sublimation/frost - below canopy or non-vegetated (kg m-2 s-1) - real(dp),pointer :: scalarGroundEvaporation ! ground evaporation/condensation - below canopy or non-vegetated (kg m-2 s-1) - real(dp),pointer :: scalarRainPlusMelt ! rain plus melt, as input to soil before calculating surface runoff (m s-1) - real(dp),pointer :: scalarSurfaceRunoff ! surface runoff (m s-1) - real(dp),pointer :: scalarSoilInflux ! influx of water at the top of the soil profile (m s-1) - real(dp),pointer :: scalarSoilCompress ! change in storage associated with compression of the soil matrix (kg m-2) - real(dp),pointer :: scalarSoilBaseflow ! total baseflow from throughout the soil profile (m s-1) - real(dp),pointer :: scalarSoilDrainage ! drainage from the bottom of the soil profile (m s-1) - real(dp),pointer :: scalarAquiferRecharge ! recharge to the aquifer (m s-1) - real(dp),pointer :: scalarAquiferBaseflow ! baseflow from the aquifer (m s-1) - real(dp),pointer :: scalarAquiferTranspire ! transpiration from the aquifer (m s-1) - real(dp),pointer :: mLayerColumnOutflow(:) ! total outflow from each layer in a given soil column (m3 s-1) - ! local pointers to timestep-average flux variables - real(dp),pointer :: totalSoilCompress ! change in storage associated with compression of the soil matrix (kg m-2) - real(dp),pointer :: averageThroughfallSnow ! snow that reaches the ground without ever touching the canopy (kg m-2 s-1) - real(dp),pointer :: averageThroughfallRain ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) - real(dp),pointer :: averageCanopySnowUnloading ! unloading of snow from the vegetion canopy (kg m-2 s-1) - real(dp),pointer :: averageCanopyLiqDrainage ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) - real(dp),pointer :: averageCanopyMeltFreeze ! melt/freeze of water stored in the canopy (kg m-2 s-1) - real(dp),pointer :: averageCanopyTranspiration ! canopy transpiration (kg m-2 s-1) - real(dp),pointer :: averageCanopyEvaporation ! canopy evaporation/condensation (kg m-2 s-1) - real(dp),pointer :: averageCanopySublimation ! canopy sublimation/frost (kg m-2 s-1) - real(dp),pointer :: averageSnowSublimation ! snow sublimation/frost - below canopy or non-vegetated (kg m-2 s-1) - real(dp),pointer :: averageGroundEvaporation ! ground evaporation/condensation - below canopy or non-vegetated (kg m-2 s-1) - real(dp),pointer :: averageRainPlusMelt ! rain plus melt, as input to soil before calculating surface runoff (m s-1) - real(dp),pointer :: averageSurfaceRunoff ! surface runoff (m s-1) - real(dp),pointer :: averageSoilInflux ! influx of water at the top of the soil profile (m s-1) - real(dp),pointer :: averageSoilBaseflow ! total baseflow from throughout the soil profile (m s-1) - real(dp),pointer :: averageSoilDrainage ! drainage from the bottom of the soil profile (m s-1) - real(dp),pointer :: averageAquiferRecharge ! recharge to the aquifer (m s-1) - real(dp),pointer :: averageAquiferBaseflow ! baseflow from the aquifer (m s-1) - real(dp),pointer :: averageAquiferTranspire ! transpiration from the aquifer (m s-1) - real(dp),pointer :: averageColumnOutflow(:) ! outflow from each layer in the soil profile (m3 s-1) ! ---------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message="coupled_em/" ! This is the start of a data step for a local HRU + ! link canopy depth to the information in the data structure + canopy: associate(canopyDepth => 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 mdify 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==ix_snow) - nSoil = count(indx_data%var(iLookINDEX%layerType)%dat==ix_soil) + 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 - scalarCanopyLiq => mvar_data%var(iLookMVAR%scalarCanopyLiq)%dat(1) - scalarCanopyIce => mvar_data%var(iLookMVAR%scalarCanopyIce)%dat(1) - balanceCanopyWater0 = scalarCanopyLiq + scalarCanopyIce - - ! point to model state variables - ! NOTE: need to do this at the start of each sub-step because number of layers may change - mLayerDepth => mvar_data%var(iLookMVAR%mLayerDepth)%dat(nSnow+1:nLayers) ! depth of each soil layer (m) - mLayerVolFracIce => mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat(nSnow+1:nLayers) ! volumetric ice content in each soil layer (-) - mLayerVolFracLiq => mvar_data%var(iLookMVAR%mLayerVolFracLiq)%dat(nSnow+1:nLayers) ! volumetric liquid water content in each soil layer (-) - scalarAquiferStorage => mvar_data%var(iLookMVAR%scalarAquiferStorage)%dat(1) ! aquifer storage (m) + ! 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 and surface melt pond + sfcMeltPond = 0._dp ! change in storage associated with the surface melt pond (kg m-2) + + ! initialize mean fluxes + do iVar=1,size(averageFlux_meta) + flux_mean%var(iVar)%dat(:) = 0._dp + 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) + ) ! (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 - !scalarTotalSoilIce = sum(iden_ice *mLayerVolFracIce(1:nSoil)*mLayerDepth(1:nSoil)) - ! get the total water in the soil (liquid plus ice) at the start of the time step (kg m-2) - balanceSoilWater0 = scalarTotalSoilLiq + scalarTotalSoilIce + ! 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 - ! print re-start file - if(printRestart)then - call printRestartFile(output_fileSuffix,dt_init,time_data,mvar_data,err,cmessage) - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif - !pause - endif + ! end association of local variables with information in the data structures + end associate - ! assign pointers to algorithmic control parameters - minstep => mpar_data%var(iLookPARAM%minstep) ! minimum time step (s) - maxstep => mpar_data%var(iLookPARAM%maxstep) ! maximum time step (s) + ! short-cut to the algorithmic control parameters + ! NOTE - temporary assignment of minstep to foce something reasonable + minstep = 10._dp ! 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 - ! define maximum number of iterations - maxiter = nint(mpar_data%var(iLookPARAM%maxiter)) - - ! get the length of the time step (seconds) - dt = data_step - ! compute the number of layers with roots - nLayersRoots = count(mvar_data%var(iLookMVAR%iLayerHeight)%dat(nSnow:nLayers-1) < mpar_data%var(iLookPARAM%rootingDepth)-verySmall) - if(nLayersRoots == 0)then; err=20; message=trim(message)//'no roots within the soil profile'; return; endif + 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 - mvar_data%var(iLookMVAR%scalarFoliageNitrogenFactor)%dat(1) = 1._dp ! foliage nitrogen concentration (1.0 = saturated) + diag_data%var(iLookDIAG%scalarFoliageNitrogenFactor)%dat(1) = 1._dp ! foliage nitrogen concentration (1.0 = saturated) + + ! save SWE + oldSWE = prog_data%var(iLookPROG%scalarSWE)%dat(1) + !print*, 'nSnow = ', nSnow + !print*, 'oldSWE = ', oldSWE + + ! (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(dp)) + + ! 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) + + ! (2) 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._dp + 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._dp + dCanopyWetFraction_dWat = 0._dp + dCanopyWetFraction_dT = 0._dp + end if + + ! (3) 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 + + + ! (4) 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 + + + ! (5) 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 + 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 + + ! 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._dp + else + flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1) = 0._dp + flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1) = 0._dp + end if + + ! (6) 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) + + ! 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 + + ! **************************************************************************************************** + ! *** MAIN SOLVER ************************************************************************************ + ! **************************************************************************************************** ! initialize the length of the sub-step - dt_sub = min(dt_init,min(dt,maxstep)) - dt_done = 0._dp + dt_solv = 0._dp ! 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 - do ! continuous do statement with exit clause (alternative to "while") + 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 = ', dt_sub, dt_init, dt + !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 ! increment the number of sub-steps nsub = nsub+1 - ! save SWE - oldSWE = mvar_data%var(iLookMVAR%scalarSWE)%dat(1) - !print*, 'nSnow = ', nSnow - !print*, 'oldSWE = ', oldSWE - - - ! (1) compute phenology... - ! ------------------------ - - ! compute the temperature of the root zone: used in vegetation phenology - mvar_data%var(iLookMVAR%scalarRootZoneTemp)%dat(1) = sum(mvar_data%var(iLookMVAR%mLayerTemp)%dat(nSnow+1:nSnow+nLayersRoots)) / real(nLayersRoots, kind(dp)) + ! 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 + endif - ! compute the exposed LAI and SAI and whether veg is buried by snow - call vegPhenlgy(& - ! input/output: data structures + ! 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 + + ! (7) 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 - type_data, & ! intent(in): type of vegetation and soil - attr_data, & ! intent(in): spatial attributes mpar_data, & ! intent(in): model parameters - mvar_data, & ! intent(inout): model variables for a local HRU + 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 - 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) + modifiedLayers, & ! intent(out): flag to denote that layers were modified err,cmessage) ! intent(out): error control - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif - - - ! (2) compute wetted canopy area... - ! --------------------------------- - - ! compute maximum canopy liquid water (kg m-2) - mvar_data%var(iLookMVAR%scalarCanopyLiqMax)%dat(1) = mpar_data%var(iLookPARAM%refInterceptCapRain)*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 - select case(model_decisions(iLookDECISIONS%snowIncept)%iDecision) - case(lightSnow); mvar_data%var(iLookMVAR%scalarCanopyIceMax)%dat(1) = exposedVAI*mpar_data%var(iLookPARAM%refInterceptCapSnow) ! use maximum per unit leaf area storage capacity for snow (kg m-2) - case(stickySnow); mvar_data%var(iLookMVAR%scalarCanopyIceMax)%dat(1) = exposedVAI*mpar_data%var(iLookPARAM%refInterceptCapSnow)*4._dp ! use maximum per unit leaf area storage capacity for snow (kg m-2) - 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*, 'mvar_data%var(iLookMVAR%scalarCanopyLiqMax)%dat(1) = ', mvar_data%var(iLookMVAR%scalarCanopyLiqMax)%dat(1) - !print*, 'mvar_data%var(iLookMVAR%scalarCanopyIceMax)%dat(1) = ', mvar_data%var(iLookMVAR%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 + if(err/=0)then; err=55; message=trim(message)//trim(cmessage); return; end if + + ! recompute the number of snow and soil layers + ! NOTE: do this here for greater visibility + nSnow = count(indx_data%var(iLookINDEX%layerType)%dat==iname_snow) + nSoil = count(indx_data%var(iLookINDEX%layerType)%dat==iname_soil) + nLayers = nSnow+nSoil + + ! put the data in the structures + indx_data%var(iLookINDEX%nSnow)%dat(1) = nSnow + indx_data%var(iLookINDEX%nSoil)%dat(1) = nSoil + indx_data%var(iLookINDEX%nLayers)%dat(1) = nLayers + + ! 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 + 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 - ! 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 - (mvar_data%var(iLookMVAR%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 - mvar_data%var(iLookMVAR%scalarCanopyLiq)%dat(1), & ! canopy liquid water (kg m-2) - mvar_data%var(iLookMVAR%scalarCanopyIce)%dat(1), & ! canopy ice (kg m-2) - mvar_data%var(iLookMVAR%scalarCanopyLiqMax)%dat(1), & ! maximum canopy liquid water (kg m-2) - mvar_data%var(iLookMVAR%scalarCanopyLiqMax)%dat(1), & ! maximum canopy ice content (kg m-2) - ! output - mvar_data%var(iLookMVAR%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; endif - - ! vegetation is completely buried by snow (or no veg exisits at all) - else - mvar_data%var(iLookMVAR%scalarCanopyWetFraction)%dat(1) = 0._dp - dCanopyWetFraction_dWat = 0._dp - dCanopyWetFraction_dT = 0._dp - 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 - ! (3) 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 - dt_sub, & ! intent(in): model time step (s) - (nSnow > 0), & ! intent(in): logical flag to denote if snow is present + 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) + + ! (7) 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 - model_decisions, & ! intent(in): model decisions - mpar_data, & ! intent(in): model parameters - mvar_data, & ! intent(inout): model variables for a local HRU + 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=20; message=trim(message)//trim(cmessage); return; endif - - - ! (4) compute canopy sw radiation fluxes... - ! ----------------------------------------- - call vegSWavRad(& - dt_sub, & ! intent(in): time step (s) -- only used in Noah-MP radiation, to compute albedo - computeVegFlux, & ! intent(in): logical flag to compute vegetation fluxes (.false. if veg buried by snow) - err,cmessage) ! intent(out): error control - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif + err,cmessage) ! intent(out): error control + if(err/=0)then; err=55; message=trim(message)//trim(cmessage); return; end if + + + ! (8) 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 + end if + ! (9) solve model equations... + ! ---------------------------- + ! save input step + dtSave = dt_sub - ! (5) 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(& + ! get the new solution + call opSplittin(& ! input: model control - dt_sub, & ! 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 - mvar_data, & ! intent(inout): model 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; endif - !print*, 'canopyIce = ', mvar_data%var(iLookMVAR%scalarCanopyIce)%dat(1) - - ! adjust canopy temperature to account for new snow - call tempAdjust(& - ! input: derived parameters - canopyDepth, & ! intent(in): canopy depth (m) + 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 - mpar_data, & ! intent(in): model parameters - mvar_data, & ! intent(inout): model 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; endif - - ! 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 - mvar_data%var(iLookMVAR%scalarThroughfallRain)%dat(1) = mvar_data%var(iLookMVAR%scalarRainfall)%dat(1) - mvar_data%var(iLookMVAR%scalarCanopyLiqDrainage)%dat(1) = 0._dp + 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 - mvar_data%var(iLookMVAR%scalarThroughfallRain)%dat(1) = 0._dp - mvar_data%var(iLookMVAR%scalarCanopyLiqDrainage)%dat(1) = 0._dp + doLayerMerge = .false. endif - ! (6) 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 - dt_sub, & ! time step (seconds) - (nSnow > 0), & ! logical flag if snow layers exist - mpar_data%var(iLookPARAM%snowfrz_scale), & ! freeezing curve parameter for snow (K-1) - ! input: diagnostic scalar variables - mvar_data%var(iLookMVAR%scalarSnowfallTemp)%dat(1), & ! computed temperature of fresh snow (K) - mvar_data%var(iLookMVAR%scalarNewSnowDensity)%dat(1), & ! computed density of new snow (kg m-3) - mvar_data%var(iLookMVAR%scalarThroughfallSnow)%dat(1), & ! throughfall of snow through the canopy (kg m-2 s-1) - mvar_data%var(iLookMVAR%scalarCanopySnowUnloading)%dat(1), & ! unloading of snow from the canopy (kg m-2 s-1) - ! input/output: state variables - mvar_data%var(iLookMVAR%scalarSWE)%dat(1), & ! SWE (kg m-2) - mvar_data%var(iLookMVAR%scalarSnowDepth)%dat(1), & ! total snow depth (m) - mvar_data%var(iLookMVAR%mLayerTemp)%dat(1), & ! temperature of the top layer (K) - mvar_data%var(iLookMVAR%mLayerDepth)%dat(1), & ! depth of the top layer (m) - mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat(1), & ! volumetric fraction of ice of the top layer (-) - mvar_data%var(iLookMVAR%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; endif - - ! re-compute snow depth and SWE - if(nSnow > 0)then - mvar_data%var(iLookMVAR%scalarSnowDepth)%dat(1) = sum(mvar_data%var(iLookMVAR%mLayerDepth)%dat(1:nSnow)) - mvar_data%var(iLookMVAR%scalarSWE)%dat(1) = sum( (mvar_data%var(iLookMVAR%mLayerVolFracLiq)%dat(1:nSnow)*iden_water + & - mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat(1:nSnow)*iden_ice) & - * mvar_data%var(iLookMVAR%mLayerDepth)%dat(1:nSnow) ) + ! 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._dp + ! check that the step is not tiny + if(dt_sub < minstep)then + print*,ixSolution + message=trim(message)//'length of the coupled step is below the minimum step length' + err=20; return + endif + ! try again + cycle substeps endif - !print*, 'SWE after snowfall = ', mvar_data%var(iLookMVAR%scalarSWE)%dat(1) - ! update coordinate variables - call calcHeight(& - ! input/output: data structures - indx_data, & ! intent(in): layer type - mvar_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; endif + ! update first step + firstSubStep=.false. + + ! (10) 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 (-) + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat & ! depth of each snow+soil layer (m) + ) ! associations to variables in data structures + + ! (10a) compute change in canopy ice content due to sublimation... + ! -------------------------------------------------------------- + if(computeVegFlux)then - ! **************************************************************************************************** - ! *** MAIN SOLVER ************************************************************************************ - ! **************************************************************************************************** + ! remove mass of ice on the canopy + scalarCanopyIce = scalarCanopyIce + scalarCanopySublimation*dt_sub - ! initialize dt - ntemp = 0 ! number of temporary sub-steps - ntrial = 0 ! number of trial sub-steps - dt_solv = 0._dp ! progress towards dt_sub - dt_temp = dt_sub ! temporary substep - - ! intialize variables needed for SWE mass balance check - effRainfall = 0._dp ! if no snow layers, water is added to the top of the soil zone - snwDrainage = 0._dp ! no snow drainage when no snow layers - sublimation = 0._dp ! no sublimation when no snow layers - sfcMeltPond = 0._dp ! surface melt pond - - ! initialize the rejected step - rejectedStep=.false. ! always try the first time - - ! ** continuous do loop to handle any non-convergence or mass balance issues that arise - do ! (multiple attempts for non-convergence etc.; minstep check to avoid excessive iteration) - - ! increment trial sub-steps - ntrial = ntrial+1 - - ! if step is rejected, then no need to revise layer structure etc. - if(.not.rejectedStep)then - - ! (7) merge/sub-divide snow layers... - ! ----------------------------------- - call volicePack(& - ! 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 - mvar_data, & ! intent(inout): model 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; endif - - ! recompute the number of snow and soil layers - ! NOTE: do this here for greater visibility - nSnow = count(indx_data%var(iLookINDEX%layerType)%dat==ix_snow) - nSoil = count(indx_data%var(iLookINDEX%layerType)%dat==ix_soil) - nLayers = nSnow+nSoil - - ! put the data in the structures - indx_data%var(iLookINDEX%nSnow)%dat(1) = nSnow - indx_data%var(iLookINDEX%nSoil)%dat(1) = nSoil - indx_data%var(iLookINDEX%nLayers)%dat(1) = nLayers - - ! re-compute snow depth and SWE - if(nSnow > 0)then - mvar_data%var(iLookMVAR%scalarSnowDepth)%dat(1) = sum(mvar_data%var(iLookMVAR%mLayerDepth)%dat(1:nSnow)) - mvar_data%var(iLookMVAR%scalarSWE)%dat(1) = sum( (mvar_data%var(iLookMVAR%mLayerVolFracLiq)%dat(1:nSnow)*iden_water + & - mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat(1:nSnow)*iden_ice) & - * mvar_data%var(iLookMVAR%mLayerDepth)%dat(1:nSnow) ) - endif - - - ! (7) 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 - mvar_data, & ! intent(inout): model 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; endif - - - ! (8) 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 - mvar_data%var(iLookMVAR%scalarSWE)%dat(1), & ! intent(inout): snow water equivalent (kg m-2) - mvar_data%var(iLookMVAR%scalarSnowDepth)%dat(1), & ! intent(inout): snow depth (m) - mvar_data%var(iLookMVAR%scalarSfcMeltPond)%dat(1), & ! intent(inout): surface melt pond (kg m-2) - ! input/output: properties of the upper-most soil layer - mvar_data%var(iLookMVAR%mLayerTemp)%dat(nSnow+1), & ! intent(inout): surface layer temperature (K) - mvar_data%var(iLookMVAR%mLayerDepth)%dat(nSnow+1), & ! intent(inout): surface layer depth (m) - mvar_data%var(iLookMVAR%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; endif - endif - - ! ** if previous step is not rejected + ! if removed all ice, take the remaining sublimation from water + if(scalarCanopyIce < 0._dp)then + scalarCanopyLiq = scalarCanopyLiq + scalarCanopyIce + scalarCanopyIce = 0._dp endif - ! test: recompute snow depth and SWE - if(nSnow > 0)then - mvar_data%var(iLookMVAR%scalarSnowDepth)%dat(1) = sum(mvar_data%var(iLookMVAR%mLayerDepth)%dat(1:nSnow)) - mvar_data%var(iLookMVAR%scalarSWE)%dat(1) = sum( (mvar_data%var(iLookMVAR%mLayerVolFracLiq)%dat(1:nSnow)*iden_water + & - mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat(1:nSnow)*iden_ice) & - * mvar_data%var(iLookMVAR%mLayerDepth)%dat(1:nSnow) ) + ! modify fluxes if there is insufficient canopy water to support the converged sublimation rate over the time step dt_sub + if(scalarCanopyLiq < 0._dp)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._dp endif - !write(*,'(a,1x,2(f20.5,1x),l1)') 'b4 systemSolv: testSWE, meltPond, rejectedStep = ', mvar_data%var(iLookMVAR%scalarSWE)%dat(1), mvar_data%var(iLookMVAR%scalarSfcMeltPond)%dat(1), rejectedStep - - ! print progress - !if(dt_temp < dt_sub-tinyNumber)then - ! write(*,'(a,1x,i4,1x,3(f15.2,1x))') 'ntrial, dt_temp, dt_solv, dt_sub = ', ntrial, dt_temp, dt_solv, dt_sub - ! !pause - !endif - - ! (9) solve model equations... - ! ---------------------------- - - ! get the new solution - call systemSolv(& - ! input: model control - dt_temp, & ! intent(in): length of the model sub-step - maxiter, & ! intent(in): maximum number of iterations - (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(in): index data - mvar_data, & ! intent(inout): model variables for a local HRU - bvar_data, & ! intent(in): model variables for the local basin - model_decisions, & ! intent(in): model decisions - ! output: model control - niter, & ! intent(out): number of iterations - err,cmessage) ! intent(out): error code and error message - - ! check for fatal errors - if(err>0)then; err=20; message=trim(message)//trim(cmessage); return; endif - !print*, 'after solv: mvar_data%var(iLookMVAR%iLayerLiqFluxSoil)%dat(0)*dt_temp*dt_temp/dt = ', mvar_data%var(iLookMVAR%iLayerLiqFluxSoil)%dat(0)*dt_temp*dt_temp/dt - - ! test: recompute snow depth and SWE - if(nSnow > 0)then - mvar_data%var(iLookMVAR%scalarSnowDepth)%dat(1) = sum(mvar_data%var(iLookMVAR%mLayerDepth)%dat(1:nSnow)) - mvar_data%var(iLookMVAR%scalarSWE)%dat(1) = sum( (mvar_data%var(iLookMVAR%mLayerVolFracLiq)%dat(1:nSnow)*iden_water + & - mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat(1:nSnow)*iden_ice) & - * mvar_data%var(iLookMVAR%mLayerDepth)%dat(1:nSnow) ) - endif - !write(*,'(a,1x,2(i4,1x),10(f15.5,1x))') 'nTrial, nTemp, dt_temp, dt_solv, dt_sub, test SWE = ', & - ! nTrial, nTemp, dt_temp, dt_solv, dt_sub, mvar_data%var(iLookMVAR%scalarSWE)%dat(1) - - ! if err<0 (warnings) and hence non-convergence - if(err<0)then - ! (adjust time step length) - dt_temp = dt_temp*0.5_dp ! halve the sub-step - write(*,'(a,1x,2(f13.3,1x))') trim(cmessage), dt_temp, minstep - rejectedStep=.true. - ! (check that time step greater than the minimum step) - if(dt_temp < minstep)then - message=trim(message)//'dt_temp is below the minimum time step' - err=20; return - endif - !pause 'failed step' - ! (try again) - cycle ! try again - else - rejectedStep=.false. - !pause 'accepted step' - endif - - ! check that err=0 at this point (it should be) - if(err/=0)then; message=trim(message)//'expect err=0'; return; endif - - - ! (10a) compute change in canopy ice content due to sublimation... - ! -------------------------------------------------------------- - ! NOTE: keep in continuous do loop in case insufficient water on canopy for sublimation - if(computeVegFlux)then - - ! remove mass of ice on the canopy - mvar_data%var(iLookMVAR%scalarCanopyIce)%dat(1) = mvar_data%var(iLookMVAR%scalarCanopyIce)%dat(1) + & - mvar_data%var(iLookMVAR%scalarCanopySublimation)%dat(1)*dt_temp - ! if removed all ice, take the remaining sublimation from water - if(mvar_data%var(iLookMVAR%scalarCanopyIce)%dat(1) < 0._dp)then - mvar_data%var(iLookMVAR%scalarCanopyLiq)%dat(1) = mvar_data%var(iLookMVAR%scalarCanopyLiq)%dat(1) + mvar_data%var(iLookMVAR%scalarCanopyIce)%dat(1) - mvar_data%var(iLookMVAR%scalarCanopyIce)%dat(1) = 0._dp - endif + end if ! (if computing the vegetation flux) - ! check that there is sufficient canopy water to support the converged sublimation rate over the time step dt_temp - ! NOTE we conducted checks and time step adjustments in systemSolv above so we should not get here: hence fatal error - if(mvar_data%var(iLookMVAR%scalarCanopyLiq)%dat(1) < -tinyNumber)then - message=trim(message)//'canopy sublimation rate over time step dt_temp depletes more than the available water' - err=20; return - endif + ! (10b) 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 - endif ! (if computing the vegetation flux) + ! compute sublimation loss (kg m-2) + subLoss = dt_sub*scalarSnowSublimation + ! try to remove ice from the top layer + iSnow=1 + mLayerVolFracIce(iSnow) = mLayerVolFracIce(iSnow) + subLoss/(mLayerDepth(iSnow)*iden_ice) ! update volumetric ice content (-) - ! (10b) 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 - - ! compute volumetric sublimation (-) - volSub = dt_temp*mvar_data%var(iLookMVAR%scalarSnowSublimation)%dat(1)/mvar_data%var(iLookMVAR%mLayerDepth)%dat(1) - - ! update volumetric fraction of ice (-) - ! NOTE: fluxes are positive downward - mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat(1) = mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat(1) + volSub/iden_ice + ! check that we did not remove all the ice + if(mLayerVolFracIce(iSnow) < verySmall)then + stepFailure = .true. + doLayerMerge = .true. + dt_sub = max(dt_init/2._dp, minstep) + cycle substeps + else + stepFailure = .false. + doLayerMerge = .false. + endif - ! check that there is sufficient ice in the top snow layer to support the converged sublimation rate over the time step dt_temp - ! NOTE we conducted checks and time step adjustments in systemSolv above so we should not get here: hence fatal error - if(mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat(1) < -tinyNumber)then - message=trim(message)//'surface sublimation rate over time step dt_temp depletes more than the available water' - err=20; return - endif + ! check + if(any(mLayerVolFracIce(1:nSnow) < 0._dp) .or. any(mLayerVolFracIce(1:nSnow) > 1._dp) )then + message=trim(message)//'unrealistic volumetric fraction of ice for snow layers' + err=20; return + endif - ! no snow - else + ! no snow + else - ! no snow: check that sublimation is zero - if(abs(mvar_data%var(iLookMVAR%scalarSnowSublimation)%dat(1)) > verySmall)then - message=trim(message)//'sublimation of snow has been computed when no snow exists' - err=20; return - endif - - endif ! (if snow layers exist) - !print*, 'ice after sublimation: ', mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat(1)*iden_ice - - - ! (11) account for compaction and cavitation in the snowpack... - ! ------------------------------------------------------------ - if(nSnow>0)then - call snwDensify(& - ! intent(in): variables - dt_temp, & ! intent(in): time step (s) - mvar_data%var(iLookMVAR%mLayerTemp)%dat(1:nSnow), & ! intent(in): temperature of each layer (K) - mvar_data%var(iLookMVAR%mLayerMeltFreeze)%dat(1:nSnow), & ! intent(in): volumetric melt in each layer (kg m-3) - mvar_data%var(iLookMVAR%scalarSnowSublimation)%dat(1), & ! intent(in): sublimation from the snow surface (kg m-2 s-1) - ! intent(in): parameters - mpar_data%var(iLookPARAM%densScalGrowth), & ! intent(in): density scaling factor for grain growth (kg-1 m3) - mpar_data%var(iLookPARAM%tempScalGrowth), & ! intent(in): temperature scaling factor for grain growth (K-1) - mpar_data%var(iLookPARAM%grainGrowthRate), & ! intent(in): rate of grain growth (s-1) - mpar_data%var(iLookPARAM%densScalOvrbdn), & ! intent(in): density scaling factor for overburden pressure (kg-1 m3) - mpar_data%var(iLookPARAM%tempScalOvrbdn), & ! intent(in): temperature scaling factor for overburden pressure (K-1) - mpar_data%var(iLookPARAM%base_visc), & ! intent(in): viscosity coefficient at T=T_frz and snow density=0 (kg m-2 s) - ! intent(inout): state variables - mvar_data%var(iLookMVAR%mLayerDepth)%dat(1:nSnow), & ! intent(inout): depth of each layer (m) - mvar_data%var(iLookMVAR%mLayerVolFracLiq)%dat(1:nSnow), & ! intent(inout): volumetric fraction of liquid water after itertations (-) - mvar_data%var(iLookMVAR%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; endif - endif ! if snow layers exist - - ! update coordinate variables - call calcHeight(& - ! input/output: data structures - indx_data, & ! intent(in): layer type - mvar_data, & ! intent(inout): model variables for a local HRU + ! 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 + + ! (11) 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) + flux_data%var(iLookFLUX%scalarSnowSublimation)%dat(1), & ! intent(in): sublimation from the snow surface (kg m-2 s-1) + ! 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) - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif + 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 - ! (12) compute sub-step averages associated with the temporary steps... - ! --------------------------------------------------------------------- + ! 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 - ! keep track of the number of temporary sub-steps - ntemp = ntemp+1 + ! 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 model fluxes - dt_wght = dt_temp/dt ! define weight applied to each sub-step - call increment_fluxes(dt_wght,(nsub==1 .and. ntemp==1)) + ! **************************************************************************************************** + ! *** END MAIN SOLVER ******************************************************************************** + ! **************************************************************************************************** - !dt_prog = dt_done+dt_solv+dt_temp ! progress in time step (s) - !dt_frac = dt_prog/dt ! fraction of time step completed (-) - !write(*,'(a,1x,3(f9.3,1x),10(e20.10,1x))') 'dt_wght, dt_prog, dt_frac, totalSoilCompress, dt_prog*averageSoilInflux/dt_frac, scalarSoilCompress, scalarSoilInflux*dt_temp = ', & - ! dt_wght, dt_prog, dt_frac, totalSoilCompress, dt_prog*averageSoilInflux/dt_frac, scalarSoilCompress, mvar_data%var(iLookMVAR%iLayerLiqFluxSoil)%dat(0)*dt_temp - !pause + ! increment sub-step + dt_solv = dt_solv + dt_sub - ! compute effective rainfall input and snowpack drainage to/from the snowpack (kg m-2 s-1) - if(nSnow > 0)then - effRainfall = effRainfall + (mvar_data%var(iLookMVAR%scalarThroughfallRain)%dat(1) + mvar_data%var(iLookMVAR%scalarCanopyLiqDrainage)%dat(1) )*dt_temp/dt_sub - snwDrainage = snwDrainage + (mvar_data%var(iLookMVAR%iLayerLiqFluxSnow)%dat(nSnow)*iden_water )*dt_temp/dt_sub ! m s-1 -> kg m-2 s-1 - sublimation = sublimation + (mvar_data%var(iLookMVAR%scalarSnowSublimation)%dat(1))*dt_temp/dt_sub - ! compute the surface melt pond (kg m-2) - else - sfcMeltPond = sfcMeltPond + mvar_data%var(iLookMVAR%scalarSfcMeltPond)%dat(1) - endif + ! save the time step to initialize the subsequent step + if(dt_solv= dt_sub-verySmall) exit + ! check that we have completed the sub-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_temp = min(dt_sub - dt_solv, dt_temp) - !print*, 'dt_temp, dt_sub = ', dt_temp, dt_sub + ! 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 ! (multiple attempts for non-convergence) - !print*, 'after do loop: dt_sub = ', dt_sub + end do substeps ! (sub-step loop) + !print*, 'PAUSE: completed time step'; read(*,*) - ! **************************************************************************************************** - ! *** END MAIN SOLVER ******************************************************************************** - ! **************************************************************************************************** + ! 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 - ! (13) check energy and mass balance... - ! ------------------------------------- + ! *********************************************************************************************************************************** + ! *********************************************************************************************************************************** + ! *********************************************************************************************************************************** + ! *********************************************************************************************************************************** - ! recompute snow depth and SWE - if(nSnow > 0)then - mvar_data%var(iLookMVAR%scalarSnowDepth)%dat(1) = sum(mvar_data%var(iLookMVAR%mLayerDepth)%dat(1:nSnow)) - mvar_data%var(iLookMVAR%scalarSWE)%dat(1) = sum( (mvar_data%var(iLookMVAR%mLayerVolFracLiq)%dat(1:nSnow)*iden_water + & - mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat(1:nSnow)*iden_ice) & - * mvar_data%var(iLookMVAR%mLayerDepth)%dat(1:nSnow) ) - endif + ! --- + ! (12) balance checks... + ! ---------------------- - ! check SWE - effSnowfall = mvar_data%var(iLookMVAR%scalarThroughfallSnow)%dat(1) + mvar_data%var(iLookMVAR%scalarCanopySnowUnloading)%dat(1) - newSWE = mvar_data%var(iLookMVAR%scalarSWE)%dat(1) + ! 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 (-) + totalSoilCompress => diag_data%var(iLookDIAG%scalarSoilCompress)%dat(1) ,& ! total soil compression over whole later (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) + ) ! (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._dp)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 + + 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 SWE + if(nSnow>0)then + effSnowfall = averageThroughfallSnow + averageCanopySnowUnloading + effRainfall = averageThroughfallRain + averageCanopyLiqDrainage + newSWE = prog_data%var(iLookPROG%scalarSWE)%dat(1) delSWE = newSWE - (oldSWE - sfcMeltPond) - massBalance = delSWE - (effSnowfall + effRainfall + sublimation - snwDrainage)*dt_sub + massBalance = delSWE - (effSnowfall + effRainfall + averageSnowSublimation - averageSnowDrainage*iden_water)*data_step if(abs(massBalance) > 1.d-6)then print*, 'nSnow = ', nSnow - print*, 'nTemp = ', nTemp - write(*,'(a,1x,f20.10)') 'dt_sub = ', dt_sub + 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*dt_sub - write(*,'(a,1x,f20.10)') 'effSnowfall = ', effSnowfall*dt_sub - write(*,'(a,1x,f20.10)') 'sublimation = ', sublimation*dt_sub - write(*,'(a,1x,f20.10)') 'snwDrainage = ', snwDrainage*dt_sub + 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 - - ! (14) adjust length of the substep... - ! ------------------------------------ - - ! increment the time step - dt_done = dt_done + dt_sub - !print*, '***** ', dt_done, dt_sub, niter - !pause ' after increment the time step' - - ! modify the length of the time step - if(nitern_dec) dt_sub = dt_temp*F_dec - if(dt_sub < minstep)then; message=trim(message)//'dt_sub is below the minimum time step'; return; endif - - ! save the time step to initialize the subsequent step - if(dt_done
10000) then - write(message,'(a,f13.10,a,f9.2,a,i0,a)')trim(message)//"dt < 0.00001 and nsub > 10000 [dt=",dt_init,"; dt_done=",& - dt_done,"; nsub=",nsub,"]" - err=20; return - endif - - ! exit do-loop if finished - if(dt_done>=dt)exit - - ! make sure that we don't exceed the step - dt_sub = min(dt-dt_done, dt_sub) - !print*, 'in substep loop: dt_sub = ', dt_sub - - end do ! (sub-step loop) - !stop 'completed time step' - - ! --- - ! (14) balance checks... - ! ---------------------- - - ! get total canopy water - scalarCanopyLiq => mvar_data%var(iLookMVAR%scalarCanopyLiq)%dat(1) - scalarCanopyIce => mvar_data%var(iLookMVAR%scalarCanopyIce)%dat(1) - balanceCanopyWater1 = scalarCanopyLiq + scalarCanopyIce - - ! get snowfall and rainfall - scalarSnowfall => mvar_data%var(iLookMVAR%scalarSnowfall)%dat(1) ! computed snowfall rate (kg m-2 s-1) - scalarRainfall => mvar_data%var(iLookMVAR%scalarRainfall)%dat(1) ! computed rainfall rate (kg m-2 s-1) - - ! print progress - !write(*,'(a,1x,f20.10)') 'balanceCanopyWater0 = ', balanceCanopyWater0 - !write(*,'(a,1x,f20.10)') 'balanceCanopyWater1 = ', balanceCanopyWater1 - !write(*,'(a,1x,f20.10)') '(scalarSnowfall - averageThroughfallSnow)*dt = ', (scalarSnowfall - averageThroughfallSnow)*dt - !write(*,'(a,1x,f20.10)') '(scalarRainfall - averageThroughfallRain)*dt = ', (scalarRainfall - averageThroughfallRain)*dt - !write(*,'(a,1x,f20.10)') 'averageCanopySnowUnloading = ', averageCanopySnowUnloading*dt - !write(*,'(a,1x,f20.10)') 'averageCanopyLiqDrainage = ', averageCanopyLiqDrainage*dt - !write(*,'(a,1x,f20.10)') 'averageCanopySublimation = ', averageCanopySublimation*dt - !write(*,'(a,1x,f20.10)') 'averageCanopyEvaporation = ', averageCanopyEvaporation*dt - - ! 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)*dt + (scalarRainfall - averageThroughfallRain)*dt & - - averageCanopySnowUnloading*dt - averageCanopyLiqDrainage*dt + averageCanopySublimation*dt + averageCanopyEvaporation*dt) - if(abs(scalarCanopyWatBalError) > 1.d-1)then - print*, '** canopy water balance error:' - write(*,'(a,1x,f20.10)') 'dt = ', dt - write(*,'(a,1x,f20.10)') 'balanceCanopyWater0 = ', balanceCanopyWater0 - write(*,'(a,1x,f20.10)') 'balanceCanopyWater1 = ', balanceCanopyWater1 - write(*,'(a,1x,f20.10)') '(scalarSnowfall - averageThroughfallSnow)*dt = ', (scalarSnowfall - averageThroughfallSnow)*dt - write(*,'(a,1x,f20.10)') '(scalarRainfall - averageThroughfallRain)*dt = ', (scalarRainfall - averageThroughfallRain)*dt - write(*,'(a,1x,f20.10)') 'averageCanopySnowUnloading = ', averageCanopySnowUnloading*dt - write(*,'(a,1x,f20.10)') 'averageCanopyLiqDrainage = ', averageCanopyLiqDrainage*dt - write(*,'(a,1x,f20.10)') 'averageCanopySublimation = ', averageCanopySublimation*dt - write(*,'(a,1x,f20.10)') 'averageCanopyEvaporation = ', averageCanopyEvaporation*dt - write(*,'(a,1x,f20.10)') 'scalarCanopyWatBalError = ', scalarCanopyWatBalError - message=trim(message)//'canopy hydrology does not balance' - err=20; return - endif - !pause 'canopy hydrology does balance' + endif ! if failed mass balance check + endif ! if snow layers exist - ! point to model state variables - ! NOTE: need to do this at the end of each sub-step because number of layers may change - mLayerDepth => mvar_data%var(iLookMVAR%mLayerDepth)%dat(nSnow+1:nLayers) ! depth of each soil layer (m) - mLayerVolFracIce => mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat(nSnow+1:nLayers) ! volumetric ice content in each soil layer (-) - mLayerVolFracLiq => mvar_data%var(iLookMVAR%mLayerVolFracLiq)%dat(nSnow+1:nLayers) ! volumetric liquid water content in each soil layer (-) - scalarAquiferStorage => mvar_data%var(iLookMVAR%scalarAquiferStorage)%dat(1) ! aquifer storage (m) + ! ----- + ! * 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 - !scalarTotalSoilIce = sum(iden_ice *mLayerVolFracIce(1:nSoil)*mLayerDepth(1:nSoil)) ! get the total water in the soil (liquid plus ice) at the end of the time step (kg m-2) balanceSoilWater1 = scalarTotalSoilLiq + scalarTotalSoilIce @@ -907,173 +1060,56 @@ subroutine coupled_em(printRestart,output_fileSuffix,dt_init,err,message) balanceAquifer1 = scalarAquiferStorage*iden_water ! get the input and output to/from the soil zone (kg m-2) - balanceSoilInflux = averageSoilInflux*iden_water*dt - balanceSoilBaseflow = averageSoilBaseflow*iden_water*dt - balanceSoilDrainage = averageSoilDrainage*iden_water*dt - balanceSoilTranspiration = averageCanopyTranspiration*dt ! NOTE ground evaporation included in the flux at the upper boundary - - !write(*,'(a,1x,f20.10)') 'totalSoilCompress = ', totalSoilCompress ! kg m-2 - !write(*,'(a,1x,f20.10)') 'averageSoilInflux = ', averageSoilInflux*iden_water*dt ! m s-1 -> kg m-2 - !write(*,'(a,1x,f20.10)') 'averageSoilBaseflow = ', averageSoilBaseflow*iden_water*dt - !write(*,'(a,1x,f20.10)') 'averageSoilDrainage = ', averageSoilDrainage*iden_water*dt - !write(*,'(a,1x,f20.10)') 'averageCanopyTranspiration = ', averageCanopyTranspiration*dt - !write(*,'(a,1x,f20.10)') 'averageGroundEvaporation = ', averageGroundEvaporation*dt - - !print*, 'sum(mLayerBaseflow) = ', sum(mvar_data%var(iLookMVAR%mLayerBaseflow)%dat) + 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 soil water balance - scalarSoilWatBalError = balanceSoilWater1 - (balanceSoilWater0 + (balanceSoilInflux + balanceSoilTranspiration - balanceSoilBaseflow - balanceSoilDrainage - totalSoilCompress) ) - if(abs(scalarSoilWatBalError) > 1.d-2)then ! NOTE: kg m-2, so need coarse tolerance to account for precision issues - write(*,'(a,1x,f20.10)') 'dt = ', dt + scalarSoilWatBalError = balanceSoilWater1 - (balanceSoilWater0 + (balanceSoilInflux + balanceSoilET - balanceSoilBaseflow - balanceSoilDrainage - totalSoilCompress) ) + if(abs(scalarSoilWatBalError) > absConvTol_liquid*iden_water*10._dp)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)') 'balanceSoilTranspiration = ', balanceSoilTranspiration + write(*,'(a,1x,f20.10)') 'balanceSoilET = ', balanceSoilET write(*,'(a,1x,f20.10)') 'scalarSoilWatBalError = ', scalarSoilWatBalError - ! check the water balance in each layer - do iLayer=1,nSoil - xCompress = mvar_data%var(iLookMVAR%mLayerCompress)%dat(iLayer) - xFlux0 = mvar_data%var(iLookMVAR%iLayerLiqFluxSoil)%dat(iLayer-1)*dt - xFlux1 = mvar_data%var(iLookMVAR%iLayerLiqFluxSoil)%dat(iLayer)*dt - write(*,'(a,1x,i4,1x,10(e20.10,1x))') 'iLayer, xFlux0, xFlux1, (xFlux1 - xFlux0)/mLayerDepth(iLayer), xCompress = ', & - iLayer, xFlux0, xFlux1, (xFlux1 - xFlux0)/mLayerDepth(iLayer), xCompress - end do - + 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 - endif - !pause 'soil hydrology does balance' + end if + + ! end association of local variables with information in the data structures + end associate - !print*, 'mvar_data%var(iLookMVAR%averageCanopyLiqDrainage)%dat(1) = ', mvar_data%var(iLookMVAR%averageCanopyLiqDrainage)%dat(1) + ! end association to canopy depth + end associate canopy ! save the surface temperature (just to make things easier to visualize) - mvar_data%var(iLookMVAR%scalarSurfaceTemp)%dat(1) = mvar_data%var(iLookMVAR%mLayerTemp)%dat(1) + 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>2000)then - message=trim(message)//'number of sub-steps > 2000' + if(nsub>50000)then + write(message,'(a,i0)') trim(cmessage)//'number of sub-steps > 50000 for HRU ', hruID err=20; return - endif - - - ! ******************************************************************************************************************************** - ! ******************************************************************************************************************************** - ! ******************************************************************************************************************************** - - contains - - - ! ********************************************************************************************************* - ! internal subroutine increment_fluxes: calculate timestep-average fluxes - ! ********************************************************************************************************* - subroutine increment_fluxes(dt_wght,initialize) - real(dp),intent(in) :: dt_wght ! weight assigned to sub-step - logical(lgt),intent(in) :: initialize ! flag to initialize fluxes - - ! set up pointers - - ! assign pointers to timestep-average model fluxes - if(initialize)then - totalSoilCompress => mvar_data%var(iLookMVAR%totalSoilCompress)%dat(1) ! change in storage associated with compression of the soil matrix (kg m-2) - averageThroughfallSnow => mvar_data%var(iLookMVAR%averageThroughfallSnow)%dat(1) ! snow that reaches the ground without ever touching the canopy (kg m-2 s-1) - averageThroughfallRain => mvar_data%var(iLookMVAR%averageThroughfallRain)%dat(1) ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) - averageCanopySnowUnloading => mvar_data%var(iLookMVAR%averageCanopySnowUnloading)%dat(1) ! unloading of snow from the vegetion canopy (kg m-2 s-1) - averageCanopyLiqDrainage => mvar_data%var(iLookMVAR%averageCanopyLiqDrainage)%dat(1) ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) - averageCanopyMeltFreeze => mvar_data%var(iLookMVAR%averageCanopyMeltFreeze)%dat(1) ! melt/freeze of water stored in the canopy (kg m-2 s-1) - averageCanopyTranspiration => mvar_data%var(iLookMVAR%averageCanopyTranspiration)%dat(1) ! canopy transpiration (kg m-2 s-1) - averageCanopyEvaporation => mvar_data%var(iLookMVAR%averageCanopyEvaporation)%dat(1) ! canopy evaporation/condensation (kg m-2 s-1) - averageCanopySublimation => mvar_data%var(iLookMVAR%averageCanopySublimation)%dat(1) ! canopy sublimation/frost (kg m-2 s-1) - averageSnowSublimation => mvar_data%var(iLookMVAR%averageSnowSublimation)%dat(1) ! snow sublimation/frost - below canopy or non-vegetated (kg m-2 s-1) - averageGroundEvaporation => mvar_data%var(iLookMVAR%averageGroundEvaporation)%dat(1) ! ground evaporation/condensation - below canopy or non-vegetated (kg m-2 s-1) - averageRainPlusMelt => mvar_data%var(iLookMVAR%averageRainPlusMelt)%dat(1) ! rain plus melt, as input to soil before calculating surface runoff (m s-1) - averageSurfaceRunoff => mvar_data%var(iLookMVAR%averageSurfaceRunoff)%dat(1) ! surface runoff (m s-1) - averageSoilInflux => mvar_data%var(iLookMVAR%averageSoilInflux)%dat(1) ! influx of water at the top of the soil profile (m s-1) - averageSoilBaseflow => mvar_data%var(iLookMVAR%averageSoilBaseflow)%dat(1) ! total baseflow from throughout the soil profile (m s-1) - averageSoilDrainage => mvar_data%var(iLookMVAR%averageSoilDrainage)%dat(1) ! drainage from the bottom of the soil profile (m s-1) - averageAquiferRecharge => mvar_data%var(iLookMVAR%averageAquiferRecharge)%dat(1) ! recharge to the aquifer (m s-1) - averageAquiferBaseflow => mvar_data%var(iLookMVAR%averageAquiferBaseflow)%dat(1) ! baseflow from the aquifer (m s-1) - averageAquiferTranspire => mvar_data%var(iLookMVAR%averageAquiferTranspire)%dat(1) ! transpiration from the aquifer (m s-1) - averageColumnOutflow => mvar_data%var(iLookMVAR%averageColumnOutflow)%dat ! outflow from each layer in the soil profile (m3 s-1) - endif - - ! initialize average fluxes - if(initialize)then - totalSoilCompress = 0._dp ! change in storage associated with compression of the soil matrix (kg m-2) - averageThroughfallSnow = 0._dp ! snow that reaches the ground without ever touching the canopy (kg m-2 s-1) - averageThroughfallRain = 0._dp ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) - averageCanopySnowUnloading = 0._dp ! unloading of snow from the vegetion canopy (kg m-2 s-1) - averageCanopyLiqDrainage = 0._dp ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) - averageCanopyMeltFreeze = 0._dp ! melt/freeze of water stored in the canopy (kg m-2 s-1) - averageCanopyTranspiration = 0._dp ! canopy transpiration (kg m-2 s-1) - averageCanopyEvaporation = 0._dp ! canopy evaporation/condensation (kg m-2 s-1) - averageCanopySublimation = 0._dp ! canopy sublimation/frost (kg m-2 s-1) - averageSnowSublimation = 0._dp ! snow sublimation/frost - below canopy or non-vegetated (kg m-2 s-1) - averageGroundEvaporation = 0._dp ! ground evaporation/condensation - below canopy or non-vegetated (kg m-2 s-1) - averageRainPlusMelt = 0._dp ! rain plus melt, as input to soil before calculating surface runoff (m s-1) - averageSurfaceRunoff = 0._dp ! surface runoff (m s-1) - averageSoilInflux = 0._dp ! influx of water at the top of the soil profile (m s-1) - averageSoilBaseflow = 0._dp ! total baseflow from throughout the soil profile (m s-1) - averageSoilDrainage = 0._dp ! drainage from the bottom of the soil profile (m s-1) - averageAquiferRecharge = 0._dp ! recharge to the aquifer (m s-1) - averageAquiferBaseflow = 0._dp ! baseflow from the aquifer (m s-1) - averageAquiferTranspire = 0._dp ! transpiration from the aquifer (m s-1) - averageColumnOutflow = 0._dp ! outflow from each layer in the soil profile (m3 s-1) - endif - - ! assign pointers to the model flux variables - ! NOTE: need to do this every sub-step becaause the model structures are re-defined - scalarThroughfallSnow => mvar_data%var(iLookMVAR%scalarThroughfallSnow)%dat(1) ! snow that reaches the ground without ever touching the canopy (kg m-2 s-1) - scalarThroughfallRain => mvar_data%var(iLookMVAR%scalarThroughfallRain)%dat(1) ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) - scalarCanopySnowUnloading => mvar_data%var(iLookMVAR%scalarCanopySnowUnloading)%dat(1) ! unloading of snow from the vegetion canopy (kg m-2 s-1) - scalarCanopyLiqDrainage => mvar_data%var(iLookMVAR%scalarCanopyLiqDrainage)%dat(1) ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) - scalarCanopyMeltFreeze => mvar_data%var(iLookMVAR%scalarCanopyMeltFreeze)%dat(1) ! melt/freeze of water stored in the canopy (kg m-2 s-1) - scalarCanopyTranspiration => mvar_data%var(iLookMVAR%scalarCanopyTranspiration)%dat(1) ! canopy transpiration (kg m-2 s-1) - scalarCanopyEvaporation => mvar_data%var(iLookMVAR%scalarCanopyEvaporation)%dat(1) ! canopy evaporation/condensation (kg m-2 s-1) - scalarCanopySublimation => mvar_data%var(iLookMVAR%scalarCanopySublimation)%dat(1) ! canopy sublimation/frost (kg m-2 s-1) - scalarSnowSublimation => mvar_data%var(iLookMVAR%scalarSnowSublimation)%dat(1) ! snow sublimation/frost - below canopy or non-vegetated (kg m-2 s-1) - scalarGroundEvaporation => mvar_data%var(iLookMVAR%scalarGroundEvaporation)%dat(1) ! ground evaporation/condensation - below canopy or non-vegetated (kg m-2 s-1) - scalarRainPlusMelt => mvar_data%var(iLookMVAR%scalarRainPlusMelt)%dat(1) ! rain plus melt, as input to soil before calculating surface runoff (m s-1) - scalarSurfaceRunoff => mvar_data%var(iLookMVAR%scalarSurfaceRunoff)%dat(1) ! surface runoff (m s-1) - scalarSoilInflux => mvar_data%var(iLookMVAR%iLayerLiqFluxSoil)%dat(0) ! influx of water at the top of the soil profile (m s-1) - scalarSoilDrainage => mvar_data%var(iLookMVAR%iLayerLiqFluxSoil)%dat(nSoil) ! drainage from the bottom of the soil profile (m s-1) - scalarSoilCompress => mvar_data%var(iLookMVAR%scalarSoilCompress)%dat(1) ! change in storage associated with compression of the soil matrix (kg m-2) - scalarSoilBaseflow => mvar_data%var(iLookMVAR%scalarSoilBaseflow)%dat(1) ! total baseflow from throughout the soil profile (m s-1) - scalarAquiferRecharge => mvar_data%var(iLookMVAR%scalarAquiferRecharge)%dat(1) ! recharge to the aquifer (m s-1) - scalarAquiferBaseflow => mvar_data%var(iLookMVAR%scalarAquiferBaseflow)%dat(1) ! baseflow from the aquifer (m s-1) - scalarAquiferTranspire => mvar_data%var(iLookMVAR%scalarAquiferTranspire)%dat(1) ! transpiration from the aquifer (m s-1) - mLayerColumnOutflow => mvar_data%var(iLookMVAR%mLayerColumnOutflow)%dat ! total outflow from each layer in a given soil column (m3 s-1) - - ! increment storage over the time step - totalSoilCompress = totalSoilCompress + scalarSoilCompress ! NOTE mass not rate ! change in storage associated with compression of the soil matrix (kg m-2) - - ! increment timestep-average fluxes - averageThroughfallSnow = averageThroughfallSnow + scalarThroughfallSnow *dt_wght ! snow that reaches the ground without ever touching the canopy (kg m-2 s-1) - averageThroughfallRain = averageThroughfallRain + scalarThroughfallRain *dt_wght ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) - averageCanopySnowUnloading = averageCanopySnowUnloading + scalarCanopySnowUnloading *dt_wght ! unloading of snow from the vegetion canopy (kg m-2 s-1) - averageCanopyLiqDrainage = averageCanopyLiqDrainage + scalarCanopyLiqDrainage *dt_wght ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) - averageCanopyMeltFreeze = averageCanopyMeltFreeze + scalarCanopyMeltFreeze *dt_wght ! melt/freeze of water stored in the canopy (kg m-2 s-1) - averageCanopyTranspiration = averageCanopyTranspiration + scalarCanopyTranspiration *dt_wght ! canopy transpiration (kg m-2 s-1) - averageCanopyEvaporation = averageCanopyEvaporation + scalarCanopyEvaporation *dt_wght ! canopy evaporation/condensation (kg m-2 s-1) - averageCanopySublimation = averageCanopySublimation + scalarCanopySublimation *dt_wght ! canopy sublimation/frost (kg m-2 s-1) - averageSnowSublimation = averageSnowSublimation + scalarSnowSublimation *dt_wght ! snow sublimation/frost - below canopy or non-vegetated (kg m-2 s-1) - averageGroundEvaporation = averageGroundEvaporation + scalarGroundEvaporation *dt_wght ! ground evaporation/condensation - below canopy or non-vegetated (kg m-2 s-1) - averageRainPlusMelt = averageRainPlusMelt + scalarRainPlusMelt *dt_wght ! rain plus melt, as input to soil before calculating surface runoff (m s-1) - averageSurfaceRunoff = averageSurfaceRunoff + scalarSurfaceRunoff *dt_wght ! surface runoff (m s-1) - averageSoilInflux = averageSoilInflux + scalarSoilInflux *dt_wght ! influx of water at the top of the soil profile (m s-1) - averageSoilBaseflow = averageSoilBaseflow + scalarSoilBaseflow *dt_wght ! total baseflow from throughout the soil profile (m s-1) - averageSoilDrainage = averageSoilDrainage + scalarSoilDrainage *dt_wght ! drainage from the bottom of the soil profile (m s-1) - averageAquiferRecharge = averageAquiferRecharge + scalarAquiferRecharge *dt_wght ! recharge to the aquifer (m s-1) - averageAquiferBaseflow = averageAquiferBaseflow + scalarAquiferBaseflow *dt_wght ! baseflow from the aquifer (m s-1) - averageAquiferTranspire = averageAquiferTranspire + scalarAquiferTranspire *dt_wght ! transpiration from the aquifer (m s-1) - averageColumnOutflow = averageColumnOutflow + mLayerColumnOutflow *dt_wght ! outflow from each soil layer in a given soil column (m3 s-1) - - end subroutine increment_fluxes - + end if end subroutine coupled_em @@ -1128,140 +1164,18 @@ subroutine implctMelt(& else scalarSfcMeltPond = nrgAvailable/LH_fus scalarSWE = scalarSWE - scalarSfcMeltPond - endif + 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._dp ! kg m-2 - endif ! (if the temperature of the top soil layer is greater than Tfreeze) + 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._dp ! kg m-2 - endif ! (if the "snow without a layer" exists) + end if ! (if the "snow without a layer" exists) end subroutine implctMelt - ! ********************************************************************************************************* - ! private subroutine printRestartFile: print a re-start file - ! ********************************************************************************************************* - subroutine printRestartFile(& - output_fileSuffix,& ! intent(in): suffix defining the model experiment - dt_init, & ! intent(in): time step length (s) - time_data, & ! intent(in): model time structures - mvar_data, & ! intent(in): model variables for a local HRU - err,message) ! intent(out): error control - ! -------------------------------------------------------------------------------------------------------- - ! -------------------------------------------------------------------------------------------------------- - ! access the derived types to define the data structures - USE data_struc,only:var_i ! data vector (i4b) - USE data_struc,only:var_dlength ! data vector with variable length dimension (dp) - ! access named variables defining elements in the data structures - USE var_lookup,only:iLookMVAR,iLookTIME ! named variables for structure elements - ! access file paths - USE summaFileManager,only:OUTPUT_PATH,OUTPUT_PREFIX ! define output file - ! access desired modules - USE ascii_util_module,only:file_open ! open file - implicit none - ! -------------------------------------------------------------------------------------------------------- - ! input - character(*),intent(in) :: output_fileSuffix ! suffix defining the model experiment - real(dp),intent(in) :: dt_init ! time step length (s) - type(var_i),intent(in) :: time_data ! model time structures - type(var_dlength),intent(in) :: mvar_data ! model variables for a local HRU - ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! -------------------------------------------------------------------------------------------------------- - ! local variables - integer(i4b),parameter :: ixUnit=64 ! file unit - logical(lgt) :: fileOpen ! flag to denote if the file unit is already used - character(len=256),parameter :: filepref='summaRestart' ! prefix for the restart filename - character(len=256) :: timeString ! string to define the time - character(len=256) :: filename ! name of the restart file - character(len=256) :: cmessage ! error message of downstream routine - integer(i4b) :: iLayer ! index of the model layer - real(dp),parameter :: valueMissing=-999._dp ! missing value - ! -------------------------------------------------------------------------------------------------------- - ! initialize error control - err=0; message='printRestartFile/' - - ! define the time string - write(timeString,'(a,i4,3(a,i2.2))') '_',time_data%var(iLookTIME%iyyy),'-',time_data%var(iLookTIME%im),'-',time_data%var(iLookTIME%id),'-',time_data%var(iLookTIME%ih) - - ! define the file name - filename = trim(OUTPUT_PATH)//trim(filepref)//trim(timeString)//trim(output_fileSuffix)//'.txt' - !print*, trim(filename) - !pause - - ! check if file unit is open already - inquire(unit=ixUnit,opened=fileOpen) - if(fileOpen)then; err=20; message=trim(message)//'file ixUnit is open'; return; endif - - ! open file for writing - open(ixUnit,file=trim(filename),status="unknown",action="write",iostat=err) - if(err/=0)then - message=trim(message)//"OpenError['"//trim(filename)//"']" - err=20; return - endif - - ! write a header - write(ixUnit,'(a)') '! This is a summa re-start file' - write(ixUnit,'(a)') '! ---------------------------------------------------------------------------------------------------------------------' - - ! write scalar state variables - write(ixUnit,'(a)') '' - write(ixUnit,'(a25,1x,e20.10)') 'dt_init ', dt_init ! time step length (s) - write(ixUnit,'(a25,1x,e20.10)') 'scalarCanopyIce ', mvar_data%var(iLookMVAR%scalarCanopyIce )%dat(1) ! canopy ice content (kg m-2) - write(ixUnit,'(a25,1x,e20.10)') 'scalarCanopyLiq ', mvar_data%var(iLookMVAR%scalarCanopyLiq )%dat(1) ! canopy liquid water content (kg m-2) - write(ixUnit,'(a25,1x,e20.10)') 'scalarCanairTemp ', mvar_data%var(iLookMVAR%scalarCanairTemp )%dat(1) ! temperature of the canopy air space (K) - write(ixUnit,'(a25,1x,e20.10)') 'scalarCanopyTemp ', mvar_data%var(iLookMVAR%scalarCanopyTemp )%dat(1) ! temperature of the vegetation canopy (K) - write(ixUnit,'(a25,1x,e20.10)') 'scalarSnowAlbedo ', mvar_data%var(iLookMVAR%scalarSnowAlbedo )%dat(1) ! snow albedo (-) - write(ixUnit,'(a25,1x,e20.10)') 'scalarSWE ', mvar_data%var(iLookMVAR%scalarSWE )%dat(1) ! snow water equivalent (kg m-2) - write(ixUnit,'(a25,1x,e20.10)') 'scalarSnowDepth ', mvar_data%var(iLookMVAR%scalarSnowDepth )%dat(1) ! snow depth (m) - write(ixUnit,'(a25,1x,e20.10)') 'scalarSfcMeltPond ', mvar_data%var(iLookMVAR%scalarSfcMeltPond )%dat(1) ! surface melt pond (kg m-2) - write(ixUnit,'(a25,1x,e20.10)') 'scalarAquiferStorage ', mvar_data%var(iLookMVAR%scalarAquiferStorage)%dat(1) ! aquifer storage (m) - write(ixUnit,'(a)') '' - - ! make the file easier to read - write(ixUnit,'(a)') '! ---------------------------------------------------------------------------------------------------------------------' - write(ixUnit,'(a)') '! ---------------------------------------------------------------------------------------------------------------------' - - ! write layer state variables - write(ixUnit,'(a)') '' - write(ixUnit,'(a)') ' layerType iLayerHeight mLayerDepth mLayerTemp mLayerVolFracIce mLayerVolFracLiq mLayerMatricHead' - - ! write state variables for each snow layer - if(nSnow>0)then - do iLayer=1,nSnow ! loop through snow layers - write(ixUnit,'(a10,2x,2(e22.15,2x),4(e20.10,1x))') ' snow', & - mvar_data%var(iLookMVAR%iLayerHeight )%dat(iLayer-1), & ! height at the top of the layer (m) - mvar_data%var(iLookMVAR%mLayerDepth )%dat(iLayer), & ! depth of each layer (m) - mvar_data%var(iLookMVAR%mLayerTemp )%dat(iLayer), & ! temperature of each layer (K) - mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat(iLayer), & ! volumetric ice content (-) - mvar_data%var(iLookMVAR%mLayerVolFracLiq)%dat(iLayer), & ! volumetric liquid water content (-) - valueMissing ! matric head (missing for snow) - end do ! looping through snow layers - endif ! if snow layers exist - - ! write state variables for each soil layer - do iLayer=1,nSoil ! loop through snow layers - write(ixUnit,'(a10,2x,2(e22.15,2x),4(e20.10,1x))') ' soil', & - mvar_data%var(iLookMVAR%iLayerHeight )%dat(nSnow+iLayer-1), & ! height at the top of the layer (m) - mvar_data%var(iLookMVAR%mLayerDepth )%dat(nSnow+iLayer), & ! depth of each layer (m) - mvar_data%var(iLookMVAR%mLayerTemp )%dat(nSnow+iLayer), & ! temperature of each layer (K) - mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat(nSnow+iLayer), & ! volumetric ice content (-) - mvar_data%var(iLookMVAR%mLayerVolFracLiq)%dat(nSnow+iLayer), & ! volumetric liquid water content (-) - mvar_data%var(iLookMVAR%mLayerMatricHead)%dat(iLayer) ! matric head (m) - end do ! looping through soil layers - - ! end definition of layer variables - write(ixUnit,'(a)') '' - - ! close file - close(ixUnit) - - end subroutine printRestartFile - - end module coupled_em_module diff --git a/build/source/engine/derivforce.f90 b/build/source/engine/derivforce.f90 old mode 100644 new mode 100755 index 6991a5d25..8932bb835 --- a/build/source/engine/derivforce.f90 +++ b/build/source/engine/derivforce.f90 @@ -20,6 +20,12 @@ module derivforce_module USE nrtype +! 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) implicit none private public::derivforce @@ -29,146 +35,136 @@ module derivforce_module ! ************************************************************************************************ ! public subroutine derivforce: compute derived forcing data ! ************************************************************************************************ - subroutine derivforce(err,message) + subroutine derivforce(time_data,forc_data,attr_data,mpar_data,diag_data,flux_data,err,message) USE multiconst,only:Tfreeze ! freezing point of pure water (K) USE multiconst,only:secprhour ! number of seconds in an hour - USE data_struc,only:data_step ! length of the data step (s) - USE data_struc,only:time_data,forc_data ! forcing data structures - USE data_struc,only:attr_data,mpar_data,mvar_data ! model data structures + USE multiconst,only:minprhour ! number of minutes in an hour + USE globalData,only:data_step ! length of the data step (s) + USE globalData,only:model_decisions ! model decision structure + USE data_types,only:var_dlength ! data structure: x%var(:)%dat (dp) USE var_lookup,only:iLookTIME,iLookATTR ! named variables for structure elements - USE var_lookup,only:iLookPARAM,iLookFORCE,iLookMVAR ! named variables for structure elements + USE var_lookup,only:iLookPARAM,iLookFORCE,iLookDIAG,iLookFLUX ! named variables for structure elements + USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure 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 ! compute derived forcing data variables implicit none - ! dummy variables - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + ! input variables + integer(i4b), intent(in) :: time_data(:) ! vector of time data for a given time step + real(dp), intent(inout) :: forc_data(:) ! vector of forcing data for a given time step + real(dp), intent(in) :: attr_data(:) ! vector of model attributes + type(var_dlength),intent(in) :: mpar_data ! vector of model parameters + ! 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 ! variables for cosine of the solar zenith angle - integer(i4b),pointer :: im ! month - integer(i4b),pointer :: id ! day - real(dp) :: ahour ! hour at start of time step - real(dp) :: dataStep ! data step (hours) - real(dp),parameter :: slope=0._dp ! terrain slope (assume flat) - real(dp),parameter :: azimuth=0._dp ! terrain azimuth (assume zero) - real(dp),pointer :: latitude ! latitude (degrees north) - real(dp) :: hri ! average radiation index over time step DT - real(dp),pointer :: cosZenith ! average cosine of the zenith angle over time step DT - ! local pointers to model parameters - real(dp),pointer :: Frad_vis ! fraction radiation absorbed in visible part of spectrum (-) - real(dp),pointer :: directScale ! scaling factor for fractional driect radiaion parameterization (-) - real(dp),pointer :: Frad_direct ! maximum fraction direct radiation (-) - real(dp),pointer :: minwind ! minimum windspeed (m s-1) - real(dp),pointer :: fc_param ! freezing curve parameter for snow (K-1) - real(dp),pointer :: tempCritRain ! critical temperature where precipitation is rain (K) - real(dp),pointer :: tempRangeTimestep ! temperature range over the time step (K) - real(dp),pointer :: frozenPrecipMultip ! frozen precipitation multiplier (-) - real(dp),pointer :: newSnowDenMin ! minimum new snow density (kg m-3) - real(dp),pointer :: newSnowDenMult ! multiplier for new snow density (kg m-3) - real(dp),pointer :: newSnowDenScal ! scaling factor for new snow density (K) - ! local pointers to model forcing data - real(dp),pointer :: SWRadAtm ! downward shortwave radiation (W m-2) - real(dp),pointer :: airtemp ! air temperature at 2 meter height (K) - real(dp),pointer :: windspd ! wind speed at 10 meter height (m s-1) - real(dp),pointer :: airpres ! air pressure at 2 meter height (Pa) - real(dp),pointer :: spechum ! specific humidity at 2 meter height (g g-1) - real(dp),pointer :: pptrate ! precipitation rate (kg m-2 s-1) - ! local pointers to derived model forcing data - real(dp),pointer :: scalarO2air ! atmospheric o2 concentration (Pa) - real(dp),pointer :: scalarCO2air ! atmospheric co2 concentration (Pa) - ! local pointers to model variables - real(dp),pointer :: scalarFractionDirect ! fraction of direct radiation (0-1) - real(dp),pointer :: spectralIncomingDirect(:) ! downwelling direct shortwave radiation in each wave band (W m-2) - real(dp),pointer :: spectralIncomingDiffuse(:) ! downwelling diffuse shortwave radiation in each wave band (W m-2) - real(dp),pointer :: VPair ! vapor pressure of the air above the vegetation canopy (Pa) - real(dp),pointer :: twetbulb ! wet bulb temperature (K) - real(dp),pointer :: rainfall ! computed rainfall rate (kg m-2 s-1) - real(dp),pointer :: snowfall ! computed snowfall rate (kg m-2 s-1) - real(dp),pointer :: snowfallTemp ! computed temperature of fresh snow (K) - real(dp),pointer :: newSnowDensity ! computed density of fresh snow (kg m-3) + real(dp) :: ahour ! hour at start of time step + real(dp) :: dataStep ! data step (hours) + real(dp),parameter :: slope=0._dp ! terrain slope (assume flat) + real(dp),parameter :: azimuth=0._dp ! terrain azimuth (assume zero) + real(dp) :: hri ! average radiation index over time step DT ! local variables - real(dp),parameter :: valueMissing=-9999._dp ! missing value - real(dp),parameter :: co2Factor=355.e-6_dp ! empirical factor to obtain partial pressure of co2 - real(dp),parameter :: o2Factor=0.209_dp ! empirical factor to obtain partial pressure of o2 - real(dp) :: relhum ! relative humidity (-) - real(dp) :: fracrain ! fraction of precipitation that falls as rain - real(dp) :: maxFrozenSnowTemp ! maximum temperature of snow when the snow is predominantely frozen (K) - real(dp),parameter :: unfrozenLiq=0.01_dp ! unfrozen liquid water used to compute maxFrozenSnowTemp (-) - real(dp),parameter :: eps=epsilon(fracrain) ! a number that is almost negligible - real(dp) :: Tmin,Tmax ! minimum and maximum wet bulb temperature in the time step (K) + integer(i4b),parameter :: nBands=2 ! number of spectral bands + real(dp),parameter :: valueMissing=-9999._dp ! missing value + real(dp),parameter :: co2Factor=355.e-6_dp ! empirical factor to obtain partial pressure of co2 + real(dp),parameter :: o2Factor=0.209_dp ! empirical factor to obtain partial pressure of o2 + real(dp) :: relhum ! relative humidity (-) + real(dp) :: fracrain ! fraction of precipitation that falls as rain + real(dp) :: maxFrozenSnowTemp ! maximum temperature of snow when the snow is predominantely frozen (K) + real(dp),parameter :: unfrozenLiq=0.01_dp ! unfrozen liquid water used to compute maxFrozenSnowTemp (-) + real(dp),parameter :: eps=epsilon(fracrain) ! a number that is almost negligible + real(dp) :: Tmin,Tmax ! minimum and maximum wet bulb temperature in the time step (K) + real(dp),parameter :: pomNewSnowDenMax=150._dp ! 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(dp),parameter :: andersonWarmDenLimit=2._dp ! Upper air temperature limit in Anderson (1976) new snow density (C) + real(dp),parameter :: andersonColdDenLimit=15._dp! Lower air temperature limit in Anderson (1976) new snow density (C) + real(dp),parameter :: andersonDenScal=1.5_dp ! Scalar parameter in Anderson (1976) new snow density function (-) + real(dp),parameter :: pahautDenWindScal=0.5_dp ! Scalar parameter for wind impacts on density using Pahaut (1976) function (-) +! ************************************************************************************************ + ! associate local variables with the information in the data structures + associate(& + ! model parameters + Frad_vis => mpar_data%var(iLookPARAM%Frad_vis)%dat(1) , & ! fraction radiation absorbed in visible part of spectrum (-) + directScale => mpar_data%var(iLookPARAM%directScale)%dat(1) , & ! scaling factor for fractional driect radiaion parameterization (-) + Frad_direct => mpar_data%var(iLookPARAM%Frad_direct)%dat(1) , & ! maximum fraction direct radiation (-) + minwind => mpar_data%var(iLookPARAM%minwind)%dat(1) , & ! minimum windspeed (m s-1) + fc_param => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1) , & ! freezing curve parameter for snow (K-1) + tempCritRain => mpar_data%var(iLookPARAM%tempCritRain)%dat(1) , & ! critical temperature where precipitation is rain (K) + tempRangeTimestep => mpar_data%var(iLookPARAM%tempRangeTimestep)%dat(1) , & ! temperature range over the time step (K) + frozenPrecipMultip => mpar_data%var(iLookPARAM%frozenPrecipMultip)%dat(1) , & ! frozen precipitation multiplier (-) + newSnowDenMin => mpar_data%var(iLookPARAM%newSnowDenMin)%dat(1) , & ! minimum new snow density (kg m-3) + newSnowDenMult => mpar_data%var(iLookPARAM%newSnowDenMult)%dat(1) , & ! multiplier for new snow density (kg m-3) + newSnowDenScal => mpar_data%var(iLookPARAM%newSnowDenScal)%dat(1) , & ! scaling factor for new snow density (K) + constSnowDen => mpar_data%var(iLookPARAM%constSnowDen)%dat(1) , & ! Constant new snow density (kg m-3) + newSnowDenAdd => mpar_data%var(iLookPARAM%newSnowDenAdd)%dat(1) , & ! Pahaut 1976, additive factor for new snow density (kg m-3) + newSnowDenMultTemp => mpar_data%var(iLookPARAM%newSnowDenMultTemp)%dat(1) , & ! Pahaut 1976, multiplier for new snow density applied to air temperature (kg m-3 K-1) + 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) + ! radiation geometry variables + im => time_data(iLookTIME%im) , & ! month + id => time_data(iLookTIME%id) , & ! day + ih => time_data(iLookTIME%ih) , & ! hour + imin => time_data(iLookTIME%imin) , & ! minute + latitude => attr_data(iLookATTR%latitude) , & ! latitude (degrees north) + cosZenith => diag_data%var(iLookDIAG%scalarCosZenith)%dat(1) , & ! average cosine of the zenith angle over time step DT + ! model forcing data + SWRadAtm => forc_data(iLookFORCE%SWRadAtm) , & ! downward shortwave radiation (W m-2) + airtemp => forc_data(iLookFORCE%airtemp) , & ! air temperature at 2 meter height (K) + windspd => forc_data(iLookFORCE%windspd) , & ! wind speed at 10 meter height (m s-1) + airpres => forc_data(iLookFORCE%airpres) , & ! air pressure at 2 meter height (Pa) + spechum => forc_data(iLookFORCE%spechum) , & ! specific humidity at 2 meter height (g g-1) + pptrate => forc_data(iLookFORCE%pptrate) , & ! precipitation rate (kg m-2 s-1) + ! 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) + ! 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) + spectralIncomingDiffuse => flux_data%var(iLookFLUX%spectralIncomingDiffuse)%dat , & ! downwelling diffuse shortwave radiation for each waveband (W m-2) + ! snow accumulation variables + rainfall => flux_data%var(iLookFLUX%scalarRainfall)%dat(1) , & ! computed rainfall rate (kg m-2 s-1) + snowfall => flux_data%var(iLookFLUX%scalarSnowfall)%dat(1) , & ! computed snowfall rate (kg m-2 s-1) + VPair => diag_data%var(iLookDIAG%scalarVPair)%dat(1) , & ! vapor pressure of the air above the vegetation canopy (Pa) + twetbulb => diag_data%var(iLookDIAG%scalarTwetbulb)%dat(1) , & ! wet bulb temperature (K) + snowfallTemp => diag_data%var(iLookDIAG%scalarSnowfallTemp)%dat(1) , & ! computed temperature of fresh snow (K) + newSnowDensity => diag_data%var(iLookDIAG%scalarNewSnowDensity)%dat(1) & ! computed density of new snow (kg m-3) + ) ! (associating local variables with the information in the data structures) + ! initialize error control - err=0; message="f-derivforce/" - ! assign pointers to model parameters - Frad_vis => mpar_data%var(iLookPARAM%Frad_vis) ! fraction radiation absorbed in visible part of spectrum (-) - directScale => mpar_data%var(iLookPARAM%directScale) ! scaling factor for fractional driect radiaion parameterization (-) - Frad_direct => mpar_data%var(iLookPARAM%Frad_direct) ! maximum fraction direct radiation (-) - minwind => mpar_data%var(iLookPARAM%minwind) ! minimum windspeed (m s-1) - fc_param => mpar_data%var(iLookPARAM%snowfrz_scale) ! freezing curve parameter for snow (K-1) - tempCritRain => mpar_data%var(iLookPARAM%tempCritRain) ! critical temperature where precipitation is rain (K) - tempRangeTimestep => mpar_data%var(iLookPARAM%tempRangeTimestep) ! temperature range over the time step (K) - frozenPrecipMultip => mpar_data%var(iLookPARAM%frozenPrecipMultip) ! frozen precipitation multiplier (-) - newSnowDenMin => mpar_data%var(iLookPARAM%newSnowDenMin) ! minimum new snow density (kg m-3) - newSnowDenMult => mpar_data%var(iLookPARAM%newSnowDenMult) ! multiplier for new snow density (kg m-3) - newSnowDenScal => mpar_data%var(iLookPARAM%newSnowDenScal) ! scaling factor for new snow density (K) - ! assign pointers to radiation geometry variables - im => time_data%var(iLookTIME%im) ! month - id => time_data%var(iLookTIME%id) ! day - dataStep = data_step/secprhour ! time step (hours) - ahour = real(time_data%var(iLookTIME%ih),kind(dp)) - dataStep ! hour at start of time step - latitude => attr_data%var(iLookATTR%latitude) ! latitude (degrees north - cosZenith => mvar_data%var(iLookMVAR%scalarCosZenith)%dat(1) ! average cosine of the zenith angle over time step DT - ! assign pointers to model forcing data - SWRadAtm => forc_data%var(iLookFORCE%SWRadAtm) ! downward shortwave radiation (W m-2) - airtemp => forc_data%var(iLookFORCE%airtemp) ! air temperature at 2 meter height (K) - windspd => forc_data%var(iLookFORCE%windspd) ! wind speed at 10 meter height (m s-1) - airpres => forc_data%var(iLookFORCE%airpres) ! air pressure at 2 meter height (Pa) - spechum => forc_data%var(iLookFORCE%spechum) ! specific humidity at 2 meter height (g g-1) - pptrate => forc_data%var(iLookFORCE%pptrate) ! precipitation rate (kg m-2 s-1) - ! assign pointers to derived model forcing data - scalarO2air => mvar_data%var(iLookMVAR%scalarO2air)%dat(1) ! atmospheric o2 concentration (Pa) - scalarCO2air => mvar_data%var(iLookMVAR%scalarCO2air)%dat(1) ! atmospheric co2 concentration (Pa) - ! assign pointers to radiation variables - scalarFractionDirect => mvar_data%var(iLookMVAR%scalarFractionDirect)%dat(1) ! fraction of direct radiation (0-1) - spectralIncomingDirect => mvar_data%var(iLookMVAR%spectralIncomingDirect)%dat ! downwelling direct shortwave radiation for each waveband (W m-2) - spectralIncomingDiffuse => mvar_data%var(iLookMVAR%spectralIncomingDiffuse)%dat ! downwelling diffuse shortwave radiation for each waveband (W m-2) - if(size(spectralIncomingDirect) /= 2 .or. size(spectralIncomingDiffuse) /= 2)then - err=20; message=trim(message)//'expect two spectral classes for radiation'; return - endif - ! assign pointers to snow accumulation variables - VPair => mvar_data%var(iLookMVAR%scalarVPair)%dat(1) ! vapor pressure of the air above the vegetation canopy (Pa) - twetbulb => mvar_data%var(iLookMVAR%scalarTwetbulb)%dat(1) ! wet bulb temperature (K) - rainfall => mvar_data%var(iLookMVAR%scalarRainfall)%dat(1) ! computed rainfall rate (kg m-2 s-1) - snowfall => mvar_data%var(iLookMVAR%scalarSnowfall)%dat(1) ! computed snowfall rate (kg m-2 s-1) - snowfallTemp => mvar_data%var(iLookMVAR%scalarSnowfallTemp)%dat(1) ! computed temperature of fresh snow (K) - newSnowDensity => mvar_data%var(iLookMVAR%scalarNewSnowDensity)%dat(1) ! computed density of new snow (kg m-3) + err=0; message="derivforce/" + + ! 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' + err=20; return + end if ! compute the partial pressure of o2 and co2 scalarCO2air = co2Factor * airpres ! atmospheric co2 concentration (Pa) scalarO2air = o2Factor * airpres ! atmospheric o2 concentration (Pa) + ! compute the decimal hour at the start of the time step + dataStep = data_step/secprhour ! time step (hours) + ahour = real(ih,kind(dp)) + real(imin,kind(dp))/minprhour - data_step/secprhour ! decimal hour (start of the step) + ! compute the cosine of the solar zenith angle call clrsky_rad(im,id,ahour,dataStep, & ! intent(in): time variables slope,azimuth,latitude, & ! intent(in): location variables hri,cosZenith) ! intent(out): cosine of the solar zenith angle - ! check that we don't have considerable shortwave when the zenith angle is low - ! NOTE: this is likely because the data are not in local time - if(cosZenith < epsilon(cosZenith) .and. SWRadAtm > 100._dp)then - message=trim(message)//'SWRadAtm > 100 W m-2 when cos zenith angle is zero -- check that forcing data are in local time, '//& - 'that the time stamp in forcing data is at the end of the data interval, and that the lat-lon '//& - 'in the site characteristix file is correct' - err=20; return - endif - ! ensure solar radiation is zero between sunset and sunrise - ! NOTE: also ensure that sw radiation is positive - if(cosZenith <= 0._dp .or. SWRadAtm < 0._dp) SWRadAtm = 0._dp + !write(*,'(a,1x,4(i2,1x),3(f9.3,1x))') 'im,id,ih,imin,ahour,dataStep,cosZenith = ', & + + ! ensure solar radiation is non-negative + if(SWRadAtm < 0._dp) SWRadAtm = 0._dp ! compute the fraction of direct radiation using the parameterization of Nijssen and Lettenmaier (1999) if(cosZenith > 0._dp)then scalarFractionDirect = Frad_direct*cosZenith/(cosZenith + directScale) else scalarFractionDirect = 0._dp - endif + 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._dp - Frad_vis) ! (direct nir) @@ -185,7 +181,7 @@ subroutine derivforce(err,message) if(relhum > 1._dp)then relhum = 1._dp spechum = RELHM2SPHM(relhum, airpres, airtemp) - endif + end if ! compute vapor pressure of the air above the vegetation canopy (Pa) VPair = vapPress(spechum,airpres) @@ -209,7 +205,7 @@ subroutine derivforce(err,message) else fracrain = (Tmax - tempCritRain)/(Tmax - Tmin) snowfallTemp = 0.5_dp*(Tmin + maxFrozenSnowTemp) - endif + end if !write(*,'(a,1x,10(f20.10,1x))') 'Tmin, twetbulb, tempRangeTimestep, tempCritRain = ', & ! Tmin, twetbulb, tempRangeTimestep, tempCritRain @@ -225,19 +221,43 @@ subroutine derivforce(err,message) ! compute rainfall and snowfall rainfall = fracrain*pptrate snowfall = (1._dp - fracrain)*pptrate*frozenPrecipMultip - endif + end if !print*, 'tempCritRain, tempRangeTimestep, pptrate, airtemp, rainfall, snowfall, twetbulb, relhum, snowfallTemp = ' !print*, tempCritRain, tempRangeTimestep, pptrate, airtemp, rainfall, snowfall, twetbulb, relhum, snowfallTemp ! compute density of new snow if(snowfall > tiny(fracrain))then - newSnowDensity = newSnowDenMin + newSnowDenMult*exp((airtemp-Tfreeze)/newSnowDenScal) ! new snow density (kg m-3) + ! Determine which method to use + select case(model_decisions(iLookDECISIONS%snowDenNew)%iDecision) + ! Hedstrom and Pomeroy 1998 + case(hedAndPom) + newSnowDensity = min(pomNewSnowDenMax,newSnowDenMin + newSnowDenMult*exp((airtemp-Tfreeze)/newSnowDenScal)) ! new snow density (kg m-3) + ! Pahaut 1976 (Boone et al. 2002) + case(pahaut_76) + newSnowDensity = max(newSnowDenMin,newSnowDenAdd + (newSnowDenMultTemp * (airtemp-Tfreeze))+(newSnowDenMultWind*((windspd)**pahautDenWindScal))); ! new snow density (kg m-3) + ! Anderson 1976 + case(anderson) + if(airtemp>(Tfreeze+andersonWarmDenLimit))then + newSnowDensity = newSnowDenMin + newSnowDenMultAnd*(newSnowDenBase)**(andersonDenScal) ! new snow density (kg m-3) + elseif(airtemp<=(Tfreeze-andersonColdDenLimit))then + newSnowDensity = newSnowDenMin ! new snow density (kg m-3) + else + newSnowDensity = newSnowDenMin + newSnowDenMultAnd*(airtemp-Tfreeze+newSnowDenBase)**(andersonDenScal) ! new snow density (kg m-3) + end if + ! Constant new snow density + case(constDens) + newSnowDensity = constSnowDen ! new snow density (kg m-3) + 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 rainfall = rainfall + snowfall ! in most cases snowfall will be zero here snowfall = 0._dp - endif + end if + + ! end association of local variables with the information in the data structures + end associate end subroutine derivforce diff --git a/build/source/engine/diagn_evar.f90 b/build/source/engine/diagn_evar.f90 old mode 100644 new mode 100755 index 0d6e9aaf3..f50a09791 --- a/build/source/engine/diagn_evar.f90 +++ b/build/source/engine/diagn_evar.f90 @@ -37,15 +37,17 @@ module diagn_evar_module lambda_ice, & ! thermal conductivity of ice (J s-1 m-1) lambda_water ! thermal conductivity of water (J s-1 m-1) -! access the number of snow and soil layers -USE data_struc,only:& - nSnow, & ! number of snow layers - nSoil, & ! number of soil layers - nLayers ! total number of layers +! access missing values +USE globalData,only:integerMissing ! missing integer +USE globalData,only:realMissing ! missing real number ! named variables that define the layer type -USE data_struc,only:ix_soil ! soil -USE data_struc,only:ix_snow ! snow +USE globalData,only:iname_snow ! snow +USE globalData,only:iname_soil ! soil + +! model decisions +USE mDecisions_module,only:Smirnova2000 ! option for temporally constant thermal conductivity + implicit none private public::diagn_evar @@ -67,20 +69,21 @@ subroutine diagn_evar(& ! input/output: data structures mpar_data, & ! intent(in): model parameters indx_data, & ! intent(in): model layer indices - mvar_data, & ! intent(inout): model variables for a local HRU + 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,message) ! intent(out): error control ! -------------------------------------------------------------------------------------------------------------------------------------- ! provide access to the derived types to define the data structures - USE data_struc,only:& + USE data_types,only:& var_d, & ! data vector (dp) var_ilength, & ! data vector with variable length dimension (i4b) var_dlength ! data vector with variable length dimension (dp) ! provide access to named variables defining elements in the data structures - USE var_lookup,only:iLookTIME,iLookTYPE,iLookATTR,iLookFORCE,iLookPARAM,iLookMVAR,iLookBVAR,iLookINDEX ! named variables for structure elements + USE var_lookup,only:iLookPARAM,iLookPROG,iLookDIAG,iLookINDEX ! named variables for structure elements USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure ! provide access to named variables for thermal conductivity of soil - USE data_struc,only:model_decisions ! model decision structure + USE globalData,only:model_decisions ! model decision structure USE mDecisions_module,only: funcSoilWet, & ! function of soil wetness mixConstit, & ! mixture of constituents hanssonVZJ ! test case for the mizoguchi lab experiment, Hansson et al. VZJ 2004 @@ -91,9 +94,10 @@ subroutine diagn_evar(& logical(lgt),intent(in) :: computeVegFlux ! logical flag to denote if computing the vegetation flux real(dp),intent(in) :: canopyDepth ! depth of the vegetation canopy (m) ! input/output: data structures - type(var_d),intent(in) :: mpar_data ! model parameters - type(var_ilength),intent(inout) :: indx_data ! model layer indices - type(var_dlength),intent(inout) :: mvar_data ! model variables for a local HRU + 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: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -101,6 +105,7 @@ subroutine diagn_evar(& ! 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(dp) :: TCn ! thermal conductivity below the layer interface (W m-1 K-1) real(dp) :: TCp ! thermal conductivity above the layer interface (W m-1 K-1) real(dp) :: zdn ! height difference between interface and lower value (m) @@ -109,7 +114,9 @@ subroutine diagn_evar(& real(dp) :: lambda_drysoil ! thermal conductivity of dry soil (W m-1) real(dp) :: lambda_wetsoil ! thermal conductivity of wet soil (W m-1) real(dp) :: lambda_wet ! thermal conductivity of the wet material + real(dp) :: relativeSat ! relative saturation (-) real(dp) :: kerstenNum ! the Kersten number (-), defining weight applied to conductivity of the wet medium + real(dp) :: den ! denominator in the thermal conductivity calculations ! local variables to reproduce the thermal conductivity of Hansson et al. VZJ 2005 real(dp),parameter :: c1=0.55_dp ! optimized parameter from Hansson et al. VZJ 2005 (W m-1 K-1) real(dp),parameter :: c2=0.8_dp ! optimized parameter from Hansson et al. VZJ 2005 (W m-1 K-1) @@ -120,38 +127,47 @@ subroutine diagn_evar(& real(dp),parameter :: f2=1.06_dp ! optimized parameter from Hansson et al. VZJ 2005 (-) real(dp) :: fArg,xArg ! temporary variables (see Hansson et al. VZJ 2005 for details) ! -------------------------------------------------------------------------------------------------------------------------------- - ! initialize error control - err=0; message="diagn_evar/" ! associate variables in data structure associate(& ! input: model decisions + ixThCondSnow => model_decisions(iLookDECISIONS%thCondSnow)%iDecision, & ! intent(in): choice of method for thermal conductivity of snow ixThCondSoil => model_decisions(iLookDECISIONS%thCondSoil)%iDecision, & ! intent(in): choice of method for thermal conductivity of soil ! input: state variables - scalarCanopyIce => mvar_data%var(iLookMVAR%scalarCanopyIce)%dat(1), & ! intent(in): canopy ice content (kg m-2) - scalarCanopyLiquid => mvar_data%var(iLookMVAR%scalarCanopyLiq)%dat(1), & ! intent(in): canopy liquid water content (kg m-2) - mLayerVolFracIce => mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat, & ! intent(in): volumetric fraction of ice at the start of the sub-step (-) - mLayerVolFracLiq => mvar_data%var(iLookMVAR%mLayerVolFracLiq)%dat, & ! intent(in): volumetric fraction of liquid water at the start of the sub-step (-) + scalarCanopyIce => prog_data%var(iLookPROG%scalarCanopyIce)%dat(1), & ! intent(in): canopy ice content (kg m-2) + scalarCanopyLiquid => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1), & ! intent(in): canopy liquid water content (kg m-2) + mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat, & ! intent(in): volumetric fraction of ice at the start of the sub-step (-) + mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat, & ! intent(in): volumetric fraction of liquid water at the start of the sub-step (-) ! input: coordinate variables - layerType => indx_data%var(iLookINDEX%layerType)%dat, & ! intent(in): layer type (ix_soil or ix_snow) - mLayerHeight => mvar_data%var(iLookMVAR%mLayerHeight)%dat, & ! intent(in): height at the mid-point of each layer (m) - iLayerHeight => mvar_data%var(iLookMVAR%iLayerHeight)%dat, & ! intent(in): height at the interface of each layer (m) + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1), & ! intent(in): number of snow layers + nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1), & ! intent(in): number of soil 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) + mLayerHeight => prog_data%var(iLookPROG%mLayerHeight)%dat, & ! intent(in): height at the mid-point of each layer (m) + iLayerHeight => prog_data%var(iLookPROG%iLayerHeight)%dat, & ! intent(in): height at the interface of each layer (m) ! input: heat capacity and thermal conductivity - specificHeatVeg => mpar_data%var(iLookPARAM%specificHeatVeg), & ! intent(in): specific heat of vegetation (J kg-1 K-1) - maxMassVegetation => mpar_data%var(iLookPARAM%maxMassVegetation), & ! intent(in): maximum mass of vegetation (kg m-2) - iden_soil => mpar_data%var(iLookPARAM%soil_dens_intr), & ! intent(in): intrinsic density of soil (kg m-3) - thCond_soil => mpar_data%var(iLookPARAM%thCond_soil), & ! intent(in): thermal conductivity of soil (W m-1 K-1) - theta_sat => mpar_data%var(iLookPARAM%theta_sat), & ! intent(in): soil porosity (-) - frac_sand => mpar_data%var(iLookPARAM%frac_sand), & ! intent(in): fraction of sand (-) - frac_silt => mpar_data%var(iLookPARAM%frac_silt), & ! intent(in): fraction of silt (-) - frac_clay => mpar_data%var(iLookPARAM%frac_clay), & ! intent(in): fraction of clay (-) + 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) + fixedThermalCond_snow => mpar_data%var(iLookPARAM%fixedThermalCond_snow)%dat(1), & ! intent(in): 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): intrinsic density of soil (kg m-3) + thCond_soil => mpar_data%var(iLookPARAM%thCond_soil)%dat, & ! intent(in): thermal conductivity of soil (W m-1 K-1) + theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat, & ! intent(in): soil porosity (-) + frac_sand => mpar_data%var(iLookPARAM%frac_sand)%dat, & ! intent(in): fraction of sand (-) + frac_silt => mpar_data%var(iLookPARAM%frac_silt)%dat, & ! intent(in): fraction of silt (-) + frac_clay => mpar_data%var(iLookPARAM%frac_clay)%dat, & ! intent(in): fraction of clay (-) ! output: diagnostic variables - scalarBulkVolHeatCapVeg => mvar_data%var(iLookMVAR%scalarBulkVolHeatCapVeg)%dat(1), & ! intent(out): volumetric heat capacity of the vegetation (J m-3 K-1) - mLayerVolHtCapBulk => mvar_data%var(iLookMVAR%mLayerVolHtCapBulk)%dat, & ! intent(out): volumetric heat capacity in each layer (J m-3 K-1) - mLayerThermalC => mvar_data%var(iLookMVAR%mLayerThermalC)%dat, & ! intent(out): thermal conductivity at the mid-point of each layer (W m-1 K-1) - iLayerThermalC => mvar_data%var(iLookMVAR%iLayerThermalC)%dat, & ! intent(out): thermal conductivity at the interface of each layer (W m-1 K-1) - mLayerVolFracAir => mvar_data%var(iLookMVAR%mLayerVolFracAir)%dat & ! intent(out): volumetric fraction of air in each layer (-) + scalarBulkVolHeatCapVeg => diag_data%var(iLookDIAG%scalarBulkVolHeatCapVeg)%dat(1), & ! intent(out): volumetric heat capacity of the vegetation (J m-3 K-1) + mLayerVolHtCapBulk => diag_data%var(iLookDIAG%mLayerVolHtCapBulk)%dat, & ! intent(out): volumetric heat capacity in each layer (J m-3 K-1) + mLayerThermalC => diag_data%var(iLookDIAG%mLayerThermalC)%dat, & ! intent(out): thermal conductivity at the mid-point of each layer (W m-1 K-1) + iLayerThermalC => diag_data%var(iLookDIAG%iLayerThermalC)%dat, & ! intent(out): thermal conductivity at the interface of each layer (W m-1 K-1) + mLayerVolFracAir => diag_data%var(iLookDIAG%mLayerVolFracAir)%dat & ! intent(out): volumetric fraction of air in each layer (-) ) ! end associate statement ! -------------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message="diagn_evar/" + + ! initialize the soil layer + iSoil=integerMissing ! compute the bulk volumetric heat capacity of vegetation (J m-3 K-1) if(computeVegFlux)then @@ -160,26 +176,29 @@ subroutine diagn_evar(& Cp_ice*scalarCanopyIce/canopyDepth ! ice component else scalarBulkVolHeatCapVeg = valueMissing - endif + end if !print*, 'diagn_evar: scalarBulkVolHeatCapVeg = ', scalarBulkVolHeatCapVeg - ! 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)then - bulkden_soil = iden_soil*(1._dp - theta_sat) - lambda_drysoil = (0.135_dp*bulkden_soil + 64.7_dp) / (iden_soil - 0.947_dp*bulkden_soil) - lambda_wetsoil = (8.80_dp*frac_sand + 2.92_dp*frac_clay) / (frac_sand + frac_clay) - endif - ! 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._dp - theta_sat(iSoil) ) + lambda_drysoil = (0.135_dp*bulkden_soil + 64.7_dp) / (iden_soil(iSoil) - 0.947_dp*bulkden_soil) + lambda_wetsoil = (8.80_dp*frac_sand(iSoil) + 2.92_dp*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(ix_soil); mLayerVolFracAir(iLayer) = theta_sat - (mLayerVolFracIce(iLayer) + mLayerVolFracLiq(iLayer)) - case(ix_snow); mLayerVolFracAir(iLayer) = 1._dp - (mLayerVolFracIce(iLayer) + mLayerVolFracLiq(iLayer)) + case(iname_soil); mLayerVolFracAir(iLayer) = theta_sat(iSoil) - (mLayerVolFracIce(iLayer) + mLayerVolFracLiq(iLayer)) + case(iname_snow); mLayerVolFracAir(iLayer) = 1._dp - (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 @@ -188,16 +207,16 @@ subroutine diagn_evar(& ! ******************************************************************* select case(layerType(iLayer)) ! * soil - case(ix_soil) - mLayerVolHtCapBulk(iLayer) = iden_soil * Cp_soil * (1._dp - theta_sat) + & ! soil 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 + case(iname_soil) + mLayerVolHtCapBulk(iLayer) = iden_soil(iSoil) * Cp_soil * ( 1._dp - theta_sat(iSoil) ) + & ! soil 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 - case(ix_snow) - 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(iname_snow) + 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 end select @@ -207,7 +226,7 @@ subroutine diagn_evar(& select case(layerType(iLayer)) ! ***** soil - case(ix_soil) + case(iname_soil) ! select option for thermal conductivity of soil select case(ixThCondSoil) @@ -216,18 +235,23 @@ subroutine diagn_evar(& case(funcSoilWet) ! compute the thermal conductivity of the wet material (W m-1) - lambda_wet = lambda_wetsoil**(1._dp - theta_sat) * lambda_water**theta_sat * lambda_ice**(theta_sat - mLayerVolFracLiq(iLayer)) + lambda_wet = lambda_wetsoil**( 1._dp - theta_sat(iSoil) ) * lambda_water**theta_sat(iSoil) * lambda_ice**(theta_sat(iSoil) - mLayerVolFracLiq(iLayer)) + relativeSat = (mLayerVolFracIce(iLayer) + mLayerVolFracLiq(iLayer))/theta_sat(iSoil) ! relative saturation ! compute the Kersten number (-) - kerstenNum = log10( (mLayerVolFracIce(iLayer) + mLayerVolFracLiq(iLayer))/theta_sat ) + 1._dp + if(relativeSat > 0.1_dp)then ! log10(0.1) = -1 + kerstenNum = log10(relativeSat) + 1._dp + else + kerstenNum = 0._dp ! dry thermal conductivity + endif ! ...and, compute the thermal conductivity mLayerThermalC(iLayer) = kerstenNum*lambda_wet + (1._dp - kerstenNum)*lambda_drysoil ! ** mixture of constituents case(mixConstit) - mLayerThermalC(iLayer) = thCond_soil * (1._dp - theta_sat) + & ! soil component - lambda_ice * mLayerVolFracIce(iLayer) + & ! ice component - lambda_water* mLayerVolFracLiq(iLayer) + & ! liquid water component - lambda_air * mLayerVolFracAir(iLayer) ! air component + mLayerThermalC(iLayer) = thCond_soil(iSoil) * ( 1._dp - theta_sat(iSoil) ) + & ! soil component + lambda_ice * mLayerVolFracIce(iLayer) + & ! ice component + lambda_water * mLayerVolFracLiq(iLayer) + & ! liquid water component + lambda_air * mLayerVolFracAir(iLayer) ! air component ! ** test case for the mizoguchi lab experiment, Hansson et al. VZJ 2004 case(hanssonVZJ) @@ -241,11 +265,21 @@ subroutine diagn_evar(& end select ! option for the thermal conductivity of soil ! ***** snow - case(ix_snow) - call tcond_snow(mLayerVolFracIce(iLayer)*iden_ice,mLayerThermalC(iLayer),err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + case(iname_snow) + ! temporally constant thermal conductivity + if(ixThCondSnow==Smirnova2000)then + mLayerThermalC(iLayer) = fixedThermalCond_snow + ! 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 + endif + ! * 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) @@ -256,20 +290,27 @@ subroutine diagn_evar(& ! * 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) - iLayerThermalC(iLayer) = (TCn*TCp*(zdn + zdp)) / (TCn*zdp + TCp*zdn) + den = TCn*zdp + TCp*zdn ! denominator + ! compute thermal conductivity + if(TCn+TCp > epsilon(TCn))then + iLayerThermalC(iLayer) = (TCn*TCp*(zdn + zdp)) / den + 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 + end do ! looping through layers ! special case of hansson if(ixThCondSoil==hanssonVZJ)then iLayerThermalC(0) = 28._dp*(0.5_dp*(iLayerHeight(1) - iLayerHeight(0))) else iLayerThermalC(0) = mLayerThermalC(1) - endif + end if ! assume the thermal conductivity at the domain boundaries is equal to the thermal conductivity of the layer iLayerThermalC(nLayers) = mLayerThermalC(nLayers) diff --git a/build/source/engine/eval8summa.f90 b/build/source/engine/eval8summa.f90 new file mode 100755 index 000000000..e9fab5857 --- /dev/null +++ b/build/source/engine/eval8summa.f90 @@ -0,0 +1,500 @@ +! 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 eval8summa_module + +! data types +USE nrtype + +! 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 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 + +! 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) + +! 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 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 + +! 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 + +implicit none +private +public::eval8summa + +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 + ! 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_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 + ! provide access to 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:iLookDERIV ! named variables for structure elements + implicit none + ! -------------------------------------------------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------------------------------------------------- + ! input: model control + real(dp),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 + ! input: state vectors + real(dp),intent(in) :: stateVecTrial(:) ! model state vector + real(dp),intent(in) :: fScale(:) ! function scaling vector + real(qp),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 + type(var_ilength), intent(in) :: indx_data ! indices defining model states and layers + ! 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: baseflow + integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) + real(dp),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(dp),intent(out) :: fluxVec(:) ! flux vector + real(dp),intent(out) :: resSink(:) ! sink terms on the RHS of the flux equation + real(qp),intent(out) :: resVec(:) ! NOTE: qp ! residual vector + real(dp),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(dp) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) + real(dp) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) + real(dp) :: scalarCanopyWatTrial ! trial value for liquid water storage in the canopy (kg m-2) + real(dp),dimension(nLayers) :: mLayerTempTrial ! trial value for temperature of layers in the snow and soil domains (K) + real(dp),dimension(nLayers) :: mLayerVolFracWatTrial ! trial value for volumetric fraction of total water (-) + real(dp),dimension(nSoil) :: mLayerMatricHeadTrial ! trial value for total water matric potential (m) + real(dp),dimension(nSoil) :: mLayerMatricHeadLiqTrial ! trial value for liquid water matric potential (m) + ! diagnostic variables + real(dp) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) + real(dp) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) + real(dp),dimension(nLayers) :: mLayerVolFracLiqTrial ! trial value for volumetric fraction of liquid water (-) + real(dp),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),parameter :: ixVegVolume=1 ! index of the desired vegetation control volumne (currently only one veg layer) + real(dp) :: xMin,xMax ! minimum and maximum values for water content + real(dp) :: scalarCanopyHydTrial ! trial value for mass of water on the vegetation canopy (kg m-2) + real(dp),parameter :: canopyTempMax=500._dp ! expected maximum value for the canopy temperature (K) + real(dp),dimension(nLayers) :: mLayerVolFracHydTrial ! trial value for volumetric fraction of water (-), general vector merged from Wat and Liq + real(dp),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) + 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 (-) + mLayerPoreSpace => diag_data%var(iLookDIAG%mLayerPoreSpace)%dat ,& ! intent(in): [dp(:)] pore space 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) + ! 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._dp) 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._dp + endif + + ! --> maximum + select case( layerType(iLayer) ) + case(iname_snow); xMax = merge(iden_ice, mLayerPoreSpace(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 + + ! 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: 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 + .false., & ! intent(in): logical flag to denote the need for the explicit Euler update + 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. + +module f2008funcs_module +USE nrtype +implicit none +private +public::cloneStruc +public::findIndex + +! define generic interface +interface cloneStruc + module procedure cloneStruc_rv, cloneStruc_iv +end interface cloneStruc + +contains + + ! ************************************************************************************************ + ! public function findIndex: find the first index within a vector + ! ************************************************************************************************ + function findIndex(vector,desiredValue,missingValue) + ! finds the first index within a vector + ! -- if the index does not exist, returns zero + ! NOTE: workaround for (not-yet-implemented) f2008 intrinsic findloc + implicit none + ! dummy variables + integer(i4b),intent(in) :: vector(:) ! vector to search + integer(i4b),intent(in) :: desiredValue ! desired value in the vector + integer(i4b),intent(in),optional :: missingValue ! desired missing value if desiredValue is not found + integer(i4b) :: findIndex ! first index of the desired value in the vector + ! local variables + integer(i4b),dimension(1) :: vecIndex ! first index of the desired value in the vector (vec of length=1) + + ! check if the value exisits + if(any(vector==desiredValue))then + + ! get the index: merge provides a vector with 1s where mask is true and 0s otherwise, so maxloc(merge) is the first index of value=1 + ! NOTE: workaround for (not-yet-implemented) f2008 intrinsic findloc + vecIndex=maxloc( merge(1, 0, vector==desiredValue) ) + + ! value does not exist + else + if(present(missingValue))then + vecIndex=missingValue + else + vecIndex=0 + endif + endif + + ! return function value (extract into a scalar) + findIndex=vecIndex(1) + + end function findIndex + + ! ************************************************************************************************ + ! public subroutine cloneStruc_rv: clone a data structure (real vector) + ! ************************************************************************************************ + subroutine cloneStruc_rv(dataVec,lowerBound,source,mold,err,message) + implicit none + ! input-output: data vector for allocation/population + real(dp),intent(inout),allocatable :: dataVec(:) ! data vector + ! input + integer(i4b),intent(in) :: lowerBound ! lower bound + real(dp),intent(in),optional :: source(lowerBound:) ! dataVec = shape of source + elements of source + real(dp),intent(in),optional :: mold(lowerBound:) ! dataVec = shape of mold + ! error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! ---------------------------------------------------------------------------------------------------------------------------------- + ! local variables + integer(i4b),dimension(1) :: upperBound ! upper bound of the data vector (array) + ! ----------------------------------------------------------------------------------------------------------------------------------- + ! initialize errors + err=0; message="cloneStruc_rv/" + + ! check that source and mold are present + if(.not.present(source) .and. .not.present(mold))then + message=trim(message)//'expect to receive either optional argument "source" or "mold" (neither given)' + err=20; return + end if + + ! check that source and mold are not both present + if(present(source) .and. present(mold))then + message=trim(message)//'expect to receive either optional argument "source" or "mold" (both given)' + err=20; return + end if + + ! get the upper bounds of the source or the mold vector + if(present(source))then; upperBound=ubound(source); end if + if(present(mold)) then; upperBound=ubound(mold); end if + + ! reallocate spcae + if(allocated(dataVec)) deallocate(dataVec) + allocate(dataVec(lowerBound:upperBound(1)),stat=err) + if(err/=0)then; err=20; message=trim(message)//'unable to allocate space for the data vector'; return; end if + + ! copy data + if(present(source)) dataVec(lowerBound:upperBound(1)) = source(lowerBound:upperBound(1)) + + end subroutine cloneStruc_rv + + ! ************************************************************************************************ + ! public subroutine cloneStruc_iv: clone a data structure (integer vector) + ! ************************************************************************************************ + subroutine cloneStruc_iv(dataVec,lowerBound,source,mold,err,message) + implicit none + ! input-output: data vector for allocation/population + integer(i4b),intent(inout),allocatable :: dataVec(:) ! data vector + ! input + integer(i4b),intent(in) :: lowerBound ! lower bound + integer(i4b),intent(in),optional :: source(lowerBound:) ! dataVec = shape of source + elements of source + integer(i4b),intent(in),optional :: mold(lowerBound:) ! dataVec = shape of mold + ! error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! ----------------------------------------------------------------------------------------------------------------------------------- + ! local variables + integer(i4b),dimension(1) :: upperBound ! upper bound of the data vector (array) + ! ----------------------------------------------------------------------------------------------------------------------------------- + ! initialize errors + err=0; message="cloneStruc_iv/" + + ! check that source and mold are present + if(.not.present(source) .and. .not.present(mold))then + message=trim(message)//'expect to receive either optional argument "source" or "mold" (neither given)' + err=20; return + end if + + ! check that source and mold are not both present + if(present(source) .and. present(mold))then + message=trim(message)//'expect to receive either optional argument "source" or "mold" (both given)' + err=20; return + end if + + ! get the upper bounds of the source or the mold vector + if(present(source))then; upperBound=ubound(source); end if + if(present(mold)) then; upperBound=ubound(mold); end if + + ! reallocate spcae + if(allocated(dataVec)) deallocate(dataVec) + allocate(dataVec(lowerBound:upperBound(1)),stat=err) + if(err/=0)then; err=20; message=trim(message)//'unable to allocate space for the data vector'; return; end if + + ! copy data + if(present(source)) dataVec(lowerBound:upperBound(1)) = source(lowerBound:upperBound(1)) + + end subroutine cloneStruc_iv + +end module f2008funcs_module diff --git a/build/source/engine/ffile_info.f90 b/build/source/engine/ffile_info.f90 old mode 100644 new mode 100755 index 584f38565..0dfd3ca7f --- a/build/source/engine/ffile_info.f90 +++ b/build/source/engine/ffile_info.f90 @@ -20,6 +20,8 @@ module ffile_info_module USE nrtype +USE netcdf +USE globalData,only:integerMissing implicit none private public::ffile_info @@ -29,178 +31,217 @@ module ffile_info_module ! ************************************************************************************************ ! public subroutine ffile_info: read information on model forcing files ! ************************************************************************************************ - subroutine ffile_info(nHRU,err,message) + subroutine ffile_info(nGRU,err,message) ! used to read metadata on the forcing data file USE ascii_util_module,only:file_open + USE netcdf_util_module,only:nc_file_open ! open netCDF file + USE netcdf_util_module,only:netcdf_err ! netcdf error handling function USE summaFileManager,only:SETNGS_PATH ! path for metadata files + USE summaFileManager,only:INPUT_PATH ! path for forcing files USE summaFileManager,only:FORCING_FILELIST ! list of model forcing files - USE data_struc,only:time_meta,forc_meta ! model forcing metadata - USE data_struc,only:forcFileInfo,data_step ! info on model forcing file - USE data_struc,only:type_hru ! data structure for categorical data - USE var_lookup,only:iLookTYPE ! named variables to index elements of the data vectors + 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 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 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 output - integer(i4b),intent(in) :: nHRU ! number of hydrologic response units + ! 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 ! 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 + ! the rest character(LEN=1024),allocatable :: dataLines(:) ! vector of lines of information (non-comment lines) - integer(i4b),parameter :: imiss = -999 ! missing data character(len=256) :: cmessage ! error message for downwind routine character(LEN=256) :: infile ! input filename - integer(i4b),parameter :: unt=99 ! DK: need to either define units globally, or use getSpareUnit - integer(i4b) :: iline ! loop through lines in the file - integer(i4b),parameter :: maxLines=1000 ! maximum lines in the file - character(LEN=256) :: filenameDesc ! name of file that describes the forcing datafile - character(LEN=256) :: temp='uninitialized' ! single lime of information - integer(i4b) :: iend ! check for the end of the file - character(LEN=256) :: ffmt ! file format - character(LEN=32) :: varname ! name of variable - character(LEN=64) :: vardata ! data on variable - character(len=2) :: dLim ! column delimiter + 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) :: iHRU,jHRU,kHRU ! index of HRUs (position in vector) - integer(i4b) :: hruIndex ! identifier of each HRU - real(dp) :: dataStep_iHRU ! data step for a given forcing data file + 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 ! index of GRU and HRU + integer(i4b) :: ncHruId(1) ! hruID from the forcing files + real(dp) :: dataStep_iFile ! data step for a given forcing data file + logical(lgt) :: xist ! .TRUE. if the file exists + ! Start procedure here err=0; message="ffile_info/" ! ------------------------------------------------------------------------------------------------------------------ - ! (1) read in the list of forcing files + ! (1) read from the list of forcing files ! ------------------------------------------------------------------------------------------------------------------ - ! allocate space for forcing information - if(associated(forcFileInfo)) deallocate(forcFileInfo) - allocate(forcFileInfo(nHRU), stat=err) - if(err/=0)then; err=20; message=trim(message)//'problem allocating space for forcFileInfo'; return; endif - ! build filename + ! build filename for forcing file list infile = trim(SETNGS_PATH)//trim(FORCING_FILELIST) + ! open file call file_open(trim(infile),unt,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + 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,dataLines,err,cmessage) - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif - ! check that we have the correct number of HRUs - if(size(dataLines) /= nHRU)then; err=20; message=trim(message)//'incorrect number of HRUs in file ['//trim(infile)//']'; return; endif - ! loop through list of forcing descriptor files and put in the appropriate place in the data structure - do iHRU=1,nHRU - ! split the line into "words" (expect two words: the HRU index, and the file describing forcing data for that index) - read(dataLines(iHRU),*,iostat=err) hruIndex, filenameDesc - if(err/=0)then; message=trim(message)//'problem reading a line of data from file ['//trim(infile)//']'; return; endif - ! identify the HRU index - do jHRU=1,nHRU - if(hruIndex == type_hru(jHRU)%var(iLookTYPE%hruIndex))then - kHRU=jHRU - exit - endif - if(jHRU == nHRU)then ! we get to here if we have tested the last HRU and have not exited the loop - write(message,'(a,i0,a)') trim(message)//'unable to identify HRU in forcing file description [index = ',hruIndex,'; file='//trim(infile)//']' - err=20; return - endif - end do - ! put the filename in the structure - forcFileInfo(kHRU)%filenmDesc = trim(filenameDesc) - write(*,'(2(a,1x),2(i6,1x))') 'filenameDesc, hruIndex, kHRU = ', trim(filenameDesc), hruIndex, kHRU + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if + nFile = size(dataLines) + + ! allocate space for forcing information + if(allocated(forcFileInfo)) deallocate(forcFileInfo) + allocate(forcFileInfo(nFile), stat=err) + if(err/=0)then; err=20; message=trim(message)//'problem allocating space for forcFileInfo'; return; end if + + ! poputate the forcingInfo structure with filenames + do iFile=1,nFile + ! split the line into "words" (expect one word: the file describing forcing data for that index) + read(dataLines(iFile),*,iostat=err) filenameData + if(err/=0)then; message=trim(message)//'problem reading a line of data from file ['//trim(infile)//']'; return; end if + ! set forcing file name attribute + forcFileInfo(iFile)%filenmData = trim(filenameData) end do ! (looping through files) - close(unt) + + ! close ascii file + close(unit=unt,iostat=err); if(err/=0)then;message=trim(message)//'problem closing forcing file list'; return; end if + ! ------------------------------------------------------------------------------------------------------------------ - ! (2) read in the information that describes each forcing file + ! (2) pull descriptive information from netcdf forcing file and check number of HRUs in each forcing file matches nHRU ! ------------------------------------------------------------------------------------------------------------------ - ! check that the time metadata is already populated - if(.not.associated(time_meta))then; err=30; message=trim(message)//"TimeMetadataNonexistent"; return; endif - ! check that the forcing metadata is already populated - if(.not.associated(forc_meta))then; err=30; message=trim(message)//"ForcingMetadataNonexistent"; return; endif - ! read description of file that is used in each HRU - do iHRU=1,nHRU - ! allocate space for the column indices - if(associated(forcFileInfo(iHRU)%time_ix)) deallocate(forcFileInfo(iHRU)%time_ix) - if(associated(forcFileInfo(iHRU)%data_ix)) deallocate(forcFileInfo(iHRU)%data_ix) - allocate(forcFileInfo(iHRU)%time_ix(size(time_meta)),& - forcFileInfo(iHRU)%data_ix(size(forc_meta)),stat=err) - if(err/=0)then; err=40; message=trim(message)//"problemAllocateStructureElement"; return; endif - ! initialize column indices to missing - forcFileInfo(iHRU)%time_ix(:) = imiss - forcFileInfo(iHRU)%data_ix(:) = imiss - ! build filename - infile = trim(SETNGS_PATH)//trim(forcFileInfo(iHRU)%filenmDesc) - !print*, 'infile = ', trim(infile) + + ! get the number of forcing variables + nForcing = size(forc_meta) + + ! loop through files, and read descriptive information from each file + do iFile=1,nFile + + ! ensure allocatable structure components are deallocated + if(allocated(forcFileInfo(iFile)%data_id)) deallocate(forcFileInfo(iFile)%data_id) + if(allocated(forcFileInfo(iFile)%varName)) deallocate(forcFileInfo(iFile)%varName) + + ! allocate space for structure components + allocate(forcFileInfo(iFile)%data_id(nForcing), forcFileInfo(iFile)%varName(nForcing), stat=err) + if(err/=0)then; err=41; message=trim(message)//"problemAllocateStructureElement"; return; end if + + ! initialize variable ids to missing + forcFileInfo(iFile)%data_id(:) = integerMissing + + ! build filename for actual forcing file + infile = trim(INPUT_PATH)//trim(forcFileInfo(iFile)%filenmData) + ! check if file exists + inquire(file=trim(infile),exist=xist) + if(.not.xist)then + message=trim(message)//"FileNotFound[file='"//trim(infile)//"']" + err=10; return + end if + ! open file - call file_open(trim(infile),unt,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - ! get to the start of the variable descriptions - do iline=1,maxLines - read(unt,'(a)',iostat=iend)temp; if (iend/=0)exit ! read line of data - if (temp(1:1)/='!') exit ! assume first line not comment is format code - end do ! looping through file to find the format code - ! read in format string - read(temp,*)ffmt - ! loop through the lines in the file - do iline=1,maxLines - ! read a line of data and exit if an error code (character read, so only possible error is end of file) - read(unt,'(a)',iostat=iend)temp; if (iend/=0)exit - ! check that the line is not a comment - if (temp(1:1)=='!')cycle - ! save data into a temporary variables - read(temp,trim(ffmt),iostat=err) varname, dLim, vardata - if (err/=0) then; err=30; message=trim(message)//"errorReadLine[file="//trim(infile)//"; line="//trim(temp)//"]"; return; endif - ! check the delimiter - if(dLim(1:1)/='|')then; err=30; message=trim(message)//"incorrectFormat"//trim(infile); return; endif - !print*, 'varname = ', trim(varname) - !print*, 'vardata = ', trim(vardata) - ! put data into data structure - select case(trim(varname)) - case('filenmData'); read(vardata,*) forcFileInfo(iHRU)%filenmData - case('ncols' ); read(vardata,*) forcFileInfo(iHRU)%ncols - ! process the data step + mode=nf90_NoWrite + call nc_file_open(trim(infile), mode, ncid, err, cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + + ! how many variables are there? + err = nf90_inquire(ncid, nvariables=nVar) + call netcdf_err(err,message); if (err/=0) return + + ! set nVar attribute + forcFileInfo(iFile)%nVars = nVar + + ! inquire nhru dimension size + err = nf90_inq_dimid(ncid,'hru',dimId); if(err/=0)then; message=trim(message)//'cannot find dimension hru'; return; endif + err = nf90_inquire_dimension(ncid,dimId,len=file_nHRU); if(err/=0)then; message=trim(message)//'cannot read dimension hru'; return; endif + + ! inquire time dimension size + err = nf90_inq_dimid(ncid,'time',dimId); if(err/=0)then; message=trim(message)//'cannot find dimension time'; return; end if + 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 + do iNC=1,nVar + + ! inqure about current variable name, type, number of dimensions + err = nf90_inquire_variable(ncid,iNC,name=varName) + if(err/=0)then; message=trim(message)//'problem inquiring variable: '//trim(varName); return; end if + + ! process variable + select case(trim(varName)) + + ! if variable is in the forcing vector + case('time','pptrate','SWRadAtm','LWRadAtm','airtemp','windspd','airpres','spechum') + + ! get variable index + 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 + + ! put netcdf file variable index in the forcing file metadata structure + err = nf90_inq_varid(ncid, trim(varName), forcFileInfo(iFile)%data_id(ivar)) + if(err/=0)then; message=trim(message)//"problem inquiring forcing variable[var="//trim(varName)//"]"; return; end if + + ! put variable name in forcing file metadata structure + forcFileInfo(iFile)%varName(ivar) = trim(varName) + + ! get first time from file, place into forcFileInfo + if(trim(varname)=='time')then + err = nf90_get_var(ncid,forcFileInfo(iFile)%data_id(ivar),forcFileInfo(iFile)%firstJulDay,start=(/1/)) + 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 case('data_step' ) - read(vardata,*) dataStep_iHRU - if(iHRU == 1)then - data_step = dataStep_iHRU + + ! 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 + + ! check data_step is the same for all forcing files + if(iFile == 1)then + data_step = dataStep_iFile else - if(abs(dataStep_iHRU - data_step) > epsilon(dataStep_iHRU))then - write(message,'(a,i0,a)') trim(message)//'data step for HRU ',iHRU,'differs from the datastep of the first HRU' + if(abs(dataStep_iFile - data_step) > epsilon(dataStep_iFile))then + write(message,'(a,i0,a)') trim(message)//'data step for forcing file ',iFile,'differs from the datastep of the first forcing file' err=20; return - endif - endif - ! ***** identify the index of the time data variable - case('iyyy','im','id','ih','imin') - ivar = get_ixtime(trim(varname)) - if(ivar < 0)then; err=40; message=trim(message)//"variableNotFound[var="//trim(varname)//"]"; return; endif - if(ivar>size(forcFileInfo(iHRU)%time_ix))then - err=35; message=trim(message)//"indexOutOfRange[var="//trim(varname)//"]"; return - endif - ! put column index in the structure - read(vardata,*) forcFileInfo(iHRU)%time_ix(ivar) - ! ***** identity index for the forcing data variable - case('pptrate','SWRadAtm','LWRadAtm','airtemp','windspd','airpres','spechum') - ivar = get_ixforce(trim(varname)) - if(ivar < 0)then; err=40; message=trim(message)//"variableNotFound[var="//trim(varname)//"]"; return; endif - if(ivar>size(forcFileInfo(iHRU)%data_ix))then - err=35; message=trim(message)//"indexOutOfRange[var="//trim(varname)//"]"; return - endif - ! put column index in the structure - read(vardata,*) forcFileInfo(iHRU)%data_ix(ivar) - ! ***** error check - case default - message=trim(message)//'variableNotFound[var='//trim(varname)//'; file='//trim(infile)//']' - err=20; return - endselect - enddo ! (loop through lines in the file) - ! close file unit - close(unt) - end do ! (looping through files describing each HRU) - ! identify the first HRU to use a given data file - do iHRU=1,nHRU - forcFileInfo(iHRU)%ixFirstHRU = 0 - do jHRU=1,iHRU-1 - if(trim(forcFileInfo(iHRU)%filenmData) == trim(forcFileInfo(jHRU)%filenmData))then - forcFileInfo(iHRU)%ixFirstHRU = jHRU ! index of first HRU to share the same data - endif - end do - end do - end subroutine ffile_info + end if + end if + + ! HRU id -- required + case('hruId') + + ! check to see if hruId exists as a variable, this is a required variable + err = nf90_inq_varid(ncid,trim(varname),varId) + if(err/=0)then; message=trim(message)//'hruID variable not present'; return; endif + ! check that the hruId is what we expect + ! NOTE: we enforce that the HRU order in the forcing files is the same as in the zLocalAttributes files (too slow otherwise) + do iGRU=1,nGRU + do localHRU=1,gru_struc(iGRU)%hruCount + err = nf90_get_var(ncid,varId,ncHruId,start=(/gru_struc(iGRU)%hruInfo(localHRU)%hru_nc/),count=(/1/)) + if(gru_struc(iGRU)%hruInfo(localHRU)%hru_id /= ncHruId(1))then + write(message,'(a,i0,a,i0,a,i0,a,a)') trim(message)//'hruId for global HRU: ',gru_struc(iGRU)%hruInfo(localHRU)%hru_nc,' - ', & + ncHruId(1), ' differs from the expected: ',gru_struc(iGRU)%hruInfo(localHRU)%hru_id, ' in file ', trim(infile) + write(message,'(a)') trim(message)//' order of hruId in forcing file needs to match order in zLocalAttributes.nc' + err=40; return + endif + end do + end do + + ! 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 any forcing variables are missed + if(any(forcFileInfo(iFile)%data_id(:)==integerMissing))then + do iVar=1,size(forcFileInfo(iFile)%data_id) + if(forcFileInfo(iFile)%data_id(iVar)==integerMissing)then; err=40; message=trim(message)//"variable missing [var='"//trim(forcFileInfo(iFile)%varname(iVar))//"']"; return; end if + end do + end if + + end do ! (loop through files) + + end subroutine ffile_info end module ffile_info_module diff --git a/build/source/engine/getVectorz.f90 b/build/source/engine/getVectorz.f90 new file mode 100755 index 000000000..082f34eb7 --- /dev/null +++ b/build/source/engine/getVectorz.f90 @@ -0,0 +1,534 @@ +! 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 getVectorz_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 + +! 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:& + 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_ilength, & ! data vector with variable length dimension (i4b) + var_dlength ! data vector with variable length dimension (dp) + +! 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 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) +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 + +implicit none +private +public::popStateVec +public::getScaling +public::varExtract + +! common variables +real(dp),parameter :: valueMissing=-9999._dp ! missing value + +contains + + ! ********************************************************************************************************** + ! 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 + ! 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(dp),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) + ! 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 + 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 thecanopy 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 + + ! 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(dp),intent(out) :: fScale(:) ! function scaling vector (mixed units) + real(dp),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(dp),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(dp),parameter :: fScaleLiq=0.01_dp ! func eval: characteristic scale for volumetric liquid water content (-) + real(dp),parameter :: fScaleMat=10._dp ! func eval: characteristic scale for matric head (m) + real(dp),parameter :: fScaleNrg=1000000._dp ! func eval: characteristic scale for energy (J m-3) + real(dp),parameter :: xScaleLiq=0.1_dp ! state var: characteristic scale for volumetric liquid water content (-) + real(dp),parameter :: xScaleMat=10._dp ! state var: characteristic scale for matric head (m) + real(dp),parameter :: xScaleTemp=1._dp ! 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._dp / fScaleNrg ! 1/(J m-3) + xScale = 1._dp ! 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._dp / (fScaleLiq*canopyDepth*iden_water) ! 1/(kg m-2) + xScale = 1._dp ! (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._dp / fScaleLiq ! (-) + xScale = 1._dp ! (-) + 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._dp / fScaleLiq ! (-) + xScale = 1._dp ! (m) + end where + + ! ----- + ! * 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._dp ! nothing else on the left hand side + where(ixStateType_subset==iname_liqCanopy) sMul = 1._dp ! 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._dp ! nothing else on the left hand side + where(ixStateType_subset==iname_liqCanopy) dMat = 1._dp ! 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._dp ! state multiplier = 1 (nothing else on the left-hand-side) + dMat(ixStateSubset) = 1._dp ! 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 + + ! ------------------------------------------------------------------------------------------ + ! ------------------------------------------------------------------------------------------ + + 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(& + ! 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) + ! 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: error control + err,message) ! intent(out): error control + ! -------------------------------------------------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------------------------------------------------- + implicit none + ! input + real(dp),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(dp),intent(out) :: scalarCanairTempTrial ! trial value of canopy air temperature (K) + real(dp),intent(out) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) + real(dp),intent(out) :: scalarCanopyWatTrial ! trial value of canopy total water (kg m-2) + real(dp),intent(out) :: scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) + real(dp),intent(out) :: scalarCanopyIceTrial ! trial value of canopy ice content (kg m-2) + ! output: variables for the snow-soil domain + real(dp),intent(out) :: mLayerTempTrial(:) ! trial vector of layer temperature (K) + real(dp),intent(out) :: mLayerVolFracWatTrial(:) ! trial vector of volumetric total water content (-) + real(dp),intent(out) :: mLayerVolFracLiqTrial(:) ! trial vector of volumetric liquid water content (-) + real(dp),intent(out) :: mLayerVolFracIceTrial(:) ! trial vector of volumetric ice water content (-) + real(dp),intent(out) :: mLayerMatricHeadTrial(:) ! trial vector of total water matric potential (m) + real(dp),intent(out) :: 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 + ! -------------------------------------------------------------------------------------------------------------------------------- + ! 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) + 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 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 + + ! 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 + + end associate + + end subroutine varExtract + +end module getVectorz_module diff --git a/build/source/engine/get_ixname.f90 b/build/source/engine/get_ixname.f90 deleted file mode 100644 index 4691dea41..000000000 --- a/build/source/engine/get_ixname.f90 +++ /dev/null @@ -1,684 +0,0 @@ -! 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 get_ixname_module -! used to get the index of a named variable -USE nrtype ! variable types, etc. -implicit none -private -public::get_ixdecisions -public::get_ixTime -public::get_ixAttr -public::get_ixType -public::get_ixForce -public::get_ixParam -public::get_ixMvar -public::get_ixIndex -public::get_ixBpar -public::get_ixBvar -contains - - ! ******************************************************************************************************************* - ! public function get_ixdecisions: get the index of the named variables for the model decisions - ! ******************************************************************************************************************* - function get_ixdecisions(varName) - USE var_lookup,only:iLookDECISIONS ! indices of the named variables - implicit none - ! define dummy variables - character(*), intent(in) :: varName ! variable name - integer(i4b) :: get_ixdecisions ! index of the named variable - ! define local variables - integer(i4b), parameter :: imiss = -999 ! missing value - ! get the index of the named variables - select case(trim(varName)) - ! simulation options - case('simulStart' ); get_ixdecisions=iLookDECISIONS%simulStart ! ( 1) simulation start time - case('simulFinsh' ); get_ixdecisions=iLookDECISIONS%simulFinsh ! ( 2) simulation end time - ! Noah-MP decisions - case('soilCatTbl' ); get_ixdecisions=iLookDECISIONS%soilCatTbl ! ( 3) soil-category dateset - case('vegeParTbl' ); get_ixdecisions=iLookDECISIONS%vegeParTbl ! ( 4) vegetation category dataset - case('soilStress' ); get_ixdecisions=iLookDECISIONS%soilStress ! ( 5) choice of function for the soil moisture control on stomatal resistance - case('stomResist' ); get_ixdecisions=iLookDECISIONS%stomResist ! ( 6) choice of function for stomatal resistance - ! SUMMA decisions - case('num_method' ); get_ixdecisions=iLookDECISIONS%num_method ! ( 7) choice of numerical method - case('fDerivMeth' ); get_ixdecisions=iLookDECISIONS%fDerivMeth ! ( 8) choice of method to calculate flux derivatives - case('LAI_method' ); get_ixdecisions=iLookDECISIONS%LAI_method ! ( 9) choice of method to determine LAI and SAI - case('f_Richards' ); get_ixdecisions=iLookDECISIONS%f_Richards ! (10) form of Richards' equation - case('groundwatr' ); get_ixdecisions=iLookDECISIONS%groundwatr ! (11) choice of groundwater parameterization - case('hc_profile' ); get_ixdecisions=iLookDECISIONS%hc_profile ! (12) choice of hydraulic conductivity profile - case('bcUpprTdyn' ); get_ixdecisions=iLookDECISIONS%bcUpprTdyn ! (13) type of upper boundary condition for thermodynamics - case('bcLowrTdyn' ); get_ixdecisions=iLookDECISIONS%bcLowrTdyn ! (14) type of lower boundary condition for thermodynamics - case('bcUpprSoiH' ); get_ixdecisions=iLookDECISIONS%bcUpprSoiH ! (15) type of upper boundary condition for soil hydrology - case('bcLowrSoiH' ); get_ixdecisions=iLookDECISIONS%bcLowrSoiH ! (16) type of lower boundary condition for soil hydrology - case('veg_traits' ); get_ixdecisions=iLookDECISIONS%veg_traits ! (17) choice of parameterization for vegetation roughness length and displacement height - case('canopyEmis' ); get_ixdecisions=iLookDECISIONS%canopyEmis ! (18) choice of parameterization for canopy emissivity - case('snowIncept' ); get_ixdecisions=iLookDECISIONS%snowIncept ! (19) choice of parameterization for snow interception - case('windPrfile' ); get_ixdecisions=iLookDECISIONS%windPrfile ! (20) choice of canopy wind profile - case('astability' ); get_ixdecisions=iLookDECISIONS%astability ! (21) choice of stability function - case('compaction' ); get_ixdecisions=iLookDECISIONS%compaction ! (22) choice of compaction routine - case('snowLayers' ); get_ixdecisions=iLookDECISIONS%snowLayers ! (23) choice of method to combine and sub-divide snow layers - case('thCondSnow' ); get_ixdecisions=iLookDECISIONS%thCondSnow ! (24) choice of thermal conductivity representation for snow - case('thCondSoil' ); get_ixdecisions=iLookDECISIONS%thCondSoil ! (25) choice of thermal conductivity representation for soil - case('canopySrad' ); get_ixdecisions=iLookDECISIONS%canopySrad ! (26) choice of method for canopy shortwave radiation - case('alb_method' ); get_ixdecisions=iLookDECISIONS%alb_method ! (27) choice of albedo representation - case('spatial_gw' ); get_ixdecisions=iLookDECISIONS%spatial_gw ! (28) choice of method for spatial representation of groundwater - case('subRouting' ); get_ixdecisions=iLookDECISIONS%subRouting ! (29) choice of method for sub-grid routing - ! get to here if cannot find the variable - case default - get_ixdecisions = imiss - endselect - end function get_ixdecisions - - - ! ******************************************************************************************************************* - ! public function get_ixtime: get the index of the named variables for the model time - ! ******************************************************************************************************************* - 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 - ! define local variables - integer(i4b), parameter :: imiss = -999 ! missing value - ! 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 - ! get to here if cannot find the variable - case default - get_ixtime = imiss - endselect - end function get_ixtime - - - ! ******************************************************************************************************************* - ! public function get_ixforce: get the index of the named variables for the model forcing data - ! ******************************************************************************************************************* - 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 - ! define local variables - integer(i4b), parameter :: imiss = -999 ! missing value - ! 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) - ! get to here if cannot find the variable - case default - get_ixforce = imiss - endselect - end function get_ixforce - - - ! ******************************************************************************************************************* - ! public function get_ixAttr: get the index of the named variables for the site characteristics - ! ******************************************************************************************************************* - function get_ixAttr(varName) - USE var_lookup,only:iLookATTR ! indices of the named variables - implicit none - ! define dummy variables - character(*), intent(in) :: varName ! variable name - integer(i4b) :: get_ixAttr ! index of the named variable - ! define local variables - integer(i4b), parameter :: imiss = -999 ! missing value - ! get the index of the named variables - select case(trim(varName)) - case('latitude' ); get_ixAttr = iLookATTR%latitude ! latitude (degrees north) - case('longitude' ); get_ixAttr = iLookATTR%longitude ! longitude (degrees east) - case('elevation' ); get_ixAttr = iLookATTR%elevation ! elevation (m) - case('tan_slope' ); get_ixAttr = iLookATTR%tan_slope ! tan water table slope, taken as tan local ground surface slope (-) - case('contourLength' ); get_ixAttr = iLookATTR%contourLength ! length of contour at downslope edge of HRU (m) - case('HRUarea' ); get_ixAttr = iLookATTR%HRUarea ! area of each HRU (m2) - case('mHeight' ); get_ixAttr = iLookATTR%mHeight ! measurement height above bare ground (m) - ! get to here if cannot find the variable - case default - get_ixAttr = imiss - endselect - end function get_ixAttr - - - ! ******************************************************************************************************************* - ! public function get_ixType: get the index of the named variables for the local classification of veg, soil, etc. - ! ******************************************************************************************************************* - function get_ixType(varName) - USE var_lookup,only:iLookTYPE ! indices of the named variables - implicit none - ! define dummy variables - character(*), intent(in) :: varName ! variable name - integer(i4b) :: get_ixType ! index of the named variable - ! define local variables - integer(i4b), parameter :: imiss = -999 ! missing value - ! get the index of the named variables - select case(trim(varName)) - case('hruIndex' ); get_ixType = iLookTYPE%hruIndex ! index defining HRU index - case('vegTypeIndex' ); get_ixType = iLookTYPE%vegTypeIndex ! index defining vegetation type - case('soilTypeIndex' ); get_ixType = iLookTYPE%soilTypeIndex ! index defining soil type - case('slopeTypeIndex' ); get_ixType = iLookTYPE%slopeTypeIndex ! index defining slope - case('downHRUindex' ); get_ixType = iLookTYPE%downHRUindex ! index of downslope HRU (0 = basin outlet) - ! get to here if cannot find the variable - case default - get_ixType = imiss - endselect - end function get_ixType - - - ! ******************************************************************************************************************* - ! public function get_ixparam: get the index of the named variables for the model parameters - ! ******************************************************************************************************************* - 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 - ! define local variables - integer(i4b), parameter :: imiss = -999 ! missing value - ! 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) - ! 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 (-) - ! freezing curve for snow - case('snowfrz_scale' ); get_ixparam = iLookPARAM%snowfrz_scale ! scaling parameter for the freezing curve for snow (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) - ! 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 (-) - ! 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) - ! 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('base_visc' ); get_ixparam = iLookPARAM%base_visc ! 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 (-) - ! 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 (-) - ! 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('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 (-) - ! 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('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 (-) - ! 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) - ! get to here if cannot find the variable - case default - get_ixparam = imiss - endselect - end function get_ixparam - - - ! ******************************************************************************************************************* - ! public function get_ixmvar: get the index of the named variables for the model variables - ! ******************************************************************************************************************* - function get_ixmvar(varName) - USE var_lookup,only:iLookMVAR ! indices of the named variables - implicit none - ! define dummy variables - character(*), intent(in) :: varName ! parameter name - integer(i4b) :: get_ixmvar ! index of the named variable - ! define local variables - integer(i4b), parameter :: imiss = -999 ! missing value - ! get the index of the named variables - select case(trim(varName)) - ! define timestep-average fluxes for a few key variables - case('totalSoilCompress' ); get_ixmvar = iLookMVAR%totalSoilCompress ! change in total soil storage due to compression of the soil matrix (kg m-2) - case('averageThroughfallSnow' ); get_ixmvar = iLookMVAR%averageThroughfallSnow ! snow that reaches the ground without ever touching the canopy (kg m-2 s-1) - case('averageThroughfallRain' ); get_ixmvar = iLookMVAR%averageThroughfallRain ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) - case('averageCanopySnowUnloading' ); get_ixmvar = iLookMVAR%averageCanopySnowUnloading ! unloading of snow from the vegetion canopy (kg m-2 s-1) - case('averageCanopyLiqDrainage' ); get_ixmvar = iLookMVAR%averageCanopyLiqDrainage ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) - case('averageCanopyMeltFreeze' ); get_ixmvar = iLookMVAR%averageCanopyMeltFreeze ! melt/freeze of water stored in the canopy (kg m-2 s-1) - case('averageCanopyTranspiration' ); get_ixmvar = iLookMVAR%averageCanopyTranspiration ! canopy transpiration (kg m-2 s-1) - case('averageCanopyEvaporation' ); get_ixmvar = iLookMVAR%averageCanopyEvaporation ! canopy evaporation/condensation (kg m-2 s-1) - case('averageCanopySublimation' ); get_ixmvar = iLookMVAR%averageCanopySublimation ! canopy sublimation/frost (kg m-2 s-1) - case('averageSnowSublimation' ); get_ixmvar = iLookMVAR%averageSnowSublimation ! snow sublimation/frost - below canopy or non-vegetated (kg m-2 s-1) - case('averageGroundEvaporation' ); get_ixmvar = iLookMVAR%averageGroundEvaporation ! ground evaporation/condensation - below canopy or non-vegetated (kg m-2 s-1) - case('averageRainPlusMelt' ); get_ixmvar = iLookMVAR%averageRainPlusMelt ! rain plus melt, as input to soil before calculating surface runoff (m s-1) - case('averageSurfaceRunoff' ); get_ixmvar = iLookMVAR%averageSurfaceRunoff ! surface runoff (m s-1) - case('averageSoilInflux' ); get_ixmvar = iLookMVAR%averageSoilInflux ! influx of water at the top of the soil profile (m s-1) - case('averageSoilBaseflow' ); get_ixmvar = iLookMVAR%averageSoilBaseflow ! total baseflow from throughout the soil profile (m s-1) - case('averageSoilDrainage' ); get_ixmvar = iLookMVAR%averageSoilDrainage ! drainage from the bottom of the soil profile (m s-1) - case('averageAquiferRecharge' ); get_ixmvar = iLookMVAR%averageAquiferRecharge ! recharge to the aquifer (m s-1) - case('averageAquiferBaseflow' ); get_ixmvar = iLookMVAR%averageAquiferBaseflow ! baseflow from the aquifer (m s-1) - case('averageAquiferTranspire' ); get_ixmvar = iLookMVAR%averageAquiferTranspire ! transpiration from the aquifer (m s-1) - case('averageColumnOutflow' ); get_ixmvar = iLookMVAR%averageColumnOutflow ! outflow from each layer in the soil profile (m3 s-1) - ! scalar variables -- forcing - case('scalarCosZenith' ); get_ixmvar = iLookMVAR%scalarCosZenith ! cosine of the solar zenith angle (0-1) - case('scalarFractionDirect' ); get_ixmvar = iLookMVAR%scalarFractionDirect ! fraction of direct radiation (0-1) - case('spectralIncomingDirect' ); get_ixmvar = iLookMVAR%spectralIncomingDirect ! incoming direct solar radiation in each wave band (W m-2) - case('spectralIncomingDiffuse' ); get_ixmvar = iLookMVAR%spectralIncomingDiffuse ! incoming diffuse solar radiation in each wave band (W m-2) - case('scalarVPair' ); get_ixmvar = iLookMVAR%scalarVPair ! vapor pressure of the air above the vegetation canopy (Pa) - case('scalarTwetbulb' ); get_ixmvar = iLookMVAR%scalarTwetbulb ! wetbulb temperature (K) - case('scalarRainfall' ); get_ixmvar = iLookMVAR%scalarRainfall ! computed rainfall rate (kg m-2 s-1) - case('scalarSnowfall' ); get_ixmvar = iLookMVAR%scalarSnowfall ! computed snowfall rate (kg m-2 s-1) - case('scalarSnowfallTemp' ); get_ixmvar = iLookMVAR%scalarSnowfallTemp ! temperature of fresh snow (K) - case('scalarNewSnowDensity' ); get_ixmvar = iLookMVAR%scalarNewSnowDensity ! density of fresh snow, should snow be falling in this time step (kg m-3) - case('scalarO2air' ); get_ixmvar = iLookMVAR%scalarO2air ! atmospheric o2 concentration (Pa) - case('scalarCO2air' ); get_ixmvar = iLookMVAR%scalarCO2air ! atmospheric co2 concentration (Pa) - ! scalar variables -- state variables - case('scalarCanopyIce' ); get_ixmvar = iLookMVAR%scalarCanopyIce ! mass of ice on the vegetation canopy (kg m-2) - case('scalarCanopyLiq' ); get_ixmvar = iLookMVAR%scalarCanopyLiq ! mass of liquid water on the vegetation canopy (kg m-2) - case('scalarCanairTemp' ); get_ixmvar = iLookMVAR%scalarCanairTemp ! temperature of the canopy air space (K) - case('scalarCanopyTemp' ); get_ixmvar = iLookMVAR%scalarCanopyTemp ! temperature of the vegetation canopy (K) - case('scalarSnowAge' ); get_ixmvar = iLookMVAR%scalarSnowAge ! non-dimensional snow age (-) - case('scalarSnowAlbedo' ); get_ixmvar = iLookMVAR%scalarSnowAlbedo ! snow albedo for the entire spectral band (-) - case('spectralSnowAlbedoDirect' ); get_ixmvar = iLookMVAR%spectralSnowAlbedoDirect ! direct snow albedo for individual spectral bands (-) - case('spectralSnowAlbedoDiffuse' ); get_ixmvar = iLookMVAR%spectralSnowAlbedoDiffuse ! diffuse snow albedo for individual spectral bands (-) - case('scalarSnowDepth' ); get_ixmvar = iLookMVAR%scalarSnowDepth ! total snow depth (m) - case('scalarSWE' ); get_ixmvar = iLookMVAR%scalarSWE ! snow water equivalent (kg m-2) - case('scalarSfcMeltPond' ); get_ixmvar = iLookMVAR%scalarSfcMeltPond ! ponded water caused by melt of the "snow without a layer" (kg m-2) - case('scalarAquiferStorage' ); get_ixmvar = iLookMVAR%scalarAquiferStorage ! relative aquifer storage -- above bottom of the soil profile (m) - case('scalarSurfaceTemp' ); get_ixmvar = iLookMVAR%scalarSurfaceTemp ! surface temperature (K) - ! NOAH-MP vegetation variables (general) - case('scalarGreenVegFraction' ); get_ixmvar = iLookMVAR%scalarGreenVegFraction ! green vegetation fraction used to compute LAI (-) - case('scalarBulkVolHeatCapVeg' ); get_ixmvar = iLookMVAR%scalarBulkVolHeatCapVeg ! bulk volumetric heat capacity of vegetation (J m-3 K-1) - case('scalarRootZoneTemp' ); get_ixmvar = iLookMVAR%scalarRootZoneTemp ! average temperature of the root zone (K) - case('scalarLAI' ); get_ixmvar = iLookMVAR%scalarLAI ! one-sided leaf area index (m2 m-2) - case('scalarSAI' ); get_ixmvar = iLookMVAR%scalarSAI ! one-sided stem area index (m2 m-2) - case('scalarExposedLAI' ); get_ixmvar = iLookMVAR%scalarExposedLAI ! exposed leaf area index after burial by snow (m2 m-2) - case('scalarExposedSAI' ); get_ixmvar = iLookMVAR%scalarExposedSAI ! exposed stem area index after burial by snow (m2 m-2) - case('scalarCanopyIceMax' ); get_ixmvar = iLookMVAR%scalarCanopyIceMax ! maximum interception storage capacity for ice (kg m-2) - case('scalarCanopyLiqMax' ); get_ixmvar = iLookMVAR%scalarCanopyLiqMax ! maximum interception storage capacity for liquid water (kg m-2) - case('scalarGrowingSeasonIndex' ); get_ixmvar = iLookMVAR%scalarGrowingSeasonIndex ! growing season index (0=off, 1=on) - case('scalarVP_CanopyAir' ); get_ixmvar = iLookMVAR%scalarVP_CanopyAir ! vapor pressure of the canopy air space (Pa) - ! NOAH-MP vegetation variables (shortwave radiation) - case('scalarCanopySunlitFraction' ); get_ixmvar = iLookMVAR%scalarCanopySunlitFraction ! sunlit fraction of canopy (-) - case('scalarCanopySunlitLAI' ); get_ixmvar = iLookMVAR%scalarCanopySunlitLAI ! sunlit leaf area (-) - case('scalarCanopyShadedLAI' ); get_ixmvar = iLookMVAR%scalarCanopyShadedLAI ! shaded leaf area (-) - case('scalarCanopySunlitPAR' ); get_ixmvar = iLookMVAR%scalarCanopySunlitPAR ! average absorbed par for sunlit leaves (w m-2) - case('scalarCanopyShadedPAR' ); get_ixmvar = iLookMVAR%scalarCanopyShadedPAR ! average absorbed par for shaded leaves (w m-2) - case('spectralBelowCanopyDirect' ); get_ixmvar = iLookMVAR%spectralBelowCanopyDirect ! downward direct flux below veg layer for each spectral band W m-2) - case('spectralBelowCanopyDiffuse' ); get_ixmvar = iLookMVAR%spectralBelowCanopyDiffuse ! downward diffuse flux below veg layer for each spectral band (W m-2) - case('scalarBelowCanopySolar' ); get_ixmvar = iLookMVAR%scalarBelowCanopySolar ! solar radiation transmitted below the canopy (W m-2) - case('spectralAlbGndDirect' ); get_ixmvar = iLookMVAR%spectralAlbGndDirect ! direct albedo of underlying surface for each spectral band (-) - case('spectralAlbGndDiffuse' ); get_ixmvar = iLookMVAR%spectralAlbGndDiffuse ! diffuse albedo of underlying surface for each spectral band (-) - case('scalarGroundAlbedo' ); get_ixmvar = iLookMVAR%scalarGroundAlbedo ! albedo of the ground surface (-) - case('scalarCanopyAbsorbedSolar' ); get_ixmvar = iLookMVAR%scalarCanopyAbsorbedSolar ! solar radiation absorbed by canopy (W m-2) - case('scalarGroundAbsorbedSolar' ); get_ixmvar = iLookMVAR%scalarGroundAbsorbedSolar ! solar radiation absorbed by ground (W m-2) - ! NOAH-MP vegetation variables (longwave radiation) - case('scalarCanopyEmissivity' ); get_ixmvar = iLookMVAR%scalarCanopyEmissivity ! effective canopy emissivity (-) - case('scalarLWRadCanopy' ); get_ixmvar = iLookMVAR%scalarLWRadCanopy ! longwave radiation emitted from the canopy (W m-2) - case('scalarLWRadGround' ); get_ixmvar = iLookMVAR%scalarLWRadGround ! longwave radiation emitted at the ground surface (W m-2) - case('scalarLWRadUbound2Canopy' ); get_ixmvar = iLookMVAR%scalarLWRadUbound2Canopy ! downward atmospheric longwave radiation absorbed by the canopy (W m-2) - case('scalarLWRadUbound2Ground' ); get_ixmvar = iLookMVAR%scalarLWRadUbound2Ground ! downward atmospheric longwave radiation absorbed by the ground (W m-2) - case('scalarLWRadUbound2Ubound' ); get_ixmvar = iLookMVAR%scalarLWRadUbound2Ubound ! atmospheric radiation refl by ground + lost thru upper boundary (W m-2) - case('scalarLWRadCanopy2Ubound' ); get_ixmvar = iLookMVAR%scalarLWRadCanopy2Ubound ! longwave radiation emitted from canopy lost thru upper boundary (W m-2) - case('scalarLWRadCanopy2Ground' ); get_ixmvar = iLookMVAR%scalarLWRadCanopy2Ground ! longwave radiation emitted from canopy absorbed by the ground (W m-2) - case('scalarLWRadCanopy2Canopy' ); get_ixmvar = iLookMVAR%scalarLWRadCanopy2Canopy ! canopy longwave reflected from ground and absorbed by the canopy (W m-2) - case('scalarLWRadGround2Ubound' ); get_ixmvar = iLookMVAR%scalarLWRadGround2Ubound ! longwave radiation emitted from ground lost thru upper boundary (W m-2) - case('scalarLWRadGround2Canopy' ); get_ixmvar = iLookMVAR%scalarLWRadGround2Canopy ! longwave radiation emitted from ground and absorbed by the canopy (W m-2) - case('scalarLWNetCanopy' ); get_ixmvar = iLookMVAR%scalarLWNetCanopy ! net longwave radiation at the canopy (W m-2) - case('scalarLWNetGround' ); get_ixmvar = iLookMVAR%scalarLWNetGround ! net longwave radiation at the ground surface (W m-2) - case('scalarLWNetUbound' ); get_ixmvar = iLookMVAR%scalarLWNetUbound ! net longwave radiation at the upper atmospheric boundary (W m-2) - ! NOAH-MP vegetation variables (turbulent heat transfer) - case('scalarLatHeatSubVapCanopy' ); get_ixmvar = iLookMVAR%scalarLatHeatSubVapCanopy ! latent heat of sublimation/vaporization used for veg canopy (J kg-1) - case('scalarLatHeatSubVapGround' ); get_ixmvar = iLookMVAR%scalarLatHeatSubVapGround ! latent heat of sublimation/vaporization used for ground surface (J kg-1) - case('scalarSatVP_CanopyTemp' ); get_ixmvar = iLookMVAR%scalarSatVP_CanopyTemp ! saturation vapor pressure at the temperature of vegetation canopy (Pa) - case('scalarSatVP_GroundTemp' ); get_ixmvar = iLookMVAR%scalarSatVP_GroundTemp ! saturation vapor pressure at the temperature of the ground (Pa) - case('scalarZ0Canopy' ); get_ixmvar = iLookMVAR%scalarZ0Canopy ! roughness length of the canopy (m) - case('scalarWindReductionFactor' ); get_ixmvar = iLookMVAR%scalarWindReductionFactor ! canopy wind reduction factor (-) - case('scalarZeroPlaneDisplacement' ); get_ixmvar = iLookMVAR%scalarZeroPlaneDisplacement ! zero plane displacement (m) - case('scalarRiBulkCanopy' ); get_ixmvar = iLookMVAR%scalarRiBulkCanopy ! bulk Richardson number for the canopy (-) - case('scalarRiBulkGround' ); get_ixmvar = iLookMVAR%scalarRiBulkGround ! bulk Richardson number for the ground surface (-) - case('scalarCanopyStabilityCorrection'); get_ixmvar = iLookMVAR%scalarCanopyStabilityCorrection ! stability correction for the canopy (-) - case('scalarGroundStabilityCorrection'); get_ixmvar = iLookMVAR%scalarGroundStabilityCorrection ! stability correction for the ground surface (-) - case('scalarEddyDiffusCanopyTop' ); get_ixmvar = iLookMVAR%scalarEddyDiffusCanopyTop ! eddy diffusivity for heat at the top of the canopy (m2 s-1) - case('scalarFrictionVelocity' ); get_ixmvar = iLookMVAR%scalarFrictionVelocity ! friction velocity - canopy momentum sink (m s-1) - case('scalarWindspdCanopyTop' ); get_ixmvar = iLookMVAR%scalarWindspdCanopyTop ! windspeed at the top of the canopy (m s-1) - case('scalarWindspdCanopyBottom' ); get_ixmvar = iLookMVAR%scalarWindspdCanopyBottom ! windspeed at the height of the bottom of the canopy (m s-1) - case('scalarGroundResistance' ); get_ixmvar = iLookMVAR%scalarGroundResistance ! below canopy aerodynamic resistance (s m-1) - case('scalarCanopyResistance' ); get_ixmvar = iLookMVAR%scalarCanopyResistance ! above canopy aerodynamic resistance (s m-1) - case('scalarLeafResistance' ); get_ixmvar = iLookMVAR%scalarLeafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) - case('scalarSoilResistance' ); get_ixmvar = iLookMVAR%scalarSoilResistance ! soil surface resistance (s m-1) - case('scalarSoilRelHumidity' ); get_ixmvar = iLookMVAR%scalarSoilRelHumidity ! relative humidity in the soil pores in the upper-most soil layer (-) - case('scalarSenHeatTotal' ); get_ixmvar = iLookMVAR%scalarSenHeatTotal ! sensible heat from the canopy air space to the atmosphere (W m-2) - case('scalarSenHeatCanopy' ); get_ixmvar = iLookMVAR%scalarSenHeatCanopy ! sensible heat from the canopy to the canopy air space (W m-2) - case('scalarSenHeatGround' ); get_ixmvar = iLookMVAR%scalarSenHeatGround ! sensible heat from the ground (below canopy or non-vegetated) (W m-2) - case('scalarLatHeatTotal' ); get_ixmvar = iLookMVAR%scalarLatHeatTotal ! latent heat from the canopy air space to the atmosphere (W m-2) - case('scalarLatHeatCanopyEvap' ); get_ixmvar = iLookMVAR%scalarLatHeatCanopyEvap ! evaporation latent heat from the canopy to the canopy air space (W m-2) - case('scalarLatHeatCanopyTrans' ); get_ixmvar = iLookMVAR%scalarLatHeatCanopyTrans ! transpiration latent heat from the canopy to the canopy air space (W m-2) - case('scalarLatHeatGround' ); get_ixmvar = iLookMVAR%scalarLatHeatGround ! latent heat from the ground (below canopy or non-vegetated) (W m-2) - case('scalarCanopyAdvectiveHeatFlux' ); get_ixmvar = iLookMVAR%scalarCanopyAdvectiveHeatFlux ! heat advected to the canopy surface with rain + snow (W m-2) - case('scalarGroundAdvectiveHeatFlux' ); get_ixmvar = iLookMVAR%scalarGroundAdvectiveHeatFlux ! heat advected to the ground surface with throughfall and unloading/drainage (W m-2) - case('scalarCanopyTranspiration' ); get_ixmvar = iLookMVAR%scalarCanopyTranspiration ! canopy transpiration (kg m-2 s-1) - case('scalarCanopyEvaporation' ); get_ixmvar = iLookMVAR%scalarCanopyEvaporation ! canopy evaporation/condensation (kg m-2 s-1) - case('scalarCanopySublimation' ); get_ixmvar = iLookMVAR%scalarCanopySublimation ! canopy sublimation/frost (kg m-2 s-1) - case('scalarGroundEvaporation' ); get_ixmvar = iLookMVAR%scalarGroundEvaporation ! ground evaporation/condensation (below canopy or non-vegetated) (kg m-2 s-1) - case('scalarSnowSublimation' ); get_ixmvar = iLookMVAR%scalarSnowSublimation ! snow sublimation/frost (below canopy or non-vegetated) (kg m-2 s-1) - ! NOAH-MP vegetation variables (transpiration) - case('scalarTranspireLim' ); get_ixmvar = iLookMVAR%scalarTranspireLim ! aggregate soil moisture and aquifer storage limit on transpiration (-) - case('scalarTranspireLimAqfr' ); get_ixmvar = iLookMVAR%scalarTranspireLimAqfr ! aquifer storage limit on transpiration (-) - case('scalarFoliageNitrogenFactor' ); get_ixmvar = iLookMVAR%scalarFoliageNitrogenFactor ! foliage nitrogen concentration, 1=saturated (-) - case('scalarStomResistSunlit' ); get_ixmvar = iLookMVAR%scalarStomResistSunlit ! stomatal resistance for sunlit leaves (s m-1) - case('scalarStomResistShaded' ); get_ixmvar = iLookMVAR%scalarStomResistShaded ! stomatal resistance for shaded leaves (s m-1) - case('scalarPhotosynthesisSunlit' ); get_ixmvar = iLookMVAR%scalarPhotosynthesisSunlit ! sunlit photosynthesis (umolco2 m-2 s-1) - case('scalarPhotosynthesisShaded' ); get_ixmvar = iLookMVAR%scalarPhotosynthesisShaded ! shaded photosynthesis (umolco2 m-2 s-1) - ! NOAH-MP vegetation variables (canopy water) - case('scalarCanopyWetFraction' ); get_ixmvar = iLookMVAR%scalarCanopyWetFraction ! fraction of canopy that is wet - case('scalarGroundSnowFraction' ); get_ixmvar = iLookMVAR%scalarGroundSnowFraction ! fraction of ground that is covered with snow (-) - case('scalarThroughfallSnow' ); get_ixmvar = iLookMVAR%scalarThroughfallSnow ! snow that reaches the ground without ever touching the canopy (kg m-2 s-1) - case('scalarThroughfallRain' ); get_ixmvar = iLookMVAR%scalarThroughfallRain ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) - case('scalarCanopySnowUnloading' ); get_ixmvar = iLookMVAR%scalarCanopySnowUnloading ! unloading of snow from the vegetion canopy (kg m-2 s-1) - case('scalarCanopyLiqDrainage' ); get_ixmvar = iLookMVAR%scalarCanopyLiqDrainage ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) - case('scalarCanopyMeltFreeze' ); get_ixmvar = iLookMVAR%scalarCanopyMeltFreeze ! melt/freeze of water stored in the canopy (kg m-2 s-1) - ! scalar variables -- soil and aquifer fluxes - case('scalarRainPlusMelt' ); get_ixmvar = iLookMVAR%scalarRainPlusMelt ! rain plus melt, as input to soil before calculating surface runoff (m s-1) - case('scalarInfilArea' ); get_ixmvar = iLookMVAR%scalarInfilArea ! fraction of unfrozen area where water can infiltrate (-) - case('scalarFrozenArea' ); get_ixmvar = iLookMVAR%scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) - case('scalarInfiltration' ); get_ixmvar = iLookMVAR%scalarInfiltration ! infiltration of water into the soil profile (m s-1) - case('scalarExfiltration' ); get_ixmvar = iLookMVAR%scalarExfiltration ! exfiltration of water from the top of the soil profile (m s-1) - case('scalarSurfaceRunoff' ); get_ixmvar = iLookMVAR%scalarSurfaceRunoff ! surface runoff (m s-1) - case('scalarInitAquiferRecharge' ); get_ixmvar = iLookMVAR%scalarInitAquiferRecharge ! recharge to the aquifer -- at the start of the step (m s-1) - case('scalarAquiferRecharge' ); get_ixmvar = iLookMVAR%scalarAquiferRecharge ! recharge to the aquifer (m s-1) - case('scalarInitAquiferTranspire' ); get_ixmvar = iLookMVAR%scalarInitAquiferTranspire ! transpiration from the aquifer (m s-1) - case('scalarAquiferTranspire' ); get_ixmvar = iLookMVAR%scalarAquiferTranspire ! transpiration from the aquifer (m s-1) - case('scalarInitAquiferBaseflow' ); get_ixmvar = iLookMVAR%scalarInitAquiferBaseflow ! baseflow from the aquifer (m s-1) - case('scalarAquiferBaseflow' ); get_ixmvar = iLookMVAR%scalarAquiferBaseflow ! baseflow from the aquifer (m s-1) - ! scalar variables -- sub-step average fluxes for the soil zone - case('scalarSoilInflux' ); get_ixmvar = iLookMVAR%scalarSoilInflux ! sub-step average: influx of water at the top of the soil profile (m s-1) - case('scalarSoilCompress' ); get_ixmvar = iLookMVAR%scalarSoilCompress ! change in total soil storage due to compression of the soil matrix (kg m-2) - case('scalarSoilBaseflow' ); get_ixmvar = iLookMVAR%scalarSoilBaseflow ! sub-step average: total baseflow from throughout the soil profile (m s-1) - case('scalarSoilDrainage' ); get_ixmvar = iLookMVAR%scalarSoilDrainage ! sub-step average: drainage from the bottom of the soil profile (m s-1) - case('scalarSoilTranspiration' ); get_ixmvar = iLookMVAR%scalarSoilTranspiration ! sub-step average: total transpiration from the soil (m s-1) - ! scalar variables -- mass balance check - case('scalarSoilWatBalError' ); get_ixmvar = iLookMVAR%scalarSoilWatBalError ! error in the total soil water balance (kg m-2) - case('scalarAquiferBalError' ); get_ixmvar = iLookMVAR%scalarAquiferBalError ! error in the aquifer water balance (kg m-2) - case('scalarTotalSoilLiq' ); get_ixmvar = iLookMVAR%scalarTotalSoilLiq ! total mass of liquid water in the soil (kg m-2) - case('scalarTotalSoilIce' ); get_ixmvar = iLookMVAR%scalarTotalSoilIce ! total mass of ice in the soil (kg m-2) - ! variables at the mid-point of each layer -- domain geometry - case('mLayerDepth' ); get_ixmvar = iLookMVAR%mLayerDepth ! depth of each layer (m) - case('mLayerHeight' ); get_ixmvar = iLookMVAR%mLayerHeight ! height at the midpoint of each layer (m) - case('mLayerRootDensity' ); get_ixmvar = iLookMVAR%mLayerRootDensity ! fraction of roots in each soil layer (-) - ! variables at the mid-point of each layer -- coupled energy and mass - case('mLayerTemp' ); get_ixmvar = iLookMVAR%mLayerTemp ! temperature of each layer (K) - case('mLayerVolFracAir' ); get_ixmvar = iLookMVAR%mLayerVolFracAir ! volumetric fraction of air in each layer (-) - case('mLayerVolFracIce' ); get_ixmvar = iLookMVAR%mLayerVolFracIce ! volumetric fraction of icein each layer (-) - case('mLayerVolFracLiq' ); get_ixmvar = iLookMVAR%mLayerVolFracLiq ! volumetric fraction of liquid water in each layer (-) - case('mLayerVolHtCapBulk' ); get_ixmvar = iLookMVAR%mLayerVolHtCapBulk ! volumetric heat capacity in each layer (J m-3 K-1) - case('mLayerTcrit' ); get_ixmvar = iLookMVAR%mLayerTcrit ! critical soil temperature above which all water is unfrozen (K) - case('mLayerdTheta_dTk' ); get_ixmvar = iLookMVAR%mLayerdTheta_dTk ! analytical derivative in the freezing curve (K-1) - case('mLayerThermalC' ); get_ixmvar = iLookMVAR%mLayerThermalC ! thermal conductivity at the mid-point of each layer (W m-1 K-1) - case('mLayerRadCondFlux' ); get_ixmvar = iLookMVAR%mLayerRadCondFlux ! temporal derivative in energy from radiative and conductive flux (J m-2 s-1) - case('mLayerMeltFreeze' ); get_ixmvar = iLookMVAR%mLayerMeltFreeze ! rate of ice content change from melt/freeze in each layer (kg m-3 s-1) - case('mLayerInfilFreeze' ); get_ixmvar = iLookMVAR%mLayerInfilFreeze ! rate of ice content change by freezing infiltrating flux (kg m-3 s-1) - case('mLayerSatHydCond' ); get_ixmvar = iLookMVAR%mLayerSatHydCond ! saturated hydraulic conductivity in each layer (m s-1) - case('mLayerSatHydCondMP' ); get_ixmvar = iLookMVAR%mLayerSatHydCondMP ! saturated hydraulic conductivity of macropores in each layer (m s-1) - case('mLayerMatricHead' ); get_ixmvar = iLookMVAR%mLayerMatricHead ! matric head of water in the soil (m) - case('mLayerdTheta_dPsi' ); get_ixmvar = iLookMVAR%mLayerdTheta_dPsi ! analytical derivative in the soil water characteristic w.r.t. psi (m-1) - case('mLayerdPsi_dTheta' ); get_ixmvar = iLookMVAR%mLayerdPsi_dTheta ! analytical derivative in the soil water characteristic w.r.t. theta (m) - case('mLayerThetaResid' ); get_ixmvar = iLookMVAR%mLayerThetaResid ! residual volumetric water content in each snow layer (-) - case('mLayerPoreSpace' ); get_ixmvar = iLookMVAR%mLayerPoreSpace ! total pore space in each snow layer (-) - case('mLayerCompress' ); get_ixmvar = iLookMVAR%mLayerCompress ! change in volumetric water content due to compression of soil (-) - case('mLayerTranspireLim' ); get_ixmvar = iLookMVAR%mLayerTranspireLim ! moisture avail factor limiting transpiration in each layer (-) - case('mLayerInitTranspire' ); get_ixmvar = iLookMVAR%mLayerInitTranspire ! transpiration loss from each soil layer at the start of the step (kg m-2 s-1) - case('mLayerTranspire' ); get_ixmvar = iLookMVAR%mLayerTranspire ! transpiration loss from each soil layer (kg m-2 s-1) - case('mLayerInitQMacropore' ); get_ixmvar = iLookMVAR%mLayerInitQMacropore ! liquid flux from micropores to macropores at the start-of-step (m s-1) - case('mLayerQMacropore' ); get_ixmvar = iLookMVAR%mLayerQMacropore ! liquid flux from micropores to macropores (m s-1) - case('mLayerInitBaseflow' ); get_ixmvar = iLookMVAR%mLayerInitBaseflow ! baseflow from each soil layer at the start of the time step (m s-1) - case('mLayerBaseflow' ); get_ixmvar = iLookMVAR%mLayerBaseflow ! baseflow from each soil layer (m s-1) - case('mLayerColumnInflow' ); get_ixmvar = iLookMVAR%mLayerColumnInflow ! total inflow to each layer in a given soil column (m3 s-1) - case('mLayerColumnOutflow' ); get_ixmvar = iLookMVAR%mLayerColumnOutflow ! total outflow from each layer in a given soil column (m3 s-1) - ! variables at the interface of each layer - case('iLayerHeight' ); get_ixmvar = iLookMVAR%iLayerHeight ! height at the interface of each layer (m) - case('iLayerThermalC' ); get_ixmvar = iLookMVAR%iLayerThermalC ! thermal conductivity at the interface of each layer (W m-1 K-1) - case('iLayerConductiveFlux' ); get_ixmvar = iLookMVAR%iLayerConductiveFlux ! conductive energy flux at layer interfaces at end of time step (W m-2) - case('iLayerAdvectiveFlux' ); get_ixmvar = iLookMVAR%iLayerAdvectiveFlux ! advective energy flux at layer interfaces at end of time step (W m-2) - case('iLayerInitNrgFlux' ); get_ixmvar = iLookMVAR%iLayerInitNrgFlux ! energy flux at layer interfaces at the start of the time step (W m-2) - case('iLayerNrgFlux' ); get_ixmvar = iLookMVAR%iLayerNrgFlux ! energy flux at layer interfaces at the end of the time step (W m-2) - case('iLayerSatHydCond' ); get_ixmvar = iLookMVAR%iLayerSatHydCond ! saturated hydraulic conductivity in each layer (m s-1) - case('iLayerInitLiqFluxSnow' ); get_ixmvar = iLookMVAR%iLayerInitLiqFluxSnow ! liquid flux at snow layer interfaces at the start of the time step (m s-1) - case('iLayerInitLiqFluxSoil' ); get_ixmvar = iLookMVAR%iLayerInitLiqFluxSoil ! liquid flux at soil layer interfaces at the start of the time step (m s-1) - case('iLayerInitFluxReversal' ); get_ixmvar = iLookMVAR%iLayerInitFluxReversal ! start of step liquid flux at soil layer interfaces from impedance (m s-1) - case('iLayerLiqFluxSnow' ); get_ixmvar = iLookMVAR%iLayerLiqFluxSnow ! liquid flux at snow layer interfaces at the end of the time step (m s-1) - case('iLayerLiqFluxSoil' ); get_ixmvar = iLookMVAR%iLayerLiqFluxSoil ! liquid flux at soil layer interfaces at the end of the time step (m s-1) - case('iLayerFluxReversal' ); get_ixmvar = iLookMVAR%iLayerFluxReversal ! end of step liquid flux at soil layer interfaces from impedance (m s-1) - ! time stepping variables - case('dt_init' ); get_ixmvar = iLookMVAR%dt_init ! length of initial time step at start of next data interval (s) - ! "short-cut" variables - case('scalarVGn_m' ); get_ixmvar = iLookMVAR%scalarVGn_m ! van Genuchten "m" parameter (-) - case('scalarKappa' ); get_ixmvar = iLookMVAR%scalarKappa ! constant in the freezing curve function (m K-1) - case('scalarVolHtCap_air' ); get_ixmvar = iLookMVAR%scalarVolHtCap_air ! volumetric heat capacity air (J m-3 K-1) - case('scalarVolHtCap_ice' ); get_ixmvar = iLookMVAR%scalarVolHtCap_ice ! volumetric heat capacity ice (J m-3 K-1) - case('scalarVolHtCap_soil' ); get_ixmvar = iLookMVAR%scalarVolHtCap_soil ! volumetric heat capacity dry soil (J m-3 K-1) - case('scalarVolHtCap_water' ); get_ixmvar = iLookMVAR%scalarVolHtCap_water ! volumetric heat capacity liquid wat (J m-3 K-1) - case('scalarLambda_drysoil' ); get_ixmvar = iLookMVAR%scalarLambda_drysoil ! thermal conductivity of dry soil (W m-1) - case('scalarLambda_wetsoil' ); get_ixmvar = iLookMVAR%scalarLambda_wetsoil ! thermal conductivity of wet soil (W m-1) - case('scalarVolLatHt_fus' ); get_ixmvar = iLookMVAR%scalarVolLatHt_fus ! volumetric latent heat of fusion (J m-3) - case('scalarAquiferRootFrac' ); get_ixmvar = iLookMVAR%scalarAquiferRootFrac ! fraction of roots below the soil profile (-) - ! get to here if cannot find the variable - case default - get_ixmvar = imiss - endselect - end function get_ixmvar - - - ! ******************************************************************************************************************* - ! public function get_ixindex: get the index of the named variables for the model indices - ! ******************************************************************************************************************* - function get_ixindex(varName) - USE var_lookup,only:iLookINDEX ! indices of the named variables - implicit none - ! define dummy variables - character(*), intent(in) :: varName ! parameter name - integer(i4b) :: get_ixINDEX ! index of the named variable - ! define local variables - integer(i4b), parameter :: imiss = -999 ! missing value - ! get the index of the named variables - select case(trim(varName)) - case('nSnow' ); get_ixindex = iLookINDEX%nSnow ! number of snow layers - case('nSoil' ); get_ixindex = iLookINDEX%nSoil ! number of soil layers - case('nLayers' ); get_ixindex = iLookINDEX%nLayers ! total number of layers - case('midSnowStartIndex'); get_ixindex = iLookINDEX%midSnowStartIndex ! start index of the midSnow vector for a given timestep - case('midSoilStartIndex'); get_ixindex = iLookINDEX%midSoilStartIndex ! start index of the midSoil vector for a given timestep - case('midTotoStartIndex'); get_ixindex = iLookINDEX%midTotoStartIndex ! start index of the midToto vector for a given timestep - case('ifcSnowStartIndex'); get_ixindex = iLookINDEX%ifcSnowStartIndex ! start index of the ifcSnow vector for a given timestep - case('ifcSoilStartIndex'); get_ixindex = iLookINDEX%ifcSoilStartIndex ! start index of the ifcSoil vector for a given timestep - case('ifcTotoStartIndex'); get_ixindex = iLookINDEX%ifcTotoStartIndex ! start index of the ifcToto vector for a given timestep - case('layerType' ); get_ixindex = iLookINDEX%layerType ! type of layer (soil or snow) - ! get to here if cannot find the variable - case default - get_ixindex = imiss - endselect - end function get_ixindex - - - ! ******************************************************************************************************************* - ! public function get_ixbpar: get the index of the named variables for the basin-average variables - ! ******************************************************************************************************************* - 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 - ! define local variables - integer(i4b), parameter :: imiss = -999 ! missing value - ! 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 (-) - ! 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) - ! get to here if cannot find the variable - case default - get_ixbpar = imiss - endselect - end function get_ixbpar - - - ! ******************************************************************************************************************* - ! public function get_ixbvar: get the index of the named variables for the basin-average variables - ! ******************************************************************************************************************* - 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 - ! define local variables - integer(i4b), parameter :: imiss = -999 ! missing value - ! 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) - ! 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) - ! 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) - ! get to here if cannot find the variable - case default - get_ixbvar = imiss - endselect - end function get_ixbvar - - -end module get_ixname_module diff --git a/build/source/engine/groundwatr.f90 b/build/source/engine/groundwatr.f90 old mode 100644 new mode 100755 index eda923619..1e24a65db --- a/build/source/engine/groundwatr.f90 +++ b/build/source/engine/groundwatr.f90 @@ -28,17 +28,12 @@ module groundwatr_module qbaseTopmodel, & ! TOPMODEL-ish baseflow parameterization bigBucket, & ! a big bucket (lumped aquifer model) noExplicit ! no explicit groundwater parameterization -! access the number of snow and soil layers -USE data_struc,only:& - nSnow, & ! number of snow layers - nSoil, & ! number of soil layers - nLayers ! total number of layers ! provide access to the derived types to define the data structures -USE data_struc,only:& +USE data_types,only:& var_d, & ! data vector (dp) var_dlength ! data vector with variable length dimension (dp) ! provide access to named variables defining elements in the data structures -USE var_lookup,only:iLookATTR,iLookPARAM,iLookMVAR +USE var_lookup,only:iLookATTR,iLookPARAM,iLookPROG,iLookFLUX ! utility modules implicit none ! constant parameters @@ -76,6 +71,9 @@ module groundwatr_module 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 @@ -87,7 +85,9 @@ subroutine groundwatr(& ! input/output: data structures attr_data, & ! intent(in): spatial attributes mpar_data, & ! intent(in): model parameters - mvar_data, & ! intent(inout): model variables for a local HRU + 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) @@ -98,11 +98,15 @@ subroutine groundwatr(& err,message) ! intent(out): error control ! --------------------------------------------------------------------------------------- ! provide access to the derived types to define the data structures - USE data_struc,only:& + USE data_types,only:& var_d, & ! data vector (dp) var_dlength ! data vector with variable length dimension (dp) ! provide access to named variables defining elements in the data structures - USE var_lookup,only:iLookATTR,iLookPARAM,iLookMVAR ! named variables for structure elements + USE var_lookup,only:iLookATTR ! 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:iLookPARAM ! named variables for structure elements ! 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 @@ -111,6 +115,9 @@ subroutine groundwatr(& ! * 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(dp),intent(in) :: mLayerdTheta_dPsi(:) ! derivative in the soil water characteristic w.r.t. matric head in each layer (m-1) @@ -119,8 +126,10 @@ subroutine groundwatr(& real(dp),intent(in) :: mLayerVolFracIce(:) ! volumetric fraction of ice (-) ! input/output: data structures type(var_d),intent(in) :: attr_data ! spatial attributes - type(var_d),intent(in) :: mpar_data ! model parameters - type(var_dlength),intent(inout) :: mvar_data ! model variables for a local HRU + 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(dp),intent(out) :: mLayerBaseflow(:) ! baseflow from each soil layer (m s-1) @@ -150,18 +159,18 @@ subroutine groundwatr(& associate(& ! input: baseflow parameters - fieldCapacity => mpar_data%var(iLookPARAM%fieldCapacity), & ! intent(in): [dp] field capacity (-) - theta_sat => mpar_data%var(iLookPARAM%theta_sat), & ! intent(in): [dp] soil porosity (-) - theta_res => mpar_data%var(iLookPARAM%theta_res), & ! intent(in): [dp] residual volumetric water content (-) + 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), & ! intent(in): [dp] van Genutchen "alpha" parameter (m-1) - vGn_n => mpar_data%var(iLookPARAM%vGn_n), & ! intent(in): [dp] van Genutchen "n" parameter (-) - vGn_m => mvar_data%var(iLookMVAR%scalarVGn_m)%dat(1), & ! intent(in): [dp] van Genutchen "m" parameter (-) + 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 => mvar_data%var(iLookMVAR%scalarExfiltration)%dat(1), & ! intent(out):[dp] exfiltration from the soil profile (m s-1) - mLayerColumnOutflow => mvar_data%var(iLookMVAR%mLayerColumnOutflow)%dat & ! intent(out):[dp(:)] column outflow from each soil layer (m3 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) ) ! end association to variables in data structures @@ -174,9 +183,9 @@ subroutine groundwatr(& 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; endif ! (only consider saturated layer at the bottom of the soil profile) + else; exit; end if ! (only consider saturated layer at the bottom of the soil profile) end do ! (looping through soil layers) - endif + end if ! check for an early return (no layers are "active") if(ixSaturation > nSoil)then @@ -185,7 +194,7 @@ subroutine groundwatr(& mLayerBaseflow(:) = 0._dp ! baseflow from each soil layer (m s-1) dBaseflow_dMatric(:,:) = 0._dp ! derivative in baseflow w.r.t. matric head (s-1) return - endif ! if some layers are saturated + end if ! if some layers are saturated ! ************************************************************************************************ ! (2) compute the baseflow flux and its derivative w.r.t volumetric liquid water content @@ -194,14 +203,18 @@ subroutine groundwatr(& ! use private subroutine to compute baseflow (for multiple calls for numerical Jacobian) call computeBaseflow(& ! input: control and state variables - .true., & ! intent(in): .true. if derivatives are desired + 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 - mvar_data, & ! intent(inout): model variables for a local HRU + 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) @@ -233,19 +246,26 @@ subroutine groundwatr(& mLayerMatricHeadPerturbed(iLayer) = mLayerMatricHeadPerturbed(iLayer) + dx ! compute the columetruc liquid water content - mLayerVolFracLiqPerturbed(iLayer) = volFracLiq(mLayerMatricHeadPerturbed(iLayer),vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) + mLayerVolFracLiqPerturbed(iLayer) = volFracLiq(mLayerMatricHeadPerturbed(iLayer),vGn_alpha(iLayer),theta_res(iLayer),theta_sat(iLayer),vGn_n(iLayer),vGn_m(iLayer)) ! compute baseflow flux + ! NOTE: This is an optional second call to computeBaseflow that is invoked when computing numerical derivatives. + ! Since the purpose here is to compute the numerical derivatives, we do not need to compute analytical derivatives also. + ! Hence, analytical derivatives are not desired call computeBaseflow(& ! input: control and state variables - .false., & ! intent(in): .true. if derivatives are desired + nSnow, & ! intent(in): number of snow layers + nSoil, & ! intent(in): number of soil layers + nLayers, & ! intent(in): total number of layers + .false., & ! intent(in): .true. if analytical derivatives are desired ixSaturation, & ! intent(in): index of upper-most "saturated" layer mLayerVolFracLiqPerturbed, & ! 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 - mvar_data, & ! intent(inout): model variables for a local HRU + 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 mLayerBaseflowPerturbed, & ! intent(out): baseflow flux in each soil layer (m s-1) dBaseflow_dVolLiq) ! intent(out): ** NOT USED ** derivative in baseflow w.r.t. volumetric liquid water content (s-1) @@ -265,7 +285,7 @@ subroutine groundwatr(& do iLayer=1,nSoil; write(*,'(i4,1x,100(e12.5,1x))') iLayer, nJac(1:nSoil,iLayer); end do !pause 'testing Jacobian' - endif ! if desire to compute the Jacobian + end if ! if desire to compute the Jacobian ! end association to variables in data structures end associate @@ -278,6 +298,9 @@ end subroutine groundwatr ! *********************************************************************************************************************** subroutine 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 derivDesired, & ! intent(in): .true. if derivatives are desired ixSaturation, & ! intent(in): index of upper-most "saturated" layer mLayerVolFracLiq, & ! intent(in): volumetric fraction of liquid water in each soil layer (-) @@ -285,7 +308,8 @@ subroutine computeBaseflow(& ! input/output: data structures attr_data, & ! intent(in): spatial attributes mpar_data, & ! intent(in): model parameters - mvar_data, & ! intent(inout): model variables for a local HRU + 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) @@ -294,14 +318,18 @@ subroutine computeBaseflow(& ! * dummy variables ! --------------------------------------------------------------------------------------- ! input: control and state variables + 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) :: derivDesired ! .true. if derivatives are desired integer(i4b),intent(in) :: ixSaturation ! index of upper-most "saturated" layer real(dp),intent(in) :: mLayerVolFracLiq(:) ! volumetric fraction of liquid water (-) real(dp),intent(in) :: mLayerVolFracIce(:) ! volumetric fraction of ice (-) ! input/output: data structures type(var_d),intent(in) :: attr_data ! spatial attributes - type(var_d),intent(in) :: mpar_data ! model parameters - type(var_dlength),intent(inout) :: mvar_data ! model variables for a local HRU + 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 ! output: baseflow real(dp),intent(out) :: mLayerBaseflow(:) ! baseflow from each soil layer (m s-1) real(dp),intent(out) :: dBaseflow_dVolLiq(:,:) ! derivative in baseflow w.r.t. matric head (s-1) @@ -309,7 +337,7 @@ subroutine computeBaseflow(& ! * local variables ! --------------------------------------------------------------------------------------- ! general local variables - integer(i4b) :: iLayer,jLayer,kLayer ! index of model layer + integer(i4b) :: iLayer,jLayer ! index of model layer ! local variables for the exfiltration real(dp) :: totalColumnInflow ! total column inflow (m s-1) real(dp) :: totalColumnOutflow ! total column outflow (m s-1) @@ -334,23 +362,19 @@ subroutine computeBaseflow(& real(dp),dimension(nSoil) :: dExfiltrate_dVolLiq ! derivative in exfiltration w.r.t. volumetric liquid water content (-) ! local variables for testing (debugging) logical(lgt),parameter :: printFlag=.false. ! flag for printing (debugging) - logical(lgt),parameter :: testDerivatives=.false. ! flag to test derivatives (debugging) real(dp) :: xDepth,xTran,xFlow ! temporary variables (depth, transmissivity, flow) - real(qp) :: dPart0,dPart1,dPart2,dPart3 ! derivatives for part of a function - real(qp) :: f0,f1 ! different function evaluations - real(qp) :: t0,t1,tOld ! different function evaluations ! --------------------------------------------------------------------------------------- ! * association to data in structures ! --------------------------------------------------------------------------------------- associate(& ! input: coordinate variables - soilDepth => mvar_data%var(iLookMVAR%iLayerHeight)%dat(nLayers), & ! intent(in): [dp] total soil depth (m) - mLayerDepth => mvar_data%var(iLookMVAR%mLayerDepth)%dat(nSnow+1:nLayers),& ! intent(in): [dp(:)] depth of each soil layer (m) + soilDepth => 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 => mvar_data%var(iLookMVAR%mLayerSatHydCondMP)%dat(1), & ! intent(in): [dp] saturated hydraulic conductivity at the surface (m s-1) - mLayerColumnInflow => mvar_data%var(iLookMVAR%mLayerColumnInflow)%dat, & ! intent(in): [dp(:)] inflow into each soil layer (m3/s) + 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) @@ -358,14 +382,14 @@ subroutine computeBaseflow(& 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), & ! intent(in): [dp] TOPMODEL exponent (-) - kAnisotropic => mpar_data%var(iLookPARAM%kAnisotropic), & ! intent(in): [dp] anisotropy factor for lateral hydraulic conductivity (- - fieldCapacity => mpar_data%var(iLookPARAM%fieldCapacity), & ! intent(in): [dp] field capacity (-) - theta_sat => mpar_data%var(iLookPARAM%theta_sat), & ! intent(in): [dp] soil porosity (-) + 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 => mvar_data%var(iLookMVAR%scalarExfiltration)%dat(1), & ! intent(out):[dp] exfiltration from the soil profile (m s-1) - mLayerColumnOutflow => mvar_data%var(iLookMVAR%mLayerColumnOutflow)%dat & ! intent(out):[dp(:)] column outflow from each soil layer (m3 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) ) ! end association to variables in data structures ! *********************************************************************************************************************** @@ -376,14 +400,14 @@ subroutine computeBaseflow(& ! (1) compute the baseflow flux in each soil layer ! *********************************************************************************************************************** - ! compute the porosity and the maximum transmissivity + ! compute the maximum transmissivity ! NOTE: this can be done as a pre-processing step - activePorosity = theta_sat - fieldCapacity ! "active" porosity (-) - tran0 = kAnisotropic*surfaceHydCond*soilDepth/zScale_TOPMODEL ! maximum transmissivity (m2 s-1) + 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._dp,mLayerVolFracLiq(iLayer) - fieldCapacity))/activePorosity ! compute layer transmissivity if(iLayer==nSoil)then @@ -394,7 +418,7 @@ subroutine computeBaseflow(& zActive(iLayer) = zActive(iLayer+1) + drainableWater trTotal(iLayer) = tran0*(zActive(iLayer)/soilDepth)**zScale_TOPMODEL trSoil(iLayer) = trTotal(iLayer) - trTotal(iLayer+1) - endif + 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 @@ -404,7 +428,7 @@ subroutine computeBaseflow(& zActive(1:ixSaturation-1) = 0._dp trTotal(1:ixSaturation-1) = 0._dp trSoil(1:ixSaturation-1) = 0._dp - endif + end if ! compute the outflow from each layer (m3 s-1) mLayerColumnOutflow(1:nSoil) = trSoil(1:nSoil)*tan_slope*contourLength @@ -423,21 +447,10 @@ subroutine computeBaseflow(& logF = 1._dp / (1._dp + 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._dp + expF)**2._dp - ! (test the derivative) - !if(testDerivatives)then - ! do iLayer=1,nSoil - ! mLayerVolFracLiqCopy(:) = mLayerVolFracLiq(:) - ! mLayerVolFracLiqCopy(iLayer) = mLayerVolFracLiq(iLayer) + dx - ! t1 = sum(mLayerDepth(1:nSoil)*(theta_sat - (mLayerVolFracLiqCopy(1:nSoil)+mLayerVolFracIce(1:nSoil))) ) - ! f1 = 1._dp / (1._dp + exp((t1 - xCenter)/xWidth)) - ! write(*,'(a,1x,i4,1x,10(f30.20,1x))') 'iLayer, dLogFunc_dLiq(iLayer), (f1 - logF)/dx = ', iLayer, dLogFunc_dLiq(iLayer), (f1 - logF)/dx - ! end do ! (testing derivative for individual soil layers) - ! !pause ' check logistic' - !endif else logF = 0._dp dLogFunc_dLiq(:) = 0._dp - endif + end if ! compute the exfiltartion (m s-1) if(totalColumnInflow > totalColumnOutflow .and. logF > tiny(1._dp))then @@ -445,7 +458,7 @@ subroutine computeBaseflow(& !write(*,'(a,1x,10(f30.20,1x))') 'scalarExfiltration = ', scalarExfiltration else scalarExfiltration = 0._dp - endif + end if ! check !write(*,'(a,1x,10(f30.20,1x))') 'zActive(1), soilDepth, availStorage, logF, scalarExfiltration = ', & @@ -464,17 +477,17 @@ subroutine computeBaseflow(& ! test if(printFlag)then - xDepth = sum(mLayerDepth(ixSaturation:nSoil)*(mLayerVolFracLiq(ixSaturation:nSoil) - fieldCapacity))/activePorosity ! "effective" water table thickness (m) + 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))') 'tran0, activePorosity, soilDepth = ', tran0, activePorosity, soilDepth 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' - endif + end if ! *********************************************************************************************************************** ! (2) compute the derivative in the baseflow flux w.r.t. volumetric liquid water content (m s-1) @@ -490,7 +503,7 @@ subroutine computeBaseflow(& length2area = tan_slope*contourLength/HRUarea ! compute the ratio of layer depth to maximum water holding capacity (-) - depth2capacity(1:nSoil) = mLayerDepth(1:nSoil)/(activePorosity*soilDepth) + 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._dp) @@ -511,61 +524,7 @@ subroutine computeBaseflow(& 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) - endif - - - ! *********************************************************************************************************************** - ! *********************************************************************************************************************** - ! *********************************************************************************************************************** - ! *********************************************************************************************************************** - - ! test derivatives - if(testDerivatives)then - - iLayer = 1 - jLayer = 6 - - ! compute analytical derivatives for baseflow w.r.t. volumetric liquid water content (m s-1) - dPart1 = mLayerDepth(iLayer)/(activePorosity*soilDepth) - dPart2 = tran0*zScale_TOPMODEL*(zActive(iLayer)/SoilDepth)**(zScale_TOPMODEL - 1._dp) - write(*,'(a,1x,e20.10,1x)') 'anal deriv = ', dPart1*dPart2*tan_slope*contourLength/HRUarea - - ! check x-derivative terms.... - - ! check water table depth - f0 = zActive(iLayer) - if(jLayer. + +module indexState_module + +! data types +USE nrtype + +! missing data +USE globalData,only:integerMissing ! missing integer + +! named variables for domain types +USE globalData,only:iname_cas ! canopy air space +USE globalData,only:iname_veg ! vegetation +USE globalData,only:iname_snow ! snow +USE globalData,only:iname_soil ! 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 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 + +! provide access to the derived types to define the data structures +USE data_types,only:var_ilength ! data vector with variable length dimension (i4b) + +! provide access to the metadata +USE globalData,only:indx_meta ! metadata for the variables in the index structure + +! provide access to indices that define elements of the data structures +USE var_lookup,only:iLookINDEX ! named variables for structure elements + +! provide access to the missing f2008 functions +USE f2008funcs_module,only:findIndex ! finds the index of the first value within a vector + +! provide access to the numerical recipes utility modules +USE nr_utility_module,only:arth ! creates a sequence of numbers (start, incr, n) + +implicit none +private +public::indexState +public::indexSplit +contains + + + ! ********************************************************************************************************** + ! public subroutine indexState: define list of indices for each state variable + ! ********************************************************************************************************** + subroutine indexState(computeVegFlux, & ! intent(in): flag to denote if computing the vegetation flux + 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,message) ! intent(out): error control + ! -------------------------------------------------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------------------------------------------------- + ! input + logical(lgt),intent(in) :: computeVegFlux ! flag to denote if computing the vegetation flux + integer(i4b),intent(in) :: nSnow,nSoil,nLayers ! number of snow and soil layers, and total number of layers + type(var_ilength),intent(inout) :: indx_data ! indices defining model states and layers + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! -------------------------------------------------------------------------------------------------------------------------------- + ! general local variables + character(len=256) :: cmessage ! message of downwind routine + integer(i4b),parameter :: nVarSnowSoil=2 ! number of state variables in the snow and soil domain (energy and total water/matric head) + ! indices of model state variables + integer(i4b) :: ixTopNrg ! index of upper-most energy state in the snow-soil subdomain + integer(i4b) :: ixTopWat ! index of upper-most total water state in the snow-soil subdomain + ! -------------------------------------------------------------------------------------------------------------------------------- + ! make association with variables in the data structures + associate(& + ! number of state variables of different type + nCasNrg => indx_data%var(iLookINDEX%nVegNrg)%dat(1) , & ! number of energy state variables for the canopy air space + nVegNrg => indx_data%var(iLookINDEX%nVegNrg)%dat(1) , & ! number of energy state variables for the vegetation canopy + nVegMass => indx_data%var(iLookINDEX%nVegMass)%dat(1) , & ! number of hydrology states for vegetation (mass of water) + nVegState => indx_data%var(iLookINDEX%nVegState)%dat(1) , & ! number of vegetation state variables + nNrgState => indx_data%var(iLookINDEX%nNrgState)%dat(1) , & ! number of energy state variables + nWatState => indx_data%var(iLookINDEX%nWatState)%dat(1) , & ! number of "total water" states (vol. total water content) + nMatState => indx_data%var(iLookINDEX%nMatState)%dat(1) , & ! number of matric head state variables + nMassState => indx_data%var(iLookINDEX%nMassState)%dat(1), & ! number of hydrology state variables (mass of water) + nState => indx_data%var(iLookINDEX%nState)%dat(1) , & ! total number of model state variables + ! vectors of indices for specfic state types within specific sub-domains IN THE FULL STATE VECTOR + ixNrgCanair => indx_data%var(iLookINDEX%ixNrgCanair)%dat , & ! indices IN THE FULL VECTOR for energy states in canopy air space domain + ixNrgCanopy => indx_data%var(iLookINDEX%ixNrgCanopy)%dat , & ! indices IN THE FULL VECTOR for energy states in the canopy domain + ixHydCanopy => indx_data%var(iLookINDEX%ixHydCanopy)%dat , & ! indices IN THE FULL VECTOR for hydrology states in the canopy domain + ixNrgLayer => indx_data%var(iLookINDEX%ixNrgLayer)%dat , & ! indices IN THE FULL VECTOR for energy states in the snow+soil domain + ixHydLayer => indx_data%var(iLookINDEX%ixHydLayer)%dat , & ! indices IN THE FULL VECTOR for hydrology states in the snow+soil domain + ! indices for model state variables + ixSoilState => indx_data%var(iLookINDEX%ixSoilState)%dat , & ! list of indices for all soil layers + ixLayerState => indx_data%var(iLookINDEX%ixLayerState)%dat & ! list of indices for all model layers + ) ! association to variables in the data structures + ! -------------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message='indexState/' + + ! ----- + ! * define the number of state variables... + ! ----------------------------------------- + + ! define the number of vegetation state variables (defines position of snow-soil states in the state vector) + if(computeVegFlux)then + nCasNrg = 1 + nVegNrg = 1 + nVegMass = 1 + nVegState = nCasNrg + nVegNrg + nVegMass + else + nCasNrg = 0 + nVegNrg = 0 + nVegMass = 0 + nVegState = 0 + end if + + ! define the number state variables of different type + nNrgState = nCasNrg + nVegNrg + nLayers ! number of energy state variables + nWatState = nSnow ! number of "total water" state variables -- will be modified later if using primary variable switching + nMatState = nSoil ! number of matric head state variables -- will be modified later if using primary variable switching + nMassState = nVegMass ! number of mass state variables -- currently restricted to canopy water + + ! define the number of model state variables + nState = nVegState + nLayers*nVarSnowSoil ! *nVarSnowSoil (both energy and total water) + + ! ----- + ! * define the indices of state variables WITHIN THE FULL STATE VECTOR... + ! ----------------------------------------------------------------------- + + ! define indices in the vegetation domain + if(computeVegFlux)then + ixNrgCanair = 1 ! indices IN THE FULL VECTOR for energy states in canopy air space domain (-) + ixNrgCanopy = 2 ! indices IN THE FULL VECTOR for energy states in the canopy domain (-) + ixHydCanopy = 3 ! indices IN THE FULL VECTOR for hydrology states in the canopy domain (-) + else + ixNrgCanair = integerMissing + ixNrgCanopy = integerMissing + ixHydCanopy = integerMissing + end if + + ! define the index of the top layer + ! NOTE: local variables -- actual indices defined when building the state subset + ixTopNrg = nVegState + 1 ! energy + ixTopWat = nVegState + 2 ! total water (only snow) + + ! define the indices within the snow+soil domain + ixNrgLayer = arth(ixTopNrg,nVarSnowSoil,nLayers) ! energy + ixHydLayer = arth(ixTopWat,nVarSnowSoil,nLayers) ! total water + + ! ----- + ! * define the type of model states... + ! ------------------------------------ + + ! re-allocate index vectors for the full state vector (if needed)... + call resizeIndx( (/iLookINDEX%ixMapFull2Subset, iLookINDEX%ixControlVolume, iLookINDEX%ixDomainType, iLookINDEX%ixStateType, iLookINDEX%ixAllState/), & ! desired variables + indx_data, & ! data structure + nState, & ! vector length + err,cmessage) ! error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! make an association to the ALLOCATABLE variables in the data structures + ! NOTE: we need to do this here since the size may have changed above + associate(& + ixControlVolume => indx_data%var(iLookINDEX%ixControlVolume)%dat , & ! index of control volume for different domains (veg, snow, soil) + ixDomainType => indx_data%var(iLookINDEX%ixDomainType)%dat , & ! indices defining the type of the domain (iname_veg, iname_snow, iname_soil) + ixStateType => indx_data%var(iLookINDEX%ixStateType)%dat , & ! indices defining the type of the state (iname_nrgLayer...) + ixAllState => indx_data%var(iLookINDEX%ixAllState)%dat & ! list of indices for all model state variables + ) ! making an association to variables in the data structures + + ! define indices for state variables + ixAllState = arth(1,1,nState) + ixSoilState = arth(1,1,nSoil) + ixLayerState = arth(1,1,nLayers) + + ! define the state type for the vegetation canopy + if(computeVegFlux)then + ixStateType(ixNrgCanair) = iname_nrgCanair + ixStateType(ixNrgCanopy) = iname_nrgCanopy + ixStateType(ixHydCanopy) = iname_watCanopy + endif + + ! define the state type for the snow+soil domain (energy) + ixStateType(ixNrgLayer) = iname_nrgLayer + + ! define the state type for the snow+soil domain (hydrology) + if(nSnow>0) ixStateType( ixHydLayer( 1:nSnow) ) = iname_watLayer + ixStateType( ixHydLayer(nSnow+1:nLayers) ) = iname_matLayer ! refine later to be either iname_watLayer or iname_matLayer + + ! define the domain type for vegetation + if(computeVegFlux)then + ixDomainType(ixNrgCanair) = iname_cas + ixDomainType(ixNrgCanopy) = iname_veg + ixDomainType(ixHydCanopy) = iname_veg + endif + + ! define the domain type for snow + if(nSnow>0)then + ixDomainType( ixNrgLayer(1:nSnow) ) = iname_snow + ixDomainType( ixHydLayer(1:nSnow) ) = iname_snow + endif + + ! define the domain type for soil + ixDomainType( ixNrgLayer(nSnow+1:nLayers) ) = iname_soil + ixDomainType( ixHydLayer(nSnow+1:nLayers) ) = iname_soil + + ! define the index of each control volume in the vegetation domains + if(computeVegFlux)then + ixControlVolume(ixNrgCanair) = 1 ! NOTE: assumes scalar + ixControlVolume(ixNrgCanopy) = 1 + ixControlVolume(ixHydCanopy) = 1 + endif + + ! define the index of the each control volume in the snow domain + if(nSnow>0)then + ixControlVolume( ixNrgLayer(1:nSnow) ) = ixLayerState(1:nSnow) + ixControlVolume( ixHydLayer(1:nSnow) ) = ixLayerState(1:nSnow) + endif + + ! define the index of the each control volume in the soil domain + ixControlVolume( ixNrgLayer(nSnow+1:nLayers) ) = ixSoilState(1:nSoil) + ixControlVolume( ixHydLayer(nSnow+1:nLayers) ) = ixSoilState(1:nSoil) + + !print*, 'ixControlVolume = ', ixControlVolume + !print*, 'ixDomainType = ', ixDomainType + !print*, 'ixStateType = ', ixStateType + + ! end association to the ALLOCATABLE variables in the data structures + end associate + + ! -------------------------------------------------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------------------------------------------------- + + end associate ! end association to variables in the data structures + 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 + indx_data, & ! intent(inout) : index data structure + err,message) ! intent(out) : error control + ! -------------------------------------------------------------------------------------------------------------------------------- + ! 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 + ! output + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! -------------------------------------------------------------------------------------------------------------------------------- + ! 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 + ! ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------ + ! ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------ + ! make association to variables in the data structures + fullState: associate(& + + ! 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) + + ! 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 + + ! 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 + + ! 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 + + ! 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 + + ) ! association to variables in the data structures + + ! ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------ + ! initialize error control + err=0; message='indexSplit/' + + ! ----- + ! - preliminaries... + ! ------------------ + + ! define the type of variable in the snow+soil domain + ixHydType(1:nLayers) = ixStateType( ixHydLayer(1:nLayers) ) + + ! get the mapping between the full state vector and the state subset + ixMapFull2Subset( pack(ixAllState, stateSubsetMask) ) = arth(1,1,nSubset) ! indices in the state subset + ixMapFull2Subset( pack(ixAllState, .not.stateSubsetMask) ) = integerMissing + + ! ----- + ! - get vectors of different state subsets... + ! ------------------------------------------- + + ! get different masks + volFracWat_mask = (ixHydType==iname_watLayer .or. ixHydType==iname_liqLayer) + matricHead_mask = (ixHydType(nSnow+1:nLayers)==iname_matLayer .or. ixHydType(nSnow+1:nLayers)==iname_lmpLayer) + + ! get state subsets for desired variables + do iVar=1,size(indx_data%var) ! loop through index variables + + ! get the subset of indices + ! NOTE: indxSubset(subset, fullVector, mask), provides subset of fullVector where mask==.true. + select case(iVar) + case(iLookINDEX%ixMapSubset2Full); call indxSubset(indx_data%var(iVar)%dat, ixAllState, stateSubsetMask, err, cmessage) + case(iLookINDEX%ixStateType_subset); call indxSubset(indx_data%var(iVar)%dat, ixStateType, stateSubsetMask, err, cmessage) + case(iLookINDEX%ixDomainType_subset); call indxSubset(indx_data%var(iVar)%dat, ixDomainType, stateSubsetMask, err, cmessage) + case(iLookINDEX%ixVolFracWat); call indxSubset(indx_data%var(iVar)%dat, ixLayerState, volFracWat_mask, err, cmessage) + case(iLookINDEX%ixMatricHead); call indxSubset(indx_data%var(iVar)%dat, ixSoilState, matricHead_mask, err, cmessage) + case default; cycle ! only need to process the above variables + end select ! iVar + if(err/=0)then; message=trim(message)//trim(cmessage)//'[varname='//trim(indx_meta(ivar)%varname)//']'; return; endif + + end do ! looping through variables in the data structure + + ! make association to variables in the data structures + subsetState: associate(ixStateType_subset => indx_data%var(iLookINDEX%ixStateType_subset)%dat) ! named variables defining the states in the subset + + ! ----- + ! - get indices for the (currently) scalar states in the vegetation domain... + ! --------------------------------------------------------------------------- + + ! check the number of state variables in the vegetation canopy + if(count(ixStateType_subset==iname_nrgCanair)>1)then; err=20; message=trim(message)//'expect count(iname_nrgCanair)=1 or 0'; return; endif + if(count(ixStateType_subset==iname_nrgCanopy)>1)then; err=20; message=trim(message)//'expect count(iname_nrgCanopy)=1 or 0'; return; endif + if(count(ixStateType_subset==iname_watCanopy)>1)then; err=20; message=trim(message)//'expect count(iname_watCanopy)=1 or 0'; return; endif + + ! define indices for energy states for the canopy air space and the vegetation canopy + ! NOTE: finds first index of named variable within stateType (set to integerMissing if not found) + ixCasNrg = findIndex(ixStateType_subset, iname_nrgCanair, integerMissing) ! energy of the canopy air space + ixVegNrg = findIndex(ixStateType_subset, iname_nrgCanopy, integerMissing) ! energy of the vegetation canopy + + ! define indices for hydrology states for the vegetation canopy + ! NOTE: local variables -- ixVegHyd defined next + ixVegWat = findIndex(ixStateType_subset, iname_watCanopy, integerMissing) ! total water in the vegetation canopy + ixVegLiq = findIndex(ixStateType_subset, iname_liqCanopy, integerMissing) ! liquid water in the vegetation canopy + ixVegHyd = merge(ixVegWat, ixVegLiq, ixVegWat/=integerMissing) + + ! define index for the upper-most energy state variables in the snow+soil domain + ixTopNrg = findIndex(ixStateType_subset, iname_nrgLayer, integerMissing) ! upper-most energy state in the snow+soil system + + ! define index for the upper-most hydrology state variables in the snow+soil domain + ! NOTE: local variables -- ixTopHyd defined next + ixTopWat = findIndex(ixStateType_subset, iname_watLayer, integerMissing) ! upper-most total water state variable in the snow+soil system + ixTopLiq = findIndex(ixStateType_subset, iname_liqLayer, integerMissing) ! upper-most liquid water state variable in the snow+soil system + ixTopMat = findIndex(ixStateType_subset, iname_matLayer, integerMissing) ! upper-most total water matric potential state + ixTopLMP = findIndex(ixStateType_subset, iname_lmpLayer, integerMissing) ! upper-most liquid water matric potential state + + ! define index for the upper most hydrology state in the snow+soil system + if(ixTopWat==integerMissing .and. ixTopLiq==integerMissing)then + ixTopHyd = merge(ixTopMat, ixTopLMP, ixTopMat/=integerMissing) ! no water state, so upper-most hydrology state is the upper-most matric head state (if it exists) + else + ixTopHyd = merge(ixTopWat, ixTopLiq, ixTopWat/=integerMissing) ! ixTopWat is used if it is not missing + endif + + ! ----- + ! - get vector of indices within the state subset state variables of a given type... + ! ---------------------------------------------------------------------------------- + + ! define index in full state vector + ixSequence = arth(1,1,nSubset) + + ! get state subsets for desired variables + do iVar=1,size(indx_data%var) ! loop through index variables + + ! 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 default; cycle ! only need to process the above variables + end select ! iVar + + ! get the subset of indices + ! NOTE: indxSubset(subset, fullVector, mask), provides subset of fullVector where mask==.true. + call indxSubset(indx_data%var(iVar)%dat,ixSequence,stateTypeMask,err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage)//'[varname='//trim(indx_meta(ivar)%varname)//']'; return; endif + + end do ! looping through variables in the data structure + + ! ----- + ! - get vector of indices of the state subset for layers in the snow+soil domain... + ! --------------------------------------------------------------------------------- + + ! get list of indices for energy + ! NOTE: layers not in the state subset will be missing + ixSnowSoilNrg = ixMapFull2Subset(ixNrgLayer) ! both snow and soil layers + ixSnowOnlyNrg = ixMapFull2Subset(ixNrgLayer( 1:nSnow )) ! snow layers only + ixSoilOnlyNrg = ixMapFull2Subset(ixNrgLayer(nSnow+1:nLayers)) ! soil layers only + + ! get list of indices for hydrology + ! NOTE: layers not in the state subset will be missing + ixSnowSoilHyd = ixMapFull2Subset(ixHydLayer) ! both snow and soil layers + ixSnowOnlyHyd = ixMapFull2Subset(ixHydLayer( 1:nSnow )) ! snow layers only + ixSoilOnlyHyd = ixMapFull2Subset(ixHydLayer(nSnow+1:nLayers)) ! soil layers only + + ! get the number of valid states for energy + nSnowSoilNrg = count(ixSnowSoilNrg/=integerMissing) + nSnowOnlyNrg = count(ixSnowOnlyNrg/=integerMissing) + nSoilOnlyNrg = count(ixSoilOnlyNrg/=integerMissing) + + ! get the number of valid states for hydrology + nSnowSoilHyd = count(ixSnowSoilHyd/=integerMissing) + nSnowOnlyHyd = count(ixSnowOnlyHyd/=integerMissing) + nSoilOnlyHyd = count(ixSoilOnlyHyd/=integerMissing) + + ! end association to data in structures + end associate subsetState + end associate fullState + + end subroutine indexSplit + + + ! ********************************************************************************************************** + ! private subroutine indxSubset: get a subset of indices for a given mask + ! ********************************************************************************************************** + 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 + ! input + 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 + ! ----------------------------------------------------------------------------------------------------------------------------------- + ! local variables + integer(i4b) :: nSubset ! length of the subset + ! ----------------------------------------------------------------------------------------------------------------------------------- + ! initialize errors + err=0; message="indxSubset/" + + ! check size match + if(size(ixMaster)/=size(mask))then + message=trim(message)//'size mismatch' + err=20; return + endif + + ! get the number of variables + nSubset = count(mask) + + ! check if we need to reallocate space + if(size(ixSubset)/=nSubset) then + + ! deallocate space + deallocate(ixSubset,stat=err) + if(err/=0)then; message=trim(message)//'unable to deallocate space for variable'; err=20; return; endif + + ! allocate space + allocate(ixSubset(nSubset),stat=err) + if(err/=0)then; message=trim(message)//'unable to deallocate space for variable'; err=20; return; endif + + endif ! allocating space + + ! define indices for variable types in specific sub-domains + if(nSubset>0) ixSubset = pack(ixMaster, mask) + + end subroutine indxSubset + + + + + + ! ********************************************************************************************************** + ! private subroutine resizeIndx: re-size specific index vectors + ! ********************************************************************************************************** + subroutine resizeIndx(ixDesire,indx_data,nVec,err,message) + ! input + integer(i4b) ,intent(in) :: ixDesire(:) ! variables needing to be re-sized + type(var_ilength),intent(inout) :: indx_data ! indices defining model states and layers + integer(i4b) ,intent(in) :: nVec ! desired vector length + ! output + integer(i4b) ,intent(out) :: err ! error code + character(*) ,intent(out) :: message ! error message + ! local variables + integer(i4b) :: jVar,iVar ! vatiable index + ! initialize error control + err=0; message='resizeIndx/' + + ! loop through variables + do jVar=1,size(ixDesire) + + ! define index in index array + iVar = ixDesire(jVar) + + ! check iVar is within range + if(iVar<1 .or. iVar>size(indx_data%var))then + message=trim(message)//'desired variable is out of range' + err=20; return + endif + + ! check if we need to reallocate space + if(size(indx_data%var(iVar)%dat) == nVec) cycle + + ! deallocate space + deallocate(indx_data%var(iVar)%dat,stat=err) + if(err/=0)then + message=trim(message)//'unable to deallocate space for variable '//trim(indx_meta(ivar)%varname) + err=20; return + endif + + ! allocate space + allocate(indx_data%var(iVar)%dat(nVec),stat=err) + if(err/=0)then + message=trim(message)//'unable to allocate space for variable '//trim(indx_meta(ivar)%varname) + err=20; return + endif + + ! set to missing + indx_data%var(iVar)%dat = integerMissing + + end do ! looping through variables + + end subroutine resizeIndx + +end module indexState_module diff --git a/build/source/engine/layerDivide.f90 b/build/source/engine/layerDivide.f90 old mode 100644 new mode 100755 index 5e057bf0b..de7f22208 --- a/build/source/engine/layerDivide.f90 +++ b/build/source/engine/layerDivide.f90 @@ -28,14 +28,9 @@ module layerDivide_module iden_ice, & ! intrinsic density of ice (kg m-3) iden_water ! intrinsic density of liquid water (kg m-3) -! access the number of snow and soil layers -USE data_struc,only:& - nSnow, & ! number of snow layers - nSoil, & ! number of soil layers - nLayers ! total number of layers - ! access named variables for snow and soil -USE data_struc,only:ix_soil,ix_snow ! named variables for snow and soil +USE globalData,only:iname_snow ! named variables for snow +USE globalData,only:iname_soil ! named variables for soil ! define look-up values for the choice of method to combine and sub-divide snow layers USE mDecisions_module,only:& @@ -58,9 +53,14 @@ module layerDivide_module implicit none private public::layerDivide -interface addOneLayer - module procedure AddOneLayer_rv, AddOneLayer_iv -end interface AddOneLayer + +! provide access to the number layers throughout the module +integer(i4b) :: nSnow ! number of snow layers +integer(i4b) :: nSoil ! number of soil layers +integer(i4b) :: nLayers ! total number of layers +! define missing values +real(dp) :: missingDouble=-9999._dp ! missing value (double precision) +integer(i4b) :: missingInteger=-9999 ! missing value (integer) contains @@ -72,80 +72,53 @@ subroutine layerDivide(& model_decisions, & ! intent(in): model decisions mpar_data, & ! intent(in): model parameters indx_data, & ! intent(inout): type of each layer - mvar_data, & ! intent(inout): model variables for a local HRU - ! output: error control + 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 a layer was divided err,message) ! intent(out): error control ! -------------------------------------------------------------------------------------------------------- ! -------------------------------------------------------------------------------------------------------- ! access the derived types to define the data structures - USE data_struc,only:& + USE data_types,only:& 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 + ! access metadata + USE globalData,only:prog_meta,diag_meta,flux_meta,indx_meta ! metadata ! access named variables defining elements in the data structures - USE var_lookup,only:iLookTIME,iLookTYPE,iLookATTR,iLookFORCE,iLookPARAM,iLookMVAR,iLookBVAR,iLookINDEX ! named variables for structure elements - USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure + USE var_lookup,only:iLookPROG,iLookDIAG,iLookFLUX,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 ! computational modules - USE snow_utils_module,only:fracliquid,templiquid ! functions to compute temperature/liquid water + USE snow_utils_module,only:fracliquid,templiquid ! functions to compute temperature/liquid water implicit none ! -------------------------------------------------------------------------------------------------------- ! input/output: model data structures type(model_options),intent(in) :: model_decisions(:) ! model decisions - type(var_d),intent(in) :: mpar_data ! model parameters + type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_ilength),intent(inout) :: indx_data ! type of each layer - type(var_dlength),intent(inout) :: mvar_data ! model variables for a local HRU - ! output: error control + 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 + ! output + logical(lgt),intent(out) :: divideLayer ! flag to denote that a layer was divided integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! -------------------------------------------------------------------------------------------------------- - ! variables in the data structures - ! model decisions - integer(i4b) :: ix_snowLayers ! decision for snow combination - ! model parameters (new snow density) - real(dp) :: newSnowDenMin ! minimum new snow density (kg m-3) - real(dp) :: newSnowDenMult ! multiplier for new snow density (kg m-3) - real(dp) :: newSnowDenScal ! scaling factor for new snow density (K) - ! model parameters (control on the depth of snow layers) - real(dp) :: zmax ! maximum layer depth (m) - real(dp) :: zmaxLayer1_lower ! maximum layer depth for the 1st (top) layer when only 1 layer (m) - real(dp) :: zmaxLayer2_lower ! maximum layer depth for the 2nd layer when only 2 layers (m) - real(dp) :: zmaxLayer3_lower ! maximum layer depth for the 3rd layer when only 3 layers (m) - real(dp) :: zmaxLayer4_lower ! maximum layer depth for the 4th layer when only 4 layers (m) - real(dp) :: zmaxLayer1_upper ! maximum layer depth for the 1st (top) layer when > 1 layer (m) - real(dp) :: zmaxLayer2_upper ! maximum layer depth for the 2nd layer when > 2 layers (m) - real(dp) :: zmaxLayer3_upper ! maximum layer depth for the 3rd layer when > 3 layers (m) - real(dp) :: zmaxLayer4_upper ! maximum layer depth for the 4th layer when > 4 layers (m) - ! model parameters (compute layer temperature) - real(dp) :: fc_param ! freeezing curve parameter for snow (K-1) - ! diagnostic scalar variables - real(dp) :: scalarSnowDepth ! total snow depth (m) - real(dp) :: scalarSWE ! SWE (kg m-2) - real(dp) :: scalarSnowfall ! snowfall flux (kg m-2 s-1) - real(dp) :: scalarSnowfallTemp ! computed temperature of fresh snow (K) - ! model state variables (all layers) - ! NOTE: use pointers because dimension length changes - real(dp),pointer :: mLayerTemp(:) ! temperature of each layer (K) - real(dp),pointer :: mLayerVolFracIce(:) ! volumetric fraction of ice in each layer (-) - real(dp),pointer :: mLayerVolFracLiq(:) ! volumetric fraction of liquid water in each layer (-) - ! model coordinate variables - ! NOTE: use pointers because dimension length changes - real(dp),pointer :: mLayerDepth(:) ! depth of the layer (m) - real(dp),pointer :: mLayerHeight(:) ! height of the layer mid-point (m) - real(dp),pointer :: iLayerHeight(:) ! height of the layer interface (m) - ! model index variables - ! NOTE: use pointers because dimension length changes - integer(i4b),pointer :: layerType(:) ! type of the layer (ix_soil or ix_snow) - ! -------------------------------------------------------------------------------------------------------- ! define local variables character(LEN=256) :: cmessage ! error message of downwind routine integer(i4b) :: iLayer ! layer index - integer(i4b) :: kLayer ! layer index + integer(i4b) :: jLayer ! layer index real(dp),dimension(4) :: zmax_lower ! lower value of maximum layer depth real(dp),dimension(4) :: zmax_upper ! upper value of maximum layer depth real(dp) :: zmaxCheck ! value of zmax for a given snow layer integer(i4b) :: nCheck ! number of layers to check to divide logical(lgt) :: createLayer ! flag to indicate we are creating a new snow layer + real(dp) :: depthOriginal ! original layer depth before sub-division (m) + real(dp),parameter :: fracTop=0.5_dp ! fraction of old layer used for the top layer real(dp) :: surfaceLayerSoilTemp ! temperature of the top soil layer (K) real(dp) :: maxFrozenSnowTemp ! maximum temperature when effectively all water is frozen (K) real(dp),parameter :: unfrozenLiq=0.01_dp ! unfrozen liquid water used to compute maxFrozenSnowTemp (-) @@ -153,6 +126,7 @@ subroutine layerDivide(& real(dp) :: 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(dp),parameter :: verySmall=1.e-10_dp ! a very small number (used for error checking) ! -------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message="layerDivide/" @@ -161,43 +135,43 @@ subroutine layerDivide(& associate(& ! model decisions ix_snowLayers => model_decisions(iLookDECISIONS%snowLayers)%iDecision, & ! decision for snow combination + ! model parameters (compute layer temperature) + fc_param => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1), & ! freezing curve parameter for snow (K-1) ! model parameters (new snow density) - newSnowDenMin => mpar_data%var(iLookPARAM%newSnowDenMin), & ! minimum new snow density (kg m-3) - newSnowDenMult => mpar_data%var(iLookPARAM%newSnowDenMult), & ! multiplier for new snow density (kg m-3) - newSnowDenScal => mpar_data%var(iLookPARAM%newSnowDenScal), & ! scaling factor for new snow density (K) + newSnowDenMin => mpar_data%var(iLookPARAM%newSnowDenMin)%dat(1), & ! minimum new snow density (kg m-3) + newSnowDenMult => mpar_data%var(iLookPARAM%newSnowDenMult)%dat(1), & ! multiplier for new snow density (kg m-3) + newSnowDenScal => mpar_data%var(iLookPARAM%newSnowDenScal)%dat(1), & ! scaling factor for new snow density (K) ! model parameters (control the depth of snow layers) - zmax => mpar_data%var(iLookPARAM%zmax), & ! maximum layer depth (m) - zmaxLayer1_lower => mpar_data%var(iLookPARAM%zmaxLayer1_lower), & ! maximum layer depth for the 1st (top) layer when only 1 layer (m) - zmaxLayer2_lower => mpar_data%var(iLookPARAM%zmaxLayer2_lower), & ! maximum layer depth for the 2nd layer when only 2 layers (m) - zmaxLayer3_lower => mpar_data%var(iLookPARAM%zmaxLayer3_lower), & ! maximum layer depth for the 3rd layer when only 3 layers (m) - zmaxLayer4_lower => mpar_data%var(iLookPARAM%zmaxLayer4_lower), & ! maximum layer depth for the 4th layer when only 4 layers (m) - zmaxLayer1_upper => mpar_data%var(iLookPARAM%zmaxLayer1_upper), & ! maximum layer depth for the 1st (top) layer when > 1 layer (m) - zmaxLayer2_upper => mpar_data%var(iLookPARAM%zmaxLayer2_upper), & ! maximum layer depth for the 2nd layer when > 2 layers (m) - zmaxLayer3_upper => mpar_data%var(iLookPARAM%zmaxLayer3_upper), & ! maximum layer depth for the 3rd layer when > 3 layers (m) - zmaxLayer4_upper => mpar_data%var(iLookPARAM%zmaxLayer4_upper), & ! maximum layer depth for the 4th layer when > 4 layers (m) - ! model parameters (compute layer temperature) - fc_param => mpar_data%var(iLookPARAM%snowfrz_scale), & ! freezing curve parameter for snow (K-1) + zmax => mpar_data%var(iLookPARAM%zmax)%dat(1), & ! maximum layer depth (m) + zmaxLayer1_lower => mpar_data%var(iLookPARAM%zmaxLayer1_lower)%dat(1), & ! maximum layer depth for the 1st (top) layer when only 1 layer (m) + zmaxLayer2_lower => mpar_data%var(iLookPARAM%zmaxLayer2_lower)%dat(1), & ! maximum layer depth for the 2nd layer when only 2 layers (m) + zmaxLayer3_lower => mpar_data%var(iLookPARAM%zmaxLayer3_lower)%dat(1), & ! maximum layer depth for the 3rd layer when only 3 layers (m) + zmaxLayer4_lower => mpar_data%var(iLookPARAM%zmaxLayer4_lower)%dat(1), & ! maximum layer depth for the 4th layer when only 4 layers (m) + zmaxLayer1_upper => mpar_data%var(iLookPARAM%zmaxLayer1_upper)%dat(1), & ! maximum layer depth for the 1st (top) layer when > 1 layer (m) + zmaxLayer2_upper => mpar_data%var(iLookPARAM%zmaxLayer2_upper)%dat(1), & ! maximum layer depth for the 2nd layer when > 2 layers (m) + zmaxLayer3_upper => mpar_data%var(iLookPARAM%zmaxLayer3_upper)%dat(1), & ! maximum layer depth for the 3rd layer when > 3 layers (m) + zmaxLayer4_upper => mpar_data%var(iLookPARAM%zmaxLayer4_upper)%dat(1), & ! maximum layer depth for the 4th layer when > 4 layers (m) ! diagnostic scalar variables - scalarSnowfall => mvar_data%var(iLookMVAR%scalarSnowfall)%dat(1), & ! snowfall flux (kg m-2 s-1) - scalarSnowfallTemp => mvar_data%var(iLookMVAR%scalarSnowfallTemp)%dat(1), & ! computed temperature of fresh snow (K) - scalarSnowDepth => mvar_data%var(iLookMVAR%scalarSnowDepth)%dat(1), & ! total snow depth (m) - scalarSWE => mvar_data%var(iLookMVAR%scalarSWE)%dat(1) & ! SWE (kg m-2) + scalarSnowfall => flux_data%var(iLookFLUX%scalarSnowfall)%dat(1), & ! snowfall flux (kg m-2 s-1) + scalarSnowfallTemp => diag_data%var(iLookDIAG%scalarSnowfallTemp)%dat(1), & ! computed temperature of fresh snow (K) + scalarSnowDepth => prog_data%var(iLookPROG%scalarSnowDepth)%dat(1), & ! total snow depth (m) + scalarSWE => prog_data%var(iLookPROG%scalarSWE)%dat(1) & ! SWE (kg m-2) ) ! end associate statement - ! assign pointers to model state variables - mLayerDepth => mvar_data%var(iLookMVAR%mLayerDepth)%dat ! depth of the layer (m) - mLayerTemp => mvar_data%var(iLookMVAR%mLayerTemp)%dat ! temperature of each layer (K) - mLayerVolFracIce => mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat ! volumetric fraction of ice in each layer (-) - mLayerVolFracLiq => mvar_data%var(iLookMVAR%mLayerVolFracLiq)%dat ! volumetric fraction of liquid water in each layer (-) - ! assign local pointers to the model index structures - layerType => indx_data%var(iLookINDEX%layerType)%dat ! layer type (ix_soil or ix_snow) + ! --------------------------------------------------------------------------------------------------- - ! -------------------------------------------------------------------------------------------------------- + ! initialize flag to denote that a layer was divided + divideLayer=.false. ! identify algorithmic control parameters to syb-divide and combine snow layers zmax_lower = (/zmaxLayer1_lower, zmaxLayer2_lower, zmaxLayer3_lower, zmaxLayer4_lower/) zmax_upper = (/zmaxLayer1_upper, zmaxLayer2_upper, zmaxLayer3_upper, zmaxLayer4_upper/) + ! initialize the number of snow 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) + ! ***** special case of no snow layers if(nSnow==0)then @@ -211,20 +185,29 @@ subroutine layerDivide(& ! ** create a new snow layer if(createLayer)then + ! flag that the layers have changed + divideLayer=.true. + ! add a layer to all model variables iLayer=0 ! (layer to divide: 0 is the special case of "snow without a layer") - call addModelLayer(mvar_data,indx_data,iLayer,err,cmessage) - if(err/=0)then; err=10; message=trim(message)//trim(cmessage); return; endif + call addModelLayer(prog_data,prog_meta,iLayer,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + call addModelLayer(diag_data,diag_meta,iLayer,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + call addModelLayer(flux_data,flux_meta,iLayer,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + call addModelLayer(indx_data,indx_meta,iLayer,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if - ! re-assign pointers to the coordinate variables - mLayerDepth => mvar_data%var(iLookMVAR%mLayerDepth)%dat ! depth of each layer (m) - layerType => indx_data%var(iLookINDEX%layerType)%dat ! layer type (ix_soil or ix_snow) - - ! re-assign pointers to the model state variables + ! associate local variables to the information in the data structures ! NOTE: need to do this here, since state vectors have just been modified - mLayerTemp => mvar_data%var(iLookMVAR%mLayerTemp)%dat ! temperature of each layer (K) - mLayerVolFracIce => mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat ! volumetric fraction of ice in each layer (-) - mLayerVolFracLiq => mvar_data%var(iLookMVAR%mLayerVolFracLiq)%dat ! volumetric fraction of liquid water in each layer (-) + associate(& + ! coordinate variables + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat ,& ! depth of each layer (m) + ! model state variables + mLayerTemp => prog_data%var(iLookPROG%mLayerTemp)%dat ,& ! temperature of each layer (K) + mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat ,& ! volumetric fraction of ice in each layer (-) + mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat & ! volumetric fraction of liquid water in each layer (-) + ) ! (association of local variables to the information in the data structures) + + ! get the layer depth + mLayerDepth(1) = scalarSnowDepth ! compute surface layer temperature surfaceLayerSoilTemp = mLayerTemp(2) ! temperature of the top soil layer (K) @@ -239,122 +222,131 @@ subroutine layerDivide(& mLayerVolFracIce(1) = (1._dp - fracLiq)*volFracWater*(iden_water/iden_ice) ! volumetric fraction of ice (-) mLayerVolFracLiq(1) = fracLiq *volFracWater ! volumetric fraction of liquid water (-) + ! end association with local variables to the information in the data structures) + end associate + ! initialize albedo ! NOTE: albedo is computed within the Noah-MP radiation routine if(model_decisions(iLookDECISIONS%canopySrad)%iDecision /= noah_mp)then select case(model_decisions(iLookDECISIONS%alb_method)%iDecision) ! (constant decay rate -- albedo the same for all spectral bands) case(constantDecay) - mvar_data%var(iLookMVAR%scalarSnowAlbedo)%dat(1) = mpar_data%var(iLookPARAM%albedoMax) - mvar_data%var(iLookMVAR%spectralSnowAlbedoDiffuse)%dat(:) = mpar_data%var(iLookPARAM%albedoMax) + prog_data%var(iLookPROG%scalarSnowAlbedo)%dat(1) = mpar_data%var(iLookPARAM%albedoMax)%dat(1) + prog_data%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(:) = mpar_data%var(iLookPARAM%albedoMax)%dat(1) ! (variable decay rate) case(variableDecay) - mvar_data%var(iLookMVAR%spectralSnowAlbedoDiffuse)%dat(ixVisible) = mpar_data%var(iLookPARAM%albedoMaxVisible) - mvar_data%var(iLookMVAR%spectralSnowAlbedoDiffuse)%dat(ixNearIR) = mpar_data%var(iLookPARAM%albedoMaxNearIR) - mvar_data%var(iLookMVAR%scalarSnowAlbedo)%dat(1) = ( mpar_data%var(iLookPARAM%Frad_vis))*mpar_data%var(iLookPARAM%albedoMaxVisible) + & - (1._dp - mpar_data%var(iLookPARAM%Frad_vis))*mpar_data%var(iLookPARAM%albedoMaxNearIR) + prog_data%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(ixVisible) = mpar_data%var(iLookPARAM%albedoMaxVisible)%dat(1) + prog_data%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(ixNearIR) = mpar_data%var(iLookPARAM%albedoMaxNearIR)%dat(1) + prog_data%var(iLookPROG%scalarSnowAlbedo)%dat(1) = ( mpar_data%var(iLookPARAM%Frad_vis)%dat(1))*mpar_data%var(iLookPARAM%albedoMaxVisible)%dat(1) + & + (1._dp - mpar_data%var(iLookPARAM%Frad_vis)%dat(1))*mpar_data%var(iLookPARAM%albedoMaxNearIR)%dat(1) case default; err=20; message=trim(message)//'unable to identify option for snow albedo'; return end select ! identify option for snow albedo ! set direct albedo to diffuse albedo - mvar_data%var(iLookMVAR%spectralSnowAlbedoDirect)%dat(:) = mvar_data%var(iLookMVAR%spectralSnowAlbedoDiffuse)%dat(:) - endif ! (if NOT using the Noah-MP radiation routine) - - ! update the total number of layers - nSnow = count(indx_data%var(iLookINDEX%layerType)%dat==ix_snow) - nSoil = count(indx_data%var(iLookINDEX%layerType)%dat==ix_soil) - nLayers = nSnow + nSoil - - ! save the number of layers in the data structures - indx_data%var(iLookINDEX%nSnow)%dat(1) = nSnow - indx_data%var(iLookINDEX%nSoil)%dat(1) = nSoil - indx_data%var(iLookINDEX%nLayers)%dat(1) = nLayers + diag_data%var(iLookDIAG%spectralSnowAlbedoDirect)%dat(:) = prog_data%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(:) + end if ! (if NOT using the Noah-MP radiation routine) - ! check - print*, trim(message) - do kLayer=1,nLayers - write(*,'(i4,1x,4(f9.3,1x))') layerType(kLayer), mLayerDepth(kLayer), mLayerTemp(kLayer), mLayerVolFracIce(kLayer), mLayerVolFracLiq(kLayer) - end do - print*, 'created a new layer, nSnow = ', count(indx_data%var(iLookINDEX%layerType)%dat==ix_snow) - print*, 'snow albedo = ', mvar_data%var(iLookMVAR%scalarSnowAlbedo)%dat(1) - - !pause ' check layer sub-division' - - endif ! if creating a new layer - return - endif + end if ! if creating a new layer ! end special case of nSnow=0 ! ******************************************************************************************************************** ! ******************************************************************************************************************** - ! check - !print*, 'before sub-division' - !do kLayer=1,nLayers - ! write(*,'(i4,1x,4(f9.3,1x))') layerType(kLayer), mLayerDepth(kLayer), mLayerTemp(kLayer), mLayerVolFracIce(kLayer), mLayerVolFracLiq(kLayer) - !end do - !if(scalarSnowDepth > 0.5_dp) pause ' deep snow' - ! ***** sub-divide snow layers, if necessary + else ! if nSnow>0 - ! identify the number of layers to check for need for sub-division - select case(ix_snowLayers) - case(sameRulesAllLayers); nCheck = nSnow - case(rulesDependLayerIndex); nCheck = min(nSnow,4) ! the depth of the 5th layer, if it exists, does not have a maximum value - 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) - - ! loop through all layers, and sub-divide a given layer, if necessary - do iLayer=1,nCheck - - ! identify the maximum depth of the layer + ! identify the number of layers to check for need for sub-division select case(ix_snowLayers) - case(sameRulesAllLayers); zmaxCheck = zmax - case(rulesDependLayerIndex) - if(iLayer == nSnow)then - zmaxCheck = zmax_lower(iLayer) - else - zmaxCheck = zmax_upper(iLayer) - endif + case(sameRulesAllLayers); nCheck = nSnow + case(rulesDependLayerIndex); nCheck = min(nSnow,4) ! the depth of the 5th layer, if it exists, does not have a maximum value 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) - - ! check the need to sub-divide - if(mvar_data%var(iLookMVAR%mLayerDepth)%dat(iLayer) > zmaxCheck)then - - ! add a layer to all model variables - call addModelLayer(mvar_data,indx_data,iLayer,err,cmessage) ! adds model layer to the index BELOW the layer that is too thick - if(err/=0)then; err=10; message=trim(message)//trim(cmessage); return; endif - - ! re-assign local pointer to the model index structures - layerType => indx_data%var(iLookINDEX%layerType)%dat ! layer type (ix_soil or ix_snow) - - ! identify the number of snow and soil layers, and check all is a-OK - nSnow = count(layerType==ix_snow) - nSoil = count(layerType==ix_soil) - nLayers = nSnow + nSoil - - ! save the number of layers in the data structures - indx_data%var(iLookINDEX%nSnow)%dat(1) = nSnow - indx_data%var(iLookINDEX%nSoil)%dat(1) = nSoil - indx_data%var(iLookINDEX%nLayers)%dat(1) = nLayers - - ! check - mLayerTemp => mvar_data%var(iLookMVAR%mLayerTemp)%dat ! temperature of each layer (K) - mLayerDepth => mvar_data%var(iLookMVAR%mLayerDepth)%dat ! depth of each layer (m) - mLayerVolFracIce => mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat ! volumetric fraction of ice in each layer (-) - mLayerVolFracLiq => mvar_data%var(iLookMVAR%mLayerVolFracLiq)%dat ! volumetric fraction of liquid water in each layer (-) - !print*, 'after sub-division' - !do kLayer=1,nLayers - ! write(*,'(i4,1x,4(f9.3,1x))') layerType(kLayer), mLayerDepth(kLayer), mLayerTemp(kLayer), mLayerVolFracIce(kLayer), mLayerVolFracLiq(kLayer) - !end do - !print*, 'created a new layer, nSnow = ', count(indx_data%var(iLookINDEX%layerType)%dat==ix_snow) - !pause ' check layer sub-division' - - exit ! NOTE: only sub-divide one layer per substep - - endif ! (if sub-dividing layer) - - end do ! (looping through layers) + + ! loop through all layers, and sub-divide a given layer, if necessary + do iLayer=1,nCheck + + ! identify the maximum depth of the layer + select case(ix_snowLayers) + case(sameRulesAllLayers); zmaxCheck = zmax + case(rulesDependLayerIndex) + if(iLayer == nSnow)then + zmaxCheck = zmax_lower(iLayer) + else + zmaxCheck = zmax_upper(iLayer) + end if + 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) + + ! check the need to sub-divide + if(prog_data%var(iLookPROG%mLayerDepth)%dat(iLayer) > zmaxCheck)then + + ! flag that layers were divided + divideLayer=.true. + + ! add a layer to all model variables + call addModelLayer(prog_data,prog_meta,iLayer,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + call addModelLayer(diag_data,diag_meta,iLayer,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + call addModelLayer(flux_data,flux_meta,iLayer,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + call addModelLayer(indx_data,indx_meta,iLayer,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + + ! define the layer depth + layerSplit: associate(mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat) + depthOriginal = mLayerDepth(iLayer) + mLayerDepth(iLayer) = fracTop*depthOriginal + mLayerDepth(iLayer+1) = (1._dp - fracTop)*depthOriginal + end associate layerSplit + + exit ! NOTE: only sub-divide one layer per substep + + end if ! (if sub-dividing layer) + + end do ! (looping through layers) + + end if ! if nSnow==0 + + ! update coordinates + if(divideLayer)then + + ! associate coordinate variables in data structure + geometry: associate(& + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat ,& ! depth of the layer (m) + mLayerHeight => prog_data%var(iLookPROG%mLayerHeight)%dat ,& ! height of the layer mid-point (m) + iLayerHeight => prog_data%var(iLookPROG%iLayerHeight)%dat ,& ! height of the layer interface (m) + layerType => indx_data%var(iLookINDEX%layerType)%dat ,& ! type of each layer (iname_snow or iname_soil) + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! number of snow layers + nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1) ,& ! number of soil layers + nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1) & ! total number of layers + ) ! (association of local variables with coordinate variab;es in data structures) + + ! update the layer type + layerType(1:nSnow+1) = iname_snow + 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) + nLayers = nSnow + nSoil + + ! re-set coordinate variables + iLayerHeight(0) = -scalarSnowDepth + do jLayer=1,nLayers + iLayerHeight(jLayer) = iLayerHeight(jLayer-1) + mLayerDepth(jLayer) + mLayerHeight(jLayer) = (iLayerHeight(jLayer-1) + iLayerHeight(jLayer))/2._dp + end do + + ! check + if(abs(sum(mLayerDepth(1:nSnow)) - scalarSnowDepth) > verySmall)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) + message=trim(message)//'sum of layer depths does not equal snow depth' + err=20; return + end if + + ! end association with coordinate variables in data structure + end associate geometry + + end if ! if dividing a layer ! end associate variables in data structure end associate @@ -365,205 +357,123 @@ end subroutine layerDivide ! ************************************************************************************************ ! private subroutine addModelLayer: add an additional layer to all model vectors ! ************************************************************************************************ - subroutine addModelLayer(mvar_data,indx_data,ix_divide,err,message) - ! provide access to variables in the data structures - USE data_struc,only:mvar_meta ! metadata - USE data_struc,only:var_ilength,var_dlength ! data vectors with variable length dimension - USE var_lookup,only:iLookPARAM,iLookMVAR,iLookINDEX ! named variables for structure elements + subroutine addModelLayer(dataStruct,metaStruct,ix_divide,err,message) + USE var_lookup,only:iLookVarType ! look up structure for variable typed + USE get_ixName_module,only:get_varTypeName ! to access type strings for error messages + USE f2008funcs_module,only:cloneStruc ! used to "clone" data structures -- temporary replacement of the intrinsic allocate(a, source=b) + USE data_types,only:var_ilength,var_dlength ! data vectors with variable length dimension + USE data_types,only:var_info ! metadata structure implicit none ! --------------------------------------------------------------------------------------------- ! input/output: data structures - type(var_dlength),intent(inout) :: mvar_data ! model variables for a local HRU - type(var_ilength),intent(inout) :: indx_data ! type of model layer + class(*),intent(inout) :: dataStruct ! data structure + type(var_info),intent(in) :: metaStruct(:) ! metadata structure ! input: snow layer indices - integer(i4b),intent(in) :: ix_divide ! index of the layer to divide + integer(i4b),intent(in) :: ix_divide ! index of the layer to divide ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! --------------------------------------------------------------------------------------------- - ! variables in the data structures - ! diagnostic variables - real(dp) :: scalarSnowDepth ! total snow depth (m) - ! model coordinate variables - ! NOTE: use pointers because dimension length changes - real(dp),pointer :: mLayerDepth(:) ! depth of the layer (m) - real(dp),pointer :: mLayerHeight(:) ! height of the layer mid-point (m) - real(dp),pointer :: iLayerHeight(:) ! height of the layer interface (m) - ! model index variables - ! NOTE: use pointers because dimension length changes - integer(i4b),pointer :: layerType(:) ! type of the layer (ix_soil or ix_snow) + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message ! --------------------------------------------------------------------------------------------- ! local variables - integer(i4b) :: ivar ! index of model variable - integer(i4b) :: jLayer ! index of model layer - integer(i4b) :: ix_lower ! lower bound of the vector - integer(i4b) :: ix_upper ! upper bound of the vector - logical(lgt) :: stateVariable ! .true. if variable is a state variable - real(dp) :: depthOriginal ! original layer depth before sub-division (m) - real(dp),parameter :: fracTop=0.5_dp ! fraction of old layer used for the top layer - character(LEN=256) :: cmessage ! error message of downwind routine + integer(i4b) :: ivar ! index of model variable + integer(i4b) :: ix_lower ! lower bound of the vector + integer(i4b) :: ix_upper ! upper bound of the vector + logical(lgt) :: stateVariable ! .true. if variable is a state variable + real(dp),allocatable :: tempVec_dp(:) ! temporary vector (double precision) + integer(i4b),allocatable :: tempVec_i4b(:) ! temporary vector (integer) + character(LEN=256) :: cmessage ! error message of downwind routine ! --------------------------------------------------------------------------------------------- ! initialize error control err=0; message='addModelLayer/' - ! associate variables in data structure - associate(& - scalarSnowDepth => mvar_data%var(iLookMVAR%scalarSnowDepth)%dat(1) & ! total snow depth (m) - ) ! associate - ! ***** add a layer to each model variable - do ivar=1,size(mvar_data%var) - + do ivar=1,size(metaStruct) + ! define bounds - select case(trim(mvar_meta(ivar)%vartype)) - case('midSnow'); ix_lower=1; ix_upper=nSnow - case('midToto'); ix_lower=1; ix_upper=nLayers - case('ifcSnow'); ix_lower=0; ix_upper=nSnow - case('ifcToto'); ix_lower=0; ix_upper=nLayers + select case(metaStruct(ivar)%vartype) + case(iLookVarType%midSnow); ix_lower=1; ix_upper=nSnow + case(iLookVarType%midToto); ix_lower=1; ix_upper=nLayers + case(iLookVarType%ifcSnow); ix_lower=0; ix_upper=nSnow + case(iLookVarType%ifcToto); ix_lower=0; ix_upper=nLayers case default; cycle end select - + ! identify whether it is a state variable - select case(trim(mvar_meta(ivar)%varname)) + select case(trim(metaStruct(ivar)%varname)) case('mLayerDepth','mLayerTemp','mLayerVolFracIce','mLayerVolFracLiq'); stateVariable=.true. case default; stateVariable=.false. end select - ! add an additional layer -- only get to here if snow in the layer - call AddOneLayer(mvar_data%var(ivar)%dat,ix_lower,ix_upper,ix_divide,stateVariable,err,cmessage) - if(err/=0)then; err=10; message=trim(message)//trim(cmessage); return; endif - - end do ! looping through variables + ! divide layers + select type(dataStruct) + + ! ** double precision + type is (var_dlength) + ! check allocated + if(.not.allocated(dataStruct%var(ivar)%dat))then; err=20; message='data vector is not allocated'; return; end if + ! assign the data vector to the temporary vector + call cloneStruc(tempVec_dp, ix_lower, source=dataStruct%var(ivar)%dat, err=err, message=cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + ! reallocate space for the new vector + deallocate(dataStruct%var(ivar)%dat,stat=err) + if(err/=0)then; err=20; message='problem in attempt to deallocate memory for data vector'; return; end if + allocate(dataStruct%var(ivar)%dat(ix_lower:ix_upper+1),stat=err) + if(err/=0)then; err=20; message='problem in attempt to reallocate memory for data vector'; return; end if + ! populate the state vector + 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_dp(1:ix_divide) ! copy data + dataStruct%var(ivar)%dat(ix_divide+1) = tempVec_dp(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_dp(ix_divide+1:ix_upper) ! copy data + end if ! if the vector exists + ! not a state variable + else + dataStruct%var(ivar)%dat(:) = missingDouble + end if + ! deallocate the temporary vector: strictly not necessary, but include to be safe + deallocate(tempVec_dp,stat=err) + if(err/=0)then; err=20; message='problem deallocating temporary data vector'; return; end if + + ! ** integer + type is (var_ilength) + ! check allocated + if(.not.allocated(dataStruct%var(ivar)%dat))then; err=20; message='data vector is not allocated'; return; end if + ! assign the data vector to the temporary vector + call cloneStruc(tempVec_i4b, ix_lower, source=dataStruct%var(ivar)%dat, err=err, message=cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + ! reallocate space for the new vector + deallocate(dataStruct%var(ivar)%dat,stat=err) + if(err/=0)then; err=20; message='problem in attempt to deallocate memory for data vector'; return; end if + allocate(dataStruct%var(ivar)%dat(ix_lower:ix_upper+1),stat=err) + if(err/=0)then; err=20; message='problem in attempt to reallocate memory for data vector'; return; end if + ! populate the state vector + 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 + 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 + end if ! if the vector exists + ! not a state variable + else + dataStruct%var(ivar)%dat(:) = missingInteger + end if + ! deallocate the temporary vector: strictly not necessary, but include to be safe + deallocate(tempVec_i4b,stat=err) + if(err/=0)then; err=20; message='problem deallocating temporary data vector'; return; end if + ! check that we found the data type + class default; err=20; message=trim(message)//'unable to identify the data type'; return - ! ***** modify the layer indices - call AddOneLayer(indx_data%var(iLookINDEX%layerType)%dat,1,nLayers,ix_divide,.false.,err,cmessage) - if(err/=0)then; err=10; message=trim(message)//trim(cmessage); return; endif - indx_data%var(iLookINDEX%layerType)%dat(1:nSnow+1) = ix_snow - indx_data%var(iLookINDEX%layerType)%dat(nSnow+2:nLayers+1) = ix_soil - nLayers = nLayers + 1 - - ! assign pointers to model coordinate variables - mLayerDepth => mvar_data%var(iLookMVAR%mLayerDepth)%dat ! depth of the layer (m) - mLayerHeight => mvar_data%var(iLookMVAR%mLayerHeight)%dat ! height of the layer mid-point (m) - iLayerHeight => mvar_data%var(iLookMVAR%iLayerHeight)%dat ! height of the layer interface (m) - layerType => indx_data%var(iLookINDEX%layerType)%dat ! type of each layer (ix_snow or ix_soil) - - ! ***** modify the layer depth - if(ix_divide==0)then ! no layers exist currently - mLayerDepth(1) = scalarSnowDepth - else ! layers already exist - depthOriginal = mLayerDepth(ix_divide) - mLayerDepth(ix_divide) = fracTop*depthOriginal - mLayerDepth(ix_divide+1) = (1._dp - fracTop)*depthOriginal - endif - - ! check - if(scalarSnowDepth - sum(mvar_data%var(iLookMVAR%mLayerDepth)%dat(1:nSnow)) < epsilon(scalarSnowDepth))then - message=trim(message)//'problem sub-dividing snow layer' - err=20; return - endif - - ! ***** re-set coordinate variables - iLayerHeight(0) = -scalarSnowDepth - do jLayer=1,nLayers - iLayerHeight(jLayer) = iLayerHeight(jLayer-1) + mLayerDepth(jLayer) - mLayerHeight(jLayer) = (iLayerHeight(jLayer-1) + iLayerHeight(jLayer))/2._dp - end do + end select ! dependence on data types - ! end associate variables in data structure - end associate + end do ! looping through variables end subroutine addModelLayer - - ! *************************************************************************************************** - ! private subroutine AddOneLayer_rv: add an additional snow layer (real version) - ! *************************************************************************************************** - ! Returns a new vector which has one more element than the input vector - ! -- optionally copies data from the original vector to the new vector for elements (2:n)->(3:n+1), - ! and copies element 1 into elements 1:2, and copies element 0 into element 0 - ! *************************************************************************************************** - subroutine AddOneLayer_rv(datavec,ix_lower,ix_upper,ix_divide,stateVariable,err,message) - implicit none - ! dummies - real(dp),pointer,intent(inout) :: datavec(:) ! the original and the new vector - integer(i4b),intent(in) :: ix_lower ! lower bound of the old vector - integer(i4b),intent(in) :: ix_upper ! upper bound of the old vector - integer(i4b),intent(in) :: ix_divide ! index of the layer to divide - logical(lgt),intent(in) :: stateVariable ! .true. if a state variable - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! locals - real(dp) :: tempvec(ix_lower:ix_upper) ! temporary vector - real(dp),parameter :: missingReal=-9999._dp - ! initialize error control - err=0; message='AddOneLayer_rv/' - ! check the data vector is associated - if(.not.associated(datavec))then; err=20; message='data vector is not associated'; return; endif - ! assign the data vector to the temporary vector - tempvec=datavec - ! reallocate space for the new vector - deallocate(datavec,stat=err) - if(err/=0)then; err=20; message='problem in attempt to deallocate memory for data vector'; return; endif - allocate(datavec(ix_lower:ix_upper+1),stat=err) - if(err/=0)then; err=20; message='problem in attempt to reallocate memory for data vector'; return; endif - 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 - datavec(1:ix_divide) = tempvec(1:ix_divide) ! copy data - datavec(ix_divide+1) = tempvec(ix_divide) ! repeat data for the sub-divided layer - endif - if(ix_upper > ix_divide) datavec(ix_divide+2:ix_upper+1) = tempvec(ix_divide+1:ix_upper) - endif - else - datavec = missingReal - endif - end subroutine AddOneLayer_rv - - ! *************************************************************************************************** - ! private subroutine AddOneLayer_iv: add an additional snow layer (integer version) - ! *************************************************************************************************** - ! Returns a new vector which has one more element than the input vector - ! -- optionally copies data from the original vector to the new vector for elements (2:n)->(3:n+1), - ! and copies element 1 into elements 1:2, and copies element 0 into element 0 - ! *************************************************************************************************** - subroutine AddOneLayer_iv(datavec,ix_lower,ix_upper,ix_divide,stateVariable,err,message) - implicit none - ! dummies - integer(i4b),pointer,intent(inout) :: datavec(:) ! the original and the new vector - integer(i4b),intent(in) :: ix_lower ! lower bound of the old vector - integer(i4b),intent(in) :: ix_upper ! upper bound of the old vector - integer(i4b),intent(in) :: ix_divide ! index of the layer to divide - logical(lgt),intent(in) :: stateVariable ! .true. if a state variable - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! locals - integer(i4b) :: tempvec(ix_lower:ix_upper) ! temporary vector - integer(i4b),parameter :: missingInteger=-9999 - ! initialize error control - err=0; message='AddOneLayer_iv/' - ! check the data vector is associated - if(.not.associated(datavec))then; err=20; message='data vector is not associated'; return; endif - ! assign the data vector to the temporary vector - tempvec=datavec - ! reallocate space for the new vector - deallocate(datavec,stat=err) - if(err/=0)then; err=20; message='problem in attempt to deallocate memory for data vector'; return; endif - allocate(datavec(ix_lower:ix_upper+1),stat=err) - if(err/=0)then; err=20; message='problem in attempt to reallocate memory for data vector'; return; endif - 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 - datavec(1:ix_divide) = tempvec(1:ix_divide) ! copy data - datavec(ix_divide+1) = tempvec(ix_divide) ! repeat data for the sub-divided layer - endif - if(ix_upper > ix_divide) datavec(ix_divide+2:ix_upper+1) = tempvec(ix_divide+1:ix_upper) - endif - else - datavec = missingInteger - endif - end subroutine AddOneLayer_iv - - end module layerDivide_module diff --git a/build/source/engine/layerMerge.f90 b/build/source/engine/layerMerge.f90 old mode 100644 new mode 100755 index b4aeb1845..23f6c9936 --- a/build/source/engine/layerMerge.f90 +++ b/build/source/engine/layerMerge.f90 @@ -21,13 +21,9 @@ module layerMerge_module ! data types USE nrtype -! access the number of snow and soil layers -USE data_struc,only:& - nSnow, & ! number of snow layers - nSoil, & ! number of soil layers - nLayers ! total number of layers ! access named variables for snow and soil -USE data_struc,only:ix_soil,ix_snow ! named variables for snow and soil +USE globalData,only:iname_snow ! named variables for snow +USE globalData,only:iname_soil ! named variables for soil ! physical constants USE multiconst,only:& iden_ice, & ! intrinsic density of ice (kg m-3) @@ -41,9 +37,13 @@ module layerMerge_module implicit none private public::layerMerge -interface removeOneLayer - module procedure removeOneLayer_rv, removeOneLayer_iv -end interface removeOneLayer +! provide access to the number layers throughout the module +integer(i4b) :: nSnow ! number of snow layers +integer(i4b) :: nSoil ! number of soil layers +integer(i4b) :: nLayers ! total number of layers +! define missing values +real(dp) :: missingDouble=-9999._dp ! missing value (double precision) +integer(i4b) :: missingInteger=-9999 ! missing value (integer) contains @@ -53,56 +53,44 @@ module layerMerge_module ! ***************************************************************************************************************** subroutine layerMerge(& ! input/output: model data structures + tooMuchMelt, & ! 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 - mvar_data, & ! intent(inout): model variables for a local HRU - ! output: error control + 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 + mergedLayers, & ! intent(out): flag to denote that layers were merged err,message) ! intent(out): error control ! -------------------------------------------------------------------------------------------------------- ! -------------------------------------------------------------------------------------------------------- ! access the derived types to define the data structures - USE data_struc,only:& + USE data_types,only:& 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 + ! access metadata + USE globalData,only:prog_meta,diag_meta,flux_meta,indx_meta ! metadata ! access named variables defining elements in the data structures - USE var_lookup,only:iLookTIME,iLookTYPE,iLookATTR,iLookFORCE,iLookPARAM,iLookMVAR,iLookBVAR,iLookINDEX ! named variables for structure elements - USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure + USE var_lookup,only:iLookPARAM,iLookPROG,iLookINDEX ! named variables for structure elements + USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure implicit none ! -------------------------------------------------------------------------------------------------------- ! input/output: model data structures + logical(lgt),intent(in) :: tooMuchMelt ! flag to denote that ice is insufficient to support melt type(model_options),intent(in) :: model_decisions(:) ! model decisions - type(var_d),intent(in) :: mpar_data ! model parameters + type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_ilength),intent(inout) :: indx_data ! type of each layer - type(var_dlength),intent(inout) :: mvar_data ! model variables for a local HRU - ! output: error control + 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 + ! output + logical(lgt),intent(out) :: mergedLayers ! flag to denote that layers were merged integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! -------------------------------------------------------------------------------------------------------- - ! variables in the data structures - ! model decisions - integer(i4b) :: ix_snowLayers ! decision for snow combination - ! model parameters (control on the depth of snow layers) - real(dp) :: zmin ! minimum layer depth (m) - real(dp) :: zminLayer1 ! minimum layer depth for the 1st (top) layer(m) - real(dp) :: zminLayer2 ! minimum layer depth for the 2nd layer(m) - real(dp) :: zminLayer3 ! minimum layer depth for the 3rd layer(m) - real(dp) :: zminLayer4 ! minimum layer depth for the 4th layer(m) - real(dp) :: zminLayer5 ! minimum layer depth for the 5th (bottom) layer(m) - ! model index variables - ! NOTE: use pointers because the dimension length changes - integer(i4b),pointer :: layerType(:) ! type of the layer (ix_soil or ix_snow) - ! model state variables - ! NOTE: use pointers because the dimension length changes - real(dp),pointer :: mLayerDepth(:) ! depth of each layer (m) - real(dp),pointer :: mLayerVolFracIce(:) ! volumetric fraction of ice in each layer (-) - real(dp),pointer :: mLayerVolFracLiq(:) ! volumetric fraction of liquid water in each layer (-) - ! diagnostic scalar variables - real(dp) :: scalarSnowDepth ! total snow depth (m) - real(dp) :: scalarSWE ! SWE (kg m-2) - ! -------------------------------------------------------------------------------------------------------- ! define local variables character(LEN=256) :: cmessage ! error message of downwind routine real(dp),dimension(5) :: zminLayer ! minimum layer depth in each layer (m) @@ -121,31 +109,31 @@ subroutine layerMerge(& ix_snowLayers => model_decisions(iLookDECISIONS%snowLayers)%iDecision, & ! decision for snow combination ! model parameters (control the depth of snow layers) - zmin => mpar_data%var(iLookPARAM%zmin), & ! minimum layer depth (m) - zminLayer1 => mpar_data%var(iLookPARAM%zminLayer1), & ! minimum layer depth for the 1st (top) layer (m) - zminLayer2 => mpar_data%var(iLookPARAM%zminLayer2), & ! minimum layer depth for the 2nd layer (m) - zminLayer3 => mpar_data%var(iLookPARAM%zminLayer3), & ! minimum layer depth for the 3rd layer (m) - zminLayer4 => mpar_data%var(iLookPARAM%zminLayer4), & ! minimum layer depth for the 4th layer (m) - zminLayer5 => mpar_data%var(iLookPARAM%zminLayer5), & ! minimum layer depth for the 5th (bottom) layer (m) + zmin => mpar_data%var(iLookPARAM%zmin)%dat(1), & ! minimum layer depth (m) + zminLayer1 => mpar_data%var(iLookPARAM%zminLayer1)%dat(1), & ! minimum layer depth for the 1st (top) layer (m) + zminLayer2 => mpar_data%var(iLookPARAM%zminLayer2)%dat(1), & ! minimum layer depth for the 2nd layer (m) + zminLayer3 => mpar_data%var(iLookPARAM%zminLayer3)%dat(1), & ! minimum layer depth for the 3rd layer (m) + zminLayer4 => mpar_data%var(iLookPARAM%zminLayer4)%dat(1), & ! minimum layer depth for the 4th layer (m) + zminLayer5 => mpar_data%var(iLookPARAM%zminLayer5)%dat(1), & ! minimum layer depth for the 5th (bottom) layer (m) ! diagnostic scalar variables - scalarSnowDepth => mvar_data%var(iLookMVAR%scalarSnowDepth)%dat(1), & ! total snow depth (m) - scalarSWE => mvar_data%var(iLookMVAR%scalarSWE)%dat(1) & ! SWE (kg m-2) + scalarSnowDepth => prog_data%var(iLookPROG%scalarSnowDepth)%dat(1), & ! total snow depth (m) + scalarSWE => prog_data%var(iLookPROG%scalarSWE)%dat(1) & ! SWE (kg m-2) ) ! end associate statement ! -------------------------------------------------------------------------------------------------------- - ! point to the model index structures - layerType => indx_data%var(iLookINDEX%layerType)%dat ! layer type (ix_soil or ix_snow) - - ! point to the model state variables - mLayerDepth => mvar_data%var(iLookMVAR%mLayerDepth)%dat ! depth of each layer (m) - mLayerVolFracIce => mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat ! volumetric fraction of ice in each layer (-) - mLayerVolFracLiq => mvar_data%var(iLookMVAR%mLayerVolFracLiq)%dat ! volumetric fraction of liquid water in each layer (-) - ! identify algorithmic control parameters to syb-divide and combine snow layers zminLayer = (/zminLayer1, zminLayer2, zminLayer3, zminLayer4, zminLayer5/) + ! intialize the modified layers flag + mergedLayers=.false. + + ! initialize the number of snow 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) + kSnow=0 ! initialize first layer to test (top layer) do ! attempt to remove multiple layers in a single time step (continuous do loop with exit clause) @@ -154,22 +142,36 @@ subroutine layerMerge(& nCheck=5 else nCheck=nSnow - endif + end if ! loop through snow layers do iSnow=kSnow+1,nCheck + ! associate local variables with the information in the data structures + ! NOTE: do this here, since the layer variables are re-defined + associate(& + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat , & ! depth of each layer (m) + mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat , & ! volumetric fraction of ice in each layer (-) + mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat & ! volumetric fraction of liquid water in each layer (-) + ) ! (associating local variables with the information in the data structures) + ! check if the layer depth is less than the depth threshold select case(ix_snowLayers) case(sameRulesAllLayers); removeLayer = (mLayerDepth(iSnow) < zmin) case(rulesDependLayerIndex); removeLayer = (mLayerDepth(iSnow) < zminLayer(iSnow)) 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) - !print*, 'in layerMerge: iSnow, mLayerDepth(iSnow), zminLayer(iSnow), removeLayer = ', iSnow, mLayerDepth(iSnow), zminLayer(iSnow), removeLayer + + ! check if we have too much melt + ! NOTE: assume that this is the top snow layer; need more trickery to relax this assumption + if(tooMuchMelt .and. iSnow==1) removeLayer=.true. ! check if need to remove a layer if(removeLayer)then + ! flag that we modified a layer + mergedLayers=.true. + ! ***** handle special case of a single layer if(nSnow==1)then ! set the variables defining "snow without a layer" @@ -178,11 +180,14 @@ subroutine layerMerge(& scalarSWE = (mLayerVolFracIce(1)*iden_ice + mLayerVolFracLiq(1)*iden_water)*mLayerDepth(1) ! remove the top layer from all model variable vectors ! NOTE: nSnow-1 = 0, so routine removes layer #1 - call rmLyAllVars(mvar_data,indx_data,nSnow-1,err,cmessage) - if(err/=0)then; err=10; message=trim(message)//trim(cmessage); return; endif + call rmLyAllVars(prog_data,prog_meta,nSnow-1,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + call rmLyAllVars(diag_data,diag_meta,nSnow-1,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + call rmLyAllVars(flux_data,flux_meta,nSnow-1,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + call rmLyAllVars(indx_data,indx_meta,nSnow-1,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + if(err/=0)then; err=10; message=trim(message)//trim(cmessage); return; end if ! update the total number of layers - nSnow = count(indx_data%var(iLookINDEX%layerType)%dat==ix_snow) - nSoil = count(indx_data%var(iLookINDEX%layerType)%dat==ix_soil) + nSnow = count(indx_data%var(iLookINDEX%layerType)%dat==iname_snow) + nSoil = count(indx_data%var(iLookINDEX%layerType)%dat==iname_soil) nLayers = nSnow + nSoil ! save the number of layers indx_data%var(iLookINDEX%nSnow)%dat(1) = nSnow @@ -192,13 +197,13 @@ subroutine layerMerge(& call calcHeight(& ! input/output: data structures indx_data, & ! intent(in): layer type - mvar_data, & ! intent(inout): model variables for a local HRU + 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; endif + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if ! exit the do loop (no more snow layers to remove) return - endif + end if ! (special case of 1 layer --> snow without a layer) ! ***** identify the layer to combine if(iSnow==1)then @@ -206,28 +211,26 @@ subroutine layerMerge(& elseif(iSnow==nSnow)then jSnow = nSnow-1 ! lower-most layer, combine with its upper neighbor else - if(mLayerDepth(iSnow-1) mvar_data%var(iLookMVAR%mLayerDepth)%dat ! depth of each layer (m) - !print*, 'removed layer: mLayerDepth = ', mLayerDepth - !pause + call layer_combine(mpar_data,prog_data,diag_data,flux_data,indx_data,kSnow,err,cmessage) + if(err/=0)then; err=10; message=trim(message)//trim(cmessage); return; end if ! exit the loop to try again exit - endif ! (if layer is below the mass threshold) + end if ! (if layer is below the mass threshold) kSnow=iSnow ! ksnow is used for completion test, so include here + ! end association of local variables with the information in the data structures + end associate + end do ! (looping through snow layers) !print*, 'ksnow = ', ksnow @@ -239,25 +242,24 @@ subroutine layerMerge(& ! handle special case of > 5 layers in the CLM option if(nSnow > 5 .and. ix_snowLayers == rulesDependLayerIndex)then + ! flag that layers were merged + mergedLayers=.true. ! initial check to ensure everything is wonderful in the universe - if(nSnow /= 6)then; err=5; message=trim(message)//'special case of > 5 layers: expect only six layers'; return; endif + if(nSnow /= 6)then; err=5; message=trim(message)//'special case of > 5 layers: expect only six layers'; return; end if ! combine 5th layer with layer below - call layer_combine(mpar_data,mvar_data,indx_data,5,err,cmessage) - if(err/=0)then; err=10; message=trim(message)//trim(cmessage); return; endif - ! re-assign pointers to the layer depth - mLayerDepth => mvar_data%var(iLookMVAR%mLayerDepth)%dat ! depth of each layer (m) - !print*, 'removed layer: mLayerDepth = ', mLayerDepth - !pause - if(nSnow /= 5)then; err=5; message=trim(message)//'special case of > 5 layers: expect to reduced layers to exactly 5'; return; endif - endif + call layer_combine(mpar_data,prog_data,diag_data,flux_data,indx_data,5,err,cmessage) + if(err/=0)then; err=10; message=trim(message)//trim(cmessage); return; end if + ! another check + if(nSnow /= 5)then; err=5; message=trim(message)//'special case of > 5 layers: expect to reduced layers to exactly 5'; return; end if + end if ! check that there are no more than 5 layers in the CLM option if(ix_snowLayers == rulesDependLayerIndex)then if(nSnow > 5)then message=trim(message)//'expect no more than 5 layers when combination/sub-division rules depend on the layer index (CLM option)' err=20; return - endif - endif + end if + end if ! end association to variables in the data structure end associate @@ -270,19 +272,22 @@ end subroutine layerMerge ! *********************************************************************************************************** ! combines layer iSnow with iSnow+1 ! *********************************************************************************************************** - subroutine layer_combine(mpar_data,mvar_data,indx_data,iSnow,err,message) + 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 data_struc,only:var_d ! data structures with fixed dimension - USE data_struc,only:var_ilength,var_dlength ! data vectors with variable length dimension - USE var_lookup,only:iLookPARAM,iLookMVAR,iLookINDEX ! named variables for structure elements + 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 convE2Temp_module,only:E2T_nosoil,temp2ethpy ! convert temperature to enthalpy implicit none ! ------------------------------------------------------------------------------------------------------------ ! input/output: data structures - type(var_d),intent(in) :: mpar_data ! model parameters - type(var_dlength),intent(inout) :: mvar_data ! model variables for a local HRU + 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 + type(var_dlength),intent(inout) :: flux_data ! model flux variables type(var_ilength),intent(inout) :: indx_data ! type of model layer ! input: snow layer indices integer(i4b),intent(in) :: iSnow ! index of top layer to combine @@ -290,16 +295,6 @@ subroutine layer_combine(mpar_data,mvar_data,indx_data,iSnow,err,message) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ------------------------------------------------------------------------------------------------------------ - ! variables in the data structures - ! model parameters - real(dp) :: snowfrz_scale ! scaling parameter for the freezing curve for snow (K-1) - ! model state variables - ! NOTE: these are defined as pointers because the length of the data dimension changes - real(dp),pointer :: mLayerTemp(:) ! temperature of each layer (K) - real(dp),pointer :: mLayerDepth(:) ! depth of each layer (m) - real(dp),pointer :: mLayerVolFracIce(:) ! volumetric fraction of ice in each layer (-) - real(dp),pointer :: mLayerVolFracLiq(:) ! volumetric fraction of liquid water in each layer (-) - ! ------------------------------------------------------------------------------------------------------------ ! local variables character(len=256) :: cmessage ! error message for downwind routine real(dp) :: massIce(2) ! mass of ice in the two layers identified for combination (kg m-2) @@ -314,66 +309,54 @@ subroutine layer_combine(mpar_data,mvar_data,indx_data,iSnow,err,message) real(dp) :: cEnthalpy ! combined layer enthalpy (J m-3) real(dp) :: fLiq ! fraction of liquid water at the combined temperature cTemp real(dp),parameter :: eTol=1.e-4_dp ! tolerance for the enthalpy-->temperature conversion (J m-3) + ! initialize error control err=0; message="layer_combine/" - ! associate variables with information in the data structures + ! associate local variables with information in the data structures associate(& - snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale) & ! scaling parameter for the freezing curve for snow (K-1) - ) ! end associate block - - print*, '***** removing layer', iSnow - - ! ***** compute combined model state variables - ! assign pointers to model state variables - mLayerTemp => mvar_data%var(iLookMVAR%mLayerTemp)%dat ! temperature of each layer (K) - mLayerDepth => mvar_data%var(iLookMVAR%mLayerDepth)%dat ! depth of each layer (m) - mLayerVolFracIce => mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat ! volumetric fraction of ice in each layer (-) - mLayerVolFracLiq => mvar_data%var(iLookMVAR%mLayerVolFracLiq)%dat ! volumetric fraction of liquid water in each layer (-) - !write(*,'(a,1x,6(i12,1x))') 'layer_combine, before merge: indx_data%var(iLookINDEX%layerType)%dat(1:6) = ', & - ! indx_data%var(iLookINDEX%layerType)%dat(1:6) - !write(*,'(a,1x,6(f12.3,1x))') 'layer_combine, before merge: mvar_data%var(iLookMVAR%mLayerTemp)%dat(1:6) = ', & - ! mvar_data%var(iLookMVAR%mLayerTemp)%dat(1:6) + ! model parameters + snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1), & ! scaling parameter for the freezing curve for snow (K-1) + ! model state variables + mLayerTemp => prog_data%var(iLookPROG%mLayerTemp)%dat , & ! temperature of each layer (K) + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat , & ! depth of each layer (m) + mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat , & ! volumetric fraction of ice in each layer (-) + mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat & ! volumetric fraction of liquid water in each layer (-) + ) ! (association of local variables with information in the data structures) ! compute combined depth cDepth = mLayerDepth(isnow) + mLayerDepth(isnow+1) - !write(*,'(a,10(f12.4,1x))') 'cDepth = ', cDepth ! compute mass of each layer (kg m-2) massIce(1:2) = iden_ice*mLayerVolFracIce(iSnow:iSnow+1)*mLayerDepth(iSnow:iSnow+1) massLiq(1:2) = iden_water*mLayerVolFracLiq(iSnow:iSnow+1)*mLayerDepth(iSnow:iSnow+1) - !write(*,'(a,10(f12.4,1x))') 'massIce = ', massIce - !write(*,'(a,10(f12.4,1x))') 'massLiq = ', massLiq ! compute bulk density of water (kg m-3) bulkDenWat(1:2) = (massIce(1:2) + massLiq(1:2))/mLayerDepth(iSnow:iSnow+1) cBulkDenWat = (mLayerDepth(isnow)*bulkDenWat(1) + mLayerDepth(isnow+1)*bulkDenWat(2))/cDepth - !write(*,'(a,10(f12.4,1x))') 'bulkDenWat = ', bulkDenWat - !write(*,'(a,10(f12.4,1x))') 'cBulkDenWat = ', cBulkDenWat ! 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) - !write(*,'(a,10(e20.9,1x))') 'l1Enthalpy = ', l1Enthalpy - !write(*,'(a,10(e20.9,1x))') 'l2Enthalpy = ', l2Enthalpy ! compute combined enthalpy (J m-3) 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) - if(err/=0)then; err=10; message=trim(message)//trim(cmessage); return; endif + 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 message=trim(message)//'problem with enthalpy-->temperature conversion' err=20; return - endif + end if ! check temperature is within the two temperatures - if(cTemp > max(mLayerTemp(iSnow),mLayerTemp(iSnow+1)))then; err=20; message=trim(message)//'merged temperature > max(temp1,temp2)'; return; endif - if(cTemp < min(mLayerTemp(iSnow),mLayerTemp(iSnow+1)))then; err=20; message=trim(message)//'merged temperature < min(temp1,temp2)'; return; endif + ! NOTE: use tolerance, for cases of merging a layer that has just been split + if(cTemp > max(mLayerTemp(iSnow),mLayerTemp(iSnow+1))+eTol)then; err=20; message=trim(message)//'merged temperature > max(temp1,temp2)'; return; end if + if(cTemp < min(mLayerTemp(iSnow),mLayerTemp(iSnow+1))-eTol)then; err=20; message=trim(message)//'merged temperature < min(temp1,temp2)'; return; end if ! compute volumetric fraction of liquid water fLiq = fracLiquid(cTemp,snowfrz_scale) @@ -381,18 +364,22 @@ subroutine layer_combine(mpar_data,mvar_data,indx_data,iSnow,err,message) ! compute volumetric fraction of ice and liquid water cVolFracLiq = fLiq *cBulkDenWat/iden_water cVolFracIce = (1._dp - fLiq)*cBulkDenWat/iden_ice - !cVolFracIce = (massIce(1) + massIce(2))/(cDepth*iden_ice) - !cVolFracLiq = (massLiq(1) + massLiq(2))/(cDepth*iden_water) + + ! end association of local variables with information in the data structures + end associate ! remove a model layer from all model variable vectors - call rmLyAllVars(mvar_data,indx_data,iSnow,err,cmessage) - if(err/=0)then; err=10; message=trim(message)//trim(cmessage); return; endif + call rmLyAllVars(prog_data,prog_meta,iSnow,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + call rmLyAllVars(diag_data,diag_meta,iSnow,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + call rmLyAllVars(flux_data,flux_meta,iSnow,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + call rmLyAllVars(indx_data,indx_meta,iSnow,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! define the combined layer as snow - indx_data%var(iLookINDEX%layerType)%dat(iSnow) = ix_snow + indx_data%var(iLookINDEX%layerType)%dat(iSnow) = iname_snow + ! update the total number of layers - nSnow = count(indx_data%var(iLookINDEX%layerType)%dat==ix_snow) - nSoil = count(indx_data%var(iLookINDEX%layerType)%dat==ix_soil) + nSnow = count(indx_data%var(iLookINDEX%layerType)%dat==iname_snow) + nSoil = count(indx_data%var(iLookINDEX%layerType)%dat==iname_soil) nLayers = nSnow + nSoil ! save the number of layers in the data structures @@ -401,26 +388,19 @@ subroutine layer_combine(mpar_data,mvar_data,indx_data,iSnow,err,message) indx_data%var(iLookINDEX%nLayers)%dat(1) = nLayers ! ***** put state variables for the combined layer in the appropriate place - mvar_data%var(iLookMVAR%mLayerTemp)%dat(iSnow) = cTemp - mvar_data%var(iLookMVAR%mLayerDepth)%dat(iSnow) = cDepth - mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat(iSnow) = cVolFracIce - mvar_data%var(iLookMVAR%mLayerVolFracLiq)%dat(iSnow) = cVolFracLiq + prog_data%var(iLookPROG%mLayerTemp)%dat(iSnow) = cTemp + prog_data%var(iLookPROG%mLayerDepth)%dat(iSnow) = cDepth + prog_data%var(iLookPROG%mLayerVolFracIce)%dat(iSnow) = cVolFracIce + prog_data%var(iLookPROG%mLayerVolFracLiq)%dat(iSnow) = cVolFracLiq ! ***** adjust coordinate variables call calcHeight(& ! input/output: data structures indx_data, & ! intent(in): layer type - mvar_data, & ! intent(inout): model variables for a local HRU + 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; endif - !write(*,'(a,1x,6(i12,1x))') 'layer_combine, after merge: indx_data%var(iLookINDEX%layerType)%dat(1:6) = ', & - ! indx_data%var(iLookINDEX%layerType)%dat(1:6) - !write(*,'(a,1x,6(f12.3,1x))') 'layer_combine, after merge: mvar_data%var(iLookMVAR%mLayerTemp)%dat(1:6) = ', & - ! mvar_data%var(iLookMVAR%mLayerTemp)%dat(1:6) - - ! end association to data structures - end associate + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if end subroutine layer_combine @@ -431,120 +411,104 @@ end subroutine layer_combine ! removes layer "iSnow+1" and sets layer "iSnow" to a missing value ! (layer "iSnow" will be filled with a combined layer later) ! *********************************************************************************************************** - subroutine rmLyAllVars(mvar_data,indx_data,iSnow,err,message) - USE data_struc,only:mvar_meta ! metadata - USE data_struc,only:var_ilength,var_dlength ! data vectors with variable length dimension - USE var_lookup,only:iLookMVAR,iLookINDEX ! named variables for structure elements + subroutine rmLyAllVars(dataStruct,metaStruct,iSnow,err,message) + USE var_lookup,only:iLookVarType ! look up structure for variable typed + USE get_ixName_module,only:get_varTypeName ! to access type strings for error messages + USE f2008funcs_module,only:cloneStruc ! used to "clone" data structures -- temporary replacement of the intrinsic allocate(a, source=b) + USE data_types,only:var_ilength,var_dlength ! data vectors with variable length dimension + USE data_types,only:var_info ! metadata structure implicit none + ! --------------------------------------------------------------------------------------------- ! input/output: data structures - type(var_ilength),intent(inout) :: indx_data ! type of model layer - type(var_dlength),intent(inout) :: mvar_data ! model variables for a local HRU + class(*),intent(inout) :: dataStruct ! data structure + type(var_info),intent(in) :: metaStruct(:) ! metadata structure ! input: snow layer indices - integer(i4b),intent(in) :: iSnow ! new layer + integer(i4b),intent(in) :: iSnow ! new 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 ! locals - character(len=256) :: cmessage ! error message for downwind routine - integer(i4b) :: ix_lower ! lower bound of the vector - integer(i4b) :: ix_upper ! upper bound of the vector - integer(i4b) :: ivar + integer(i4b) :: ivar ! variable index + integer(i4b) :: ix_lower ! lower bound of the vector + integer(i4b) :: ix_upper ! upper bound of the vector + real(dp),allocatable :: tempVec_dp(:) ! temporary vector (double precision) + integer(i4b),allocatable :: tempVec_i4b(:) ! temporary vector (integer) + character(LEN=256) :: cmessage ! error message of downwind routine ! initialize error control err=0; message="rmLyAllVars/" + + ! check dimensions + select type(dataStruct) + type is (var_dlength); if(size(dataStruct%var) /= size(metaStruct)) err=20 + type is (var_ilength); if(size(dataStruct%var) /= size(metaStruct)) err=20 + class default; err=20; message=trim(message)//'unable to identify the data type'; return + end select + if(err/=0)then; message=trim(message)//'dimensions of data structure and metadata structures do not match'; return; end if + ! ***** loop through model variables and remove one layer - do ivar=1,size(mvar_data%var) + do ivar=1,size(metaStruct) + ! define bounds - select case(trim(mvar_meta(ivar)%vartype)) - case('midSnow'); ix_lower=1; ix_upper=nSnow - case('midToto'); ix_lower=1; ix_upper=nLayers - case('ifcSnow'); ix_lower=0; ix_upper=nSnow - case('ifcToto'); ix_lower=0; ix_upper=nLayers + select case(metaStruct(ivar)%vartype) + case(iLookVarType%midSnow); ix_lower=1; ix_upper=nSnow + case(iLookVarType%midToto); ix_lower=1; ix_upper=nLayers + case(iLookVarType%ifcSnow); ix_lower=0; ix_upper=nSnow + case(iLookVarType%ifcToto); ix_lower=0; ix_upper=nLayers case default; cycle ! no need to remove soil layers or scalar variables end select - ! remove a layer for a model variable vector - call removeOneLayer(mvar_data%var(ivar)%dat,ix_lower,ix_upper,iSnow,err,cmessage) - if(err/=0)then; err=10; message=trim(message)//trim(cmessage); return; endif - end do - ! adjust the layer type (ix_soil or ix_snow) accordingly - call removeOneLayer(indx_data%var(iLookINDEX%layerType)%dat,1,nLayers,iSnow,err,cmessage) - if(err/=0)then; err=10; message=trim(message)//trim(cmessage); return; endif - end subroutine rmLyAllVars - - - ! ***************************************************************************************************************** - ! private subroutine removeOneLayer: combine snow layers and reduce the length of the vectors in data structures - ! ***************************************************************************************************************** - ! double precision - ! Removes layer iSnow+1 from the input vector, set layer iSnow to a missing value, - ! and reduce size of the vector by 1 element - ! ***************************************************************************************************************** - subroutine removeOneLayer_rv(datavec,ix_lower,ix_upper,iSnow,err,message) - implicit none - ! dummies - real(dp),pointer,intent(inout) :: datavec(:) ! the original and the new vector - integer(i4b),intent(in) :: ix_lower ! lower bound of the old vector - integer(i4b),intent(in) :: ix_upper ! upper bound of the old vector - integer(i4b),intent(in) :: iSnow ! new layer - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! locals - real(dp) :: tempvec(ix_lower:ix_upper-1) ! temporary vector - real(dp),parameter :: missingDouble=-9999._dp - ! initialize error control - err=0; message='RemoveOneLayer_rv/' - ! check the data vector is associated - if(.not.associated(datavec))then; err=20; message='data vector is not associated'; return; endif - ! copy elements across to the temporary vector - if(iSnow>ix_lower) tempvec(ix_lower:iSnow-1) = datavec(ix_lower:iSnow-1) - if(iSnow+1=ix_lower) tempvec(iSnow) = missingDouble - ! adjust size of the data vector (one less element) - deallocate(datavec,stat=err) - if(err/=0)then; err=20; message='problem in attempt to deallocate memory for data vector'; return; endif - allocate(datavec(ix_lower:ix_upper-1),stat=err) - if(err/=0)then; err=20; message='problem in attempt to reallocate memory for data vector'; return; endif - ! copy elements across to the data vector - datavec=tempvec - end subroutine RemoveOneLayer_rv - - ! ***************************************************************************************************************** - ! private subroutine RemoveOneLayer_iv: combine snow layers and reduce the length of the vectors in data structures - ! ***************************************************************************************************************** - ! integer - ! Removes layer iSnow+1 from the input vector, set layer iSnow to a missing value, - ! and reduce size of the vector by 1 element - ! ***************************************************************************************************************** - subroutine RemoveOneLayer_iv(datavec,ix_lower,ix_upper,iSnow,err,message) - implicit none - ! dummies - integer(i4b),pointer,intent(inout) :: datavec(:) ! the original and the new vector - integer(i4b),intent(in) :: ix_lower ! lower bound of the old vector - integer(i4b),intent(in) :: ix_upper ! upper bound of the old vector - integer(i4b),intent(in) :: iSnow ! new layer - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! locals - integer(i4b) :: tempvec(ix_lower:ix_upper-1) ! temporary vector - integer(i4b),parameter :: missingInteger=-9999 - ! initialize error control - err=0; message='RemoveOneLayer_iv/' - ! check the data vector is associated - if(.not.associated(datavec))then; err=20; message='data vector is not associated'; return; endif - ! copy elements across to the temporary vector - if(iSnow>ix_lower) tempvec(ix_lower:iSnow-1) = datavec(ix_lower:iSnow-1) - if(iSnow+1=ix_lower) tempvec(iSnow) = missingInteger - ! adjust size of the data vector (one less element) - deallocate(datavec,stat=err) - if(err/=0)then; err=20; message='problem in attempt to deallocate memory for data vector'; return; endif - allocate(datavec(ix_lower:ix_upper-1),stat=err) - if(err/=0)then; err=20; message='problem in attempt to reallocate memory for data vector'; return; endif - ! copy elements across to the data vector - datavec=tempvec - end subroutine RemoveOneLayer_iv + ! remove layers + select type(dataStruct) + + ! ** double precision + type is (var_dlength) + ! check allocated + if(.not.allocated(dataStruct%var(ivar)%dat))then; err=20; message='data vector is not allocated'; return; end if + ! allocate the temporary vector + allocate(tempVec_dp(ix_lower:ix_upper-1), stat=err) + if(err/=0)then; err=20; message=trim(message)//'unable to allocate temporary vector'; return; end if + ! copy elements across to the temporary vector + if(iSnow>=ix_lower) tempVec_dp(iSnow) = missingDouble ! set merged layer to missing (fill in later) + if(iSnow>ix_lower) tempVec_dp(ix_lower:iSnow-1) = dataStruct%var(ivar)%dat(ix_lower:iSnow-1) + if(iSnow+1=ix_lower) tempVec_i4b(iSnow) = missingInteger ! set merged layer to missing (fill in later) + if(iSnow>ix_lower) tempVec_i4b(ix_lower:iSnow-1) = dataStruct%var(ivar)%dat(ix_lower:iSnow-1) + if(iSnow+1= 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)) @@ -253,7 +349,7 @@ subroutine mDecisions(err,message) case('non_iter'); model_decisions(iLookDECISIONS%num_method)%iDecision = nonIterative ! non-iterative case('itersurf'); model_decisions(iLookDECISIONS%num_method)%iDecision = iterSurfEnergyBal ! iterate only on the surface energy balance case default - err=10; message=trim(message)//"unknown numerical [option="//trim(model_decisions(iLookDECISIONS%num_method)%cDecision)//"]"; return + 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 @@ -272,6 +368,15 @@ subroutine mDecisions(err,message) 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 @@ -341,6 +446,15 @@ subroutine mDecisions(err,message) 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 @@ -444,6 +558,17 @@ subroutine mDecisions(err,message) 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 + ! ----------------------------------------------------------------------------------------------------------------------------------------------- ! check for consistency among options ! ----------------------------------------------------------------------------------------------------------------------------------------------- @@ -454,7 +579,7 @@ subroutine mDecisions(err,message) ! 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 - ! endif + ! end if !end select ! check there is prescribedTemp or zeroFlux for thermodynamics when using prescribedHead for soil hydrology @@ -475,7 +600,7 @@ subroutine mDecisions(err,message) 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 - endif + end if end select ! check power-law profile is selected when using topmodel baseflow option @@ -484,7 +609,7 @@ subroutine mDecisions(err,message) 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 - endif + end if end select ! check bigBucket groundwater option is used when for spatial groundwater is singleBasin @@ -492,15 +617,15 @@ subroutine mDecisions(err,message) 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 - endif - endif + 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 - !endif + !end if end subroutine mDecisions @@ -515,7 +640,7 @@ subroutine readoption(err,message) USE summaFileManager,only:SETNGS_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 data_struc,only:model_decisions ! model decision structure + USE globalData,only:model_decisions ! model decision structure implicit none ! define output integer(i4b),intent(out) :: err ! error code @@ -523,7 +648,7 @@ subroutine readoption(err,message) ! define local variables character(len=256) :: cmessage ! error message for downwind routine character(LEN=256) :: infile ! input filename - integer(i4b),parameter :: unt=99 ! DK: need to either define units globally, or use getSpareUnit + integer(i4b) :: unt ! file unit (free unit output from file_open) character(LEN=256),allocatable :: charline(:) ! vector of character strings integer(i4b) :: nDecisions ! number of model decisions integer(i4b) :: iDecision ! index of model decisions @@ -537,26 +662,23 @@ subroutine readoption(err,message) 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; endif + 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; endif + 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) - ! allocate space for the model decisions - if(associated(model_decisions)) deallocate(model_decisions) - allocate(model_decisions(maxvarDecisions),stat=err) - if(err/=0)then;err=30;message=trim(message)//"problemAllocateModelDecisions"; return; endif ! 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; endif + 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)) - if(iVar<=0)then; err=40; message=trim(message)//"cannotFindDecisionIndex[name='"//trim(option)//"']"; return; endif + 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) diff --git a/build/source/engine/matrixOper.f90 b/build/source/engine/matrixOper.f90 new file mode 100755 index 000000000..5f8c9029c --- /dev/null +++ b/build/source/engine/matrixOper.f90 @@ -0,0 +1,231 @@ +! 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 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 +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 + +implicit none +private +public::lapackSolv +public::scaleMatrices +public::computeGradient +contains + + ! ********************************************************************************************************** + ! public subroutine: scaleMatrices: scale the matrices + ! ********************************************************************************************************** + subroutine scaleMatrices(ixMatrix,nState,aJac,fScale,xScale,aJacScaled,err,message) + implicit none + ! 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(dp),intent(in) :: aJac(:,:) ! original Jacobian matrix + real(dp),intent(in) :: fScale(:) ! function scaling vector + real(dp),intent(in) :: xScale(:) ! "variable" scaling vector, i.e., for state variables + ! output variables + real(dp),intent(out) :: aJacScaled(:,:) ! scaled Jacobian matrix + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! --------------------------------------------------------------------------------------------------------- + ! local variables + integer(i4b) :: iState ! row index + integer(i4b) :: jState ! comumn index + integer(i4b) :: kState ! band diagonal index + ! --------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message='scaleMatrices/' + + ! select the type of matrix + select case(ixMatrix) + + ! * full matrix + case(ixFullMatrix) + + ! scale by both the scaling factors for the function (fScale) and variable (xScale) + do iState=1,nState + do jState=1,nState + aJacScaled(iState,jState) = fScale(iState)*aJac(iState,jState)*xScale(jState) + end do + end do + + ! * band-diagonal matrix + case(ixBandMatrix) + + ! initialize the matrix to zero (some un-used elements) + aJacScaled(:,:) = 0._dp + + ! scale the rows by the function scaling factor and the colmns by the variable scaling factor + do jState=1,nState ! (loop through model state variables) + do iState=max(1,jState-ku),min(nState,jState+kl) + kState = kl+ku+1+iState-jState + aJacScaled(kState,jState) = fScale(iState)*aJac(kState,jState)*xScale(jState) + end do + end do ! looping through state variables + + ! check that we found a valid option (should not get here because of the check above; included for completeness) + case default; err=20; message=trim(message)//'unable to identify option for the type of matrix' + + end select ! (option to solve the linear system A.X=B) + + end subroutine scaleMatrices + + + ! ********************************************************************************************************* + ! * private subroutine computeGradient: compute the gradient of the function + ! ********************************************************************************************************* + subroutine computeGradient(ixMatrix,nState,aJac,rVec,grad,err,message) + implicit none + ! input + integer(i4b),intent(in) :: ixMatrix ! type of matrix (full Jacobian or band diagonal) + integer(i4b),intent(in) :: nState ! number of state variables + real(dp),intent(in) :: aJac(:,:) ! jacobian matrix + real(dp),intent(in) :: rVec(:) ! residual vector + ! output + real(dp),intent(out) :: grad(:) ! gradient + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! local + integer(i4b) :: iJac ! index of model state variable + integer(i4b) :: iState ! index of the residual vector + ! initialize error control + err=0; message='computeGradient/' + + ! check if full Jacobian or band-diagonal matrix + select case(ixMatrix) + + ! full Jacobian matrix + case(ixFullMatrix) + + ! compute the gradient + grad = matmul(rVec,aJac) ! gradient + + ! band-diagonal matrix + case(ixBandMatrix) + + ! compute the gradient + grad(:) = 0._dp + do iJac=1,nState ! (loop through state variables) + do iState=max(1,iJac-ku),min(nState,iJac+kl) + grad(iJac) = grad(iJac) + aJac(kl+ku+1+iState-iJac,iJac)*rVec(iState) + end do + end do + + ! check that we found a valid option + case default; err=20; message=trim(message)//'unable to identify option for the type of matrix' + + end select ! (option to solve the linear system A.X=B) + + end subroutine computeGradient + + + ! ********************************************************************************************************* + ! public subroutine lapackSolv: use the lapack routines to solve the linear system A.X=B + ! ********************************************************************************************************* + subroutine lapackSolv(ixMatrix,nState,aJac,rVec,xInc,err,message) + implicit none + ! dummy + integer(i4b),intent(in) :: ixMatrix ! type of matrix (full Jacobian or band diagonal) + integer(i4b),intent(in) :: nState ! number of state variables + real(dp),intent(inout) :: aJac(:,:) ! input = the Jacobian matrix A; output = decomposed matrix + real(dp),intent(in) :: rVec(:) ! the residual vector B + real(dp),intent(out) :: xInc(:) ! the solution vector X + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! local + real(dp) :: 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) + case(ixFullMatrix); message='lapackSolv/dgesv/' + case(ixBandMatrix); message='lapackSolv/dgbsv/' + case default; err=20; message=trim(message)//'unable to identify option for the type of matrix' + end select + + ! form the rhs matrix + ! NOTE: copy the vector here to ensure that the residual vector is not overwritten + rhs(:,1) = rVec(:) + + ! identify option to solve the linear system A.X=B + select case(ixMatrix) + + ! lapack: use the full Jacobian matrix to solve the linear system A.X=B + case(ixFullMatrix) + call dgesv(nState, & ! intent(in): [i4b] number of state variables + nRHS, & ! intent(in): [i4b] number of columns of the matrix B + aJac, & ! intent(inout): [dp(nState,nState)] input = the nState-by-nState Jacobian matrix A; output = decomposed matrix + nState, & ! intent(in): [i4b] the leading dimension of aJac + iPiv, & ! intent(out): [i4b(nState)] defines if row i of the matrix was interchanged with row iPiv(i) + rhs, & ! intent(inout): [dp(nState,nRHS)] input = the nState-by-nRHS matrix of matrix B; output: the solution matrix X + nState, & ! intent(in): [i4b] the leading dimension of matrix rhs + err) ! intent(out) [i4b] error code + + ! lapack: use the band diagonal matrix to solve the linear system A.X=B + case(ixBandMatrix) + call dgbsv(nState, & ! intent(in): [i4b] number of state variables + kl, & ! intent(in): [i4b] number of subdiagonals within the band of A + ku, & ! intent(in): [i4b] number of superdiagonals within the band of A + nRHS, & ! intent(in): [i4b] number of columns of the matrix B + aJac, & ! intent(inout): [dp(nBands,nState)] input = the nBands-by-nState Jacobian matrix A; output = decomposed matrix + nBands, & ! intent(in): [i4b] the leading dimension of aJac + iPiv, & ! intent(out): [i4b(nState)] defines if row i of the matrix was interchanged with row iPiv(i) + rhs, & ! intent(inout): [dp(nState,nRHS)] input = the nState-by-nRHS matrix of matrix B; output: the solution matrix X + nState, & ! intent(in): [i4b] the leading dimension of matrix rhs + err) ! intent(out) [i4b] error code + + ! check that we found a valid option (should not get here because of the check above; included for completeness) + case default; err=20; message=trim(message)//'unable to identify option for the type of matrix' + + end select ! (option to solve the linear system A.X=B) + + ! identify any errors + ! NOTE: return negative error code to force a time step reduction and another trial + if(err/=0)then + if(err<0)then + write(message,'(a,i0,a)') trim(message)//'the ',err,'-th argument had an illegal value' + err=-20; return + else + write(message,'(a,i0,a,i0,a)') trim(message)//'U(',err,',',err,') is exactly zero - factorization complete, but U is singular so the solution could not be completed' + err=-20; return + end if + end if + + ! extract the iteration increment + xInc(1:nState) = rhs(1:nState,1) + + end subroutine lapackSolv + + + +end module matrixOper_module diff --git a/build/source/engine/nr_utility.f90 b/build/source/engine/nr_utility.f90 old mode 100644 new mode 100755 index 2095b4d5f..f38bc7ed3 --- a/build/source/engine/nr_utility.f90 +++ b/build/source/engine/nr_utility.f90 @@ -25,7 +25,7 @@ FUNCTION arth_r(first,increment,n) do k=2,n arth_r(k) = arth_r(k-1) + increment end do - endif + end if END FUNCTION arth_r ! ------------------------------------------------------------------------------------------------ FUNCTION arth_d(first,increment,n) @@ -39,7 +39,7 @@ FUNCTION arth_d(first,increment,n) do k=2,n arth_d(k) = arth_d(k-1) + increment end do - endif + end if END FUNCTION arth_d ! ------------------------------------------------------------------------------------------------ FUNCTION arth_i(first,increment,n) @@ -52,7 +52,7 @@ FUNCTION arth_i(first,increment,n) do k=2,n arth_i(k) = arth_i(k-1) + increment end do - endif + end if END FUNCTION arth_i end module nr_utility_module diff --git a/build/source/engine/nrtype.f90 b/build/source/engine/nrtype.f90 old mode 100644 new mode 100755 index e7aa26c29..abc3e6aa6 --- a/build/source/engine/nrtype.f90 +++ b/build/source/engine/nrtype.f90 @@ -1,21 +1,27 @@ MODULE nrtype IMPLICIT NONE SAVE - INTEGER, PARAMETER :: I4B = SELECTED_INT_KIND(9) - INTEGER, PARAMETER :: I2B = SELECTED_INT_KIND(4) - INTEGER, PARAMETER :: I1B = SELECTED_INT_KIND(2) - INTEGER, PARAMETER :: SP = KIND(1.0) - INTEGER, PARAMETER :: DP = KIND(1.0D0) - INTEGER, PARAMETER :: QP = SELECTED_REAL_KIND(32) - INTEGER, PARAMETER :: SPC = KIND((1.0,1.0)) - INTEGER, PARAMETER :: DPC = KIND((1.0D0,1.0D0)) - INTEGER, PARAMETER :: LGT = KIND(.true.) - REAL(SP), PARAMETER :: PI=3.141592653589793238462643383279502884197_sp - REAL(SP), PARAMETER :: PIO2=1.57079632679489661923132169163975144209858_sp - REAL(SP), PARAMETER :: TWOPI=6.283185307179586476925286766559005768394_sp - REAL(SP), PARAMETER :: SQRT2=1.41421356237309504880168872420969807856967_sp - REAL(SP), PARAMETER :: EULER=0.5772156649015328606065120900824024310422_sp - REAL(DP), PARAMETER :: PI_D=3.141592653589793238462643383279502884197_dp - REAL(DP), PARAMETER :: PIO2_D=1.57079632679489661923132169163975144209858_dp - REAL(DP), PARAMETER :: TWOPI_D=6.283185307179586476925286766559005768394_dp + ! data types + INTEGER, PARAMETER :: I4B = SELECTED_INT_KIND(9) + INTEGER, PARAMETER :: I2B = SELECTED_INT_KIND(4) + INTEGER, PARAMETER :: I1B = SELECTED_INT_KIND(2) + INTEGER, PARAMETER :: SP = KIND(1.0) + INTEGER, PARAMETER :: DP = KIND(1.0D0) + INTEGER, PARAMETER :: QP = SELECTED_REAL_KIND(32) + INTEGER, PARAMETER :: SPC = KIND((1.0,1.0)) + INTEGER, PARAMETER :: DPC = KIND((1.0D0,1.0D0)) + INTEGER, PARAMETER :: LGT = KIND(.true.) + ! constants + REAL(SP), PARAMETER :: PI=3.141592653589793238462643383279502884197_sp + REAL(SP), PARAMETER :: PIO2=1.57079632679489661923132169163975144209858_sp + REAL(SP), PARAMETER :: TWOPI=6.283185307179586476925286766559005768394_sp + REAL(SP), PARAMETER :: SQRT2=1.41421356237309504880168872420969807856967_sp + REAL(SP), PARAMETER :: EULER=0.5772156649015328606065120900824024310422_sp + REAL(DP), PARAMETER :: PI_D=3.141592653589793238462643383279502884197_dp + REAL(DP), PARAMETER :: PIO2_D=1.57079632679489661923132169163975144209858_dp + REAL(DP), PARAMETER :: TWOPI_D=6.283185307179586476925286766559005768394_dp + ! missing values + real(qp), parameter :: nr_quadMissing=-9999._qp ! missing quadruple precision number + real(dp), parameter :: nr_realMissing=-9999._dp ! missing double precision 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 new file mode 100755 index 000000000..484f50206 --- /dev/null +++ b/build/source/engine/opSplittin.f90 @@ -0,0 +1,848 @@ +! 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 opSplittin_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: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_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 +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 + +! 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) + +! 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 + +! provide access to the number of flux variables +USE var_lookup,only:nFlux=>maxvarFlux ! number of model flux variables + +! 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 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 + +! 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 + +! safety: set private unless specified otherwise +implicit none +private +public::opSplittin + +! named variables for the solution method +integer(i4b),parameter :: fullyCoupled=1 ! 1st try: fully coupled solution +integer(i4b),parameter :: splitStateType=2 ! 2nd try: split the solution by state type (energy and water) +integer(i4b),parameter :: splitDomainType=3 ! 3rd try: split the solution by domain type (veg, snow, and soil) +integer(i4b),parameter :: explicitEuler=4 ! 4th try: explicit Euler solution for sub-domains of a given type + +! named variables for the state variable split +integer(i4b),parameter :: nrgSplit=1 ! order in sequence for the energy operation +integer(i4b),parameter :: massSplit=2 ! order in sequence for the mass operation + +! named variables for the domain type split +integer(i4b),parameter :: vegSplit=1 ! order in sequence for the vegetation split +integer(i4b),parameter :: snowSplit=2 ! order in sequence for the snow split +integer(i4b),parameter :: soilSplit=3 ! order in sequence for the soil split + +! maximum number of possible splits +integer(i4b),parameter :: nStateTypes=2 ! number of state types (energy, water) +integer(i4b),parameter :: nDomains=3 ! number of domains (vegetation, snow, and soil) + +! control parameters +real(dp),parameter :: valueMissing=-9999._dp ! missing value +real(dp),parameter :: verySmall=1.e-12_dp ! a very small number (used to check consistency) +real(dp),parameter :: veryBig=1.e+20_dp ! a very big number +real(dp),parameter :: dx = 1.e-8_dp ! finite difference increment + +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 (energy + ! and mass); (c) split by domain type or a given energy and mass split (vegetation, snow, and soil); + ! and (d) explicit Euler 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 + ! 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 + ixSolution, & ! intent(out): solution method used in this iteration + err,message) ! intent(out): error code and error message + ! --------------------------------------------------------------------------------------- + ! structure allocations + 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) + 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 + ! numerical recipes utility modules + 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(dp),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(dp),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) :: 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) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + real(dp),dimension(nLayers) :: mLayerVolFracIceInit ! initial vector for volumetric fraction of ice (-) + ! ------------------------------------------------------------------------------------------------------ + ! * operator splitting + ! ------------------------------------------------------------------------------------------------------ + ! minimum time step + real(dp) :: dt_min ! minimum time step (seconds) + real(dp),parameter :: dtmin_fullyCoupled=10._dp ! minimum time step for the fully coupled solution + real(dp),parameter :: dtmin_splitStateType=1._dp ! minimum time step for the split by state type + real(dp),parameter :: dtmin_splitDomainType=0.1_dp ! minimum time step for the split by domain type + real(dp),parameter :: dtmin_explicitEuler=0.1_dp ! minimum time step for the explicit Euler solution + ! explicit error tolerance (depends on state type split, so defined here) + real(dp),parameter :: errorTolLiqFlux=0.01_dp ! error tolerance in the explicit solution (liquid flux) + real(dp),parameter :: errorTolNrgFlux=10._dp ! error tolerance in the explicit solution (energy flux) + real(dp) :: errTol ! error tolerance in the explicit solution + ! number of substeps taken for a given split + integer(i4b) :: nSubsteps ! number of substeps taken for a given split + ! named variables defining the solution method + integer(i4b) :: ixSolution ! index of solution method (1,2,3,...) + ! actual number of splits + integer(i4b) :: nStateTypeSplit ! number of splits for the state type + integer(i4b) :: nDomainSplit ! number of splits for the domain + ! indices for the state type split + integer(i4b) :: iStateTypeSplit ! index of the state type split + integer(i4b) :: iTrialStateSplit ! index of state split trial + ! indices for the domain split + integer(i4b) :: iDomainSplit ! index of the domain split + ! state and flux masks for a given split + integer(i4b),dimension(nState) :: stateCheck ! number of times each state variable is updated (should=1) + logical(lgt),dimension(nState) :: stateMask ! mask defining desired state variables + logical(lgt),dimension(nFlux) :: fluxMask ! mask defining desired flux 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 + 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) + ! 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 flux call + firstSuccess=.false. + firstFluxCall=.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 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 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 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 + + ! ========================================================================================================================================== + ! ========================================================================================================================================== + ! ========================================================================================================================================== + ! ========================================================================================================================================== + + ! initialize solution method + ixSolution=fullyCoupled + + ! loop through solution methods + solution: do + + ! define the number of operator splits for the state type + if(ixSolution==fullyCoupled)then + nStateTypeSplit=1 + else + nStateTypeSplit=nStateTypes + endif + + ! state type splitting loop + stateTypeSplit: do iStateTypeSplit=1,nStateTypeSplit + trialStateSplit: do iTrialStateSplit=1,2 ! two state type trials: 1=full domain; 2=sub-domains + + ! define the number of operator splits for the domain + if(ixSolution==fullyCoupled .or. ixSolution==splitStateType)then + nDomainSplit=1 + else + nDomainSplit=nDomains + endif + + ! flag to adjust the temperature + doAdjustTemp = (ixSolution/=fullyCoupled .and. iStateTypeSplit==massSplit) + + ! get the error tolerance + errTol = merge(errorTolNrgFlux,errorTolLiqFlux,iStateTypeSplit==nrgSplit) + + ! ----- + ! * modify state variables for the mass split... + ! ---------------------------------------------- + + ! modify the state type names associated with the state vector + if(ixSolution/=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 + + ! domain type splitting loop + domainSplit: do iDomainSplit=1,nDomainSplit + + ! try multiple solution methods + trySolution: do ! exit upon success + + ! ******************************************************************************************************************************* + ! ******************************************************************************************************************************* + ! ******************************************************************************************************************************* + ! ***** trial with a given solution method... + + ! initialize error control + err=0; message="opSplittin/" + + ! ----- + ! * define subsets for a given split... + ! ------------------------------------- + + ! get the mask for the state subset + call stateFilter(ixSolution,iStateTypeSplit,iDomainSplit,indx_data,stateMask,nSubset,err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (check for errors) + + ! check + if(globalPrintFlag)then + print*, 'after filter: stateMask = ', stateMask + print*, 'ixSolution==explicitEuler = ', ixSolution==explicitEuler + endif + + ! check that state variables exist + if(nSubset==0) cycle domainSplit + + ! ----- + ! * assemble vectors for a given split... + ! --------------------------------------- + + ! define minimum time step + select case(ixSolution) + case(fullyCoupled); dt_min = dtmin_fullyCoupled + case(splitStateType); dt_min = dtmin_splitStateType + case(splitDomainType); dt_min = dtmin_splitDomainType + case(explicitEuler); dt_min = dtmin_explicitEuler + case default; err=20; message=trim(message)//'solution method not found'; return + end select + + ! 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 + stateSubset: associate(ixStateType_subset => indx_data%var(iLookINDEX%ixStateType_subset)%dat) + do iVar=1,size(flux_meta) + + ! * split solution + if(ixSolution/=fullyCoupled)then + select case(iStateTypeSplit) + case(nrgSplit); fluxMask(iVar) = any(ixStateType_subset==flux2state_orig(iVar)%state1) .or. any(ixStateType_subset==flux2state_orig(iVar)%state2) + case(massSplit); fluxMask(iVar) = 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 + + ! * fully coupled + else + fluxMask(iVar) = any(ixStateType_subset==flux2state_orig(iVar)%state1) .or. any(ixStateType_subset==flux2state_orig(iVar)%state2) + endif + + ! * check + if(globalPrintFlag .and. fluxMask(iVar))& + print*, trim(flux_meta(iVar)%varname) + + end do + end associate stateSubset + + ! initialize the model fluxes (some model fluxes are not computed in the iterations) + do iVar=1,size(flux_meta) + if(fluxMask(iVar)) flux_data%var(iVar)%dat(:) = 0._dp + end do + + ! ----- + ! * solve variable subset for one time step... + ! -------------------------------------------- + + ! 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 + + ! solve variable subset for one full time step + call varSubstep(& + ! input: model control + dt, & ! intent(inout) : time step (s) + dt_min, & ! intent(in) : minimum time step (seconds) + errTol, & ! intent(in) : error tolerance for the explicit solution + 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 + (ixSolution==explicitEuler),& ! intent(in) : flag to denote computing the explicit Euler solution + computeVegFlux, & ! intent(in) : flag to denote if computing energy flux over vegetation + fluxMask, & ! intent(in) : mask for the fluxes used in this given state subset + ! 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) + + ! check + if(globalPrintFlag .and. ixSolution>splitStateType)then + print*, 'dt = ', dt + print*, 'after varSubstep: err = ', err + print*, 'after varSubstep: cmessage = ', trim(cmessage) + print*, 'after varSubstep: stateMask = ', stateMask + 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',ixSolution==fullyCoupled) + !if(ixSolution==explicitEuler)then + ! print*, trim(message)//trim(cmessage) + ! print*, 'PAUSE: failed splitStateType attempt'; read(*,*) + !endif + endif + + ! if too much melt 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. + + ! ----- + ! * success: revert back to "more coupled" methods... + ! --------------------------------------------------- + + ! success = exit the trySolution loop + if(.not.failure)then + + ! 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 + + ! fully coupled + if(ixSolution==fullyCoupled)then + exit stateTypeSplit ! stay within the ixSolution loop in case mass balance errors + + ! split state type + elseif(ixSolution==splitStateType)then + exit domainSplit ! this (1) tries the other state split if iStateTypeSplit1) dtMultiplier=0.5_dp + + ! 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 stateSubset: get a mask for the desired state variables + ! ********************************************************************************************************** + subroutine stateFilter(ixSolution,iStateTypeSplit,iDomainSplit,indx_data,stateMask,nSubset,err,message) + implicit none + ! input + integer(i4b),intent(in) :: ixSolution ! index of solution method (1,2,3,...) + integer(i4b),intent(in) :: iStateTypeSplit ! index of the state type split + integer(i4b),intent(in) :: iDomainSplit ! index of the domain split + type(var_ilength),intent(inout) :: indx_data ! indices for a local HRU + ! 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 + ! -------------------------------------------------------------------------------------------------------------------------------------------------------------------------- + ! 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 + ! 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(ixSolution) + + ! ----- + ! - fully coupled... + ! ------------------ + + ! use all state variables + case(fullyCoupled); stateMask(:) = .true. + + ! ----- + ! - splitting by state type... + ! ---------------------------- + + ! split into energy and mass + case(splitStateType) + 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) + case default; err=20; message=trim(message)//'unable to identify split based on state type'; return + end select + + ! ----- + ! - splitting by domain... + ! ------------------------ + + ! split into vegetation, snow, and soil + case(splitDomainType,explicitEuler) + + ! 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:) 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 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 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) + + case default; err=20; message=trim(message)//'unable to identify solution method'; return + end select ! (selecting solution method) + + ! get the number of selected state variables + nSubset = count(stateMask) + + ! end associations + end associate + + end subroutine stateFilter + +end module opSplittin_module diff --git a/build/source/engine/pOverwrite.f90 b/build/source/engine/pOverwrite.f90 old mode 100644 new mode 100755 index 67574ea17..23248c9d1 --- a/build/source/engine/pOverwrite.f90 +++ b/build/source/engine/pOverwrite.f90 @@ -29,9 +29,8 @@ module pOverwrite_module ! ************************************************************************************************ ! public subroutine pOverwrite: use Noah tables to overwrite default model parameters ! ************************************************************************************************ - subroutine pOverwrite(ixVeg,ixSoil,err,message) - ! FUSE data structures - USE data_struc,only:localParFallback ! data structures for default values and constraints for model parameters + subroutine pOverwrite(ixVeg,ixSoil,defaultParam,err,message) + ! SUMMA dictionary USE var_lookup,only:iLookPARAM ! named variables for elements of the data structures ! Noah table dimensions USE module_sf_noahlsm, only: LUCATS ! dimension of the vegetation tables (number of land use catagories) @@ -41,50 +40,55 @@ subroutine pOverwrite(ixVeg,ixSoil,err,message) USE NOAHMP_VEG_PARAMETERS, only: HVT ! Noah-MP: height at top of canopy (m) USE NOAHMP_VEG_PARAMETERS, only: HVB ! Noah-MP: height at bottom of canopy (m) USE NOAHMP_VEG_PARAMETERS, only: DLEAF ! Noah-MP: characteristic leaf dimension (m) + 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: REFSMC ! Noah-MP: reference volumetric soil moisture content (-) USE module_sf_noahlsm, only: WLTSMC ! Noah-MP: volumetric soil moisture content when plants are wilting (-) implicit none ! define input - integer(i4b),intent(in) :: ixVeg ! vegetation category - integer(i4b),intent(in) :: ixSoil ! soil category + integer(i4b),intent(in) :: ixVeg ! vegetation category + integer(i4b),intent(in) :: ixSoil ! soil category ! define output - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + real(dp),intent(inout) :: defaultParam(:) ! default model parameters + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message ! Start procedure here err=0; message="pOverwrite/" ! define vegetation class - if(ixVeg < 1)then; err=20; message=trim(message)//'index for vegetation type must be > 0'; return; endif + if(ixVeg < 1)then; err=20; message=trim(message)//'index for vegetation type must be > 0'; return; end if if(ixVeg > LUCATS)then write(message,'(2(a,i0),a)')trim(message)//'index for vegetation type is greater than dimension of vegetation table [ixVeg = ', ixVeg, & '; LUCATS = ', LUCATS, ']' err=20; return - endif + end if ! define soil class - if(ixSoil < 1)then; err=20; message=trim(message)//'index for soil type must be > 0'; return; endif + if(ixSoil < 1)then; err=20; message=trim(message)//'index for soil type must be > 0'; return; end if if(ixSoil > NSLTYPE)then write(message,'(2(a,i0),a)')trim(message)//'index for soil type is greater than dimension of soil table [ixSoil = ', ixSoil, & '; NSLTYPE = ', NSLTYPE, ']' err=20; return - endif + end if ! include parameters from the vegetation tables - localParFallback(iLookPARAM%heightCanopyTop)%default_val = HVT(ixVeg) ! Noah-MP: height at top of canopy (m) - localParFallback(iLookPARAM%heightCanopyBottom)%default_val = HVB(ixVeg) ! Noah-MP: height at bottom of canopy (m) - localParFallback(iLookPARAM%z0Canopy)%default_val = Z0MVT(ixVeg) ! Noah-MP: momentum roughness length (m) - localParFallback(iLookPARAM%leafDimension)%default_val = DLEAF(ixVeg) ! Noah-MP: characteristic leaf dimension (m) + defaultParam(iLookPARAM%heightCanopyTop) = HVT(ixVeg) ! Noah-MP: height at top of canopy (m) + defaultParam(iLookPARAM%heightCanopyBottom) = HVB(ixVeg) ! Noah-MP: height at bottom of canopy (m) + defaultParam(iLookPARAM%z0Canopy) = Z0MVT(ixVeg) ! Noah-MP: momentum roughness length (m) + defaultParam(iLookPARAM%leafDimension) = DLEAF(ixVeg) ! Noah-MP: characteristic leaf dimension (m) + defaultParam(iLookPARAM%vcmax25_canopyTop) = VCMX25(ixVeg) ! Noah-MP: maximum Rubisco carboxylation rate (umol m-2 s-1) + defaultParam(iLookPARAM%cond2photo_slope) = MP(ixVeg) ! Noah-MP: slope of conductance-photosynthesis relationship (-) ! include parameters from the soil tables - localParFallback(iLookPARAM%k_soil)%default_val = k_soil(ixSoil) ! hydraulic conductivity (m s-1) - localParFallback(iLookPARAM%theta_res)%default_val = theta_res(ixSoil) ! residual volumetric liquid water content (-) - localParFallback(iLookPARAM%theta_sat)%default_val = theta_sat(ixSoil) ! soil porosity (-) - localParFallback(iLookPARAM%vGn_alpha)%default_val = vGn_alpha(ixSoil) ! van Genutchen "alpha" parameter (m-1) - localParFallback(iLookPARAM%vGn_n)%default_val = vGn_n(ixSoil) ! van Genutchen "n" parameter (-) - localParFallback(iLookPARAM%critSoilTranspire)%default_val = REFSMC(ixSoil) ! Noah-MP: reference volumetric soil moisture content (-) - localParFallback(iLookPARAM%critSoilWilting)%default_val = WLTSMC(ixSoil) ! Noah-MP: volumetric soil moisture content when plants are wilting (-) + 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 (-) end subroutine pOverwrite diff --git a/build/source/engine/paramCheck.f90 b/build/source/engine/paramCheck.f90 old mode 100644 new mode 100755 index 10527f360..dcba8ff4c --- a/build/source/engine/paramCheck.f90 +++ b/build/source/engine/paramCheck.f90 @@ -34,22 +34,24 @@ module paramCheck_module ! ************************************************************************************************ ! public subroutine paramCheck: check consistency of model parameters ! ************************************************************************************************ - subroutine paramCheck(err,message) + subroutine paramCheck(mpar_data,err,message) ! model decisions - USE data_struc,only:model_decisions ! model decision structure + USE globalData,only:model_decisions ! model decision structure USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure - ! FUSE data structures - USE data_struc,only:mpar_data ! data structures for model parameters + ! SUMMA look-up variables + USE data_types,only:var_dlength ! data vector with variable length dimension (dp): x%var(:)%dat(:) USE var_lookup,only:iLookPARAM ! named variables for elements of the data structures implicit none + ! define input + type(var_dlength),intent(in) :: mpar_data ! model parameters ! define output - 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) :: iLayer ! index of model layers - real(dp),dimension(5) :: zminLayer ! minimum layer depth in each layer (m) - real(dp),dimension(4) :: zmaxLayer_lower ! lower value of maximum layer depth - real(dp),dimension(4) :: zmaxLayer_upper ! upper value of maximum layer depth + integer(i4b) :: iLayer ! index of model layers + real(dp),dimension(5) :: zminLayer ! minimum layer depth in each layer (m) + real(dp),dimension(4) :: zmaxLayer_lower ! lower value of maximum layer depth + real(dp),dimension(4) :: zmaxLayer_upper ! upper value of maximum layer depth ! Start procedure here err=0; message="paramCheck/" @@ -61,27 +63,27 @@ subroutine paramCheck(err,message) select case(model_decisions(iLookDECISIONS%snowLayers)%iDecision) ! SNTHERM option case(sameRulesAllLayers) - if(mpar_data%var(iLookPARAM%zmax)/mpar_data%var(iLookPARAM%zmin) < 2.5_dp)then + if(mpar_data%var(iLookPARAM%zmax)%dat(1)/mpar_data%var(iLookPARAM%zmin)%dat(1) < 2.5_dp)then message=trim(message)//'zmax must be at least 2.5 times larger than zmin: this avoids merging layers that have just been divided' err=20; return - endif + end if ! CLM option case(rulesDependLayerIndex) ! (build vectors of min/max) - zminLayer = (/mpar_data%var(iLookPARAM%zminLayer1),& - mpar_data%var(iLookPARAM%zminLayer2),& - mpar_data%var(iLookPARAM%zminLayer3),& - mpar_data%var(iLookPARAM%zminLayer4),& - mpar_data%var(iLookPARAM%zminLayer5)/) - zmaxLayer_lower = (/mpar_data%var(iLookPARAM%zmaxLayer1_lower),& - mpar_data%var(iLookPARAM%zmaxLayer2_lower),& - mpar_data%var(iLookPARAM%zmaxLayer3_lower),& - mpar_data%var(iLookPARAM%zmaxLayer4_lower)/) - zmaxLayer_upper = (/mpar_data%var(iLookPARAM%zmaxLayer1_upper),& - mpar_data%var(iLookPARAM%zmaxLayer2_upper),& - mpar_data%var(iLookPARAM%zmaxLayer3_upper),& - mpar_data%var(iLookPARAM%zmaxLayer4_upper)/) - ! (check consistency) + zminLayer = (/mpar_data%var(iLookPARAM%zminLayer1)%dat(1),& + mpar_data%var(iLookPARAM%zminLayer2)%dat(1),& + mpar_data%var(iLookPARAM%zminLayer3)%dat(1),& + mpar_data%var(iLookPARAM%zminLayer4)%dat(1),& + mpar_data%var(iLookPARAM%zminLayer5)%dat(1)/) + zmaxLayer_lower = (/mpar_data%var(iLookPARAM%zmaxLayer1_lower)%dat(1),& + mpar_data%var(iLookPARAM%zmaxLayer2_lower)%dat(1),& + mpar_data%var(iLookPARAM%zmaxLayer3_lower)%dat(1),& + mpar_data%var(iLookPARAM%zmaxLayer4_lower)%dat(1)/) + zmaxLayer_upper = (/mpar_data%var(iLookPARAM%zmaxLayer1_upper)%dat(1),& + mpar_data%var(iLookPARAM%zmaxLayer2_upper)%dat(1),& + mpar_data%var(iLookPARAM%zmaxLayer3_upper)%dat(1),& + mpar_data%var(iLookPARAM%zmaxLayer4_upper)%dat(1)/) + ! (check consistency) do iLayer=1,4 ! NOTE: the lower layer does not have a maximum value ! ensure that we have higher maximum thresholds for sub-division when fewer number of layers if(zmaxLayer_lower(iLayer) < zmaxLayer_upper(iLayer))then @@ -89,7 +91,7 @@ subroutine paramCheck(err,message) iLayer,' layer(s) is greater than the maximum threshold for sub-division in the case where there are > ',& iLayer,' layer(s)' err=20; return - endif + end if ! ensure that the maximum thickness is 3 times greater than the minimum thickness if(zmaxLayer_upper(iLayer)/zminLayer(iLayer) < 2.5_dp .or. zmaxLayer_upper(iLayer)/zminLayer(iLayer+1) < 2.5_dp)then write(*,'(a,1x,3(f20.10,1x))') 'zmaxLayer_upper(iLayer), zminLayer(iLayer), zminLayer(iLayer+1) = ', & @@ -97,7 +99,7 @@ subroutine paramCheck(err,message) write(message,'(a,3(i0,a))') trim(message)//'zmaxLayer_upper for layer ',iLayer,' must be 2.5 times larger than zminLayer for layers ',& iLayer,' and ',iLayer+1,': this avoids merging layers that have just been divided' err=20; return - endif + end if end do ! loop through layers 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) @@ -105,36 +107,74 @@ subroutine paramCheck(err,message) ! ------------------------------------------------------------------------------------------------------------------------------------------- ! ***** - ! * check soil stress functionality... - ! ************************************ + ! * check parameter dependencies... + ! ********************************* + + ! associations + associate(& + ! canopy geometry + 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(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 (-) + theta_res => mpar_data%var(iLookPARAM%theta_res)%dat & ! intent(in): [dp(:)] soil residual volumetric water content (-) + ) ! associations to parameters + + ! check canopy geometry + if(heightCanopyTop < heightCanopyBottom)then + write(message,'(a,i0,a)') trim(message)//'height of canopy top is less than the height of the canopy bottom' + err=20; return + endif ! check that the maximum transpiration limit is within bounds - if(mpar_data%var(iLookPARAM%critSoilTranspire)>mpar_data%var(iLookPARAM%theta_sat) .or. & - mpar_data%var(iLookPARAM%critSoilTranspire) theta_sat) .or. any(critSoilTranspire < theta_res) )then + print*, 'theta_res = ', theta_res + print*, 'theta_sat = ', theta_sat + print*, 'critSoilTranspire = ', critSoilTranspire message=trim(message)//'critSoilTranspire parameter is out of range '// & '[NOTE: if overwriting Noah-MP soil table values in paramTrial, must overwrite all soil parameters]' err=20; return - endif + end if ! check that the soil wilting point is within bounds - if(mpar_data%var(iLookPARAM%critSoilWilting)>mpar_data%var(iLookPARAM%theta_sat) .or. & - mpar_data%var(iLookPARAM%critSoilWilting)mpar_data%var(iLookPARAM%theta_sat) .or. & - mpar_data%var(iLookPARAM%fieldCapacity)hru mapping structure + USE globalData,only:index_map ! hru->gru mapping structure + implicit none + + character(*),intent(in) :: attrFile ! name of attributed file + integer(i4b),intent(out) :: fileGRU ! number of GRUs in the input file + integer(i4b),intent(out) :: fileHRU ! number of HRUs in the input file + integer(i4b),intent(inout) :: nGRU ! number of GRUs in the run domain + integer(i4b),intent(inout) :: nHRU ! number of HRUs in the run domain + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + integer(i4b),intent(in),optional :: startGRU ! index of the starting GRU for parallelization run + integer(i4b),intent(in),optional :: checkHRU ! index of the HRU for a single HRU run + + ! locals + integer(i4b) :: sGRU ! starting GRU + integer(i4b) :: iHRU ! HRU couinting index + integer(i4b) :: iGRU ! GRU loop index + integer(i4b),allocatable :: gru_id(:),hru_id(:)! read gru/hru IDs in from attributes file + integer(i4b),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 + integer(i4b) :: ncID ! NetCDF file ID + integer(i4b) :: varID ! NetCDF variable ID + integer(i4b) :: gruDimId ! variable id of GRU dimension from netcdf file + integer(i4b) :: hruDimId ! variable id of HRU dimension from netcdf file + character(len=256) :: cmessage ! error message for downwind routine + + ! Start procedure here + err=0; message="read_dimension/" + + ! check that we do not have conflicting flags + if(present(startGRU).and.present(checkHRU))then; message=trim(message)//'startGRU and checkHRU both exist'; return; end if + + ! open nc file + call nc_file_open(trim(attrFile),nf90_noWrite,ncID,err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + + ! ********************************************************************************************* + ! read and set GRU dimensions + ! ********************************************************************************************** + ! get gru dimension of whole file + err = nf90_inq_dimid(ncID,"gru",gruDimId); if(err/=nf90_noerr)then; message=trim(message)//'problem finding gru dimension/'//trim(nf90_strerror(err)); return; end if + err = nf90_inquire_dimension(ncID, gruDimId, len = fileGRU); if(err/=nf90_noerr)then; message=trim(message)//'problem reading gru dimension/'//trim(nf90_strerror(err)); return; end if + + ! get hru dimension of whole file + err = nf90_inq_dimid(ncID,"hru",hruDimId); if(err/=nf90_noerr)then; message=trim(message)//'problem finding hru dimension/'//trim(nf90_strerror(err)); return; end if + err = nf90_inquire_dimension(ncID, hruDimId, len = fileHRU); if(err/=nf90_noerr)then; message=trim(message)//'problem reading hru dimension/'//trim(nf90_strerror(err)); return; end if + + ! get runtime GRU dimensions + if (present(startGRU)) then + if (nGRU < 1) then; err=20; message=trim(message)//'nGRU < 1 for a startGRU run'; return; end if + sGRU = startGRU + elseif (present(checkHRU)) then + nGRU = 1 + else + sGRU = 1 + nGRU = fileGRU + endif + + ! check dimensions + if ((present(startGRU)).and.(startGRU + nGRU > fileGRU)) then; err=20; message=trim(message)//'startGRU + nGRU is larger than then the GRU dimension'; return; end if + if ((present(checkHRU)).and.(checkHRU > fileHRU)) then; err=20; message=trim(message)//'checkHRU is larger than then the HRU dimension' ; return; end if + + ! ********************************************************************************************* + ! read mapping vectors and populate mapping structures + ! ********************************************************************************************** + ! allocate space for GRU indices + allocate(gru_id(fileGRU)) + allocate(hru_ix(fileHRU),hru_id(fileHRU),hru2gru_id(fileHRU)) + + ! read gru_id from netcdf file + err = nf90_inq_varid(ncID,"gruId",varID); if (err/=0) then; message=trim(message)//'problem finding gruId'; return; end if + err = nf90_get_var(ncID,varID,gru_id); if (err/=0) then; message=trim(message)//'problem reading gruId'; return; end if + + ! read hruIndex from netcdf file + err = nf90_inq_varid(ncID,"hruId",varID); if (err/=0) then; message=trim(message)//'problem finding hruId'; return; end if + err = nf90_get_var(ncID,varID,hru_id); if (err/=0) then; message=trim(message)//'problem reading hruId'; return; end if + + ! read hru2gru_id from netcdf file + 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 + +! allocate first level of gru to hru mapping +allocate(gru_struc(nGRU)) + +! set gru to hru mapping +if (present(checkHRU)) then ! allocate space for single-HRU run + + ! gru to hru maping + iGRU = 1 + gru_struc(iGRU)%hruCount = 1 ! number of HRUs in each GRU + gru_struc(iGRU)%gruId = hru2gru_id(checkHRU) ! set gru id + allocate(gru_struc(iGRU)%hruInfo(gru_struc(iGRU)%hruCount)) ! allocate second level of gru to hru map + gru_struc(iGRU)%hruInfo(iGRU)%hru_nc = checkHRU ! set hru id in attributes netcdf file + gru_struc(iGRU)%hruInfo(iGRU)%hru_ix = 1 ! set index of hru in run domain + gru_struc(iGRU)%hruInfo(iGRU)%hru_id = hru_id(checkHRU) ! set id of hru + +else ! allocate space for anything except a single HRU run + + iHRU = 1 + do iGRU = 1,nGRU + + 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 + gru_struc(iGRU)%gruId = gru_id(iGRU+sGRU-1) ! set gru id + allocate(gru_struc(iGRU)%hruInfo(gru_struc(iGRU)%hruCount)) ! allocate second level of gru to hru map + gru_struc(iGRU)%hruInfo(:)%hru_nc = pack(hru_ix,hru2gru_id == gru_struc(iGRU)%gruId) ! set hru id in attributes netcdf file + gru_struc(iGRU)%hruInfo(:)%hru_ix = arth(iHRU,1,gru_struc(iGRU)%hruCount) ! set index of hru in run domain + gru_struc(iGRU)%hruInfo(:)%hru_id = hru_id(gru_struc(iGRU)%hruInfo(:)%hru_nc) ! set id of hru + iHRU = iHRU + gru_struc(iGRU)%hruCount + enddo ! iGRU = 1,nGRU + +end if ! not checkHRU + +! set hru to gru mapping +nHRU = sum(gru_struc%hruCount) ! total number of HRUs +allocate(index_map(nHRU)) ! allocate first level of hru to gru mapping + +if (present(checkHRU)) then ! allocate space for single-HRU run + if (nHRU/=1) then; err=-20; message=trim(message)//'wrong # of HRUs for checkHRU run'; return; end if + iGRU = 1; + index_map(1)%gru_ix = iGRU ! index of gru in run domain to which the hru belongs + index_map(1)%localHRU = hru_ix(1) ! index of hru within the gru + +else ! anything other than a single HRU run + do iGRU = 1,nGRU + index_map(gru_struc(iGRU)%hruInfo(:)%hru_ix)%gru_ix = iGRU ! index of gru in run domain to which the hru belongs + index_map(gru_struc(iGRU)%hruInfo(:)%hru_ix)%localHRU = hru_ix(1:gru_struc(iGRU)%hruCount) ! index of hru within the gru + enddo ! iGRU = 1,nGRU + +end if ! not checkHRU + +end subroutine read_dimension + ! ************************************************************************************************ ! public subroutine read_attrb: read information on local attributes ! ************************************************************************************************ - subroutine read_attrb(nHRU,err,message) + subroutine read_attrb(attrFile,nGRU,attrStruct,typeStruct,err,message) ! provide access to subroutines - USE ascii_util_module,only:file_open ! open ascii file - USE ascii_util_module,only:split_line ! extract the list of variable names from the character string - USE ascii_util_module,only:get_vlines ! read a vector of non-comment lines from an ASCII file - USE allocspace_module,only:alloc_attr ! module to allocate space for local attributes - USE allocspace_module,only:alloc_type ! module to allocate space for categorical data - ! provide access to data - USE summaFileManager,only:SETNGS_PATH ! path for metadata files - USE summaFileManager,only:LOCAL_ATTRIBUTES ! file containing information on local attributes - USE data_struc,only:attr_meta,type_meta ! metadata structures - USE data_struc,only:attr_hru,type_hru ! data structures - USE var_lookup,only:iLookATTR,iLookTYPE ! named variables for elements of the data structures - USE get_ixname_module,only:get_ixAttr,get_ixType ! access function to find index of elements in structure + USE netcdf + 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 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_double ! x%gru(:)%hru(:)%var(:) (dp) + ! provide access to global data + USE globalData,only:gru_struc ! gru-hru mapping structure + USE globalData,only:attr_meta,type_meta ! metadata structures + USE get_ixname_module,only:get_ixAttr,get_ixType ! access function to find index of elements in structure implicit none - ! define output - integer(i4b),intent(out) :: nHRU ! number of hydrologic response units - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! define general variables - real(dp),parameter :: missingDouble=-9999._dp ! missing data - integer(i4b),parameter :: missingInteger=-9999 ! missing data - character(len=256) :: cmessage ! error message for downwind routine - character(LEN=256) :: infile ! input filename - integer(i4b),parameter :: unt=99 ! DK: need to either define units globally, or use getSpareUnit - integer(i4b) :: iline ! loop through lines in the file - integer(i4b),parameter :: maxLines=1000 ! maximum lines in the file - character(LEN=256) :: temp ! single lime of information + + ! io vars + character(*) :: attrFile ! input filename + integer(i4b),intent(in) :: nGRU ! number of grouped response units + type(gru_hru_double),intent(inout) :: attrStruct ! local attributes for each HRU + type(gru_hru_int),intent(inout) :: typeStruct ! local classification of soil veg etc. for each HRU + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! define local variables - integer(i4b) :: iend ! check for the end of the file - character(LEN=512) :: nameString ! string containing the list of attribute names - character(LEN=256),allocatable :: attNames(:) ! vector of attribute names - character(LEN=256),allocatable :: attData(:) ! vector of attribute data for a given HRU - character(LEN=256),allocatable :: dataLines(:) ! vector of character strings from non-comment lines - integer(i4b),parameter :: categorical=101 ! named variable to denote categorical data - integer(i4b),parameter :: numerical=102 ! named variable to denote numerical data - integer(i4b),allocatable :: varType(:) ! type of variable (categorical or numerical) - integer(i4b),allocatable :: varIndx(:) ! index of variable within its data structure - integer(i4b) :: iAtt ! index of an attribute name - integer(i4b) :: iHRU ! index of an HRU - integer(i4b) :: nAtt ! number of model attributes - integer(i4b) :: nVar_attr ! number of variables in the model attribute structure - integer(i4b) :: nVar_type ! number of variables in the model category structure - logical(lgt),allocatable :: checkType(:) ! vector to check if we have all desired categorical values - logical(lgt),allocatable :: checkAttr(:) ! vector to check if we have all desired local attributes + character(len=256) :: cmessage ! error message for downwind routine + integer(i4b) :: iVar ! loop through varibles in the netcdf file + integer(i4b) :: iHRU ! index of an HRU within a GRU + integer(i4b) :: iGRU ! index of an GRU + integer(i4b) :: varType ! type of variable (categorical or numerical) + integer(i4b) :: varIndx ! index of variable within its data structure + + ! check structures + integer(i4b) :: iCheck ! index of an attribute name + logical(lgt),allocatable :: checkType(:) ! vector to check if we have all desired categorical values + logical(lgt),allocatable :: checkAttr(:) ! vector to check if we have all desired local attributes + + ! netcdf variables + integer(i4b) :: ncID ! netcdf file id + character(LEN=nf90_max_name) :: varName ! character array of netcdf variable name + integer(i4b) :: nVar ! number of variables in netcdf local attribute file + integer(i4b),parameter :: categorical=101 ! named variable to denote categorical data + integer(i4b),parameter :: numerical=102 ! named variable to denote numerical data + integer(i4b) :: categorical_var(1) ! temporary categorical variable from local attributes netcdf file + real(dp) :: numeric_var(1) ! temporary numeric variable from local attributes netcdf file + + ! define mapping variables + ! Start procedure here err=0; message="read_attrb/" ! ********************************************************************************************** - ! (0) get number of variables in each data structure + ! (1) prepare check vectors ! ********************************************************************************************** - ! check that metadata structures are initialized - if(.not.associated(attr_meta) .or. .not.associated(type_meta))then - err=10; message=trim(message)//"metadataNotInitialized"; return - endif - nVar_attr = size(attr_meta) - nVar_type = size(type_meta) - ! allocate space for the check vectors - allocate(checkType(nVar_type),checkAttr(nVar_attr),stat=err) + allocate(checkType(size(type_meta)),checkAttr(size(attr_meta)),stat=err) if(err/=0)then; err=20; message=trim(message)//'problem allocating space for variable check vectors'; return; endif checkType(:) = .false. checkAttr(:) = .false. - ! ********************************************************************************************** - ! (1) open files, etc. + ! (2) open netcdf file ! ********************************************************************************************** - ! build filename - infile = trim(SETNGS_PATH)//trim(LOCAL_ATTRIBUTES) ! open file - call file_open(trim(infile),unt,err,cmessage) + call nc_file_open(trim(attrFile),nf90_noWrite,ncID,err,cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + ! get number of variables total in netcdf file + err = nf90_inquire(ncID,nvariables=nVar) + call netcdf_err(err,message); if (err/=0) return ! ********************************************************************************************** - ! (2) read local attributes + ! (3) read local attributes ! ********************************************************************************************** - ! --------------------------------------------------------------------------------------------- - ! read attribute names - ! --------------------------------------------------------------------------------------------- - do iline=1,maxLines - ! (read through comment lines) - read(unt,'(a)',iostat=iend) temp ! read a line of data - if(iend/=0)then; err=20; message=trim(message)//'got to end of file before found the format code'; return; endif - if (temp(1:1)=='!')cycle - ! (read in format string -- assume that the first non-comment line is the list of attribute names) - read(temp,'(a)')nameString ! read in list of attribute names - exit - if(iLine==maxLines)then; err=20; message=trim(message)//'problem finding list of attribute names'; return; endif - end do ! looping through lines - ! --------------------------------------------------------------------------------------------- - ! identify the type of each attribute - ! --------------------------------------------------------------------------------------------- - ! split the line into an array of words - call split_line(nameString,attNames,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - ! identify the number of attributes - nAtt = size(attNames) - ! allocate space for the variable type and index - allocate(varType(nAtt),varIndx(nAtt), stat=err) - if(err/=0)then; err=20; message=trim(message)//'unable to allocate space for the variable type and index'; return; endif - ! initialize variables as missing - varType(:) = missingInteger - varIndx(:) = missingInteger - ! loop through the attribute names - do iAtt=1,nAtt + ! loop through variables in netcdf file and pull out local attributes + iCheck = 1 + do iVar = 1,nVar + + ! inqure about current variable name, type, number of dimensions + err = nf90_inquire_variable(ncID,iVar,name=varName) + if(err/=nf90_noerr)then; message=trim(message)//'problem inquiring variable: '//trim(varName)//'/'//trim(nf90_strerror(err)); return; endif + ! find attribute name - select case(trim(attNames(iAtt))) - ! categorical data - case('hruIndex','vegTypeIndex','soilTypeIndex','slopeTypeIndex','downHRUindex') - varType(iAtt) = categorical - varIndx(iAtt) = get_ixType(attNames(iAtt)) - checkType(varIndx(iAtt)) = .true. - ! numerical data + select case(trim(varName)) + + ! ** categorical data + case('hruId','vegTypeIndex','soilTypeIndex','slopeTypeIndex','downHRUindex') + + ! get the index of the variable + varType = categorical + if(trim(varName) == "hruId") then + varIndx = get_ixType("hruIndex") + else + varIndx = get_ixType(varName) + end if + checkType(varIndx) = .true. + + ! check that the variable could be identified in the data structure + if(varIndx < 1)then; err=20; message=trim(message)//'unable to find variable ['//trim(varName)//'] in data structure'; return; endif + + ! get data from netcdf file and store in vector + do iGRU=1,nGRU + do iHRU = 1,gru_struc(iGRU)%hruCount + err = nf90_get_var(ncID,iVar,categorical_var,start=(/gru_struc(iGRU)%hruInfo(iHRU)%hru_nc/),count=(/1/)) + if(err/=nf90_noerr)then; message=trim(message)//'problem reading: '//trim(varName); return; end if + typeStruct%gru(iGRU)%hru(iHRU)%var(varIndx) = categorical_var(1) + end do + end do + + ! ** numerical data case('latitude','longitude','elevation','tan_slope','contourLength','HRUarea','mHeight') - varType(iAtt) = numerical - varIndx(iAtt) = get_ixAttr(attNames(iAtt)) - checkAttr(varIndx(iAtt)) = .true. + + ! get the index of the variable + varType = numerical + varIndx = get_ixAttr(varName) + checkAttr(varIndx) = .true. + + ! check that the variable could be identified in the data structure + if(varIndx < 1)then; err=20; message=trim(message)//'unable to find variable ['//trim(varName)//'] in data structure'; return; endif + + ! get data from netcdf file and store in vector + do iGRU=1,nGRU + do iHRU = 1, gru_struc(iGRU)%hruCount + err = nf90_get_var(ncID,iVar,numeric_var,start=(/gru_struc(iGRU)%hruInfo(iHRU)%hru_nc/),count=(/1/)) + if(err/=nf90_noerr)then; message=trim(message)//'problem reading: '//trim(varName); return; end if + attrStruct%gru(iGRU)%hru(iHRU)%var(varIndx) = numeric_var(1) + end do + end do + + ! for mapping varibles, do nothing (information read above) + case('hru2gruId','gruId'); cycle + ! check that variables are what we expect - case default - message=trim(message)//'unknown variable ['//trim(attNames(iAtt))//'] in local attributes file' - err=20; return - end select - ! check that the variable could be identified in the data structure - if(varIndx(iAtt) < 1)then; err=20; message=trim(message)//'unable to find variable ['//trim(attNames(iAtt))//'] in data structure'; return; endif - ! print progress - !print*, (varType(iAtt)==categorical), varIndx(iAtt), trim(attNames(iAtt)) - end do ! (looping through attribute names) + case default; message=trim(message)//'unknown variable ['//trim(varName)//'] in local attributes file'; err=20; return + + end select ! select variable + + end do ! (looping through netcdf local attribute file) + + ! ********************************************************************************************** + ! (4) check that we have all the desired varaibles + ! ********************************************************************************************** ! check that we have all desired categorical variables if(any(.not.checkType))then - do iAtt=1,nVar_type - if(.not.checkType(iAtt))then; err=20; message=trim(message)//'missing variable ['//trim(type_meta(iAtt)%varname)//'] in local attributes file'; return; endif + do iCheck = 1,size(type_meta) + if(.not.checkType(iCheck))then; err=20; message=trim(message)//'missing variable ['//trim(type_meta(iCheck)%varname)//'] in local attributes file'; return; endif end do endif + ! check that we have all desired local attributes if(any(.not.checkAttr))then - do iAtt=1,nVar_attr - if(.not.checkAttr(iAtt))then; err=20; message=trim(message)//'missing variable ['//trim(attr_meta(iAtt)%varname)//'] in local attributes file'; return; endif + do iCheck = 1,size(attr_meta) + if(.not.checkAttr(iCheck))then; err=20; message=trim(message)//'missing variable ['//trim(attr_meta(iCheck)%varname)//'] in local attributes file'; return; endif end do endif - ! ********************************************************************************************** - ! (3) read attributes for each HRU, and allocate space + ! (5) close netcdf file ! ********************************************************************************************** - ! get a list of character strings from non-comment lines - call get_vlines(unt,dataLines,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - ! get the number of HRUs - nHRU = size(dataLines) - ! allocate space - call alloc_attr(nHRU,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - call alloc_type(nHRU,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - - - ! ********************************************************************************************** - ! (4) put data in the structures - ! ********************************************************************************************** - ! loop through HRUs - do iHRU=1,nHRU - ! split the line into an array of words - call split_line(dataLines(iHRU),attData,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - if(size(attData) /= nAtt)then; err=20; message=trim(message)//'number of attributes does not match expected number of attributes'; return; endif - ! put attributes in the appropriate structures - do iAtt=1,nAtt - select case(varType(iAtt)) - case(numerical); read(attData(iAtt),*,iostat=err) attr_hru(iHRU)%var(varIndx(iAtt)) - case(categorical); read(attData(iAtt),*,iostat=err) type_hru(iHRU)%var(varIndx(iAtt)) - case default; err=20; message=trim(message)//'unable to find type of attribute (categorical or numerical)'; return - end select - if(err/=0)then; err=20; message=trim(message)//'problem with internal read of attribute data'; return; endif - end do ! (looping through model attributes) - end do ! (looping through HRUs) - - ! ********************************************************************************************** - ! (5) deallocate space - ! ********************************************************************************************** - deallocate(attNames,attData,dataLines,varType,varIndx,checkType,checkAttr, stat=err) - if(err/=0)then; err=20; message=trim(message)//'problem deallocating space'; return; endif - - ! test - !do iHRU=1,nHRU - ! print*, '*****' - ! print*, 'hruIndex = ', type_hru(iHRU)%var(iLookTYPE%hruIndex) - ! print*, 'latitude = ', attr_hru(iHRU)%var(iLookATTR%latitude) - ! print*, 'longitude = ', attr_hru(iHRU)%var(iLookATTR%longitude) - ! print*, 'elevation = ', attr_hru(iHRU)%var(iLookATTR%elevation) - ! print*, 'mHeight = ', attr_hru(iHRU)%var(iLookATTR%mHeight) - ! print*, 'vegTypeIndex = ', type_hru(iHRU)%var(iLookTYPE%vegTypeIndex) - ! print*, 'soilTypeIndex = ', type_hru(iHRU)%var(iLookTYPE%soilTypeIndex) - ! print*, 'slopeTypeIndex = ', type_hru(iHRU)%var(iLookTYPE%slopeTypeIndex) - !end do ! (looping through HRUs) - !pause + call nc_file_close(ncID,err,cmessage) + if (err/=0)then; message=trim(message)//trim(cmessage); return; end if + ! free memory + deallocate(checkType) + deallocate(checkAttr) 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 100644 new mode 100755 index a7dee8b81..c896338f9 --- a/build/source/engine/read_force.f90 +++ b/build/source/engine/read_force.f90 @@ -28,231 +28,339 @@ module read_force_module ! ************************************************************************************************ ! public subroutine read_force: read in forcing data ! ************************************************************************************************ - subroutine read_force(istep,iHRU,err,message) + subroutine read_force(istep,iHRU_global,iFile,iRead,ncid,time_data,forc_data,err,message) + ! provide access to subroutines USE nrtype ! variable types, etc. + USE netcdf ! netcdf capability + USE netcdf_util_module,only:nc_file_open ! open netcdf file USE summaFileManager,only:INPUT_PATH ! path of the forcing data file - USE time_utils_module,only:extractTime,compJulday ! extract time info from units string + 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:compcalday ! convert julian day to calendar date USE multiconst,only:secprday ! number of seconds in a day - USE data_struc,only:forcFileInfo ! forcing file info - USE data_struc,only:data_step ! length of the data step (s) - USE data_struc,only:dJulianStart ! julian day of start time of simulation - USE data_struc,only:refTime,refJulday ! reference time - USE data_struc,only:fracJulDay ! fractional julian days since the start of year - USE data_struc,only:yearLength ! number of days in the current year - USE data_struc,only:time_meta,forc_meta ! metadata structures - USE data_struc,only:time_data,time_hru ! time information - USE data_struc,only:forc_data,forc_hru ! forcing data + USE globalData,only:forcFileInfo ! forcing file info + USE globalData,only:data_step ! length of the data step (s) + USE globalData,only:dJulianStart ! julian day of start time of simulation + USE globalData,only:refTime,refJulday ! reference time + 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:time_meta,forc_meta ! metadata structures USE var_lookup,only:iLookTIME,iLookFORCE ! named variables to define structure elements + USE get_ixname_module,only:get_ixforce ! identify index of named variable + USE globalData,only:integerMissing ! integer missing value implicit none - ! define dummy variables + ! define input variables integer(i4b),intent(in) :: istep ! time index AFTER the start index - integer(i4b),intent(in) :: iHRU ! index of hydrologic response unit + integer(i4b),intent(in) :: iHRU_global ! index of global hydrologic response unit + ! 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 + integer(i4b),intent(inout) :: ncid ! netcdf file identifier + ! define output variables + integer(i4b),intent(out) :: time_data(:) ! vector of time data for a given time step + real(dp), intent(out) :: forc_data(:) ! vector of forcing data for a given time step integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! define local variables - integer(i4b),parameter :: imiss= -9999 ! missing integer + ! netcdf related + integer(i4b) :: varId ! variable identifier + integer(i4b) :: dimId ! dimension identifier + integer(i4b) :: mode ! netcdf file mode + integer(i4b) :: dimLen ! dimension length + integer(i4b) :: attLen ! attribute length + character(len = nf90_max_name) :: varName ! dimenison name + integer(i4b) :: ncStart(2) ! start array for reading hru forcing + ! rest real(dp),parameter :: amiss= -1.d+30 ! missing real + real(dp),parameter :: verySmall=1e-3 ! tiny number character(len=256) :: infile ! filename character(len=256) :: cmessage ! error message for downwind routine - logical(lgt) :: xist ! .TRUE. if the file exists - logical(lgt) :: xopn ! .TRUE. if the file is open - integer(i4b),parameter :: baseUnit=28 ! DK: need to either define units globally, or use getSpareUnit - integer(i4b) :: unt ! file unit - integer(i4b) :: untCheck ! check that file unit is what we expect + character(len=256) :: refTimeString ! reference time string integer(i4b) :: iline ! loop through lines in the file - character(len=1024),allocatable :: cline(:) ! a line of data - integer(i4b) :: iStart ! time index st the start of the model simulation - real(dp) :: dsec ! double precision seconds (not used) - real(dp) :: juldayFirst ! julian day of the first time step in the data file + integer(i4b) :: iNC ! loop through variables in forcing file + integer(i4b) :: iVar ! index of forcing variable in forcing data vector real(dp) :: startJulDay ! julian day at the start of the year real(dp) :: currentJulday ! Julian day of current time step logical(lgt),parameter :: checkTime=.false. ! flag to check the time - ! local pointers to data structures - integer(i4b),pointer :: ncols ! number of columns in the forcing data file - integer(i4b),pointer :: time_ix(:) ! column index for time - integer(i4b),pointer :: data_ix(:) ! column index for forcing data + real(dp) :: dataJulDay ! julian day of current forcing data step being read + real(dp) :: varTime(1) ! time variable of current forcing data step being read + integer(i4b) :: nFiles ! number of forcing files + real(dp),allocatable :: fileTime(:) ! array of time from netcdf file + real(dp),allocatable :: diffTime(:) ! array of time differences + !integer(i4b) :: iyyy,im,id ! year, month, day + !integer(i4b) :: ih,imin ! hour, minute + real(dp) :: dsec ! double precision seconds (not used) ! Start procedure here err=0; message="read_force/" + + ! determine the julDay of current model step (istep) we need to read + if(istep==1)then + currentJulDay = dJulianStart + else + currentJulDay = dJulianStart + (data_step*real(iStep-1,dp))/secprday + end if + + ! get the number of forcing files + nFiles=size(forcFileInfo) ! number of forcing files + ! ********************************************************************************************** - ! early return: check if we have the data already - ! NOTE: scalar data structures are pointing to the HRU data structures - if(forcFileInfo(iHRU)%ixFirstHRU > 0)then - time_data = time_hru(forcFileInfo(iHRU)%ixFirstHRU) ! time information - forc_data = forc_hru(forcFileInfo(iHRU)%ixFirstHRU) ! forcing data - return - endif - ! ********************************************************************************************** - ! define the file unit - unt = baseUnit + iHRU - ! define local pointers to data structures - ncols => forcFileInfo(iHRU)%ncols ! number of columns in the forcing data file - time_ix => forcFileInfo(iHRU)%time_ix ! column index for time - data_ix => forcFileInfo(iHRU)%data_ix ! column index for forcing data - ! allocate space for the character vector - allocate(cline(ncols),stat=err) - if (err/=0) then; err=10; message=trim(message)//"problemAllocate"; return; endif - ! define file - infile=trim(INPUT_PATH)//trim(forcFileInfo(iHRU)%filenmData) - ! check if the forcing info file exists - inquire(file=trim(infile),exist=xist) ! Check for existence of forcing datafile - if(.not.xist)then - message=trim(message)//"FileNotFound[file='"//trim(infile)//"']" - err=10; return - endif - ! check if the file is open - inquire(file=trim(infile),opened=xopn) ! Check if the file is open + ! ***** 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 + ! ********************************************************************************************** + ! check if file is open + if(ncid==integerMissing)then ! file is closed if ncid==integerMissing + + ! *** + ! * find first timestep in any of the forcing files... + ! **************************************************** + + ! keep going until we find the file containing the first time step + do iFile=1,nFiles + + ! open netCDF file + call openForcingFile() + + ! how many time steps in current file? + err = nf90_inq_dimid(ncid,'time',dimId); if(err/=nf90_noerr)then; message=trim(message)//'trouble finding time dimension/'//trim(nf90_strerror(err)); return; endif + err = nf90_inquire_dimension(ncid,dimId,len=dimLen); if(err/=nf90_noerr)then; message=trim(message)//'trouble reading time dimension size/'//trim(nf90_strerror(err)); return; endif + + ! allocate space for time vectors + if(allocated(fileTime)) deallocate(fileTime) + if(allocated(diffTime)) deallocate(diffTime) + allocate(fileTime(dimLen),diffTime(dimLen),stat=err) + if(err/=0)then; message=trim(message)//'problem allocating time vectors'; return; end if + + ! read time vector from current file + ! NOTE: This could be faster by checking just the start and the end times + err = nf90_get_var(ncid,varId,fileTime,start=(/1/),count=(/dimLen/)) + if(err/=nf90_noerr)then; message=trim(message)//'trouble reading time vector/'//trim(nf90_strerror(err)); return; endif + + fileTime=fileTime/forcFileInfo(iFile)%convTime2Days + refJulday ! convert time to units of days, and add reference julian day + + ! find difference of fileTime from currentJulday + diffTime=abs(fileTime-currentJulday) + + ! start time is in the current file + if(any(diffTime < verySmall))then + + iRead=minloc(diffTime,1) + exit + + else ! time step is not in current file + + ! close file + err = nf90_close(ncid) + if(err/=nf90_noerr)then; message=trim(message)//'trouble closing file '//trim(infile); return; endif + + ! check that it is not the last file + if(iFile==nFiles)then; err=99; message=trim(message)//'first requested simulation timestep not in any forcing file'; return; end if + + end if ! first time step is not in any forcing files + + end do ! end of search for model first time step in forcing files + + end if ! if the file is not yet open ! ********************************************************************************************** - ! ***** part 1: if file not open, then open file and get to the appropriate position in the file + ! ***** part 1: if file open, check to see if we've reached the end of the file, if so close it, + ! ***** and open new file + ! ***** Then read the data ! ********************************************************************************************** - if(.not.xopn)then - ! open forcing data file - open(unt,file=trim(infile),status="old",action="read",iostat=err) - if(err/=0)then - message=trim(message)//"OpenError['"//trim(infile)//"']" - err=20; return - endif - ! define the reference time for the model simulation - call extractTime(forc_meta(iLookFORCE%time)%varunit, & ! input = units string for time data - refTime%var(iLookTIME%iyyy), & ! output = year - refTime%var(iLookTIME%im), & ! output = month - refTime%var(iLookTIME%id), & ! output = day - refTime%var(iLookTIME%ih), & ! output = hour - refTime%var(iLookTIME%imin),dsec, & ! output = minute/second - err,cmessage) ! output = error code and error message - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - ! convert the reference time to days since the beginning of time - call compjulday(refTime%var(iLookTIME%iyyy), & ! input = year - refTime%var(iLookTIME%im), & ! input = month - refTime%var(iLookTIME%id), & ! input = day - refTime%var(iLookTIME%ih), & ! input = hour - refTime%var(iLookTIME%imin),dsec, & ! input = minute/second - refJulday,err,cmessage) ! output = julian day (fraction of day) + error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - ! identify the start index - time_data%var(:) = imiss - ! read data using free format - read(unt,*,iostat=err) cline - if(err/=0)then; err=20; write(message,'(a,i0,a)')trim(message)//"ProblemLineRead[firstStep]"; return; endif - ! put data in time structure - do iline=1,size(time_ix) - if (time_ix(iline)<1 .or. time_ix(iline)>ncols) cycle - read(cline(time_ix(iline)),*,iostat=err) time_data%var(iline) - if(err/=0)then; err=30; message=trim(message)//"ProblemTimeRead[var='"//trim(time_meta(iline)%varname)//"']"; return; endif - !print*,trim(time_meta(iline)%varname),time_data%var(iline) - end do - ! compute the julian date of the first time index - call compjulday(time_data%var(iLookTIME%iyyy), & ! input = year - time_data%var(iLookTIME%im), & ! input = month - time_data%var(iLookTIME%id), & ! input = day - time_data%var(iLookTIME%ih), & ! input = hour - time_data%var(iLookTIME%imin),dsec, & ! input = minute/second - juldayFirst,err,cmessage) ! output = julian day (fraction of day) + error control - ! compute the start index - iStart = nint( (dJulianStart - juldayFirst)*secprday/data_step ) - if(iStart < 0)then - message=trim(message)//'simulation start time is before the first time index in the datafile ['//trim(infile)//']' - err=20; return - endif - ! read until just before start index - if(iStart /= 0)then - do iline=1,iStart-1 - read(unt,'(a)',iostat=err) - if(err/=0)then; err=20; message=trim(message)//'problemLineRead[is there any data within the simulation period?]'; return; endif + if(ncid>0)then + + ! check to see if we've passed end of netcdf file + if(iRead>forcFileInfo(iFile)%nTimeSteps)then + + ! close the NetCDF file + err = nf90_close(ncid) + if(err/=nf90_noerr)then; message=trim(message)//'problem closing file ['//trim(infile)//']'; return; endif + + ! increment iFile so we open next forcing file + iFile = iFile+1 + + ! open up the forcing file + call openForcingFile() + + ! reset iRead since we opened a new file + iRead=1 + + end if ! if we've passed the end of the NetCDF file + + ! ********************************************************************************************** + ! ***** part 1b: read data + ! ********************************************************************************************** + + ! initialize time and forcing data structures + time_data(:) = integerMissing + forc_data(:) = amiss + + ! read time data from iRead location in netcdf file + err = nf90_inq_varid(ncid,'time',varId); if(err/=nf90_noerr)then; message=trim(message)//'trouble finding time variable/'//trim(nf90_strerror(err)); return; endif + 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 compted julian day matches the time information in the NetCDF file + dataJulDay = varTime(1)/forcFileInfo(iFile)%convTime2Days + refJulday + if(abs(currentJulday - dataJulDay) > verySmall)then + write(message,'(a,i0,f18.8,a,f18.8,a)') trim(message)//'date for time step: ',iStep,dataJulDay,' differs from the expected date: ',currentJulDay,' in file: '//trim(infile) + err=40; return + end if + + ! convert julian day to time vector + call compcalday(dataJulDay, & ! input = julian day + time_data(iLookTIME%iyyy), & ! output = year + time_data(iLookTIME%im), & ! output = month + time_data(iLookTIME%id), & ! output = day + time_data(iLookTIME%ih), & ! output = hour + time_data(iLookTIME%imin),dsec, & ! output = minute/second + err,cmessage) ! output = error control + + ! check to see if any of the time data is missing + if(any(time_data(:)==integerMissing))then + do iline=1,size(time_data) + if(time_data(iline)==integerMissing)then; err=40; message=trim(message)//"variableMissing[var='"//trim(time_meta(iline)%varname)//"']"; return; end if end do - endif - ! handle situation where istep>1 - if (istep>1) then - ! read until just before the time step index - do iline=1,istep-1; read(unt,'(a)'); end do - ! set a warning message - err=-20; message="w-"//trim(message)//"UnexpectedFileOpen" - endif - endif ! if the file is not yet open + end if + + ! setup count,start arrays + ncStart = (/iHRU_global,iRead/) + + ! read data into forcing structure + ! assign the time var, convert days since reference to seconds since reference + forc_data(get_ixforce('time')) = (varTime(1)/forcFileInfo(iFile)%convTime2Days)*secprday + + ! other forcing var + do iNC=1,forcFileInfo(iFile)%nVars + + ! inqure about current variable name + err = nf90_inquire_variable(ncid,iNC,name=varName) + if(err/=nf90_noerr)then; message=trim(message)//'problem finding variable: '//trim(varName)//'/'//trim(nf90_strerror(err)); return; endif + + ! make sure the variable name is one desired + select case(trim(varname)) + case('pptrate','SWRadAtm','LWRadAtm','airtemp','windspd','airpres','spechum') + case default; cycle + end select + + ! get index of forcing variable in forcing data vector + ivar = get_ixforce(trim(varname)) + if(ivar < 0)then; err=40; message=trim(message)//"variableNotFound [var="//trim(varname)//"]"//'/'//trim(nf90_strerror(err)); return; endif + if(ivar > size(forcFileInfo(iFile)%data_id))then; err=40; message=trim(message)//"indexOutOfRange [var="//trim(varname)//"]"//'/'//trim(nf90_strerror(err)); return; endif + + ! get forcing data + err=nf90_get_var(ncid,forcFileInfo(iFile)%data_id(ivar),forc_data(ivar),start=ncStart) + if(err/=nf90_noerr)then; message=trim(message)//'problem inquiring variable: '//trim(varName)//'/'//trim(nf90_strerror(err)); return; endif + end do ! loop through forcing variables + + ! check that the file was in fact open + else + message=trim(message)//'expect the file to be open' + err=20; return + end if ! end ncid open check ! ********************************************************************************************** - ! ***** part 2: read data + ! ***** part 2: compute time ! ********************************************************************************************** - ! initialize time and forcing data structures - time_data%var(:) = imiss - forc_data%var(:) = amiss - ! check that the file unit is what we expect - inquire(file=trim(infile),number=untCheck) - if(unt/=untCheck)then; err=20; message=trim(message)//'unexpected file unit for file ['//trim(infile)//']'; return; endif - ! read data using free format - read(unt,*,iostat=err) cline - if(err/=0)then; err=20; write(message,'(a,i0,a)')trim(message)//"ProblemLineRead[iStep=",istep,"]"; return; endif - ! put data in time structure - do iline=1,size(time_ix) - if (time_ix(iline)<1 .or. time_ix(iline)>ncols) cycle - read(cline(time_ix(iline)),*,iostat=err) time_data%var(iline) - if(err/=0)then; err=30; message=trim(message)//"ProblemTimeRead[var='"//trim(time_meta(iline)%varname)//"']"; return; endif - !print*,trim(time_meta(iline)%varname),time_data%var(iline) - end do - ! check to see if any of the time data is missing - if(any(time_data%var(:)==imiss))then - do iline=1,size(time_ix) - if(time_data%var(iline)==imiss)then; err=40; message=trim(message)//"variableMissing[var='"//trim(time_meta(iline)%varname)//"']"; return; endif - end do - endif - ! put data in forcing structure - do iline=1,size(data_ix) - !print*,data_ix(iline) - if (data_ix(iline)<1 .or. data_ix(iline)>ncols) cycle - read(cline(data_ix(iline)),*,iostat=err) forc_data%var(iline) - if(err/=0)then; err=30; message=trim(message)//"ProblemDataRead[var='"//trim(forc_meta(iline)%varname)//"']"; return; endif - !print*,trim(forc_meta(iline)%varname),forc_data%var(iline) - end do ! compute the julian day at the start of the year - call compjulday(time_data%var(iLookTIME%iyyy), & ! input = year - 1, 1, 1, 1, 0._dp, & ! input = month, day, hour, minute, second + call compjulday(time_data(iLookTIME%iyyy), & ! input = year + 1, 1, 1, 1, 0._dp, & ! input = month, day, hour, minute, second startJulDay,err,cmessage) ! output = julian day (fraction of day) + error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + ! compute the fractional julian day for the current time step - call compjulday(time_data%var(iLookTIME%iyyy), & ! input = year - time_data%var(iLookTIME%im), & ! input = month - time_data%var(iLookTIME%id), & ! input = day - time_data%var(iLookTIME%ih), & ! input = hour - time_data%var(iLookTIME%imin),0._dp, & ! input = minute/second - currentJulday,err,cmessage) ! output = julian day (fraction of day) + error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + call compjulday(time_data(iLookTIME%iyyy), & ! input = year + time_data(iLookTIME%im), & ! input = month + time_data(iLookTIME%id), & ! input = day + time_data(iLookTIME%ih), & ! input = hour + time_data(iLookTIME%imin),0._dp, & ! input = minute/second + 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 - ! compute time since the reference time (in seconds) - forc_data%var(iLookFORCE%time) = (currentJulday-refJulday)*secprday + ! set timing of current forcing vector (in seconds since reference day) + forc_data(iLookFORCE%time) = (currentJulday-refJulday)*secprday + ! compute the number of days in the current year yearLength = 365 - if(mod(time_data%var(iLookTIME%iyyy),4) == 0)then + if(mod(time_data(iLookTIME%iyyy),4) == 0)then yearLength = 366 - if(mod(time_data%var(iLookTIME%iyyy),100) == 0)then + if(mod(time_data(iLookTIME%iyyy),100) == 0)then yearLength = 365 - if(mod(time_data%var(iLookTIME%iyyy),400) == 0)then + if(mod(time_data(iLookTIME%iyyy),400) == 0)then yearLength = 366 - endif - endif - endif + end if + end if + end if + ! check to see if any of the forcing data is missing - if(any(forc_data%var(:). - -module read_icond_module -USE nrtype -! define modeling decisions -USE mDecisions_module,only: & - moisture, & ! moisture-based form of Richards' equation - mixdform ! mixed form of Richards' equation -! define the number of layers -USE data_struc,only:& - nSnow, & ! number of snow layers - nSoil, & ! number of soil layers - nLayers ! total number of layers -implicit none -private -public::read_icond -contains - - - ! ************************************************************************************************ - ! public subroutine read_icond: read model initial conditions - ! ************************************************************************************************ - subroutine read_icond(err,message) - 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) - gravity, & ! gravitational acceleration (m s-2) - Tfreeze ! freezing point of pure water (K) - ! modules - USE snow_utils_module,only:fracliquid ! compute volumetric fraction of liquid water in snow based on temperature - USE snow_utils_module,only:templiquid ! compute temperature of snow based on volumetric fraction of liquid water - USE soil_utils_module,only:volFracLiq ! compute volumetric fraction of liquid water based on matric head - USE soil_utils_module,only:matricHead ! compute matric head based on volumetric fraction of liquid water - USE soil_utils_module,only:crit_soilT ! compute temperature above which all water is unfrozen - USE updatState_module,only:updateSnow ! update snow states - USE updatState_module,only:updateSoil ! update soil states - USE summaFileManager,only:SETNGS_PATH ! path for metadata files - USE summaFileManager,only:MODEL_INITCOND ! model initial conditions file - USE ascii_util_module,only:file_open ! open file - USE ascii_util_module,only:split_line ! extract the list of variable names from the character string - USE ascii_util_module,only:get_vlines ! get a list of character strings from non-comment lines - USE allocspace_module,only:alloc_mvar ! allocate space for model variables - USE allocspace_module,only:alloc_indx ! allocate space for model variables - ! data structures - USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure - USE data_struc,only:mpar_data ! data for model parameetrs - USE data_struc,only:mvar_data,mvar_meta ! data/metadata for model variables - USE data_struc,only:indx_data,indx_meta ! data/metadata for model indices - USE data_struc,only:ix_soil,ix_snow ! named variables to describe the type of layer - USE var_lookup,only:iLookMVAR,iLookPARAM,iLookINDEX ! named variables to describe structure elements - USE get_ixname_module,only:get_ixmvar,get_ixindex ! access function to find index of elements in structure - implicit none - ! define output - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! define local variables - integer(i4b),parameter :: missingInteger=-9999 ! missing value for integers - real(dp),parameter :: missingDouble=-9999._dp ! missing value for double - character(len=256) :: cmessage ! error message for downwind routine - character(LEN=256) :: infile ! input filename - integer(i4b),parameter :: nBand=2 ! number of spectral bands - integer(i4b),parameter :: ix_miss=-999 ! index for missing data - integer(i4b),parameter :: unt=99 ! DK: need to either define units globally, or use getSpareUnit - integer(i4b) :: iline ! loop through lines in the file - integer(i4b) :: iword ! loop through words in a line - integer(i4b),parameter :: maxLines=10000 ! maximum lines in the file - character(LEN=256) :: temp ! single line of information - integer(i4b) :: iend ! check for the end of the file - character(LEN=256) :: namesScalarDesired(10) ! names of desired scalar variables - logical(lgt),allocatable :: checkGotVars(:) ! used to check if we have got desired variables - character(LEN=256),allocatable :: varnames(:) ! vector of variable names - character(LEN=256),allocatable :: chardata(:) ! vector of character data - integer(i4b) :: ivar,jvar ! index of model variable - integer(i4b) :: layerType ! ix_snow or ix_soil - integer(i4b) :: nVars ! number of model variables - integer(i4b) :: iSnow ! index of snow model layers - integer(i4b) :: iSoil ! index of soil model layers - integer(i4b) :: iToto ! index of model layers - character(len=256),parameter :: scalar_tag='scalar_icond' ! tag for the scalar initial conditions - character(len=256),parameter :: layer_tag='layer_icond' ! tag for the layer initial conditions - logical(lgt) :: scalar_flag=.false. ! flag determines if in the scalar portion of the file - logical(lgt) :: layer_flag=.false. ! flag determines if in the layer portion of the file - logical(lgt) :: first_flag=.false. ! flag determines if reading the variable names - ! (ensure the initial conditions are consistent with the constitutive functions) - integer(i4b) :: iLayer ! layer index - real(dp),pointer :: scalarTemp ! temperature (K) - real(dp) :: scalarTheta ! liquid water equivalent of total water [liquid water + ice] (-) - integer(i4b),pointer :: scalarLayerType ! layer type - real(dp) :: scalarPsiLiq ! liquid water matric potential (m) - real(dp),pointer :: scalarVolFracIce ! volumetric fraction of ice (-) - real(dp),pointer :: scalarVolFracLiq ! volumetric fraction of liquid water (-) - real(dp),pointer :: scalarMatricHead ! matric head (m) - real(dp),pointer :: vGn_alpha ! van Genutchen "alpha" parameter - real(dp),pointer :: vGn_n ! van Genutchen "n" parameter - real(dp),pointer :: theta_sat ! soil porosity (-) - real(dp),pointer :: theta_res ! soil residual volumetric water content (-) - real(dp),pointer :: snowfrz_scale ! scaling parameter for the snow freezing curve (K-1) - real(dp),pointer :: FCapil ! fraction of snow pore space in tension storage (-) - real(dp) :: vGn_m ! van Genutchen "m" parameter (-) - real(dp) :: kappa ! constant in the freezing curve function (m K-1) - real(dp) :: maxVolFracLiq ! maximum volumetric fraction of liquid water (used in moisture-based form of Richards' equation) - real(dp) :: h1,h2 ! used to check depth and height are consistent - real(dp),pointer :: scalarCanopyTemp ! canopy temperature (K) - real(dp),pointer :: scalarCanopyIce ! mass of ice on the vegetation canopy (kg m-2) - real(dp),pointer :: scalarCanopyLiq ! mass of liquid water on the vegetation canopy (kg m-2) - real(dp) :: fLiq ! fraction of liquid water on the vegetation canopy (-) - real(dp) :: tWat ! total water on the vegetation canopy (kg m-2) - logical(lgt),parameter :: doPrintStates=.false. ! flag to print states - ! Start procedure here - err=0; message="read_icond/" - ! check the missing data flag is OK - if(ix_miss==ix_snow .or. ix_miss==ix_soil)then; err=20; message=trim(message)//& - 'missing value index is the same as ix_snow or ix_soil'; return; endif - ! allocate space for the variable check vector - allocate(checkGotVars(size(mvar_meta)),stat=err) - if(err/=0)then; err=20; message=trim(message)//'allocating logical check vector'; return; endif - checkGotVars(:) = .false. ! initialize vector - ! define desired scalar variables - if(size(namesScalarDesired)/=10)then - err=20; message=trim(message)//'expect 10 variables in namesScalarDesired'; return - endif - namesScalarDesired( 1) = 'dt_init' - namesScalarDesired( 2) = 'scalarCanopyIce' - namesScalarDesired( 3) = 'scalarCanopyLiq' - namesScalarDesired( 4) = 'scalarCanairTemp' - namesScalarDesired( 5) = 'scalarCanopyTemp' - namesScalarDesired( 6) = 'scalarSnowAlbedo' - namesScalarDesired( 7) = 'scalarSWE' - namesScalarDesired( 8) = 'scalarSnowDepth' - namesScalarDesired( 9) = 'scalarSfcMeltPond' - namesScalarDesired(10) = 'scalarAquiferStorage' - - ! ********************************************************************************************** - ! (1) open files, etc. - ! ********************************************************************************************** - ! build filename - infile = trim(SETNGS_PATH)//trim(MODEL_INITCOND) - ! open file - call file_open(trim(infile),unt,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - ! ********************************************************************************************** - ! (2) identify the number of layers - ! ********************************************************************************************** - nSnow=0 ! initialize the number of snow layers - nSoil=0 ! initialize the number of soil layers - layer_flag=.false. ! initialize layer flag - ! loop through file until reach the layer_tag - do iline=1,maxLines - read(unt,'(a)',iostat=iend)temp; if(iend/=0)then; rewind(unt); exit; endif ! read line of data, and exit if reach the end of file - if (temp(1:1)=='!')cycle - ! check if reached the end of the layer definitions - if(trim(temp)=='')then; rewind(unt); exit; endif - ! read layer data - if(layer_flag) then - ! split the line into an array of words - call split_line(temp,chardata,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - ! check if the line contains initial conditions data (contains the word "snow" or "soil") - do iword=1,size(chardata) - if(chardata(iword)=='snow') nSnow = nSnow+1 - if(chardata(iword)=='soil') nSoil = nSoil+1 - if(chardata(iword)=='snow' .or. chardata(iword)=='soil') exit ! exit once read the layer type - end do - deallocate(chardata) - endif ! if in the layer section of the file - ! check if reached the start of the layer definitions - if (trim(temp)=='') layer_flag=.true. - ! check if reached the end of the file - if (iline==maxLines) rewind(unt) - end do ! looping through lines - nLayers = nSnow + nSoil - ! ********************************************************************************************** - ! (3) allocate space for structure components - ! ********************************************************************************************** - ! (loop through model variables) - do ivar=1,size(mvar_meta) - select case(mvar_meta(ivar)%vartype) - case('scalarv'); allocate(mvar_data%var(ivar)%dat(1),stat=err) - case('wLength'); allocate(mvar_data%var(ivar)%dat(nBand),stat=err) - case('midSnow'); allocate(mvar_data%var(ivar)%dat(nSnow),stat=err) - case('midSoil'); allocate(mvar_data%var(ivar)%dat(nSoil),stat=err) - case('midToto'); allocate(mvar_data%var(ivar)%dat(nLayers),stat=err) - case('ifcSnow'); allocate(mvar_data%var(ivar)%dat(0:nSnow),stat=err) - case('ifcSoil'); allocate(mvar_data%var(ivar)%dat(0:nSoil),stat=err) - case('ifcToto'); allocate(mvar_data%var(ivar)%dat(0:nLayers),stat=err) - case default - err=40; message=trim(message)//"unknownVariableType[name='"//trim(mvar_meta(ivar)%varname)//"'; & - &type='"//trim(mvar_meta(ivar)%vartype)//"']"; return - endselect - if(err/=0)then;err=30;message=trim(message)//"problemAllocate[var='"//trim(mvar_meta(ivar)%varname)//"']"; return; endif - ! fill data with missing values - mvar_data%var(ivar)%dat(:) = missingDouble - end do ! (looping through model variables) - ! (loop through model indices) - do ivar=1,size(indx_meta) - select case(indx_meta(ivar)%vartype) - case('scalarv'); allocate(indx_data%var(ivar)%dat(1),stat=err) - case('midToto'); allocate(indx_data%var(ivar)%dat(nLayers),stat=err) - case default - err=40; message=trim(message)//"unknownVariableType[name='"//trim(indx_meta(ivar)%varname)//"'; & - &type='"//trim(indx_meta(ivar)%vartype)//"']"; return - endselect - if(err/=0)then;err=30;message=trim(message)//"problemAllocate[var='"//trim(indx_meta(ivar)%varname)//"']"; return; endif - ! fill data with missing values - indx_data%var(ivar)%dat(:) = missingInteger - end do ! (loop through model indices) - ! save the number of layers - indx_data%var(iLookINDEX%nSnow)%dat(1) = nSnow - indx_data%var(iLookINDEX%nSoil)%dat(1) = nSoil - indx_data%var(iLookINDEX%nLayers)%dat(1) = nLayers - ! initalize the indices for midSnow, midSoil, midToto, and ifcToto - indx_data%var(iLookINDEX%midSnowStartIndex)%dat(1) = 1 - indx_data%var(iLookINDEX%midSoilStartIndex)%dat(1) = 1 - indx_data%var(iLookINDEX%midTotoStartIndex)%dat(1) = 1 - indx_data%var(iLookINDEX%ifcSnowStartIndex)%dat(1) = 1 - indx_data%var(iLookINDEX%ifcSoilStartIndex)%dat(1) = 1 - indx_data%var(iLookINDEX%ifcTotoStartIndex)%dat(1) = 1 - - ! ============================================================================================== - ! ============================================================================================== - - ! ********************************************************************************************** - ! (4) read the scalar initial conditions - ! ********************************************************************************************** - scalar_flag=.false. ! initialize scalar flag - ! loop through file until reach the scalar_tag - do iline=1,maxLines - read(unt,'(a)',iostat=iend)temp; if(iend/=0)then; rewind(unt); exit; endif ! read line of data, and exit if reach the end of file - if (temp(1:1)=='!')cycle - ! check if reached the end of the scalar definitions - if (trim(temp)=='')then; rewind(unt); exit; endif - ! check if in the scalar portion of the file - if(scalar_flag)then - ! split the line -- variable name followed by variable value - call split_line(temp,chardata,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - ! find the variable -- variable name is first - jvar = get_ixmvar(trim(chardata(1))) - if(jvar<=0)then; err=30; message=trim(message)//'variableNotFound[var='//trim(chardata(1))//']'; return; endif - checkGotVars(jvar)=.true. - ! read the data -- value is second - read(chardata(2),*,iostat=err) mvar_data%var(jvar)%dat(1) - if(err/=0)then; err=40; message=trim(message)//"problemInternalRead[data='"//trim(chardata(2))//"']"; return; endif - deallocate(chardata) - !print*, jVar, trim(mvar_meta(jvar)%vardesc), mvar_data%var(jvar)%dat(1) - endif ! if we are in the scalar part of the file - ! check if reached the start of the scalar definitions - if (trim(temp)=='') scalar_flag=.true. - ! check if reached the end of the file - if (iline==maxLines) rewind(unt) - end do ! looping through lines - ! check if we got the desired scalar variables - do ivar=1,size(namesScalarDesired) - jvar=get_ixmvar(trim(namesScalarDesired(ivar))) - if(.not.checkGotVars(jvar))then - message=trim(message)//'initial condion undefined for variable '//trim(namesScalarDesired(ivar)) - err=20; return - endif - end do - ! initialize the spectral albedo - mvar_data%var(iLookMVAR%spectralSnowAlbedoDiffuse)%dat(1:nBand) = mvar_data%var(iLookMVAR%scalarSnowAlbedo)%dat(1) - ! ********************************************************************************************** - ! (5) read the layer initial conditions - ! ********************************************************************************************** - iSnow=0 ! initialize the index of the snow vector - iSoil=0 ! initialize the index of the soil vector - iToto=0 ! initialize the index of the toto vector - first_flag=.true. ! flag to define first non-comment line, which defines the layer variables - layer_flag=.false. ! initialize layer flag - ! loop through file until reach the layer_tag - do iline=1,maxLines - - read(unt,'(a)',iostat=iend)temp; if(iend/=0)exit ! read line of data, and exit if reach the end of file - if (temp(1:1)=='!')cycle - ! check if reached the end of the layer definitions - if(trim(temp)=='')then; rewind(unt); exit; endif - - ! read layer data - if(layer_flag) then - - ! ***** process the layer names and allocate space for the character data - if(first_flag)then - ! split the line into an array of words - call split_line(temp,varnames,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - ! check that required data are present - if(count(varnames=='layerType' )==0)then; err=50; message=trim(message)//"layerType=missing"; return; endif - if(count(varnames=='mLayerDepth' )==0)then; err=50; message=trim(message)//"mLayerDepth=missing"; return; endif - if(count(varnames=='iLayerHeight' )==0)then; err=50; message=trim(message)//"iLayerHeight=missing"; return; endif - if(count(varnames=='mLayerTemp' )==0)then; err=50; message=trim(message)//"mLayerTemp=missing"; return; endif - if(count(varnames=='mLayerVolFracIce')==0)then; err=50; message=trim(message)//"mLayerVolFracIce=missing"; return; endif - if(count(varnames=='mLayerVolFracLiq')==0)then; err=50; message=trim(message)//"mLayerVolFracLiq=missing"; return; endif - if(count(varnames=='mLayerMatricHead')==0)then; err=50; message=trim(message)//"mLayerMatricHead=missing"; return; endif - ! allocate space for character data - nVars = size(varnames) - allocate(chardata(nVars),stat=err) - if(err/=0)then;err=30;message=trim(message)//"problemAllocateChardata"; return; endif - ! set flag to .false. -- now read data - first_flag=.false. - cycle - endif ! (if reading the variable names - - ! ***** get the vector of data for a given layer - read(temp,*,iostat=err) chardata - if(err/=0)then;err=40;message=trim(message)//"problemInternalRead[data='"//trim(temp)//"']"; return; endif - ! identify the layer type (snow or soil) - layerType=ix_miss - do iword=1,size(chardata) - if(chardata(iword)=='snow') layerType = ix_snow - if(chardata(iword)=='soil') layerType = ix_soil - if(chardata(iword)=='snow' .or. chardata(iword)=='soil') exit ! exit once read the layer type - end do - if(layerType==ix_miss)then; err=40; message=trim(message)//"cannot identify the layer type"; return; endif - ! increment the index of the snow or soil Layer - if(layerType==ix_soil) iSoil = iSoil+1 - if(layerType==ix_snow) iSnow = iSnow+1 - ! increment the index of the concatanated vector - iToto = iToto+1 - ! loop through initial conditions variables - do ivar=1,nVars - ! check if it is the layerType variable (special case) - if(trim(varnames(ivar))=='layerType')then - indx_data%var(iLookINDEX%layerType)%dat(iToto) = layerType - cycle - endif - ! get the variable index - jvar = get_ixmvar(trim(varnames(ivar))) - if(jvar<=0)then; err=40; message=trim(message)//"cannotFindVariableIndex[name='"//trim(varnames(ivar))//"']"; return; endif - ! ***** populate the data variable ***** - select case(trim(mvar_meta(jvar)%vartype)) - case('midSoil'); if(layerType==ix_soil) read(chardata(ivar),*,iostat=err) mvar_data%var(jvar)%dat(iSoil) - case('midSnow'); if(layerType==ix_snow) read(chardata(ivar),*,iostat=err) mvar_data%var(jvar)%dat(iSnow) - case('midToto'); read(chardata(ivar),*,iostat=err) mvar_data%var(jvar)%dat(iToto) - case('ifcSnow'); read(chardata(ivar),*,iostat=err) mvar_data%var(jvar)%dat(iSnow-1) ! IC = top interface - case('ifcSoil'); read(chardata(ivar),*,iostat=err) mvar_data%var(jvar)%dat(iSoil-1) ! IC = top interface - case('ifcToto'); read(chardata(ivar),*,iostat=err) mvar_data%var(jvar)%dat(iToto-1) ! IC = top interface - case default - err=40; message=trim(message)//"unknownInitCondType[name='"//trim(mvar_meta(jvar)%varname)//"']"; return - endselect - if(err/=0)then;err=40;message=trim(message)//"problemInternalRead[data='"//trim(chardata(ivar))//"']"; return; endif - end do ! (looping through initial conditions variables) - endif ! (if layer flag) - ! check if reached the start of the layer definitions - if (trim(temp)=='') layer_flag=.true. - end do ! looping through lines in the file - ! close file - close(unt) - ! set iLayerHeight for the bottom layer - mvar_data%var(iLookMVAR%iLayerHeight)%dat(nLayers) = & - mvar_data%var(iLookMVAR%iLayerHeight)%dat(nLayers-1) + mvar_data%var(iLookMVAR%mLayerDepth)%dat(nLayers) - ! check matric head is read correctly - !print*,'mLayerMatricHead ', mvar_data%var(iLookMVAR%mLayerMatricHead)%dat(:) - ! *************************************************************************************** - ! *************************************************************************************** - ! ensure the snow albedo is realistic - ! *************************************************************************************** - ! *************************************************************************************** - ! ensure the spectral average albedo is realistic - if(mvar_data%var(iLookMVAR%scalarSnowAlbedo)%dat(1) > mpar_data%var(iLookPARAM%albedoMax)) & - mvar_data%var(iLookMVAR%scalarSnowAlbedo)%dat(1) = mpar_data%var(iLookPARAM%albedoMax) - if(mvar_data%var(iLookMVAR%scalarSnowAlbedo)%dat(1) < mpar_data%var(iLookPARAM%albedoMinWinter)) & - mvar_data%var(iLookMVAR%scalarSnowAlbedo)%dat(1) = mpar_data%var(iLookPARAM%albedoMinWinter) - ! ensure the visible albedo is realistic - if(mvar_data%var(iLookMVAR%spectralSnowAlbedoDiffuse)%dat(1) > mpar_data%var(iLookPARAM%albedoMaxVisible)) & - mvar_data%var(iLookMVAR%spectralSnowAlbedoDiffuse)%dat(1) = mpar_data%var(iLookPARAM%albedoMaxVisible) - if(mvar_data%var(iLookMVAR%spectralSnowAlbedoDiffuse)%dat(1) < mpar_data%var(iLookPARAM%albedoMinVisible)) & - mvar_data%var(iLookMVAR%spectralSnowAlbedoDiffuse)%dat(1) = mpar_data%var(iLookPARAM%albedoMinVisible) - ! ensure the nearIR albedo is realistic - if(mvar_data%var(iLookMVAR%spectralSnowAlbedoDiffuse)%dat(2) > mpar_data%var(iLookPARAM%albedoMaxNearIR)) & - mvar_data%var(iLookMVAR%spectralSnowAlbedoDiffuse)%dat(2) = mpar_data%var(iLookPARAM%albedoMaxNearIR) - if(mvar_data%var(iLookMVAR%spectralSnowAlbedoDiffuse)%dat(2) < mpar_data%var(iLookPARAM%albedoMinNearIR)) & - mvar_data%var(iLookMVAR%spectralSnowAlbedoDiffuse)%dat(2) = mpar_data%var(iLookPARAM%albedoMinNearIR) - ! *************************************************************************************** - ! *************************************************************************************** - ! ensure the initial conditions are consistent with the constitutive functions - ! *************************************************************************************** - ! *************************************************************************************** - ! assign pointers to model parameters - vGn_alpha => mpar_data%var(iLookPARAM%vGn_alpha) ! van Genutchen "alpha" parameter (m-1) - vGn_n => mpar_data%var(iLookPARAM%vGn_n) ! van Genutchen "n" parameter (-) - theta_sat => mpar_data%var(iLookPARAM%theta_sat) ! soil porosity (-) - theta_res => mpar_data%var(iLookPARAM%theta_res) ! soil residual volumetric water content (-) - snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale) ! scaling parameter for the snow freezing curve (K-1) - FCapil => mpar_data%var(iLookPARAM%FCapil) ! fraction of pore space in tension storage (-) - ! compute the maximum volumetric fraction of liquid water -- used to avoid problems of super-saturation in the moisture-based form of Richards' equation - maxVolFracLiq = theta_sat - 1.e-4_dp - ! compute the van Genutchen "m" parameter (-) - vGn_m = 1._dp - 1._dp/vGn_n - ! compute the constant in the freezing curve function (m K-1) - kappa = (iden_ice/iden_water)*(LH_fus/(gravity*Tfreeze)) ! NOTE: J = kg m2 s-2 - - ! modify the liquid water and ice in the canopy - scalarCanopyTemp => mvar_data%var(iLookMVAR%scalarCanopyTemp)%dat(1) ! canopy temperature - scalarCanopyIce => mvar_data%var(iLookMVAR%scalarCanopyIce)%dat(1) ! mass of ice on the vegetation canopy (kg m-2) - scalarCanopyLiq => mvar_data%var(iLookMVAR%scalarCanopyLiq)%dat(1) ! mass of liquid water on the vegetation canopy (kg m-2) - if(scalarCanopyIce > 0._dp .and. scalarCanopyTemp > Tfreeze)then - message=trim(message)//'canopy ice > 0 when canopy temperature > Tfreeze' - err=20; return - endif - fLiq = fracliquid(scalarCanopyTemp,snowfrz_scale) ! fraction of liquid water (-) - tWat = scalarCanopyLiq + scalarCanopyIce ! total water (kg m-2) - scalarCanopyLiq = fLiq*tWat ! mass of liquid water on the canopy (kg m-2) - scalarCanopyIce = (1._dp - fLiq)*tWat ! mass of ice on the canopy (kg m-2) - - ! loop through all layers - do iLayer=1,nLayers - ! define short-cuts - scalarTemp => mvar_data%var(iLookMVAR%mLayerTemp)%dat(iLayer) ! temperature (K) - scalarVolFracLiq => mvar_data%var(iLookMVAR%mLayerVolFracLiq)%dat(iLayer) ! volumetric fraction of liquid water in each snow layer (-) - scalarVolFracIce => mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat(iLayer) ! volumetric fraction of ice in each snow layer (-) - scalarLayerType => indx_data%var(iLookINDEX%layerType)%dat(iLayer) ! type of layer (ix_soil or ix_snow) - ! compute liquid water equivalent of total water (liquid plus ice) - scalarTheta = scalarVolFracIce*(iden_ice/iden_water) + scalarVolFracLiq - - ! check that the initial volumetric fraction of liquid water and ice is reasonable - select case(scalarLayerType) - ! ***** snow - case(ix_snow) - ! (check liquid water) - if(scalarVolFracLiq < 0._dp .or. scalarVolFracLiq > 1._dp)then - write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water < 0 or > 1: layer = ',iLayer - err=20; return - endif - ! (check ice) - if(scalarVolFracIce < 0.05_dp .or. scalarVolFracIce > 0.80_dp)then - write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice < 0.05 or > 0.70: layer = ',iLayer - err=20; return - endif - ! check total water - if(scalarTheta < 0.05_dp .or. scalarTheta > 0.80_dp)then - write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with theta (total water fraction [liquid + ice]) < 0.05 or > 0.70: layer = ',iLayer - err=20; return - endif - - ! ***** soil - case(ix_soil) - ! (check liquid water) - if(scalarVolFracLiq < theta_res .or. scalarVolFracLiq > theta_sat)then - write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of liquid water < theta_res or > theta_sat: layer = ',iLayer - err=20; return - endif - ! (check ice) - if(scalarVolFracIce < 0._dp .or. scalarVolFracIce > theta_sat)then - write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with volumetric fraction of ice < 0 or > theta_sat: layer = ',iLayer - err=20; return - endif - ! check total water - if(scalarTheta < theta_res .or. scalarTheta > theta_sat)then - write(message,'(a,1x,i0)') trim(message)//'cannot initialize the model with theta (total water fraction [liquid + ice]) < theta_res or > theta_sat: layer = ',iLayer - err=20; return - endif - - case default; err=20; message=trim(message)//'cannot identify layer type'; return - - end select - - ! process snow and soil separately - select case(scalarLayerType) - - ! ** snow - case(ix_snow) - ! check that snow temperature is less than freezing - if(scalarTemp > Tfreeze)then - message=trim(message)//'initial snow temperature is greater than freezing' - err=20; return - endif - ! compute the residual volumetric fraction of liquid water based on the specified volumetric fraction of ice - !residlVolFracLiq = FCapil*(1._dp - scalarVolFracIce) ! "residual" volumetric liquid water content (i.e., tension storage) - ! compute volumetric fraction of liquid water and ice based on temperature - !!scalarVolFracLiq = fracliquid(scalarTemp,snowfrz_scale)*scalarTheta ! volumetric fraction of liquid water - !!scalarVolFracIce = (scalarTheta - scalarVolFracLiq)*(iden_water/iden_ice) ! volumetric fraction of ice - ! check that the volumetric liquid water content is not greater than tension storage - !!if(scalarVolFracLiq > residlVolFracLiq)then - !! scalarVolFracLiq = residlVolFracLiq ! set volumetric liquid water content to tension storage - !! scalarVolFracIce = (scalarTheta - scalarVolFracLiq)*(iden_water/iden_ice) ! compute corresponding ice volume to maintain mass - !! scalarTemp = templiquid(scalarVolFracLiq/scalarTheta,snowfrz_scale) ! identify the temperature associated with tension storage - !!endif ! (if liquid water content > tension storage) - ! ensure consistency among state variables - call updateSnow(& - ! input - scalarTemp ,& ! intent(in): temperature (K) - scalarVolFracLiq+scalarVolFracIce*(iden_ice/iden_water) ,& ! intent(in): mass fraction of total water (-) - snowfrz_scale ,& ! intent(in): scaling parameter for the snow freezing curve (K-1) - ! output - scalarVolFracLiq ,& ! intent(out): volumetric fraction of liquid water (-) - scalarVolFracIce ,& ! 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; endif ! (check for errors) - - ! ** soil - case(ix_soil) - ! assign pointers to model state variables - scalarTemp => mvar_data%var(iLookMVAR%mLayerTemp)%dat(iLayer) ! temperature (K) - scalarMatricHead => mvar_data%var(iLookMVAR%mLayerMatricHead)%dat(iLayer-nSnow) ! matric head (m) - scalarVolFracLiq => mvar_data%var(iLookMVAR%mLayerVolFracLiq)%dat(iLayer) ! volumetric fraction of liquid water in each soil layer (-) - scalarVolFracIce => mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat(iLayer) ! volumetric fraction of ice in each soil layer (-) - ! ensure consistency among state variables - call updateSoil(& - ! input - scalarTemp, & ! intent(in): layer temperature (K) - scalarMatricHead, & ! intent(in): matric head (m) - vGn_alpha,vGn_n,theta_sat,theta_res,vGn_m, & ! intent(in): van Genutchen soil parameters - ! output - scalarPsiLiq, & ! intent(out): liquid water matric potential (m) - scalarVolFracLiq, & ! intent(out): volumetric fraction of liquid water (-) - scalarVolFracIce, & ! intent(out): volumetric fraction of ice (-) - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (check for errors) - case default; err=10; message=trim(message)//'unknown case for model layer'; return - endselect - end do ! (looping through layers) - ! if snow layers exist, compute snow depth and SWE - if(nSnow > 0)then - mvar_data%var(iLookMVAR%scalarSnowDepth)%dat(1) = -mvar_data%var(iLookMVAR%iLayerHeight)%dat(0) - mvar_data%var(iLookMVAR%scalarSWE)%dat(1) = sum( (mvar_data%var(iLookMVAR%mLayerVolFracLiq)%dat(1:nSnow)*iden_water + & - mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat(1:nSnow)*iden_ice) & - * mvar_data%var(iLookMVAR%mLayerDepth)%dat(1:nSnow) ) - endif ! (if snow layers exist - ! check that the layering is consistent - do iLayer=1,nLayers - h1 = sum(mvar_data%var(iLookMVAR%mLayerDepth)%dat(1:iLayer)) ! sum of the depths up to the current layer - h2 = mvar_data%var(iLookMVAR%iLayerHeight)%dat(iLayer) - mvar_data%var(iLookMVAR%iLayerHeight)%dat(0) ! difference between snow-atm interface and bottom of layer - !write(*,'(a,1x,10(e20.10,1x))') 'h1, h2, (h1 - h2) = ', h1, h2, (h1 - h2) - if(abs(h1 - h2) > 1.e-12_dp)then - write(message,'(a,1x,i0)') trim(message)//'mis-match between layer depth and layer height [suggest round numbers in initial conditions file]; layer = ', iLayer - err=20; return - endif - end do - ! ********************************************************************************************** - ! deallocate variable names vector - deallocate(varnames,chardata,stat=err) - if(err/=0)then;err=30;message=trim(message)//'deallocating variable names vector'; return; endif - ! deallocate variable check vector - deallocate(checkGotVars,stat=err) - if(err/=0)then; err=20; message=trim(message)//'deallocating logical check vector'; return; endif - ! print states - if(doPrintStates)then - print*,'****************************************************************************************' - print*, 'mLayerDepth ', mvar_data%var(iLookMVAR%mLayerDepth)%dat(:) - print*, 'iLayerHeight ', mvar_data%var(iLookMVAR%iLayerHeight)%dat(:) - print*, 'mLayerTemp ', mvar_data%var(iLookMVAR%mLayerTemp)%dat(:) - print*, 'mLayerVolFracIce ', mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat(:) - print*, 'mLayerVolFracLiq ', mvar_data%var(iLookMVAR%mLayerVolFracLiq)%dat(:) - print*, 'mLayerMatricHead ', mvar_data%var(iLookMVAR%mLayerMatricHead)%dat(:) - print*, 'scalarCanopyIce ', mvar_data%var(iLookMVAR%scalarCanopyIce)%dat(:) - print*, 'scalarCanopyLiq ', mvar_data%var(iLookMVAR%scalarCanopyLiq)%dat(:) - print*, 'scalarCanairTemp ', mvar_data%var(iLookMVAR%scalarCanairTemp)%dat(:) - print*, 'scalarCanopyTemp ', mvar_data%var(iLookMVAR%scalarCanopyTemp)%dat(:) - print*, 'scalarSnowAlbedo ', mvar_data%var(iLookMVAR%scalarSnowAlbedo)%dat(:) - print*, 'scalarSnowDepth ', mvar_data%var(iLookMVAR%scalarSnowDepth)%dat(:) - print*, 'scalarSWE ', mvar_data%var(iLookMVAR%scalarSWE)%dat(:) - print*, 'layerType ', indx_data%var(iLookINDEX%layerType)%dat(:) - print*,'****************************************************************************************' - !pause - endif ! (if printing states) - end subroutine read_icond - - -end module read_icond_module diff --git a/build/source/engine/read_param.f90 b/build/source/engine/read_param.f90 old mode 100644 new mode 100755 index aff0d5b68..f6f297d18 --- a/build/source/engine/read_param.f90 +++ b/build/source/engine/read_param.f90 @@ -19,7 +19,26 @@ ! along with this program. If not, see . module read_param_module + +! missing values +USE globalData,only:integerMissing ! missing integer +USE globalData,only:realMissing ! missing real number + +! runtime options +USE globalData,only:iRunModeFull,iRunModeGRU,iRunModeHRU ! run modes + +! common modules USE nrtype +USE netcdf +USE netcdf_util_module,only:nc_file_close ! close netcdf file +USE netcdf_util_module,only:nc_file_open ! open netcdf file +USE netcdf_util_module,only:netcdf_err ! netcdf error handling function + +! data types +USE data_types,only:gru_double ! spatial double data type: x%gru(:)%var(:) +USE data_types,only:gru_hru_int ! spatial integer data type: x%gru(:)%hru(:)%var(:) +USE data_types,only:gru_hru_doubleVec ! spatial double data type: x%gru(:)%hru(:)%var(:)%dat(:) + implicit none private public::read_param @@ -29,154 +48,314 @@ module read_param_module ! ************************************************************************************************ ! public subroutine read_param: read trial model parameter values ! ************************************************************************************************ - subroutine read_param(nHRU,err,message) + subroutine read_param(iRunMode,checkHRU,startGRU,nHRU,nGRU,typeStruct,mparStruct,bparStruct,err,message) ! used to read model initial conditions USE summaFileManager,only:SETNGS_PATH ! path for metadata files USE summaFileManager,only:PARAMETER_TRIAL ! file with parameter trial values - USE ascii_util_module,only:file_open ! open file - USE ascii_util_module,only:split_line ! extract the list of variable names from the character string - USE ascii_util_module,only:get_vlines ! get a list of character strings from non-comment lines - USE get_ixname_module,only:get_ixparam ! access function to find index of elements in structure - USE pOverwrite_module,only:pOverwrite ! module to overwrite default parameter values with info from the Noah tables - USE data_struc,only:mpar_data,mpar_hru ! data for local column model parameter sets - USE data_struc,only:localParFallback ! default values and constraints for local column model parameters - USE data_struc,only:type_hru ! data structure for categorical data + USE get_ixname_module,only:get_ixparam,get_ixbpar ! access function to find index of elements in structure + USE globalData,only:index_map,gru_struc ! mapping from global HRUs to the elements in the data structures USE var_lookup,only:iLookPARAM,iLookTYPE ! named variables to index elements of the data vectors implicit none + ! define input + integer(i4b), intent(in) :: iRunMode ! run mode + integer(i4b), intent(in) :: checkHRU ! index of single HRU if runMode = checkHRU + integer(i4b), intent(in) :: startGRU ! index of single GRU if runMode = startGRU + integer(i4b), intent(in) :: nHRU ! number of global HRUs + integer(i4b), intent(in) :: nGRU ! number of global GRUs + type(gru_hru_int), intent(in) :: typeStruct ! local classification of soil veg etc. for each HRU ! define output - integer(i4b),intent(in) :: nHRU ! number of HRUs - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + type(gru_hru_doubleVec),intent(inout) :: mparStruct ! model parameters + type(gru_double) ,intent(inout) :: bparStruct ! basin parameters + integer(i4b), intent(out) :: err ! error code + character(*), intent(out) :: message ! error message ! define local variables - character(len=1024) :: cmessage ! error message for downwind routine - character(LEN=1024) :: infile ! input filename - integer(i4b),parameter :: unt=99 ! DK: need to either define units globally, or use getSpareUnit - integer(i4b) :: iline ! loop through lines in the file - integer(i4b),parameter :: maxLines=1000 ! maximum lines in the file - integer(i4b) :: iend ! check for the end of the file - integer(i4b),parameter :: sLen=2048 ! string length for line of parameter data - character(LEN=sLen) :: temp ! single line of information - character(LEN=sLen),allocatable :: charline(:) ! vector of character strings - character(LEN=64),allocatable :: varnames(:) ! vector of variable names - character(LEN=64),allocatable :: chardata(:) ! vector of character data - logical(lgt) :: checkHRU(nHRU) ! vector of flags to check that an HRU will be populated with parameter data - integer(i4b) :: hruIndex ! HRU identifier - integer(i4b) :: iHRU,jHRU,kHRU ! index of HRU within data vector - integer(i4b) :: ipar,jpar ! index of model parameter - integer(i4b) :: nPars ! number of model parameters + character(len=1024) :: cmessage ! error message for downwind routine + character(LEN=1024) :: infile ! input filename + integer(i4b) :: iHRU ! index of HRU within data vector + integer(i4b) :: localHRU,iGRU ! index of HRU and GRU within data structure + integer(i4b) :: ixParam ! index of the model parameter in the data structure + ! indices/metadata in the NetCDF file + integer(i4b) :: ncid ! netcdf id + integer(i4b) :: nDims ! number of dimensions + integer(i4b) :: nVars ! number of variables + integer(i4b) :: idimid ! dimension index + integer(i4b) :: ivarid ! variable index + character(LEN=64) :: dimName ! dimension name + character(LEN=64) :: parName ! parameter name + integer(i4b) :: dimLength ! dimension length + integer(i4b) :: nHRU_file ! number of HRUs in the parafile + integer(i4b) :: nGRU_file ! number of GRUs in the parafile + integer(i4b) :: nSoil_file ! number of soil layers in the file + integer(i4b) :: idim_list(2) ! list of dimension ids + ! data in the netcdf file + integer(i4b) :: parLength ! length of the parameter data + integer(i4b),allocatable :: hruId(:) ! HRU identifier in the file + real(dp),allocatable :: parVector(:) ! model parameter vector + logical :: fexist ! inquire whether the parmTrial file exists + integer(i4b) :: fHRU ! index of HRU in input file + ! Start procedure here err=0; message="read_param/" + ! ********************************************************************************************** - ! (1) open files, etc. + ! * open files, etc. ! ********************************************************************************************** + ! build filename infile = trim(SETNGS_PATH)//trim(PARAMETER_TRIAL) + + ! do we need the file? + inquire(file=trim(infile),exist=fexist) + if (.not.fexist) return + ! open file - call file_open(trim(infile),unt,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - ! ********************************************************************************************** - ! (2) read the parameter names - ! ********************************************************************************************** - ! loop through file until reach the first non-comment line (list of variable names) - do iline=1,maxLines - read(unt,'(a)',iostat=iend)temp; if(iend/=0)exit ! read line of data - if (temp(1:1)=='!')cycle - ! extract the list of variable names from the character string - call split_line(temp,varnames,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - exit + call nc_file_open(trim(infile),nf90_nowrite,ncid,err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + + ! get the number of variables in the parameter file + err=nf90_inquire(ncid, nDimensions=nDims, nVariables=nVars) + call netcdf_err(err,message); if (err/=0) then; err=20; return; end if + + ! initialize the number of HRUs + nHRU_file=integerMissing + nGRU_file=integerMissing + + ! get the length of the dimensions + do idimid=1,nDims + ! get the dimension name and length + err=nf90_inquire_dimension(ncid, idimid, name=dimName, len=dimLength) + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + ! get the number of HRUs + if(trim(dimName)=='hru') nHRU_file=dimLength + if(trim(dimName)=='gru') nGRU_file=dimLength end do - ! save the number of parameters - nPars = size(varnames) - ! check that there are at least 2 "words" -- must modify at least one parameter - if(nPars < 2)then - message=trim(message)//'expect need to modify at least one parameter [file = '//trim(infile)//']' + + ! allocate hruID vector + allocate(hruId(nHRU_file)) + + ! check HRU dimension exists + if(nHRU_file==integerMissing)then + message=trim(message)//'unable to identify HRU dimension in file '//trim(infile) + err=20; return + endif + + ! check have the correct number of HRUs + if ((irunMode==irunModeFull).and.(nHRU_file/=nHRU)) then + message=trim(message)//'incorrect number of HRUs in file '//trim(infile) err=20; return endif - ! check that the first parameter is the HRU index - if(varnames(1) /= 'hruIndex')then - message=trim(message)//'expect first parameter name to be the HRU index [file = '//trim(infile)//']' + if ((irunMode==irunModeHRU).and.(nHRU_file0).and.(hruId(iHRU)/=typeStruct%gru(iGRU)%hru(localHRU)%var(iLookTYPE%hruIndex)))then + write(message,'(a,i0,a,i0,a)') trim(message)//'mismatch for HRU ', typeStruct%gru(iGRU)%hru(localHRU)%var(iLookTYPE%hruIndex), '(param HRU = ', hruId(iHRU), ')' + err=20; return + endif + end do ! looping through HRUs + + else if (iRunMode==iRunModeGRU) then + do iHRU=1,nHRU + iGRU=index_map(iHRU)%gru_ix + localHRU=index_map(iHRU)%localHRU + fHRU = gru_struc(iGRU)%hruInfo(localHRU)%hru_nc + if(hruId(fHRU)/=typeStruct%gru(iGRU)%hru(localHRU)%var(iLookTYPE%hruIndex))then + write(message,'(a,i0,a,i0,a)') trim(message)//'mismatch for HRU ', typeStruct%gru(iGRU)%hru(localHRU)%var(iLookTYPE%hruIndex), '(param HRU = ', hruId(iHRU), ')' + err=20; return + endif + enddo + + else if (iRunMode==iRunModeHRU) then + iGRU=index_map(1)%gru_ix + localHRU=index_map(1)%localHRU + if(hruId(checkHRU)/=typeStruct%gru(iGRU)%hru(localHRU)%var(iLookTYPE%hruIndex))then + write(message,'(a,i0,a,i0,a)') trim(message)//'mismatch for HRU ', typeStruct%gru(iGRU)%hru(localHRU)%var(iLookTYPE%hruIndex), '(param HRU = ', hruId(iHRU), ')' + err=20; return + endif + + ! error check + else + err = 20; message = 'run mode not recognized'; return; + end if + + endif ! if the HRU id + + end do ! looping through variables in the file + + ! ********************************************************************************************** + ! * read the local parameters and the basin parameters + ! ********************************************************************************************** + + ! loop through the parameters in the NetCDF file + do ivarid=1,nVars + + ! get the parameter name + err=nf90_inquire_variable(ncid, ivarid, name=parName) + call netcdf_err(err,message); if (err/=0) then; err=20; return; end if + + ! get the local parameters + ixParam = get_ixparam( trim(parName) ) + if(ixParam/=integerMissing)then + + ! ********************************************************************************************** + ! * read the local parameters + ! ********************************************************************************************** + + ! get the variable shape + err=nf90_inquire_variable(ncid, ivarid, nDims=nDims, dimids=idim_list) + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + + ! get the length of the depth dimension (if it exists) + if(nDims==2)then + + ! get the information on the 2nd dimension for 2-d variables + err=nf90_inquire_dimension(ncid, idim_list(2), dimName, nSoil_file) + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + + ! check that it is the depth dimension + if(trim(dimName)/='depth')then + message=trim(message)//'expect 2nd dimension of 2-d variable to be depth (dimension name = '//trim(dimName)//')' + err=20; return + endif + + ! check that the dimension length is correct + if(size(mparStruct%gru(iGRU)%hru(localHRU)%var(ixParam)%dat) /= nSoil_file)then + message=trim(message)//'unexpected number of soil layers in parameter file' + err=20; return + endif + + ! define parameter length + parLength = nSoil_file + + else + parLength = 1 + endif ! if two dimensions + + ! allocate space for model parameters + allocate(parVector(parLength),stat=err) + if(err/=0)then + message=trim(message)//'problem allocating space for parameter vector' + err=20; return + endif + + ! loop through HRUs + do iHRU=1,nHRU + + ! map to the GRUs and HRUs + iGRU=index_map(iHRU)%gru_ix + localHRU=index_map(iHRU)%localHRU + fHRU = gru_struc(iGRU)%hruInfo(localHRU)%hru_nc + + ! read parameter data + select case(nDims) + case(1); err=nf90_get_var(ncid, ivarid, parVector, start=(/fHRU/), count=(/1/) ) + case(2); err=nf90_get_var(ncid, ivarid, parVector, start=(/fHRU,1/), count=(/1,nSoil_file/) ) + case default; err=20; message=trim(message)//'unexpected number of dimensions for parameter '//trim(parName) + end select + + ! error check for the parameter read + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + + ! populate parameter structures + select case(nDims) + case(1); mparStruct%gru(iGRU)%hru(localHRU)%var(ixParam)%dat(:) = parVector(1) ! also distributes scalar across depth dimension + case(2); mparStruct%gru(iGRU)%hru(localHRU)%var(ixParam)%dat(:) = parVector(:) + case default; err=20; message=trim(message)//'unexpected number of dimensions for parameter '//trim(parName) + end select + + end do ! looping through HRUs + + ! deallocate space for model parameters + deallocate(parVector,stat=err) + if(err/=0)then + message=trim(message)//'problem deallocating space for parameter vector' + err=20; return endif - if(jHRU == nHRU)then ! we get to here if we have tested the last HRU and have not exited the loop - write(message,'(a,i0,a)') trim(message)//'unable to identify HRU in parameter file [index = ',hruIndex,'; file='//trim(infile)//']' + + ! ********************************************************************************************** + ! * read the basin parameters + ! ********************************************************************************************** + + ! get the basin parameters + else + + ! get the parameter index + ixParam = get_ixbpar( trim(parName) ) + + ! allow extra variables in the file that are not used + if(ixParam==integerMissing) cycle + + ! allocate space for model parameters + allocate(parVector(nGRU_file),stat=err) + if(err/=0)then + message=trim(message)//'problem allocating space for parameter vector' err=20; return endif - end do - ! assign mpar_data to the given parameter set - mpar_data => mpar_hru(kHRU) - ! ***** overwrite default model parameters with information from the Noah-MP tables - call pOverwrite(type_hru(kHRU)%var(iLookTYPE%vegTypeIndex), & ! vegetation category - type_hru(kHRU)%var(iLookTYPE%soilTypeIndex), & ! soil category - err,cmessage) ! error control - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif - ! ***** populate parameter set with default model parameters ***** - mpar_data%var(:) = localParFallback(:)%default_val - - ! loop through the model parameters - do ipar=2,nPars ! start at #2 because the first "word" is the HRU index - ! get the variable index - jpar = get_ixparam(trim(varnames(ipar))) - if(jpar<=0)then; err=40; message=trim(message)//"cannotFindVariableIndex[name='"//trim(varnames(ipar))//"']"; return; endif - ! populate the appropriate element of the parameter vector - read(chardata(ipar),*,iostat=err) mpar_data%var(jpar) - if(err/=0)then;err=40;message=trim(message)//"problemInternalRead[data='"//trim(chardata(ipar))//"']"; return; endif - !print*, trim(varnames(ipar)), mpar_data%var(jpar) - end do ! (looping through model parameters) - !write(*,'(a,2(i4,1x),2(f20.10,1x))') 'in read_param 2: iHRU, kHRU, mpar_data%var(iLookPARAM%zmaxLayer1_upper), mpar_hru(kHRU)%var(iLookPARAM%zmaxLayer1_upper) = ', & - ! iHRU, kHRU, mpar_data%var(iLookPARAM%zmaxLayer1_upper), mpar_hru(kHRU)%var(iLookPARAM%zmaxLayer1_upper) - end do ! (looping through HRUs) - ! check that all HRUs are populated - if(count(checkHRU) /= nHRU)then - do iHRU=1,nHRU - if(.not.checkHRU(iHRU))then - write(message,'(a,i0,a)') trim(message)//'unable to identify HRU in parameter file [index = ',type_hru(iHRU)%var(iLookTYPE%hruIndex),'; file='//trim(infile)//']' + + ! read parameter data + err=nf90_get_var(ncid, ivarid, parVector ) + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + + ! populate parameter structures + if (iRunMode==iRunModeGRU) then + do iGRU=1,nGRU + bparStruct%gru(iGRU)%var(ixParam) = parVector(iGRU+startGRU-1) + end do ! looping through GRUs + else if (iRunMode==iRunModeFull) then + do iGRU=1,nGRU + bparStruct%gru(iGRU)%var(ixParam) = parVector(iGRU) + end do ! looping through GRUs + else if (iRunMode==iRunModeHRU) then + err = 20; message='checkHRU run mode not working'; return; + endif + + ! deallocate space for model parameters + deallocate(parVector,stat=err) + if(err/=0)then + message=trim(message)//'problem deallocating space for parameter vector' err=20; return endif - end do ! looping through HRUs - endif ! if some HRUs are not populated - ! ********************************************************************************************** - deallocate(varnames,charline,chardata,stat=err) - if(err/=0)then;err=30;message=trim(message)//"problemDeallocate"; return; endif - ! ********************************************************************************************** - end subroutine read_param + endif ! reading the basin parameters + + end do ! (looping through the parameters in the NetCDF file) + + end subroutine read_param end module read_param_module diff --git a/build/source/engine/read_pinit.f90 b/build/source/engine/read_pinit.f90 old mode 100644 new mode 100755 index 8e2bf8829..6c658a236 --- a/build/source/engine/read_pinit.f90 +++ b/build/source/engine/read_pinit.f90 @@ -20,6 +20,11 @@ module read_pinit_module USE nrtype +! check for when model decisions are undefined +USE mDecisions_module,only: unDefined +USE globalData,only:model_decisions +USE globalData,only:realMissing +USE var_lookup,only:iLookDECISIONS,iLookPARAM implicit none private public::read_pinit @@ -34,35 +39,34 @@ subroutine read_pinit(filenm,isLocal,mpar_meta,parFallback,err,message) USE summaFileManager,only:SETNGS_PATH ! path for metadata files USE ascii_util_module,only:file_open ! open ascii file USE ascii_util_module,only:split_line ! extract the list of variable names from the character string - USE data_struc,only:var_info ! data type for metadata - USE data_struc,only:par_info ! data type for parameter constraints + USE data_types,only:var_info ! data type for metadata + USE data_types,only:par_info ! data type for parameter constraints USE get_ixname_module,only:get_ixParam ! identify index of named variable for local column model parameters USE get_ixname_module,only:get_ixBpar ! identify index of named variable for basin-average model parameters implicit none ! define input - character(*),intent(in) :: filenm ! name of file containing default values and constraints of model parameters - logical(lgt),intent(in) :: isLocal ! .true. if the file describes local column parameters - type(var_info),pointer,intent(in) :: mpar_meta(:) ! metadata for model parameters + character(*),intent(in) :: filenm ! name of file containing default values and constraints of model parameters + logical(lgt),intent(in) :: isLocal ! .true. if the file describes local column parameters + type(var_info),intent(in) :: mpar_meta(:) ! metadata for model parameters ! define output - type(par_info),pointer,intent(out) :: parFallback(:) ! default values and constraints of model parameters - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + type(par_info),intent(out) :: parFallback(:) ! default values and constraints of model parameters + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message ! define general variables - logical(lgt),parameter :: backwardsCompatible=.true. ! .true. if skip check that all parameters are populated - real(dp),parameter :: amiss=1.d+30 ! missing data - character(len=256) :: cmessage ! error message for downwind routine - character(LEN=256) :: infile ! input filename - integer(i4b),parameter :: unt=99 ! DK: need to either define units globally, or use getSpareUnit - integer(i4b) :: iline ! loop through lines in the file - integer(i4b),parameter :: maxLines=1000 ! maximum lines in the file - character(LEN=256) :: temp ! single line of information + logical(lgt),parameter :: backwardsCompatible=.false. ! .true. if skip check that all parameters are populated + 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) + integer(i4b) :: iline ! loop through lines in the file + integer(i4b),parameter :: maxLines=1000 ! maximum lines in the file + character(LEN=256) :: temp ! single line of information ! define local variables for the default model parameters - integer(i4b) :: iend ! check for the end of the file - character(LEN=256) :: ffmt ! file format - character(LEN=32) :: varname ! name of variable - type(par_info) :: parTemp ! temporary parameter structure - character(len=2) :: dLim ! column delimiter - integer(i4b) :: ivar ! index of model variable + integer(i4b) :: iend ! check for the end of the file + character(LEN=256) :: ffmt ! file format + character(LEN=32) :: varname ! name of variable + type(par_info) :: parTemp ! temporary parameter structure + character(LEN=2) :: dLim ! column delimiter + integer(i4b) :: ivar ! index of model variable ! Start procedure here err=0; message="read_pinit/" ! ********************************************************************************************** @@ -71,35 +75,30 @@ subroutine read_pinit(filenm,isLocal,mpar_meta,parFallback,err,message) ! build filename and update error message infile = trim(SETNGS_PATH)//trim(filenm) message=trim(message)//'file='//trim(infile)//' - ' + write(*,'(a)') trim(infile) ! open file call file_open(trim(infile),unt,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! ********************************************************************************************** ! (2) read default model parameter values and constraints ! ********************************************************************************************** - ! check that the parameter metadata is already populated - if(.not.associated(mpar_meta))then; err=30; message=trim(message)//"Parameter metadata is non-existent"; return; endif - ! allocate space for the parameter structure - if (associated(parFallback)) deallocate(parFallback) - allocate(parFallback(size(mpar_meta)),stat=err) - if(err/=0)then; err=40; message=trim(message)//"problemAllocateStructure"; return; endif ! fill parameter vector with missing data - parFallback(:)%default_val = amiss - parFallback(:)%lower_limit = amiss - parFallback(:)%upper_limit = amiss + parFallback(:)%default_val = realMissing + parFallback(:)%lower_limit = realMissing + parFallback(:)%upper_limit = realMissing ! --------------------------------------------------------------------------------------------- ! read format code ! --------------------------------------------------------------------------------------------- do iline=1,maxLines ! (read through comment lines) read(unt,'(a)',iostat=iend) temp ! read a line of data - if(iend/=0)then; err=20; message=trim(message)//'got to end of file before found the format code'; return; endif + if(iend/=0)then; err=20; message=trim(message)//'got to end of file before found the format code'; return; end if if (temp(1:1)=='!')cycle ! (read in format string -- assume that the first non-comment line is the format code) read(temp,*)ffmt ! read in format string exit - if(iLine==maxLines)then; err=20; message=trim(message)//'problem finding format code -- no non-comment line after start of parameter definitions'; return; endif + if(iLine==maxLines)then; err=20; message=trim(message)//'problem finding format code -- no non-comment line after start of parameter definitions'; return; end if end do ! looping through lines ! --------------------------------------------------------------------------------------------- ! read in default values of model parameters, and parameter constraints @@ -111,37 +110,45 @@ subroutine read_pinit(filenm,isLocal,mpar_meta,parFallback,err,message) if (temp(1:1)=='!')cycle ! (save data into a temporary variables) read(temp,trim(ffmt),iostat=err) varname, dLim, parTemp%default_val, dLim, parTemp%lower_limit, dLim, parTemp%upper_limit - if (err/=0) then; err=30; message=trim(message)//"errorReadLine"; return; endif + if (err/=0) then; err=30; message=trim(message)//"errorReadLine"; return; end if ! (identify the index of the variable in the data structure) if(isLocal)then ivar = get_ixParam(trim(varname)) else ivar = get_ixBpar(trim(varname)) - endif + end if ! (check that we have successfully found the parameter) if(ivar>0)then if(ivar>size(parFallback))then err=35; message=trim(message)//"indexOutOfRange[var="//trim(varname)//"]"; return - endif + end if ! (put data in the structure) parFallback(ivar)=parTemp !write(*,'(a,1x,i4,1x,a30,1x,f20.10,1x)') 'ivar, trim(varname), parFallback(ivar)%default_val = ', & ! ivar, trim(varname), parFallback(ivar)%default_val else - err=40; message=trim(message)//"variableNotFound[var="//trim(varname)//"]"; return - endif + err=40; message=trim(message)//"variable in parameter file not present in data structure [var="//trim(varname)//"]"; return + end if end do ! (looping through lines in the file) ! check we have populated all variables ! NOTE: ultimately need a need a parameter dictionary to ensure that the parameters used are populated if(.not.backwardsCompatible)then ! if we add new variables in future versions of the code, then some may be missing in the input file - if(any(parFallback(:)%default_val > 0.99_dp*amiss))then + if(any(parFallback(:)%default_val < 0.99_dp*realMissing))then do ivar=1,size(parFallback) - if(parFallback(ivar)%default_val > 0.99_dp*amiss)then + if(parFallback(ivar)%default_val < 0.99_dp*realMissing)then err=40; message=trim(message)//"variableNonexistent[var="//trim(mpar_meta(ivar)%varname)//"]"; return - endif + end if end do - endif - endif + end if + ! populate parameters that were not included in the original control files + else ! (need backwards compatibility) + if(isLocal)then + if(model_decisions(iLookDECISIONS%cIntercept)%iDecision == unDefined)then + parFallback(iLookPARAM%canopyWettingFactor)%default_val = 1._dp ! maximum wetted fraction of the canopy (-) + parFallback(iLookPARAM%canopyWettingExp)%default_val = 0.666666667_dp ! exponent in canopy wetting function (-) + end if + end if + end if ! close file unit close(unt) end subroutine read_pinit diff --git a/build/source/engine/snowAlbedo.f90 b/build/source/engine/snowAlbedo.f90 old mode 100644 new mode 100755 index 8d2b68185..9dd715941 --- a/build/source/engine/snowAlbedo.f90 +++ b/build/source/engine/snowAlbedo.f90 @@ -58,18 +58,20 @@ subroutine snowAlbedo(& ! input/output: data structures model_decisions, & ! intent(in): model decisions mpar_data, & ! intent(in): model parameters - mvar_data, & ! intent(inout): model variables for a local HRU + 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,message) ! intent(out): error control ! -------------------------------------------------------------------------------------------------------------------------------------- ! provide access to the derived types to define the data structures - USE data_struc,only:& + USE data_types,only:& var_i, & ! data vector (i4b) var_d, & ! data vector (dp) var_dlength, & ! data vector with variable length dimension (dp) model_options ! defines the model decisions ! provide access to named variables defining elements in the data structures - USE var_lookup,only:iLookTIME,iLookTYPE,iLookATTR,iLookFORCE,iLookPARAM,iLookMVAR,iLookBVAR,iLookINDEX ! named variables for structure elements + USE var_lookup,only:iLookPARAM,iLookFLUX,iLookDIAG,iLookPROG ! named variables for structure elements USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure ! provide access to desired modules USE snow_utils_module,only:fracliquid ! compute fraction of liquid water at a given temperature @@ -79,8 +81,10 @@ subroutine snowAlbedo(& 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_d),intent(in) :: mpar_data ! model parameters - type(var_dlength),intent(inout) :: mvar_data ! model variables for a local HRU + 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 @@ -106,28 +110,28 @@ subroutine snowAlbedo(& ixCanopySrad => model_decisions(iLookDECISIONS%canopySrad)%iDecision, & ! intent(in): index of method used for canopy sw radiation ixAlbedoMethod => model_decisions(iLookDECISIONS%alb_method)%iDecision, & ! intent(in): index of method used for snow albedo ! input: model parameters - Frad_vis => mpar_data%var(iLookPARAM%Frad_vis), & ! intent(in): fraction of radiation in visible part of spectrum (-) - Frad_direct => mpar_data%var(iLookPARAM%Frad_direct), & ! intent(in): fraction direct solar radiation (-) - albedoMax => mpar_data%var(iLookPARAM%albedoMax), & ! intent(in): maximum snow albedo for a single spectral band (-) - albedoMinWinter => mpar_data%var(iLookPARAM%albedoMinWinter), & ! intent(in): minimum snow albedo during winter for a single spectral band (-) - albedoMinSpring => mpar_data%var(iLookPARAM%albedoMinSpring), & ! intent(in): minimum snow albedo during spring for a single spectral band (-) - albedoMaxVisible => mpar_data%var(iLookPARAM%albedoMaxVisible), & ! intent(in): maximum snow albedo in the visible part of the spectrum (-) - albedoMinVisible => mpar_data%var(iLookPARAM%albedoMinVisible), & ! intent(in): minimum snow albedo in the visible part of the spectrum (-) - albedoMaxNearIR => mpar_data%var(iLookPARAM%albedoMaxNearIR), & ! intent(in): maximum snow albedo in the near infra-red part of the spectrum (-) - albedoMinNearIR => mpar_data%var(iLookPARAM%albedoMinNearIR), & ! intent(in): minimum snow albedo in the near infra-red part of the spectrum (-) - albedoDecayRate => mpar_data%var(iLookPARAM%albedoDecayRate), & ! intent(in): albedo decay rate (s) - tempScalGrowth => mpar_data%var(iLookPARAM%tempScalGrowth), & ! intent(in): temperature scaling factor for grain growth (K-1) - albedoSootLoad => mpar_data%var(iLookPARAM%albedoSootLoad), & ! intent(in): soot load factor (-) - albedoRefresh => mpar_data%var(iLookPARAM%albedoRefresh), & ! intent(in): critical mass necessary for albedo refreshment (kg m-2) - snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale), & ! intent(in): scaling parameter for the freezing curve for snow (K-1) + Frad_vis => mpar_data%var(iLookPARAM%Frad_vis)%dat(1), & ! intent(in): fraction of radiation in visible part of spectrum (-) + Frad_direct => mpar_data%var(iLookPARAM%Frad_direct)%dat(1), & ! intent(in): fraction direct solar radiation (-) + albedoMax => mpar_data%var(iLookPARAM%albedoMax)%dat(1), & ! intent(in): maximum snow albedo for a single spectral band (-) + albedoMinWinter => mpar_data%var(iLookPARAM%albedoMinWinter)%dat(1), & ! intent(in): minimum snow albedo during winter for a single spectral band (-) + albedoMinSpring => mpar_data%var(iLookPARAM%albedoMinSpring)%dat(1), & ! intent(in): minimum snow albedo during spring for a single spectral band (-) + albedoMaxVisible => mpar_data%var(iLookPARAM%albedoMaxVisible)%dat(1), & ! intent(in): maximum snow albedo in the visible part of the spectrum (-) + albedoMinVisible => mpar_data%var(iLookPARAM%albedoMinVisible)%dat(1), & ! intent(in): minimum snow albedo in the visible part of the spectrum (-) + albedoMaxNearIR => mpar_data%var(iLookPARAM%albedoMaxNearIR)%dat(1), & ! intent(in): maximum snow albedo in the near infra-red part of the spectrum (-) + albedoMinNearIR => mpar_data%var(iLookPARAM%albedoMinNearIR)%dat(1), & ! intent(in): minimum snow albedo in the near infra-red part of the spectrum (-) + albedoDecayRate => mpar_data%var(iLookPARAM%albedoDecayRate)%dat(1), & ! intent(in): albedo decay rate (s) + tempScalGrowth => mpar_data%var(iLookPARAM%tempScalGrowth)%dat(1), & ! intent(in): temperature scaling factor for grain growth (K-1) + albedoSootLoad => mpar_data%var(iLookPARAM%albedoSootLoad)%dat(1), & ! intent(in): soot load factor (-) + albedoRefresh => mpar_data%var(iLookPARAM%albedoRefresh)%dat(1), & ! intent(in): critical mass necessary for albedo refreshment (kg m-2) + snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1), & ! intent(in): scaling parameter for the freezing curve for snow (K-1) ! input: model variables - surfaceTemp => mvar_data%var(iLookMVAR%mLayerTemp)%dat(1), & ! intent(in): surface temperature - snowfallRate => mvar_data%var(iLookMVAR%scalarSnowfall)%dat(1), & ! intent(in): snowfall rate (kg m-2 s-1) - cosZenith => mvar_data%var(iLookMVAR%scalarCosZenith)%dat(1), & ! intent(in): cosine of the zenith angle (-) + surfaceTemp => prog_data%var(iLookPROG%mLayerTemp)%dat(1), & ! intent(in): surface temperature + snowfallRate => flux_data%var(iLookFLUX%scalarSnowfall)%dat(1), & ! intent(in): snowfall rate (kg m-2 s-1) + cosZenith => diag_data%var(iLookDIAG%scalarCosZenith)%dat(1), & ! intent(in): cosine of the zenith angle (-) ! input/output: model variables - spectralSnowAlbedoDiffuse => mvar_data%var(iLookMVAR%spectralSnowAlbedoDiffuse)%dat, & ! intent(inout): diffuse snow albedo in each spectral band (-) - spectralSnowAlbedoDirect => mvar_data%var(iLookMVAR%spectralSnowAlbedoDirect)%dat, & ! intent(inout): direct snow albedo in each spectral band (-) - scalarSnowAlbedo => mvar_data%var(iLookMVAR%scalarSnowAlbedo)%dat(1) & ! intent(inout): snow albedo for the entire spectral band (-) + scalarSnowAlbedo => prog_data%var(iLookPROG%scalarSnowAlbedo)%dat(1), & ! intent(inout): snow albedo for the entire spectral band (-) + spectralSnowAlbedoDirect => diag_data%var(iLookDIAG%spectralSnowAlbedoDirect)%dat, & ! intent(inout): direct snow albedo in each spectral band (-) + spectralSnowAlbedoDiffuse => prog_data%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat & ! intent(inout): diffuse snow albedo in each spectral band (-) ) ! end associate statement ! -------------------------------------------------------------------------------------------------------------------------------------- @@ -140,7 +144,7 @@ subroutine snowAlbedo(& spectralSnowAlbedoDirect(:) = valueMissing spectralSnowAlbedoDiffuse(:) = valueMissing return - endif + end if ! compute fractional increase in albedo associated with snowfall refreshFactor = dt*snowfallRate/albedoRefresh @@ -159,7 +163,7 @@ subroutine snowAlbedo(& albedoMin = albedoMinSpring else albedoMin = albedoMinWinter - endif + end if ! compute average albedo call computeAlbedo(scalarSnowAlbedo,refreshFactor,decayFactor,albedoMax,albedoMin) ! assume albedo is the same in visible and near infra-red bands, and for direct and diffuse radiation @@ -184,7 +188,7 @@ subroutine snowAlbedo(& fZen = (1._dp/bPar)*( ((1._dp + bPar)/(1._dp + 2._dp*bPar*cosZenith)) - 1._dp) else fZen = 0._dp - endif + end if ! compute direct albedo spectralSnowAlbedoDirect(ixVisible) = spectralSnowAlbedoDiffuse(ixVisible) + 0.4_dp*fZen*(1._dp - spectralSnowAlbedoDiffuse(ixVisible)) spectralSnowAlbedoDirect(ixNearIR) = spectralSnowAlbedoDiffuse(ixNearIR) + 0.4_dp*fZen*(1._dp - spectralSnowAlbedoDiffuse(ixNearIR)) @@ -199,7 +203,7 @@ subroutine snowAlbedo(& end select ! identify option for snow albedo ! check - if(scalarSnowAlbedo < 0._dp)then; err=20; message=trim(message)//'unable to identify option for snow albedo'; return; endif + if(scalarSnowAlbedo < 0._dp)then; err=20; message=trim(message)//'unable to identify option for snow albedo'; return; end if ! end association to data structures end associate diff --git a/build/source/engine/snowLiqFlx.f90 b/build/source/engine/snowLiqFlx.f90 old mode 100644 new mode 100755 index f9777498b..0e5ddf580 --- a/build/source/engine/snowLiqFlx.f90 +++ b/build/source/engine/snowLiqFlx.f90 @@ -21,11 +21,6 @@ module snowLiqFlx_module USE nrtype ! numerical recipes data types USE multiconst,only:iden_ice,iden_water ! intrinsic density of ice and water (kg m-3) -! access the number of snow and soil layers -USE data_struc,only:& - nSnow, & ! number of snow layers - nSoil, & ! number of soil layers - nLayers ! total number of layers implicit none private public::snowLiqFlx @@ -37,143 +32,88 @@ module snowLiqFlx_module ! ************************************************************************************************ subroutine snowLiqFlx(& ! input: model control - iter, & ! intent(in): iteration index + nSnow, & ! intent(in): number of snow layers + firstFluxCall, & ! intent(in): the first flux call ! 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) + 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 (-) + mLayerVolFracLiqTrial, & ! intent(in): trial value of volumetric fraction of liquid water at the current iteration (-) + ! input-output: data structures + 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(out): vertical liquid water flux at layer interfaces (m s-1) - iLayerLiqFluxSnowDeriv, & ! intent(out): derivative in vertical liquid water flux at layer interfaces (m s-1) + iLayerLiqFluxSnow, & ! intent(out): vertical liquid water flux at layer interfaces (m s-1) + iLayerLiqFluxSnowDeriv, & ! intent(out): derivative in vertical liquid water flux at layer interfaces (m s-1) ! output: error control - err,message) ! intent(out): error control - ! model variables, parameters, forcing data, etc. - USE data_struc,only:mpar_data,mvar_data ! data structures - USE var_lookup,only:iLookATTR,iLookTYPE,iLookPARAM,iLookFORCE,iLookMVAR,iLookINDEX ! named variables for structure elements + err,message) ! intent(out): error control + ! named variables + 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) implicit none ! input: model control - integer(i4b),intent(in) :: iter ! iteration index + integer(i4b),intent(in) :: nSnow ! number of snow layers + logical(lgt),intent(in) :: firstFluxCall ! the first flux call ! input: forcing for the snow domain - real(dp),intent(in) :: scalarThroughfallRain ! computed throughfall rate (kg m-2 s-1) - real(dp),intent(in) :: scalarCanopyLiqDrainage ! computed drainage of liquid water (kg m-2 s-1) + real(dp),intent(in) :: scalarThroughfallRain ! computed throughfall rate (kg m-2 s-1) + real(dp),intent(in) :: scalarCanopyLiqDrainage ! computed drainage of liquid water (kg m-2 s-1) ! input: model state vector - real(dp),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value of volumetric fraction of liquid water at the current iteration (-) + real(dp),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value of volumetric fraction of liquid water at the current iteration (-) + ! input-output: data structures + 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(dp),intent(out) :: iLayerLiqFluxSnow(0:) ! vertical liquid water flux at layer interfaces (m s-1) - real(dp),intent(out) :: iLayerLiqFluxSnowDeriv(0:) ! derivative in vertical liquid water flux at layer interfaces (m s-1) + real(dp),intent(out) :: iLayerLiqFluxSnow(0:) ! vertical liquid water flux at layer interfaces (m s-1) + real(dp),intent(out) :: 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 + 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 ! layer index + real(dp) :: multResid ! multiplier for the residual water content (-) + real(dp),parameter :: residThrs=550._dp ! ice density threshold to reduce residual liquid water content (kg m-3) + real(dp),parameter :: residScal=10._dp ! scaling factor for residual liquid water content reduction factor (kg m-3) + real(dp),parameter :: maxVolIceContent=0.7_dp ! maximum volumetric ice content to store water (-) + real(dp) :: availCap ! available storage capacity [0,1] (-) + real(dp) :: relSaturn ! relative saturation [0,1] (-) + ! ------------------------------------------------------------------------------------------------------------------------------------------ + ! make association of local variables with information in the data structures + associate(& + ! 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/' - ! ** calculate fluxes and derivatives for liquid water flow through snow - call snowLiqFlx_muster(& - ! input: model control - iter, & ! intent(in): iteration index - ! 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: snow properties and parameters - mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat(1:nSnow), & ! intent(in): volumetric ice content at the start of the time step (-) - mpar_data%var(iLookPARAM%Fcapil), & ! intent(in): capillary retention as a fraction of the total pore volume (-) - mpar_data%var(iLookPARAM%k_snow), & ! intent(in): hydraulic conductivity of snow (m s-1), 0.0055 = approx. 20 m/hr, from UEB - mpar_data%var(iLookPARAM%mw_exp), & ! intent(in): exponent for meltwater flow (-) - ! input/output: diagnostic variables -- only computed for the first iteration - mvar_data%var(iLookMVAR%mLayerPoreSpace)%dat, & ! intent(inout): pore space in each snow layer (-) - mvar_data%var(iLookMVAR%mLayerThetaResid)%dat, & ! intent(inout): esidual volumetric liquid water content in each snow layer (-) - ! output: fluxes and derivatives - iLayerLiqFluxSnow, & ! intent(out): vertical liquid water flux at layer interfaces (m s-1) - iLayerLiqFluxSnowDeriv, & ! intent(out): 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 - - end subroutine snowLiqFlx - - - ! ************************************************************************************************ - ! * private subroutine: calculate fluxes and derivatives for liquid water flow through snow - ! ************************************************************************************************ - subroutine snowLiqFlx_muster(& - ! input: model control - iter, & ! intent(in): iteration index - ! 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: snow properties and parameters - mLayerVolFracIce, & ! intent(in): volumetric ice content at the start of the time step (-) - Fcapil, & ! intent(in): capillary retention as a fraction of the total pore volume (-) - k_snow, & ! intent(in): hydraulic conductivity of snow (m s-1), 0.0055 = approx. 20 m/hr, from UEB - mw_exp, & ! intent(in): exponent for meltwater flow (-) - ! input/output: diagnostic variables -- only computed for the first iteration - mLayerPoreSpace, & ! intent(inout): pore space in each snow layer (-) - mLayerThetaResid, & ! intent(inout): residual volumetric liquid water content in each snow layer (-) - ! output: fluxes and derivatives - iLayerLiqFluxSnow, & ! intent(out): vertical liquid water flux at layer interfaces (m s-1) - iLayerLiqFluxSnowDeriv, & ! intent(out): 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) :: iter ! iteration index - ! input: forcing for the snow domain - real(dp),intent(in) :: scalarThroughfallRain ! computed throughfall rate (kg m-2 s-1) - real(dp),intent(in) :: scalarCanopyLiqDrainage ! computed drainage of liquid water (kg m-2 s-1) - ! input: model state vector - real(dp),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value of volumetric fraction of liquid water at the current iteration (-) - ! input: snow properties and parameters - real(dp),intent(in) :: mLayerVolFracIce(:) ! volumetric ice content at the start of the time step (-) - real(dp),intent(in) :: Fcapil ! capillary retention as a fraction of the total pore volume (-) - real(dp),intent(in) :: k_snow ! hydraulic conductivity of snow (m s-1), 0.0055 = approx. 20 m/hr, from UEB - real(dp),intent(in) :: mw_exp ! exponent for meltwater flow (-) - ! input/output: diagnostic variables -- only computed for the first iteration - real(dp),intent(inout) :: mLayerPoreSpace(:) ! pore space in each snow layer (-) - real(dp),intent(inout) :: mLayerThetaResid(:) ! residual volumetric liquid water content in each snow layer (-) - ! output: fluxes and derivatives - real(dp),intent(out) :: iLayerLiqFluxSnow(0:) ! vertical liquid water flux at layer interfaces (m s-1) - real(dp),intent(out) :: 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) :: iLayer ! layer index - real(dp) :: multResid ! multiplier for the residual water content (-) - real(dp),parameter :: residThrs=550._dp ! ice density threshold to reduce residual liquid water content (kg m-3) - real(dp),parameter :: residScal=10._dp ! scaling factor for residual liquid water content reduction factor (kg m-3) - real(dp),parameter :: maxVolIceContent=0.7_dp ! maximum volumetric ice content to store water (-) - real(dp) :: availCap ! available storage capacity [0,1] (-) - real(dp) :: relSaturn ! relative saturation [0,1] (-) - real(dp),parameter :: dx = 1.e-8_dp ! finite difference increment - ! --------------------------------------------------------------------------------------------------------------------------------------- - ! initialize error control - err=0; message='snowLiqFlx_muster/' - ! 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 - endif + end if ! check the meltwater exponent is >=1 - if(mw_exp<1._dp)then; err=20; message=trim(message)//'meltwater exponent < 1'; return; endif + if(mw_exp<1._dp)then; err=20; message=trim(message)//'meltwater exponent < 1'; return; end if ! define the liquid flux at the upper boundary (m s-1) iLayerLiqFluxSnow(0) = (scalarThroughfallRain + scalarCanopyLiqDrainage)/iden_water iLayerLiqFluxSnowDeriv(0) = 0._dp ! compute properties fixed over the time step - if(iter==1)then + if(firstFluxCall)then ! loop through snow layers do iLayer=1,nSnow ! compute the reduction in liquid water holding capacity at high snow density (-) @@ -183,40 +123,31 @@ subroutine snowLiqFlx_muster(& ! compute the residual volumetric liquid water content (-) mLayerThetaResid(iLayer) = Fcapil*mLayerPoreSpace(iLayer) * multResid end do ! (looping through snow layers) - endif ! (if the first iteration) + end if ! (if the first flux call) ! compute fluxes do iLayer=1,nSnow ! (loop through snow layers) - ! ** allow liquid water to pass through under very high density - if(mLayerVolFracIce(iLayer) > maxVolIceContent)then ! NOTE: use start-of-step ice content, to avoid convergence problems - iLayerLiqFluxSnow(iLayer) = iLayerLiqFluxSnow(iLayer-1) + ! 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._dp) + 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._dp iLayerLiqFluxSnowDeriv(iLayer) = 0._dp - ! ** typical flux computations - else - ! 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 - !print*, 'mLayerVolFracLiqTrial(iLayer) = ', mLayerVolFracLiqTrial(iLayer) - !print*, 'mLayerPoreSpace(iLayer), mLayerThetaResid(iLayer) = ', mLayerThetaResid(iLayer) - !print*, 'iLayer, availCap, relSaturn, k_snow = ', iLayer, availCap, relSaturn, k_snow - ! compute the flux and derivative (m s-1) - iLayerLiqFluxSnow(iLayer) = k_snow*relSaturn**mw_exp - iLayerLiqFluxSnowDeriv(iLayer) = ( (k_snow*mw_exp)/availCap ) * relSaturn**(mw_exp - 1._dp) - ! check the derivative - !relSaturn1 = (mLayerVolFracLiqTrial(iLayer)+dx - mLayerThetaResid(iLayer)) / availCap ! relative saturation - !testFlux = k_snow*relSaturn1**mw_exp - !write(*,'(a,1x,10(e25.10,1x))') 'iLayerLiqFluxSnow(iLayer), testFlux, iLayerLiqFluxSnowDeriv(iLayer), (testFlux - iLayerLiqFluxSnow(iLayer))/dx = ', & - ! iLayerLiqFluxSnow(iLayer), testFlux, iLayerLiqFluxSnowDeriv(iLayer), (testFlux - iLayerLiqFluxSnow(iLayer))/dx - else ! flow does not ocur - iLayerLiqFluxSnow(iLayer) = 0._dp - iLayerLiqFluxSnowDeriv(iLayer) = 0._dp - endif ! storage above residual content - endif ! check for very high density + endif ! storage above residual content end do ! loop through snow layers - end subroutine snowLiqFlx_muster + ! end association of local variables with information in the data structures + end associate + + 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 100644 new mode 100755 index d2ebdac37..dffc7905d --- a/build/source/engine/snow_utils.f90 +++ b/build/source/engine/snow_utils.f90 @@ -83,9 +83,9 @@ end function dFracLiq_dTk ! *********************************************************************************************************** subroutine tcond_snow(BulkDenIce,thermlcond,err,message) USE multiconst,only:lambda_air,lambda_ice ! thermal conductivity of air and ice - USE data_struc,only:model_decisions ! model decision structure + USE globalData,only:model_decisions ! model decision structure USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure - USE mDecisions_module,only:Yen1965,Mellor1977,Jordan1991,Smirnova2000 ! named variables defining thermal conductivity options + USE mDecisions_module,only:Yen1965,Mellor1977,Jordan1991 ! named variables defining thermal conductivity options implicit none real(dp),intent(in) :: BulkDenIce ! bulk density of ice (kg m-3) real(dp),intent(out) :: thermlcond ! thermal conductivity of snow (W m-1 K-1) @@ -99,7 +99,6 @@ subroutine tcond_snow(BulkDenIce,thermlcond,err,message) case(Mellor1977); thermlcond = 2.576d-6 * BulkDenIce**2._dp + 7.4d-2 ! Mellor (1977) case(Jordan1991); thermlcond = lambda_air + (7.75d-5*BulkDenIce + 1.105d-6*(BulkDenIce**2._dp)) & * (lambda_ice-lambda_air) ! Jordan (1991) - case(Smirnova2000); thermlcond = 0.35_dp ! Smirnova et al. (2000) case default err=10; message=trim(message)//"unknownOption"; return end select diff --git a/build/source/engine/snwCompact.f90 b/build/source/engine/snwCompact.f90 old mode 100644 new mode 100755 index 64d6876b4..17cb6db03 --- a/build/source/engine/snwCompact.f90 +++ b/build/source/engine/snwCompact.f90 @@ -24,8 +24,6 @@ module snwDensify_module Tfreeze, & ! freezing point of pure water (K) iden_ice, & ! intrinsic density of ice (kg m-3) iden_water ! intrinsic density of liquid water (kg m-3) -! access the number of snow layers -USE data_struc,only:nSnow ! number of snow layers implicit none private public::snwDensify @@ -37,7 +35,8 @@ module snwDensify_module subroutine snwDensify(& ! intent(in): variables - dt, & ! intent(in) time step (s) + 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) scalarSnowSublimation, & ! intent(in): sublimation from the snow surface (kg m-2 s-1) @@ -48,7 +47,7 @@ subroutine snwDensify(& 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) - base_visc, & ! 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) @@ -62,6 +61,7 @@ subroutine snwDensify(& implicit none ! intent(in): variables real(dp),intent(in) :: dt ! time step (seconds) + integer(i4b),intent(in) :: nSnow ! number of snow layers real(dp),intent(in) :: mLayerTemp(:) ! temperature of each snow layer after iterations (K) real(dp),intent(in) :: mLayerMeltFreeze(:) ! volumetric melt in each layer (kg m-3) real(dp),intent(in) :: scalarSnowSublimation ! sublimation from the snow surface (kg m-2 s-1) @@ -71,7 +71,7 @@ subroutine snwDensify(& real(dp),intent(in) :: grainGrowthRate ! rate of grain growth (s-1) real(dp),intent(in) :: densScalOvrbdn ! density scaling factor for overburden pressure (kg-1 m3) real(dp),intent(in) :: tempScalOvrbdn ! temperature scaling factor for overburden pressure (K-1) - real(dp),intent(in) :: base_visc ! viscosity coefficient at T=T_frz and snow density=0 (kg m-2 s) + real(dp),intent(in) :: baseViscosity ! viscosity coefficient at T=T_frz and snow density=0 (kg m-2 s) ! intent(inout): state variables real(dp),intent(inout) :: mLayerDepth(:) ! depth of each layer (m) real(dp),intent(inout) :: mLayerVolFracLiqNew(:) ! volumetric fraction of liquid water in each snow layer after iterations (-) @@ -81,7 +81,6 @@ subroutine snwDensify(& character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------------------------------------------- ! define local variables - real(dp),parameter :: dt_toler=0.1_dp ! fraction of compaction allowed in a time step (-) integer(i4b) :: iSnow ! index of snow layers real(dp) :: chi1,chi2,chi3,chi4,chi5 ! multipliers in the densification algorithm (-) real(dp) :: halfWeight ! half of the weight of the current snow layer (kg m-2) @@ -96,6 +95,7 @@ subroutine snwDensify(& real(dp),parameter :: snwden_min=100._dp ! minimum snow density for reducing metamorphism rate (kg m-3) real(dp),parameter :: snwDensityMax=550._dp ! maximum snow density for collapse under melt (kg m-3) real(dp),parameter :: wetSnowThresh=0.01_dp ! threshold to discriminate between "wet" and "dry" snow + real(dp),parameter :: minLayerDensity=40._dp ! minimum snow density allowed for any layer (kg m-3) ! ----------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message="snwDensify/" @@ -108,11 +108,14 @@ 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) + ! *** compute the compaction associated with grain growth (s-1) ! compute the base rate of grain growth (-) if(mLayerVolFracIceNew(iSnow)*iden_ice wetSnowThresh)then; chi3=2._dp ! snow is "wet" - else; chi3=1._dp; endif ! snow is "dry" + else; chi3=1._dp; end if ! snow is "dry" ! compute the compaction associated with grain growth (s-1) CR_grainGrowth = grainGrowthRate*chi1*chi2*chi3 + ! **** compute the compaction associated with over-burden pressure (s-1) ! compute the weight imposed on the current layer (kg m-2) halfWeight = (massIceOld + massLiqOld)/2._dp ! there is some over-burden pressure from the layer itself @@ -133,9 +137,10 @@ subroutine snwDensify(& ! compute the increase in compaction under low density snow (-) chi5 = exp(-densScalOvrbdn*mLayerVolFracIceNew(iSnow)*iden_ice) ! compute the compaction associated with over-burden pressure (s-1) - CR_ovrvdnPress = (weightSnow/base_visc)*chi4*chi5 + CR_ovrvdnPress = (weightSnow/baseViscosity)*chi4*chi5 ! update the snow weight with the halfWeight not yet used weightSnow = weightSnow + halfweight ! add half of the weight from the current layer + ! *** compute the compaction rate associated with snow melt (s-1) ! NOTE: loss of ice due to snowmelt is implicit, so can be updated directly if(iden_ice*mLayerVolFracIceNew(iSnow) < snwDensityMax)then ! only collapse layers if below a critical density @@ -144,28 +149,32 @@ subroutine snwDensify(& volFracIceLoss = max(0._dp,mLayerMeltFreeze(iSnow)/iden_ice - dt*(scalarSnowSublimation/mLayerDepth(iSnow))/iden_ice ) else volFracIceLoss = max(0._dp,mLayerMeltFreeze(iSnow)/iden_ice) ! volumetric fraction of ice lost due to melt (-) - endif + end if ! (adjust snow depth to account for cavitation) scalarDepthNew = mLayerDepth(iSnow) * mLayerVolFracIceNew(iSnow)/(mLayerVolFracIceNew(iSnow) + volFracIceLoss) !print*, 'volFracIceLoss = ', volFracIceLoss else scalarDepthNew = mLayerDepth(iSnow) - endif + end if ! compute the total compaction rate associated with metamorphism CR_metamorph = CR_grainGrowth + CR_ovrvdnPress ! update depth due to metamorphism (implicit solution) mLayerDepth(iSnow) = scalarDepthNew/(1._dp + CR_metamorph*dt) + ! check that depth is reasonable if(mLayerDepth(iSnow) < 0._dp)then write(*,'(a,1x,i4,1x,10(f12.5,1x))') 'iSnow, dt, density, massIceOld, massLiqOld = ', iSnow, dt, mLayerVolFracIceNew(iSnow)*iden_ice, massIceOld, massLiqOld write(*,'(a,1x,i4,1x,10(f12.5,1x))') 'iSnow, mLayerDepth(iSnow), scalarDepthNew, mLayerVolFracIceNew(iSnow), mLayerMeltFreeze(iSnow), CR_grainGrowth*dt, CR_ovrvdnPress*dt = ', & iSnow, mLayerDepth(iSnow), scalarDepthNew, mLayerVolFracIceNew(iSnow), mLayerMeltFreeze(iSnow), CR_grainGrowth*dt, CR_ovrvdnPress*dt endif + ! update volumetric ice and liquid water content mLayerVolFracIceNew(iSnow) = massIceOld/(mLayerDepth(iSnow)*iden_ice) mLayerVolFracLiqNew(iSnow) = massLiqOld/(mLayerDepth(iSnow)*iden_water) + !write(*,'(a,1x,i4,1x,f9.3)') 'after compact: iSnow, density = ', iSnow, mLayerVolFracIceNew(iSnow)*iden_ice !if(mLayerMeltFreeze(iSnow) > 20._dp) pause 'meaningful melt' + end do ! looping through snow layers ! check depth @@ -175,17 +184,17 @@ subroutine snwDensify(& end do message=trim(message)//'unreasonable value for snow depth' err=20; return - endif + end if ! check for low/high snow density - if(any(mLayerVolFracIceNew(1:nSnow)*iden_ice < 50._dp) .or. & - any(mLayerVolFracIceNew(1:nSnow)*iden_ice > 900._dp))then + if(any(mLayerVolFracIceNew(1:nSnow)*iden_ice < minLayerDensity) .or. & + any(mLayerVolFracIceNew(1:nSnow) > 1._dp))then do iSnow=1,nSnow write(*,'(a,1x,i4,1x,f9.3)') 'iSnow, density = ', iSnow, mLayerVolFracIceNew(iSnow)*iden_ice end do message=trim(message)//'unreasonable value for snow density' err=20; return - endif + end if end subroutine snwDensify diff --git a/build/source/engine/soilLiqFlx.f90 b/build/source/engine/soilLiqFlx.f90 old mode 100644 new mode 100755 index accefe27e..01a32a519 --- a/build/source/engine/soilLiqFlx.f90 +++ b/build/source/engine/soilLiqFlx.f90 @@ -32,13 +32,6 @@ module soilLiqFlx_module 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) -! provide access to the number of snow and soil layers -USE data_struc,only:& - nSnow, & ! number of snow layers - nSoil, & ! number of soil layers - nLayers ! total number of layers -! provide access to layer types -USE data_struc,only:ix_soil,ix_snow ! named variables for snow and soil ! provide access to look-up values for model decisions USE mDecisions_module,only: & ! look-up values for method used to compute derivative @@ -76,6 +69,7 @@ module soilLiqFlx_module ! *************************************************************************************************************** subroutine soilLiqFlx(& ! input: model control + nSoil, & ! intent(in): number of soil layers doInfiltrate, & ! intent(in): flag to compute infiltration deriv_desired, & ! intent(in): flag indicating if derivatives are desired ! input: trial state variables @@ -90,6 +84,12 @@ subroutine soilLiqFlx(& 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(in): model diagnostic variables for a local HRU + flux_data, & ! intent(in): 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 (-) @@ -113,13 +113,30 @@ subroutine soilLiqFlx(& ! output: error control err,message) ! intent(out): error control ! model decisions - USE data_struc,only:model_decisions ! model decision structure - USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure - ! model variables, parameters, forcing data, etc. - USE data_struc,only:mpar_data,mvar_data ! data structures - USE var_lookup,only:iLookATTR,iLookTYPE,iLookPARAM,iLookFORCE,iLookMVAR,iLookINDEX ! named variables for structure elements + USE globalData,only:model_decisions ! model decision structure + USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure + ! 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 + ! data types + USE data_types,only:var_d ! x%var(:) (dp) + USE data_types,only:var_ilength ! x%var(:)%dat (i4b) + USE data_types,only:var_dlength ! x%var(:)%dat (dp) + ! 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) :: deriv_desired ! flag indicating if derivatives are desired ! input: trial model state variables @@ -134,6 +151,12 @@ subroutine soilLiqFlx(& real(dp),intent(in) :: scalarCanopyTranspiration ! canopy transpiration (kg m-2 s-1) real(dp),intent(in) :: scalarGroundEvaporation ! ground evaporation (kg m-2 s-1) real(dp),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(in) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU ! output: diagnostic variables for surface runoff real(dp),intent(inout) :: xMaxInfilRate ! maximum infiltration rate (m s-1) real(dp),intent(inout) :: scalarInfilArea ! fraction of unfrozen area where water can infiltrate (-) @@ -158,328 +181,9 @@ subroutine soilLiqFlx(& integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------------------------------------------------------- - ! local variables - integer(i4b) :: ibeg,iend ! start and end indices of the soil layers in concatanated snow-soil vector - character(LEN=256) :: cmessage ! error message of downwind routine - ! initialize error control - err=0; message='soilLiqFlx/' - - ! get indices for the data structures - ibeg = nSnow + 1 - iend = nSnow + nSoil - - ! wrapper routine for liquid fluxes - call soilLiqFlx_muster(& - - ! input: model control - doInfiltrate, & ! intent(in): flag to compute infiltration - deriv_desired, & ! intent(in): flag indicating if derivatives are desired - - ! input: model decisions - model_decisions(iLookDECISIONS%fDerivMeth)%iDecision, & ! intent(in): index of the method used to calculate flux derivatives - model_decisions(iLookDECISIONS%f_Richards)%iDecision, & ! intent(in): index of the form of Richards' equation - model_decisions(iLookDECISIONS%hc_Profile)%iDecision, & ! intent(in): index of the option for the hydraulic conductivity profile - model_decisions(iLookDECISIONS%bcUpprSoiH)%iDecision, & ! intent(in): index of the upper boundary conditions for soil hydrology - model_decisions(iLookDECISIONS%bcLowrSoiH)%iDecision, & ! intent(in): index of the lower boundary conditions for soil hydrology - - ! 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: model coordinate variables -- NOTE: use of ibeg and iend - mvar_data%var(iLookMVAR%mLayerDepth)%dat(ibeg:iend), & ! intent(in): depth of the layer (m) - mvar_data%var(iLookMVAR%mLayerHeight)%dat(ibeg:iend), & ! intent(in): height of the layer mid-point (m) - mvar_data%var(iLookMVAR%iLayerHeight)%dat(ibeg-1:iend), & ! intent(in): height of the layer interfaces (m) - - ! input: upper boundary conditions - mpar_data%var(iLookPARAM%upperBoundHead), & ! intent(in): upper boundary condition for matric head (m) - mpar_data%var(iLookPARAM%upperBoundTheta), & ! intent(in): upper boundary condition for volumetric liquid water content (-) - - ! input: lower boundary conditions - mpar_data%var(iLookPARAM%lowerBoundHead), & ! intent(in): lower boundary condition for matric head (m) - mpar_data%var(iLookPARAM%lowerBoundTheta), & ! intent(in): lower boundary condition for volumetric liquid water content (-) - - ! input: soil parameters - mpar_data%var(iLookPARAM%vGn_alpha), & ! intent(in): van Genutchen "alpha" parameter (m-1) - mpar_data%var(iLookPARAM%vGn_n), & ! intent(in): van Genutchen "n" parameter (-) - mvar_data%var(iLookMVAR%scalarVGn_m)%dat(1), & ! intent(in): van Genutchen "m" parameter (-) - mpar_data%var(iLookPARAM%mpExp), & ! intent(in): empirical exponent in macropore flow equation (-) - mpar_data%var(iLookPARAM%theta_mp), & ! intent(in): volumetric liquid water content when macropore flow begins (-) - mpar_data%var(iLookPARAM%theta_sat), & ! intent(in): soil porosity (-) - mpar_data%var(iLookPARAM%theta_res), & ! intent(in): soil residual volumetric water content (-) - mpar_data%var(iLookPARAM%wettingFrontSuction), & ! intent(in): Green-Ampt wetting front suction (m) - mpar_data%var(iLookPARAM%fieldCapacity), & ! intent(in): field capacity (-) - mpar_data%var(iLookPARAM%rootingDepth), & ! intent(in): rooting depth (m) - mpar_data%var(iLookPARAM%kAnisotropic), & ! intent(in): anisotropy factor for lateral hydraulic conductivity (-) - mpar_data%var(iLookPARAM%zScale_TOPMODEL), & ! intent(in): TOPMODEL scaling factor (m) - mpar_data%var(iLookPARAM%qSurfScale), & ! intent(in): scaling factor in the surface runoff parameterization (-) - mpar_data%var(iLookPARAM%specificYield), & ! intent(in): specific yield (-) - mpar_data%var(iLookPARAM%specificStorage), & ! intent(in): specific storage coefficient (m-1) - mpar_data%var(iLookPARAM%f_impede), & ! intent(in): ice impedence factor (-) - mpar_data%var(iLookPARAM%soilIceScale), & ! intent(in): scaling factor for depth of soil ice, used to get frozen fraction (m) - mpar_data%var(iLookPARAM%soilIceCV), & ! intent(in): CV of depth of soil ice, used to get frozen fraction (-) - - ! input: saturated hydraulic conductivity - mvar_data%var(iLookMVAR%mLayerSatHydCondMP)%dat, & ! intent(in): saturated hydraulic conductivity of macropores at the mid-point of each layer (m s-1) - mvar_data%var(iLookMVAR%mLayerSatHydCond)%dat, & ! intent(in): saturated hydraulic conductivity at the mid-point of each layer (m s-1) - mvar_data%var(iLookMVAR%iLayerSatHydCond)%dat, & ! intent(in): saturated hydraulic conductivity at the interface of each layer (m s-1) - - ! input: factors limiting transpiration (from vegFlux routine) - mvar_data%var(iLookMVAR%mLayerRootDensity)%dat, & ! intent(in): root density in each layer (-) - mvar_data%var(iLookMVAR%scalarTranspireLim)%dat(1), & ! intent(in): weighted average of the transpiration limiting factor (-) - mvar_data%var(iLookMVAR%mLayerTranspireLim)%dat, & ! intent(in): transpiration limiting factor in each layer (-) - - ! output: diagnostic scalar variables - 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,cmessage) ! intent(out): error control - - ! check for errors - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - - ! save information in the data structures - mvar_data%var(iLookMVAR%mLayerdTheta_dPsi)%dat(1:nSoil) = mLayerdTheta_dPsi ! derivative in the soil water characteristic w.r.t. psi (m-1) - mvar_data%var(iLookMVAR%mLayerdPsi_dTheta)%dat(1:nSoil) = mLayerdPsi_dTheta ! derivative in the soil water characteristic w.r.t. theta (m) - - end subroutine soilLiqFlx - - - ! *************************************************************************************************************** - ! private subroutine soilLiqFlx_muster: wrapper routine to compute liquid water fluxes and their derivatives - ! *************************************************************************************************************** - subroutine soilLiqFlx_muster(& - - ! input: model control - doInfiltrate, & ! intent(in): flag to compute infiltration - deriv_desired, & ! intent(in): flag indicating if derivatives are desired - - ! model decisions - ixDerivMethod, & ! intent(in): choice of method used to compute derivative - ixRichards, & ! intent(in): choice of the form of Richards' equation - hc_Profile, & ! intent(in): index defining the option for the hydraulic conductivity profile - ixBcUpperSoilHydrology, & ! intent(in): choice of upper boundary condition for soil hydrology - ixBcLowerSoilHydrology, & ! intent(in): choice of lower boundary condition for soil hydrology - - ! input: trial state variables - mLayerTempTrial, & ! intent(in): temperature (m) - 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: model coordinate variables -- NOTE: use of ibeg and iend to restrict attention to soil - mLayerDepth, & ! intent(in): depth of the layer (m) - mLayerHeight, & ! intent(in): height of the layer mid-point (m) - iLayerHeight, & ! intent(in): height of the layer interfaces (m) - - ! input: upper boundary conditions - upperBoundHead, & ! intent(in): upper boundary condition for matric head (m) - upperBoundTheta, & ! intent(in): upper boundary condition for volumetric liquid water content (-) - - ! input: lower boundary conditions - lowerBoundHead, & ! intent(in): lower boundary condition for matric head (m) - lowerBoundTheta, & ! intent(in): lower boundary condition for volumetric liquid water content (-) - - ! 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_mp, & ! intent(in): volumetric liquid water content when macropore flow begins (-) - theta_sat, & ! intent(in): soil porosity (-) - theta_res, & ! intent(in): soil residual volumetric water content (-) - wettingFrontSuction, & ! intent(in): Green-Ampt wetting front suction (m) - fieldCapacity, & ! intent(in): field capacity (-) - rootingDepth, & ! intent(in): rooting depth (m) - kAnisotropic, & ! intent(in): anisotropy factor for lateral hydraulic conductivity (-) - zScale_TOPMODEL, & ! intent(in): TOPMODEL scaling factor (m) - qSurfScale, & ! intent(in): scaling factor in the surface runoff parameterization (-) - specificYield, & ! intent(in): specific yield (-) - specificStorage, & ! intent(in): specific storage coefficient (m-1) - f_impede, & ! intent(in): ice impedence factor (-) - soilIceScale, & ! intent(in): scaling factor for depth of soil ice, used to get frozen fraction (m) - soilIceCV, & ! intent(in): CV of depth of soil ice, used to get frozen fraction (-) - - ! input: saturated hydraulic conductivity in each layer - mLayerSatHydCondMP, & ! intent(in): saturated hydraulic conductivity of macropores at the mid-point of each layer (m s-1) - mLayerSatHydCond, & ! intent(in): saturated hydraulic conductivity at the mid-point of each layer (m s-1) - iLayerSatHydCond, & ! intent(in): saturated hydraulic conductivity at the interface of each layer (m s-1) - - ! input: factors limiting transpiration (from vegFlux routine) - mLayerRootDensity, & ! intent(in): root density in each layer (-) - scalarTranspireLim, & ! intent(in): weighted average of the transpiration limiting factor (-) - mLayerTranspireLim, & ! intent(in): transpiration limiting factor in each layer (-) - - ! 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 variables - ! ------------------------------------------------------------------------------------------------------------------------------------------------- - ! input: model control - logical(lgt),intent(in) :: doInfiltrate ! flag to compute infiltration - logical(lgt),intent(in) :: deriv_desired ! flag indicating if derivatives are desired - ! input: model decisions - integer(i4b),intent(in) :: ixDerivMethod ! choice of method used to compute derivative - integer(i4b),intent(in) :: ixRichards ! choice of the form of Richards' equation - integer(i4b),intent(in) :: hc_profile ! choice of type of hydraulic conductivity profile - integer(i4b),intent(in) :: ixBcUpperSoilHydrology ! choice of upper boundary condition for soil hydrology - integer(i4b),intent(in) :: ixBcLowerSoilHydrology ! choice of lower boundary condition for soil hydrology - ! input: trial model state variables - real(dp),intent(in) :: mLayerTempTrial(:) ! temperature in each layer at the current iteration (K) - real(dp),intent(in) :: mLayerMatricHeadTrial(:) ! matric head in each layer at the current iteration (m) - real(dp),intent(in) :: mLayerVolFracLiqTrial(:) ! volumetric fraction of liquid water at the current iteration (-) - real(dp),intent(in) :: mLayerVolFracIceTrial(:) ! volumetric fraction of ice at the current iteration (-) - ! input: pre-computed derivatves - real(dp),intent(in) :: mLayerdTheta_dTk(:) ! derivative in volumetric liquid water content w.r.t. temperature (K-1) - real(dp),intent(in) :: dPsiLiq_dTemp(:) ! derivative in liquid water matric potential w.r.t. temperature (m K-1) - ! input: model fluxes - real(dp),intent(in) :: scalarCanopyTranspiration ! canopy transpiration (kg m-2 s-1) - real(dp),intent(in) :: scalarGroundEvaporation ! ground evaporation (kg m-2 s-1) - real(dp),intent(in) :: scalarRainPlusMelt ! rain plus melt (m s-1) - ! input: model coordinate variables - real(dp),intent(in) :: mLayerDepth(:) ! depth of the layer (m) - real(dp),intent(in) :: mLayerHeight(:) ! height of the layer mid-point (m) - real(dp),intent(in) :: iLayerHeight(0:) ! height of the layer interfaces (m) - ! input: diriclet upper boundary conditions - real(dp),intent(in) :: upperBoundHead ! upper boundary condition for matric head (m) - real(dp),intent(in) :: upperBoundTheta ! upper boundary condition for volumetric liquid water content (-) - ! input: diriclet lower boundary conditions - real(dp),intent(in) :: lowerBoundHead ! lower boundary condition for matric head (m) - real(dp),intent(in) :: lowerBoundTheta ! lower boundary condition for volumetric liquid water content (-) - ! input: soil parameters - real(dp),intent(in) :: vGn_alpha ! van Genutchen "alpha" parameter (m-1) - real(dp),intent(in) :: vGn_n ! van Genutchen "n" parameter (-) - real(dp),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) - real(dp),intent(in) :: mpExp ! empirical exponent in macropore flow equation (-) - real(dp),intent(in) :: theta_mp ! volumetric liquid water content when macropore flow begins (-) - real(dp),intent(in) :: theta_sat ! soil porosity (-) - real(dp),intent(in) :: theta_res ! soil residual volumetric water content (-) - real(dp),intent(in) :: wettingFrontSuction ! Green-Ampt wetting front suction (m) - real(dp),intent(in) :: fieldCapacity ! field capacity (-) - real(dp),intent(in) :: rootingDepth ! rooting depth (m) - real(dp),intent(in) :: kAnisotropic ! anisotropy factor for lateral hydraulic conductivity (-) - real(dp),intent(in) :: zScale_TOPMODEL ! TOPMODEL scaling factor (m) - real(dp),intent(in) :: qSurfScale ! scaling factor in the surface runoff parameterization (-) - real(dp),intent(in) :: specificYield ! specific yield (-) - real(dp),intent(in) :: specificStorage ! specific storage coefficient (m-1) - real(dp),intent(in) :: f_impede ! ice impedence factor (-) - real(dp),intent(in) :: soilIceScale ! scaling factor for depth of soil ice, used to get frozen fraction (m) - real(dp),intent(in) :: soilIceCV ! CV of depth of soil ice, used to get frozen fraction (-) - ! input: saturated hydraulic conductivity - real(dp),intent(in) :: mLayerSatHydCondMP(:) ! saturated hydraulic conductivity of macropores at the mid-point of each layer (m s-1) - real(dp),intent(in) :: mLayerSatHydCond(:) ! saturated hydraulic conductivity at the mid-point of each layer (m s-1) - real(dp),intent(in) :: iLayerSatHydCond(0:) ! saturated hydraulic conductivity at the interface of each layer (m s-1) - ! input: factors limiting transpiration (from vegFlux routine) - real(dp),intent(in) :: mLayerRootDensity(:) ! root density in each layer (-) - real(dp),intent(in) :: scalarTranspireLim ! weighted average of the transpiration limiting factor (-) - real(dp),intent(in) :: mLayerTranspireLim(:) ! transpiration limiting factor in each layer (-) - ! ------------------------------------------------------------------------------------------------------------------------------------------------- - ! ***** output variables - ! ------------------------------------------------------------------------------------------------------------------------------------------------- - ! output: diagnostic variables for surface runoff - real(dp),intent(inout) :: xMaxInfilRate ! maximum infiltration rate (m s-1) - real(dp),intent(inout) :: scalarInfilArea ! fraction of unfrozen area where water can infiltrate (-) - real(dp),intent(inout) :: scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) - real(dp),intent(out) :: scalarSurfaceRunoff ! surface runoff (m s-1) - ! output: diagnostic variables for each layer - real(dp),intent(out) :: mLayerdTheta_dPsi(:) ! derivative in the soil water characteristic w.r.t. psi (m-1) - real(dp),intent(out) :: mLayerdPsi_dTheta(:) ! derivative in the soil water characteristic w.r.t. theta (m) - real(dp),intent(out) :: dHydCond_dMatric(:) ! derivative in hydraulic conductivity w.r.t matric head (s-1) - ! output: liquid fluxes - real(dp),intent(out) :: scalarSurfaceInfiltration ! surface infiltration rate (m s-1) - real(dp),intent(out) :: iLayerLiqFluxSoil(0:) ! liquid flux at soil layer interfaces (m s-1) - real(dp),intent(out) :: mLayerTranspire(:) ! transpiration loss from each soil layer (m s-1) - real(dp),intent(out) :: 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(dp),intent(out) :: dq_dHydStateAbove(0:) ! derivative in the flux in layer interfaces w.r.t. state variables in the layer above - real(dp),intent(out) :: 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(dp),intent(out) :: dq_dNrgStateAbove(0:) ! derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) - real(dp),intent(out) :: 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 - ! ------------------------------------------------------------------------------------------------------------------------------------------------- ! 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 ! additional variables to compute numerical derivatives @@ -512,15 +216,67 @@ subroutine soilLiqFlx_muster(& ! 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(dp),dimension(0:nSoil) :: iLayerHeight ! height of the layer interfaces (m) ! compute fluxes and derivatives at layer interfaces real(dp),dimension(2) :: vectorVolFracLiqTrial ! trial value of volumetric liquid water content (-) real(dp),dimension(2) :: vectorMatricHeadTrial ! trial value of matric head (m) real(dp),dimension(2) :: vectorHydCondTrial ! trial value of hydraulic conductivity (m s-1) real(dp),dimension(2) :: vectorDiffuseTrial ! trial value of hydraulic diffusivity (m2 s-1) - real(dp) :: scalardPsi_dTheta ! derivative in soil water characteristix, used for perturbations when computing numerical derivatives + real(dp) :: scalardPsi_dTheta ! derivative in soil water characteristix, used for perturbations when computing numerical derivatives ! ------------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control - err=0; message='soilLiqFlx_muster/' + 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 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(1), & ! 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 @@ -533,24 +289,28 @@ subroutine soilLiqFlx_muster(& if(ixDerivMethod==numerical)then message=trim(message)//'numerical derivates do not account for the cross derivatives between hydrology and thermodynamics' err=20; return - endif + end if ! check the need to compute analytical derivatives if(deriv_desired .and. ixDerivMethod==analytical)then desireAnal = .true. else desireAnal = .false. - endif + 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 - endif + end if ! identify the number of layers that contain roots - nRoots = count(iLayerHeight(0:nSoil-1) < rootingDepth) + 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 @@ -558,7 +318,7 @@ subroutine soilLiqFlx_muster(& 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; endif + !if(ixIce==nSoil)then; err=20; message=trim(message)//'ice extends to the bottom of the soil profile'; return; end if ! ************************************************************************************************************************************************* ! ************************************************************************************************************************************************* @@ -571,17 +331,20 @@ subroutine soilLiqFlx_muster(& 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(:) + mLayerTranspireFrac(:) = mLayerRootDensity(:) / sum(mLayerRootDensity) + end if + + ! check fractions sum to one + if(abs(sum(mLayerTranspireFrac) - 1._dp) > 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._dp - !print*, trim(message)//'mLayerTranspire = ', mLayerTranspire - !print*, trim(message)//'mLayerTranspireLim = ', mLayerTranspireLim - !print*, trim(message)//'scalarCanopyTranspiration = ', scalarCanopyTranspiration + ! special case of prescribed head -- no transpiration + if(ixBcUpperSoilHydrology==prescribedHead) mLayerTranspire(:) = 0._dp ! ************************************************************************************************************************************************* ! ************************************************************************************************************************************************* @@ -590,6 +353,7 @@ subroutine soilLiqFlx_muster(& ! compute diagnostic variables at the nodes throughout the soil profile ! ------------------------------------------------------------------------------------------------------------------------------------------------- do iSoil=1,nSoil ! (loop through soil layers) + call diagv_node(& ! input: model control desireAnal, & ! intent(in): flag indicating if derivatives are desired @@ -603,12 +367,12 @@ subroutine soilLiqFlx_muster(& 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, & ! intent(in): van Genutchen "alpha" parameter (m-1) - vGn_n, & ! intent(in): van Genutchen "n" parameter (-) - VGn_m, & ! intent(in): van Genutchen "m" parameter (-) + 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, & ! intent(in): soil porosity (-) - theta_res, & ! intent(in): soil residual volumetric water content (-) + theta_sat(iSoil), & ! intent(in): soil porosity (-) + theta_res(iSoil), & ! 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 @@ -628,7 +392,8 @@ subroutine soilLiqFlx_muster(& 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; endif + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + end do ! (looping through soil layers) ! ************************************************************************************************************************************************* @@ -680,6 +445,7 @@ subroutine soilLiqFlx_muster(& ! ===== ! compute surface flux and its derivative... ! ========================================== + call surfaceFlx(& ! input: model control doInfiltrate, & ! intent(in): flag indicating if desire to compute infiltration @@ -701,19 +467,16 @@ subroutine soilLiqFlx_muster(& upperBoundTheta, & ! intent(in): upper boundary condition (-) ! input: flux at the upper boundary scalarRainPlusMelt, & ! intent(in): rain plus melt (m s-1) - ! input: derivative in soil water characteristix - mLayerdPsi_dTheta(1), & ! intent(in): derivative of the soil moisture characteristic w.r.t. theta (m) - mLayerdTheta_dPsi(1), & ! intent(in): derivative of the soil moisture characteristic w.r.t. psi (m-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, & ! 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 (-) + 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) @@ -734,7 +497,7 @@ subroutine soilLiqFlx_muster(& 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; endif + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! include base soil evaporation as the upper boundary flux iLayerLiqFluxSoil(0) = scalarGroundEvaporation/iden_water + scalarSurfaceInfiltration @@ -746,7 +509,7 @@ subroutine soilLiqFlx_muster(& case(perturbStateBelow); scalarFlux_dStateBelow = iLayerLiqFluxSoil(0) case default; err=10; message=trim(message)//"unknown perturbation"; return end select - endif + end if !write(*,'(a,1x,10(f30.15))') 'scalarRainPlusMelt, scalarSurfaceInfiltration = ', scalarRainPlusMelt, scalarSurfaceInfiltration @@ -755,7 +518,7 @@ subroutine soilLiqFlx_muster(& ! compute numerical derivatives if(deriv_desired .and. ixDerivMethod==numerical)then dq_dHydStateBelow(0) = (scalarFlux_dStateBelow - scalarFlux)/dx ! change in surface flux w.r.t. change in the soil moisture in the top soil layer (m s-1) - endif + end if !print*, 'scalarSurfaceInfiltration, iLayerLiqFluxSoil(0) = ', scalarSurfaceInfiltration, iLayerLiqFluxSoil(0) !print*, '(ixDerivMethod==numerical), dq_dHydStateBelow(0) = ', (ixDerivMethod==numerical), dq_dHydStateBelow(0) !pause @@ -800,7 +563,7 @@ subroutine soilLiqFlx_muster(& case(mixdform); vectorMatricHeadTrial(ixPerturb) = vectorMatricHeadTrial(ixPerturb) + dx case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return end select ! (form of Richards' equation) - endif + end if ! ===== ! get hydraulic conductivty... @@ -812,21 +575,22 @@ subroutine soilLiqFlx_muster(& if(ixPerturb > 0)then select case(ixRichards) case(moisture) - scalardPsi_dTheta = dPsi_dTheta(vectorVolFracLiqTrial(ixPerturb),vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) - vectorHydCondTrial(ixPerturb) = hydCond_liq(vectorVolFracLiqTrial(ixPerturb),mLayerSatHydCond(ixOriginal),theta_res,theta_sat,vGn_m) * iceImpedeFac(ixOriginal) + 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,theta_res,theta_sat,vGn_n,vGn_m) - scalarHydCondMicro = hydCond_psi(vectorMatricHeadTrial(ixPerturb),mLayerSatHydCond(ixOriginal),vGn_alpha,vGn_n,vGn_m) * iceImpedeFac(ixOriginal) - scalarHydCondMacro = hydCondMP_liq(scalarVolFracLiqTrial,theta_sat,theta_mp,mpExp,mLayerSatHydCondMP(ixOriginal),mLayerSatHydCond(ixOriginal)) + 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,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) - endif + end if ! ===== ! compute vertical flux at layer interface and its derivative w.r.t. the state above and the state below... ! ========================================================================================================= + call iLayerFlux(& ! input: model control desireAnal, & ! intent(in): flag indicating if derivatives are desired @@ -859,7 +623,7 @@ subroutine soilLiqFlx_muster(& 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; endif + 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 @@ -869,7 +633,7 @@ subroutine soilLiqFlx_muster(& case(perturbStateBelow); scalarFlux_dStateBelow = iLayerLiqFluxSoil(iLayer) case default; err=10; message=trim(message)//"unknown perturbation"; return end select - endif + end if end do ! (looping through different flux calculations -- one or multiple calls depending if desire for numerical or analytical derivatives) @@ -877,7 +641,7 @@ subroutine soilLiqFlx_muster(& 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) - endif + end if ! check !if(iLayer==6) write(*,'(a,i4,1x,10(e25.15,1x))') 'iLayer, vectorMatricHeadTrial, iLayerHydCond(iLayer), iLayerLiqFluxSoil(iLayer) = ',& @@ -939,8 +703,8 @@ subroutine soilLiqFlx_muster(& ! compute perturbed value of hydraulic conductivity case(perturbStateAbove) select case(ixRichards) - case(moisture); scalarHydCondTrial = hydCond_liq(scalarVolFracLiqTrial,mLayerSatHydCond(nSoil),theta_res,theta_sat,vGn_m) * iceImpedeFac(nSoil) - case(mixdform); scalarHydCondTrial = hydCond_psi(scalarMatricHeadTrial,mLayerSatHydCond(nSoil),vGn_alpha,vGn_n,vGn_m) * iceImpedeFac(nSoil) + case(moisture); scalarHydCondTrial = hydCond_liq(scalarVolFracLiqTrial,mLayerSatHydCond(nSoil),theta_res(nSoil),theta_sat(nSoil),vGn_m(nSoil)) * iceImpedeFac(nSoil) + case(mixdform); scalarHydCondTrial = hydCond_psi(scalarMatricHeadTrial,mLayerSatHydCond(nSoil),vGn_alpha(nSoil),vGn_n(nSoil),vGn_m(nSoil)) * iceImpedeFac(nSoil) end select ! (use un-perturbed value) @@ -952,11 +716,11 @@ subroutine soilLiqFlx_muster(& ! ===== ! 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) - hc_profile, & ! intent(in): index defining the decrease of hydraulic conductivity with depth ixBcLowerSoilHydrology, & ! intent(in): index defining the type of boundary conditions ! input: state variables scalarMatricHeadTrial, & ! intent(in): matric head in the lowest unsaturated node (m) @@ -969,7 +733,6 @@ subroutine soilLiqFlx_muster(& lowerBoundTheta, & ! intent(in): lower boundary condition (-) ! input: derivative in the soil water characteristic mLayerdPsi_dTheta(nSoil), & ! intent(in): derivative in the soil water characteristic - mLayerdTheta_dPsi(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) @@ -980,14 +743,13 @@ subroutine soilLiqFlx_muster(& 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, & ! 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 (-) + 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) - specificYield, & ! intent(in): specific yield (-) ! 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) @@ -998,7 +760,7 @@ subroutine soilLiqFlx_muster(& 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; endif + 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 @@ -1008,7 +770,7 @@ subroutine soilLiqFlx_muster(& 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 - endif + end if end do ! (looping through different flux calculations -- one or multiple calls depending if desire for numerical or analytical derivatives) @@ -1017,7 +779,7 @@ subroutine soilLiqFlx_muster(& ! (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) - endif + end if ! no dependence on the aquifer for drainage dq_dHydStateBelow(nSoil) = 0._dp ! keep this here in case we want to couple some day.... @@ -1028,13 +790,13 @@ subroutine soilLiqFlx_muster(& ! end of drainage section - ! ***************************************************************************************************************************************************************** ! ***************************************************************************************************************************************************************** + ! end association between local variables and the information in the data structures + end associate - end subroutine soilLiqFlx_muster - + end subroutine soilLiqFlx ! *************************************************************************************************************** ! private subroutine diagv_node: compute transmittance and derivatives for model nodes @@ -1143,9 +905,18 @@ subroutine diagv_node(& real(dp) :: dK_dLiq__noIce ! derivative in hydraulic conductivity w.r.t volumetric liquid water content, in the absence of ice (m s-1) real(dp) :: dK_dPsi__noIce ! derivative in hydraulic conductivity w.r.t matric head, in the absence of ice (s-1) real(dp) :: relSatMP ! relative saturation of macropores (-) - !real(dp) :: xConst,vTheta,volLiq,volIce,x1,x2,d1,d2,effSat,psiLiq,dEff,dPsi,hydCon,hydIce ! test derivative - !real(dp) :: x1,x2 ! trial values of theta (-) - !real(dp),parameter :: dx = 1.e-8_dp ! finite difference increment (m) + ! local variables to test the derivative + logical(lgt),parameter :: testDeriv=.false. ! local flag to test the derivative + real(dp) :: xConst ! LH_fus/(gravity*Tfreeze), used in freezing point depression equation (m K-1) + real(dp) :: vTheta ! volumetric fraction of total water (-) + real(dp) :: volLiq ! volumetric fraction of liquid water (-) + real(dp) :: volIce ! volumetric fraction of ice (-) + real(dp) :: volFracLiq1,volFracLiq2 ! different trial values of volumetric liquid water content (-) + real(dp) :: effSat ! effective saturation (-) + real(dp) :: psiLiq ! liquid water matric potential (m) + real(dp) :: hydCon ! hydraulic conductivity (m s-1) + real(dp) :: hydIce ! hydraulic conductivity after accounting for ice impedance (-) + real(dp),parameter :: dx = 1.e-8_dp ! finite difference increment (m) ! initialize error control err=0; message="diagv_node/" @@ -1157,15 +928,15 @@ subroutine diagv_node(& scalardTheta_dPsi = valueMissing ! (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) - !x1 = volFracLiq(scalarMatricHeadTrial, vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) - !x2 = volFracLiq(scalarMatricHeadTrial+dx,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) - !print*, 'scalardTheta_dPsi = ', scalardTheta_dPsi, (x2 - x1)/dx - !scalardPsi_dTheta = valueMissing ! (deliberately cause problems if this is ever used) 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) + print*, 'scalardTheta_dPsi = ', scalardTheta_dPsi, (volFracLiq2 - volFracLiq1)/dx + 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 @@ -1173,7 +944,6 @@ subroutine diagv_node(& call iceImpede(scalarVolFracIceTrial,f_impede, & ! input iceImpedeFac,dIceImpede_dLiq) ! output - select case(ixRichards) ! ***** moisture-based form of Richards' equation case(moisture) @@ -1190,11 +960,11 @@ subroutine diagv_node(& dHydCond_dVolLiq = hydCond_noIce*dIceImpede_dLiq + dK_dLiq__noIce*iceImpedeFac else dHydCond_dVolLiq = dHydCond_dLiq(scalarVolFracLiqTrial,scalarSatHydCond,theta_res,theta_sat,vGn_m,.true.) - endif + 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 = valueMissing ! not used, so cause problems - endif + end if ! ***** mixed form of Richards' equation -- just compute hydraulic condictivity case(mixdform) @@ -1205,6 +975,7 @@ subroutine diagv_node(& localVolFracLiq = volFracLiq(scalarMatricHeadTrial,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) @@ -1215,7 +986,7 @@ subroutine diagv_node(& else dHydCondMacro_dVolLiq = 0._dp dHydCondMacro_dMatric = 0._dp - endif + 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 @@ -1224,7 +995,7 @@ subroutine diagv_node(& else dHydCondMicro_dTemp = 0._dp dHydCondMicro_dMatric = dHydCond_dPsi(scalarMatricHeadTrial,scalarSatHydCond,vGn_alpha,vGn_n,vGn_m,.true.) - endif + end if ! (combine derivatives) dHydCond_dMatric = dHydCondMicro_dMatric + dHydCondMacro_dMatric ! (compute analytical derivative for change in ice impedance factor w.r.t. temperature) @@ -1235,34 +1006,36 @@ subroutine diagv_node(& ! (compute derivative in hydraulic conductivity w.r.t. temperature) dHydCond_dTemp = hydCond_noIce*dIceImpede_dT + dHydCondMicro_dTemp*iceImpedeFac ! (test derivative) - !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._dp,1._dp,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 - !pause + 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._dp,1._dp,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 = valueMissing ! not used, so cause problems dDiffuse_dVolLiq = valueMissing ! not used, so cause problems - endif + end if case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return - endselect + end select ! if derivatives are not desired, then set values to missing if(.not.deriv_desired)then dHydCond_dVolLiq = valueMissing ! not used, so cause problems dDiffuse_dVolLiq = valueMissing ! not used, so cause problems dHydCond_dMatric = valueMissing ! not used, so cause problems - endif + end if end subroutine diagv_node @@ -1291,9 +1064,6 @@ subroutine surfaceFlx(& upperBoundTheta, & ! intent(in): upper boundary condition (-) ! input: flux at the upper boundary scalarRainPlusMelt, & ! intent(in): rain plus melt (m s-1) - ! input: derivative in soil water characteristix - scalardPsi_dTheta, & ! intent(in): derivative of the soil moisture characteristic w.r.t. theta (m) - scalardTheta_dPsi, & ! intent(in): derivative of the soil moisture characteristic w.r.t. psi (m-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) @@ -1352,9 +1122,6 @@ subroutine surfaceFlx(& real(dp),intent(in) :: upperBoundTheta ! upper boundary condition for volumetric liquid water content (-) ! input: flux at the upper boundary real(dp),intent(in) :: scalarRainPlusMelt ! rain plus melt, used as input to the soil zone before computing surface runoff (m s-1) - ! input: derivative in soil water characteristix - real(dp),intent(in) :: scalardPsi_dTheta ! derivative of the soil moisture characteristic w.r.t. theta (m) - real(dp),intent(in) :: scalardTheta_dPsi ! derivative of the soil moisture characteristic w.r.t. psi (m-1) ! input: transmittance real(dp),intent(in) :: surfaceSatHydCond ! saturated hydraulic conductivity at the surface (m s-1) real(dp),intent(in) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) @@ -1406,6 +1173,7 @@ subroutine surfaceFlx(& real(dp) :: fInfRaw ! infiltrating area before imposing solution constraints (-) real(dp),parameter :: maxFracCap=0.995_dp ! maximum fraction capacity -- used to avoid numerical problems associated with an enormous derivative real(dp),parameter :: scaleFactor=0.000001_dp ! scale factor for the smoothing function (-) + real(dp),parameter :: qSurfScaleMax=1000._dp ! maximum surface runoff scaling factor (-) ! (fraction of impermeable area associated with frozen ground) real(dp) :: alpha ! shape parameter in the Gamma distribution real(dp) :: xLimg ! upper limit of the integral @@ -1462,7 +1230,7 @@ subroutine surfaceFlx(& else dq_dHydState = 0._dp dNum = 0._dp - endif + end if !write(*,'(a,1x,10(e30.20,1x))') 'scalarMatricHead, scalarSurfaceInfiltration, dq_dHydState, dNum = ', & ! scalarMatricHead, scalarSurfaceInfiltration, dq_dHydState, dNum @@ -1481,16 +1249,18 @@ subroutine surfaceFlx(& do iLayer=1,nRoots-1 rootZoneLiq = rootZoneLiq + mLayerVolFracLiq(iLayer)*mLayerDepth(iLayer) rootZoneIce = rootZoneIce + mLayerVolFracIce(iLayer)*mLayerDepth(iLayer) - enddo - endif - if(rootingDepth < iLayerHeight(nRoots-1))then; err=20; message=trim(message)//'problem with definition of nRoots'; return; endif + 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)then; err=20; message=trim(message)//'liquid water in the root zone exceeds capacity'; return; endif + 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 @@ -1503,16 +1273,22 @@ subroutine surfaceFlx(& !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 - fracCap = rootZoneLiq/(maxFracCap*availCapacity) ! fraction of available root zone filled with water - fInfRaw = 1._dp - exp(-qSurfScale*(1._dp - fracCap)) ! infiltrating area -- allowed to violate solution constraints - scalarInfilArea = min(0.5_dp*(fInfRaw + sqrt(fInfRaw**2._dp + scaleFactor)), 1._dp) ! infiltrating area -- constrained - !print*, 'scalarInfilArea = ', scalarInfilArea + if(qSurfScale < qSurfScaleMax)then + fracCap = rootZoneLiq/(maxFracCap*availCapacity) ! fraction of available root zone filled with water + fInfRaw = 1._dp - exp(-qSurfScale*(1._dp - fracCap)) ! infiltrating area -- allowed to violate solution constraints + scalarInfilArea = min(0.5_dp*(fInfRaw + sqrt(fInfRaw**2._dp + scaleFactor)), 1._dp) ! infiltrating area -- constrained + !print*, 'qSurfScale, fracCap, scalarInfilArea = ', qSurfScale, fracCap, scalarInfilArea + else + scalarInfilArea = 1._dp + endif ! check to ensure we are not infiltrating into a fully saturated column - if(sum(mLayerVolFracLiq(ixIce+1:nRoots)*mLayerDepth(ixIce+1:nRoots)) > 0.9999_dp*theta_sat*sum(mLayerDepth(ixIce+1:nRoots))) scalarInfilArea=0._dp - !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)) + if(ixIce 0.9999_dp*theta_sat*sum(mLayerDepth(ixIce+1:nRoots))) scalarInfilArea=0._dp + !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) @@ -1522,18 +1298,19 @@ subroutine surfaceFlx(& scalarFrozenArea = 0._dp else scalarFrozenArea = 0._dp - endif + end if !print*, 'scalarFrozenArea, rootZoneIce = ', scalarFrozenArea, rootZoneIce - endif ! (if desire to compute infiltration) + end if ! (if desire to compute infiltration) ! compute infiltration (m s-1) scalarSurfaceInfiltration = (1._dp - scalarFrozenArea)*scalarInfilArea*min(scalarRainPlusMelt,xMaxInfilRate) - !print*, 'scalarSurfaceInfiltration = ', scalarSurfaceInfiltration - !print*, '(1._dp - scalarFrozenArea), (1._dp - scalarFrozenArea)*scalarInfilArea = ', (1._dp - scalarFrozenArea), (1._dp - scalarFrozenArea)*scalarInfilArea ! compute surface runoff (m s-1) scalarSurfaceRunoff = scalarRainPlusMelt - scalarSurfaceInfiltration + !print*, 'scalarRainPlusMelt, xMaxInfilRate = ', scalarRainPlusMelt, xMaxInfilRate + !print*, 'scalarSurfaceInfiltration, scalarSurfaceRunoff = ', scalarSurfaceInfiltration, scalarSurfaceRunoff + !print*, '(1._dp - scalarFrozenArea), (1._dp - scalarFrozenArea)*scalarInfilArea = ', (1._dp - scalarFrozenArea), (1._dp - scalarFrozenArea)*scalarInfilArea ! set surface hydraulic conductivity and diffusivity to missing (not used for flux condition) surfaceHydCond = valueMissing @@ -1548,7 +1325,7 @@ subroutine surfaceFlx(& ! ***** error check case default; err=20; message=trim(message)//'unknown upper boundary condition for soil hydrology'; return - endselect ! (type of upper boundary condition) + end select ! (type of upper boundary condition) end subroutine surfaceFlx @@ -1649,7 +1426,7 @@ subroutine iLayerFlux(& iLayerHydCond = (nodeHydCondTrial(ixLower) * nodeHydCondTrial(ixUpper))**0.5_dp else iLayerHydCond = (nodeHydCondTrial(ixLower) + nodeHydCondTrial(ixUpper))*0.5_dp - endif + 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) @@ -1678,7 +1455,7 @@ subroutine iLayerFlux(& if(.not.useGeometric)then message=trim(message)//'only currently implemented for geometric mean -- change local flag' err=20; return - endif + end if ! derivatives in hydraulic conductivity at the layer interface (m s-1) dHydCondIface_dVolLiqAbove = dHydCond_dVolLiq(ixUpper)*nodeHydCondTrial(ixLower) * 0.5_dp/max(iLayerHydCond,verySmall) dHydCondIface_dVolLiqBelow = dHydCond_dVolLiq(ixLower)*nodeHydCondTrial(ixUpper) * 0.5_dp/max(iLayerHydCond,verySmall) @@ -1696,7 +1473,7 @@ subroutine iLayerFlux(& else dHydCondIface_dMatricAbove = dHydCond_dMatric(ixUpper)/2._dp dHydCondIface_dMatricBelow = dHydCond_dMatric(ixLower)/2._dp - endif + 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 @@ -1708,7 +1485,7 @@ subroutine iLayerFlux(& else dq_dHydStateAbove = valueMissing dq_dHydStateBelow = valueMissing - endif + end if end subroutine iLayerFlux @@ -1720,7 +1497,6 @@ 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) - hc_profile, & ! intent(in): index defining the decrease of hydraulic conductivity with depth 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) @@ -1733,7 +1509,6 @@ subroutine qDrainFlux(& 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) - node__dTheta_dPsi, & ! intent(in): derivative of the soil moisture characteristic w.r.t. psi (m-1) ! 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) @@ -1751,7 +1526,6 @@ subroutine qDrainFlux(& 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) - specificYield, & ! intent(in): drainable porosity (-) ! 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) @@ -1773,7 +1547,6 @@ subroutine qDrainFlux(& ! 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) :: hc_profile ! index defining the decrease of hydraulic conductivity with depth integer(i4b),intent(in) :: bc_lower ! index defining the type of boundary conditions ! input: state and diagnostic variables real(dp),intent(in) :: nodeMatricHead ! matric head in the lowest unsaturated node (m) @@ -1786,7 +1559,6 @@ subroutine qDrainFlux(& real(dp),intent(in) :: lowerBoundTheta ! lower boundary condition for volumetric liquid water content (-) ! input: derivative in soil water characteristix real(dp),intent(in) :: node__dPsi_dTheta ! derivative of the soil moisture characteristic w.r.t. theta (m) - real(dp),intent(in) :: node__dTheta_dPsi ! derivative of the soil moisture characteristic w.r.t. psi (m-1) ! input: transmittance real(dp),intent(in) :: surfaceSatHydCond ! saturated hydraulic conductivity at the surface (m s-1) real(dp),intent(in) :: bottomSatHydCond ! saturated hydraulic conductivity at the bottom of the unsaturated zone (m s-1) @@ -1804,7 +1576,6 @@ subroutine qDrainFlux(& real(dp),intent(in) :: theta_res ! soil residual volumetric water content (-) real(dp),intent(in) :: kAnisotropic ! anisotropy factor for lateral hydraulic conductivity (-) real(dp),intent(in) :: zScale_TOPMODEL ! scale factor for TOPMODEL-ish baseflow parameterization (m) - real(dp),intent(in) :: specificYield ! specific yield (-) ! ----------------------------------------------------------------------------------------------------------------------------- ! output: hydraulic conductivity at the bottom of the unsaturated zone real(dp),intent(out) :: bottomHydCond ! hydraulic conductivity at the bottom of the unsaturated zone (m s-1) @@ -1865,7 +1636,7 @@ subroutine qDrainFlux(& else ! (do not desire derivatives) dq_dHydStateUnsat = valueMissing dq_dNrgStateUnsat = valueMissing - endif + end if ! --------------------------------------------------------------------------------------------- ! * function of matric head in the bottom layer @@ -1876,7 +1647,7 @@ subroutine qDrainFlux(& select case(ixRichards) case(moisture); nodePsi = matricHead(nodeVolFracLiq,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) case(mixdform); nodePsi = nodeMatricHead - endselect + end select zWater = nodeHeight - nodePsi scalarDrainage = kAnisotropic*surfaceSatHydCond * exp(-zWater/zScale_TOPMODEL) @@ -1893,7 +1664,7 @@ subroutine qDrainFlux(& else ! (do not desire derivatives) dq_dHydStateUnsat = valueMissing dq_dNrgStateUnsat = valueMissing - endif + end if ! --------------------------------------------------------------------------------------------- ! * free drainage @@ -1916,7 +1687,7 @@ subroutine qDrainFlux(& else ! (do not desire derivatives) dq_dHydStateUnsat = valueMissing dq_dNrgStateUnsat = valueMissing - endif + end if ! --------------------------------------------------------------------------------------------- @@ -1930,14 +1701,14 @@ subroutine qDrainFlux(& else dq_dHydStateUnsat = valueMissing dq_dNrgStateUnsat = valueMissing - endif + end if ! --------------------------------------------------------------------------------------------- ! * error check ! --------------------------------------------------------------------------------------------- case default; err=20; message=trim(message)//'unknown lower boundary condition for soil hydrology'; return - endselect ! (type of boundary condition) + end select ! (type of boundary condition) end subroutine qDrainFlux diff --git a/build/source/engine/soil_utils.f90 b/build/source/engine/soil_utils.f90 old mode 100644 new mode 100755 index 6a4329507..770a7a2eb --- a/build/source/engine/soil_utils.f90 +++ b/build/source/engine/soil_utils.f90 @@ -30,7 +30,6 @@ module soil_utils_module public::hydCondMP_liq public::dHydCond_dPsi public::dHydCond_dLiq -public::satDeficit public::volFracLiq public::matricHead public::dTheta_dPsi @@ -39,6 +38,7 @@ module soil_utils_module public::RH_soilair public::dTheta_dTk public::crit_soilT +public::liquidHead public::gammp ! constant parameters real(dp),parameter :: valueMissing=-9999._dp ! missing value parameter @@ -84,6 +84,115 @@ subroutine dIceImpede_dTemp(volFracIce,dTheta_dT,f_impede,dIceImpede_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(dp),intent(in) :: matricHeadTotal ! total water matric potential (m) + real(dp),intent(in) :: volFracLiq ! volumetric fraction of liquid water (-) + real(dp),intent(in) :: volFracIce ! volumetric fraction of ice (-) + real(dp),intent(in) :: vGn_alpha,vGn_n,theta_sat,theta_res,vGn_m ! soil parameters + real(dp),intent(in) ,optional :: dVolTot_dPsi0 ! derivative in the soil water characteristic (m-1) + real(dp),intent(in) ,optional :: dTheta_dT ! derivative in volumetric total water w.r.t. temperature (K-1) + ! output + real(dp),intent(out) :: matricHeadLiq ! liquid water matric potential (m) + real(dp),intent(out) ,optional :: dPsiLiq_dPsi0 ! derivative in the liquid water matric potential w.r.t. the total water matric potential (-) + real(dp),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(dp) :: xNum,xDen ! temporary variables (numeratir, denominator) + real(dp) :: effSat ! effective saturation (-) + real(dp) :: dPsiLiq_dEffSat ! derivative in liquid water matric potential w.r.t. effective saturation (m) + real(dp) :: 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._dp)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._dp,1._dp,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._dp,1._dp,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._dp) + + 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._dp) + 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._dp ! derivative=1 because values are identical + if(present(dPsiLiq_dTemp)) dPsiLiq_dTemp = 0._dp ! 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) ! ****************************************************************************************************************************** @@ -106,7 +215,7 @@ function hydCondMP_liq(volFracLiq,theta_sat,theta_mp,mpExp,satHydCond_ma,satHydC hydCondMP_liq = (satHydCond_ma - satHydCond_mi) * (theta_e**mpExp) else hydCondMP_liq = 0._dp - endif + 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 @@ -131,7 +240,7 @@ function hydCond_psi(psi,k_sat,alpha,n,m) / ( (1._dp + (psi*alpha)**n)**(m/2._dp) ) ) else hydCond_psi = k_sat - endif + end if end function hydCond_psi @@ -155,41 +264,10 @@ function hydCond_liq(volFracLiq,k_sat,theta_res,theta_sat,m) hydCond_liq = k_sat*theta_e**(1._dp/2._dp) * (1._dp - (1._dp - theta_e**(1._dp/m) )**m)**2._dp else hydCond_liq = k_sat - endif + end if end function hydCond_liq - ! ****************************************************************************************************************************** - ! public function satDeficit: compute the saturation deficit -- amount of water required to bring soil to saturation (-) - ! ****************************************************************************************************************************** - function satDeficit(psi) - ! model variables and parameters - USE data_struc,only:mpar_data,mvar_data ! data structures - USE var_lookup,only:iLookPARAM,iLookMVAR ! named variables for structure elements - implicit none - ! define dummy variables - real(dp),dimension(:),intent(in) :: psi - real(dp),dimension(size(psi)) :: satDeficit - ! define diagnostic variables and paramaters - real(dp),pointer :: alpha - real(dp),pointer :: n - real(dp),pointer :: m - real(dp),pointer :: theta_sat - real(dp),pointer :: theta_res - ! define local variables - real(dp),dimension(size(psi)) :: volFracLiq - ! assign pointers - alpha => mpar_data%var(iLookPARAM%vGn_alpha) ! van Genutchen "alpha" parameter (m-1) - n => mpar_data%var(iLookPARAM%vGn_n) ! van Genutchen "n" parameter (-) - m => mvar_data%var(iLookMVAR%scalarVGn_m)%dat(1) ! van Genutchen "m" parameter (-) - theta_sat => mpar_data%var(iLookPARAM%theta_sat) ! soil porosity (-) - theta_res => mpar_data%var(iLookPARAM%theta_res) ! soil residual volumetric water content (-) - ! define function value - volFracLiq = theta_res + (theta_sat - theta_res) / (1._dp + (psi*alpha)**n)**(m) - satDeficit = theta_sat - volFracLiq - end function satDeficit - - ! ****************************************************************************************************************************** ! public function volFracLiq: compute the volumetric liquid water content (-) ! ****************************************************************************************************************************** @@ -207,7 +285,7 @@ function volFracLiq(psi,alpha,theta_res,theta_sat,n,m) volFracLiq = theta_res + (theta_sat - theta_res)*(1._dp + (alpha*psi)**n)**(-m) else volFracLiq = theta_sat - endif + end if end function volFracLiq @@ -227,14 +305,15 @@ function matricHead(theta,alpha,theta_res,theta_sat,n,m) real(dp) :: matricHead ! matric head (m) ! local variables real(dp) :: effSat ! effective saturation (-) + real(dp),parameter :: verySmall=epsilon(1._dp) ! a very small number (avoid effective saturation of zero) ! compute effective saturation - effSat = (theta - theta_res) / (theta_sat - theta_res) + effSat = max(verySmall, (theta - theta_res) / (theta_sat - theta_res)) ! compute matric head - if(effSat < 1._dp)then + if (effSat < 1._dp .and. effSat > 0._dp)then matricHead = (1._dp/alpha)*( effSat**(-1._dp/m) - 1._dp)**(1._dp/n) else matricHead = 0._dp - endif + end if end function matricHead @@ -256,7 +335,7 @@ function dTheta_dPsi(psi,alpha,theta_res,theta_sat,n,m) if(abs(dTheta_dPsi) < epsilon(psi)) dTheta_dPsi = epsilon(psi) else dTheta_dPsi = epsilon(psi) - endif + end if end function dTheta_dPsi @@ -280,7 +359,7 @@ function dPsi_dTheta(volFracLiq,alpha,theta_res,theta_sat,n,m) ! check if less than saturation if(volFracLiq < theta_sat)then ! compute effective water content - theta_e = (volFracLiq - theta_res) / (theta_sat - theta_res) + theta_e = max(0.001,(volFracLiq - theta_res) / (theta_sat - theta_res)) ! compute the 1st function and derivative y1 = theta_e**(-1._dp/m) - 1._dp d1 = (-1._dp/m)*theta_e**(-1._dp/m - 1._dp) / (theta_sat - theta_res) @@ -291,7 +370,7 @@ function dPsi_dTheta(volFracLiq,alpha,theta_res,theta_sat,n,m) dPsi_dTheta = d1*d2/alpha else dPsi_dTheta = 0._dp - endif + end if end function dPsi_dTheta @@ -336,11 +415,11 @@ function dPsi_dTheta2(volFracLiq,alpha,theta_res,theta_sat,n,m,lTangent) 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 - endif + end if ! (case where volumetric liquid water content exceeds porosity) else dPsi_dTheta2 = 0._dp - endif + end if end function dPsi_dTheta2 @@ -392,10 +471,10 @@ function dHydCond_dPsi(psi,k_sat,alpha,n,m,lTangent) hydcond0 = hydCond_psi(psi, k_sat,alpha,n,m) hydcond1 = hydCond_psi(psi+dx,k_sat,alpha,n,m) dHydCond_dPsi = (hydcond1 - hydcond0)/dx - endif + end if else dHydCond_dPsi = 0._dp - endif + end if end function dHydCond_dPsi @@ -454,10 +533,10 @@ function dHydCond_dLiq(volFracLiq,k_sat,theta_res,theta_sat,m,lTangent) 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 - endif + end if else dHydCond_dLiq = 0._dp - endif + end if end function dHydCond_dLiq @@ -479,32 +558,14 @@ end function RH_soilair ! ****************************************************************************************************************************** ! public function crit_soilT: compute the critical temperature above which all water is unfrozen ! ****************************************************************************************************************************** - function crit_soilT(theta,theta_res,theta_sat,alpha,n,m) + function crit_soilT(psi) 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) - iden_ice, & ! intrinsic density of ice (kg m-3) - iden_water ! intrinsic density of water (kg m-3) + LH_fus ! latent heat of fusion (J kg-1, or m2 s-2) implicit none - ! dummy variables - real(dp),intent(in) :: theta ! total soil water content, frozen plus unfrozen (-) - real(dp),intent(in) :: theta_res ! residual liquid water content (-) - real(dp),intent(in) :: theta_sat ! porosity (-) - real(dp),intent(in) :: alpha ! vGn scaling parameter (m-1) - real(dp),intent(in) :: n ! vGn "n" parameter (-) - real(dp),intent(in) :: m ! vGn "m" parameter (-) + real(dp),intent(in) :: psi ! matric head (m) real(dp) :: crit_soilT ! critical soil temperature (K) - ! local variables - real(dp),parameter :: verySmall=1.e-8_dp ! a very small number to avoid numerical problems when there is zero storage - real(dp) :: relsat ! relative saturation (-) - real(dp) :: kappa ! constant (m K-1) - ! compute kappa (m K-1) - kappa = (iden_ice/iden_water)*(LH_fus/(gravity*Tfreeze)) ! NOTE: J = kg m2 s-2 - ! compute relative saturation (-) - relsat = (min(theta,theta_sat) - theta_res)/(theta_sat - theta_res) - ! compute the critical temperature above which all water is unfrozen (K) - !print*,'in soil_utils',Tfreeze,relsat,m,n,alpha,kappa - crit_soilT = Tfreeze + ((max(verySmall, relsat)**(-1._dp/m) - 1._dp)**(1._dp/n))/(alpha*kappa) + crit_soilT = Tfreeze + min(psi,0._dp)*gravity*Tfreeze/LH_fus end function crit_soilT @@ -514,9 +575,7 @@ end function crit_soilT function dTheta_dTk(Tk,theta_res,theta_sat,alpha,n,m) 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) - iden_ice, & ! intrinsic density of ice (kg m-3) - iden_water ! intrinsic density of water (kg m-3) + LH_fus ! latent heat of fusion (J kg-1, or m2 s-2) implicit none real(dp),intent(in) :: Tk ! temperature (K) real(dp),intent(in) :: theta_res ! residual liquid water content (-) @@ -528,16 +587,11 @@ function dTheta_dTk(Tk,theta_res,theta_sat,alpha,n,m) ! local variables real(dp) :: kappa ! constant (m K-1) real(dp) :: 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 + 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._dp) * (-m)*(1._dp + xtemp**n)**(-m - 1._dp) * (theta_sat - theta_res) end function dTheta_dTk diff --git a/build/source/engine/spline_int.f90 b/build/source/engine/spline_int.f90 old mode 100644 new mode 100755 index 3bee05603..acd900ce2 --- a/build/source/engine/spline_int.f90 +++ b/build/source/engine/spline_int.f90 @@ -29,7 +29,7 @@ SUBROUTINE spline(x,y,yp1,ypn,y2,err,message) err=20; message="f-spline/sizeMismatch"; return else n=size(x) - endif + end if ! start procedure c(1:n-1)=x(2:n)-x(1:n-1) r(1:n-1)=6.0_dp*((y(2:n)-y(1:n-1))/c(1:n-1)) @@ -75,12 +75,12 @@ SUBROUTINE splint(xa,ya,y2a,x,y,err,message) n=size(xa) else err=20; message="f-splint/sizeMismatch"; return - endif + end if ! start procedure klo=max(min(locate(xa,x),n-1),1) khi=klo+1 h=xa(khi)-xa(klo) - if (h == 0.0) then; err=20; message="f-splint/badXinput"; return; endif + if (h == 0.0_dp) then; err=20; message="f-splint/badXinput"; return; end if a=(xa(khi)-x)/h b=(x-xa(klo))/h y=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.0_dp @@ -139,15 +139,15 @@ SUBROUTINE tridag(a,b,c,r,u,err,message) n=size(a)+1 else err=20; message="f-tridag/sizeMismatch"; return - endif + end if ! start procedure bet=b(1) - if (bet == 0.0) then; err=20; message="f-tridag/errorAtCodeStage-1"; return; endif + if (bet == 0.0_dp) then; err=20; message="f-tridag/errorAtCodeStage-1"; return; end if u(1)=r(1)/bet do j=2,n gam(j)=c(j-1)/bet bet=b(j)-a(j-1)*gam(j) - if (bet == 0.0) then; err=20; message="f-tridag/errorAtCodeStage-2"; return; endif + if (bet == 0.0_dp) then; err=20; message="f-tridag/errorAtCodeStage-2"; return; end if u(j)=(r(j)-a(j-1)*u(j-1))/bet end do do j=n-1,1,-1 diff --git a/build/source/engine/ssdNrgFlux.f90 b/build/source/engine/ssdNrgFlux.f90 old mode 100644 new mode 100755 index 2e62e3d41..540cfd4b9 --- a/build/source/engine/ssdNrgFlux.f90 +++ b/build/source/engine/ssdNrgFlux.f90 @@ -21,11 +21,6 @@ module ssdNrgFlux_module ! numerical recipes data types USE nrtype -! access the number of snow and soil layers -USE data_struc,only:& - nSnow, & ! number of snow layers - nSoil, & ! number of soil layers - nLayers ! total number of layers ! physical constants USE multiconst,only:& sb, & ! Stefan Boltzman constant (W m-2 K-4) @@ -41,7 +36,8 @@ module ssdNrgFlux_module iden_ice, & ! intrinsic density of ice (kg m-3) iden_water ! intrinsic density of water (kg m-3) ! named variables for snow and soil -USE data_struc,only:ix_soil,ix_snow ! names variables for snow and soil +USE globalData,only:iname_snow ! named variables for snow +USE globalData,only:iname_soil ! named variables for soil ! provide access to look-up values for model decisions USE mDecisions_module,only: & ! look-up values for the numerical method @@ -72,146 +68,86 @@ module ssdNrgFlux_module ! ************************************************************************************************ subroutine ssdNrgFlux(& ! 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) + 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) + 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) + 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) + 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 ! model decisions - USE data_struc,only:model_decisions ! model decision structure + USE globalData,only:model_decisions ! model decision structure USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure - ! model variables, parameters, forcing data, etc. - USE data_struc,only:mpar_data,mvar_data,indx_data ! data structures - USE var_lookup,only:iLookATTR,iLookTYPE,iLookPARAM,iLookFORCE,iLookMVAR,iLookINDEX ! named variables for structure elements + ! 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 + ! data types + USE data_types,only:var_d ! x%var(:) (dp) + USE data_types,only:var_ilength ! x%var(:)%dat (i4b) + USE data_types,only:var_dlength ! x%var(:)%dat (dp) implicit none ! input: fluxes and derivatives at the upper boundary - real(dp),intent(in) :: groundNetFlux ! net energy flux for the ground surface (W m-2) - real(dp),intent(in) :: dGroundNetFlux_dGroundTemp ! derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) + real(dp),intent(in) :: groundNetFlux ! net energy flux for the ground surface (W m-2) + real(dp),intent(in) :: dGroundNetFlux_dGroundTemp ! derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) ! input: liquid water fluxes - real(dp),intent(in) :: iLayerLiqFluxSnow(0:) ! intent(in): liquid flux at the interface of each snow layer (m s-1) - real(dp),intent(in) :: iLayerLiqFluxSoil(0:) ! intent(in): liquid flux at the interface of each soil layer (m s-1) + real(dp),intent(in) :: iLayerLiqFluxSnow(0:) ! intent(in): liquid flux at the interface of each snow layer (m s-1) + real(dp),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(dp),intent(in) :: mLayerTempTrial(:) ! trial temperature of each snow/soil layer at the current iteration (K) + real(dp),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(dp),intent(out) :: iLayerNrgFlux(0:) ! energy flux at the layer interfaces (W m-2) - real(dp),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(dp),intent(out) :: dFlux_dTempBelow(0:) ! derivatives in the flux w.r.t. temperature in the layer below (J m-2 s-1 K-1) + real(dp),intent(out) :: iLayerNrgFlux(0:) ! energy flux at the layer interfaces (W m-2) + real(dp),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(dp),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 + 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 layers + real(dp) :: qFlux ! liquid flux at layer interfaces (m s-1) + real(dp) :: dz ! height difference (m) + real(dp) :: 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 and thermal properties + 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) + 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 ! ------------------------------------------------------------------------------------------------------------------------------------------------------ - - ! ***** compute energy fluxes at layer interfaces and their derivatives (J m-2 s-1) - call iLayer_nrg(& - ! input: model control variables - model_decisions(iLookDECISIONS%fDerivMeth)%iDecision, & ! intent(in): method used to calculate flux derivatives - model_decisions(iLookDECISIONS%bcLowrTdyn)%iDecision, & ! intent(in): method used to calculate the lower boundary condition for thermodynamics - ! input: model fluxes from other routines - groundNetFlux, & ! intent(in): total energy flux at the ground surface (W m-2) - 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: derivatives in input fluxes from other routines - dGroundNetFlux_dGroundTemp, & ! intent(in): derivative in total ground surface flux w.r.t. ground temperature (W m-2 K-1) - ! input: model state variables - mLayerTempTrial, & ! intent(in): trial temperature at the current iteration (K) - ! input: model coordinates and thermal properties - indx_data%var(iLookINDEX%layerType)%dat, & ! intent(in): layer type (ix_soil or ix_snow) - mvar_data%var(iLookMVAR%mLayerDepth)%dat, & ! intent(in): depth of each layer (m) - mvar_data%var(iLookMVAR%mLayerHeight)%dat, & ! intent(in): height at the mid-point of each layer (m) - mvar_data%var(iLookMVAR%iLayerThermalC)%dat, & ! intent(in): thermal conductivity at the interface of each layer (W m-1 K-1) - mpar_data%var(iLookPARAM%lowerBoundTemp), & ! intent(in): temperature of the lower boundary (K) - ! output: diagnostic fluxes - mvar_data%var(iLookMVAR%iLayerConductiveFlux)%dat, & ! intent(out): conductive energy flux at layer interfaces at end of time step (W m-2) - mvar_data%var(iLookMVAR%iLayerAdvectiveFlux)%dat, & ! intent(out): advective energy flux at layer interfaces at end of time step (W m-2) - ! output: fluxes and derivatives - 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,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - - end subroutine ssdNrgFlux - - - - ! ************************************************************************************************ - ! private subroutine iLayer_nrg: compute energy fluxes at layer interfaces, and their derivatives - ! ************************************************************************************************ - subroutine iLayer_nrg(& - ! input: model control variables - ix_fDerivMeth, & ! intent(in): index of the method used to compute derivatives (numerical or analytical) - ix_bcLowrTdyn, & ! intent(in): index of the method used to define the lower boundary condition for thermodynamics - ! input: model fluxes from other routines - groundNetFlux, & ! intent(in): total flux at the ground surface (W m-2) - 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: derivatives in input fluxes from other routines - dGroundNetFlux_dGroundTemp, & ! intent(in): derivative in total ground surface flux w.r.t. ground temperature (W m-2 K-1) - ! input: model state variables - mLayerTempTrial, & ! intent(in): trial temperature at the current iteration (K) - ! input: model coordinates and thermal properties - layerType, & ! intent(in): type of each layer - mLayerDepth, & ! intent(in): depth of each layer (m) - mLayerHeight, & ! intent(in): height of layer mid-points (m) - iLayerThermalC, & ! intent(in): thermal conductivity at layer interfaces (W m-1) - lowerBoundTemp, & ! intent(in): temperature of the lower boundary (K) - ! output: diagnostic fluxes - iLayerConductiveFlux, & ! intent(out): conductive energy flux at layer interfaces (W m-2) - iLayerAdvectiveFlux, & ! intent(out): advective energy flux at layer interfaces (W m-2) - ! output: fluxes and derivatives - 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 - ! compute derivative in fluxes at layer interfaces w.r.t. temperature in the layer above and the layer below - implicit none - ! input: model control variables - integer(i4b),intent(in) :: ix_fDerivMeth ! intent(in): index of the method used to calculate derivatives - integer(i4b),intent(in) :: ix_bcLowrTdyn ! intent(in): index of the method used to define the lower boundary condition for thermodynamics - ! input: model fluxes from other routines - real(dp),intent(in) :: groundNetFlux ! intent(in): total flux at the ground surface (W m-2) - real(dp),intent(in) :: iLayerLiqFluxSnow(0:) ! intent(in): liquid flux at the interface of each snow layer (m s-1) - real(dp),intent(in) :: iLayerLiqFluxSoil(0:) ! intent(in): liquid flux at the interface of each soil layer (m s-1) - ! input: derivatives in input fluxes from other routines - real(dp),intent(in) :: dGroundNetFlux_dGroundTemp ! intent(in): derivative in total ground surface flux w.r.t. ground temperature (W m-2 K-1) - ! input: model state variables - real(dp),intent(in) :: mLayerTempTrial(:) ! intent(in): trial temperature at the current iteration (K) - ! input: model coordinates and thermal properties - integer(i4b),intent(in) :: layerType(:) ! intent(in): type of the layer (ix_soil or ix_snow) - real(dp),intent(in) :: mLayerDepth(:) ! intent(in): depth of each layer (m) - real(dp),intent(in) :: mLayerHeight(:) ! intent(in): height of layer mid-points (m) - real(dp),intent(in) :: iLayerThermalC(0:) ! intent(in): thermal conductivity at layer interfaces (W m-1) - real(dp),intent(in) :: lowerBoundTemp ! intent(in): temperature of the lower boundary (K) - ! output: diagnostic fluxes - real(dp),intent(out) :: iLayerConductiveFlux(0:) ! intent(out): conductive energy flux at layer interfaces at end of time step (W m-2) - real(dp),intent(out) :: iLayerAdvectiveFlux(0:) ! intent(out): advective energy flux at layer interfaces at end of time step (W m-2) - ! output: fluxes and derivatives - real(dp),intent(out) :: iLayerNrgFlux(0:) ! intent(out): energy flux at the layer interfaces (W m-2) - real(dp),intent(out) :: dFlux_dTempAbove(0:) ! intent(out): derivatives in the flux w.r.t. temperature in the layer above (J m-2 s-1 K-1) - real(dp),intent(out) :: dFlux_dTempBelow(0:) ! intent(out): 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 ! intent(out): error code - character(*),intent(out) :: message ! intent(out): error message - ! local variables - integer(i4b) :: iLayer ! index of model layers - real(dp) :: qFlux ! liquid flux at layer interfaces (m s-1) - real(dp) :: dz ! height difference (m) - real(dp) :: flux0,flux1,flux2 ! fluxes used to calculate derivatives (W m-2) ! initialize error control - err=0; message='iLayer_nrg/' + 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 @@ -237,8 +173,8 @@ subroutine iLayer_nrg(& iLayerConductiveFlux(iLayer) = -iLayerThermalC(iLayer)*(mLayerTempTrial(iLayer+1) - mLayerTempTrial(iLayer)) / & (mLayerHeight(iLayer+1) - mLayerHeight(iLayer)) - !print*, 'iLayerConductiveFlux(iLayer), iLayerThermalC(iLayer) = ', iLayerConductiveFlux(iLayer), iLayerThermalC(iLayer) - endif ! (the type of layer) + !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 ! ------------------------------------------------------------------------------------------------------------------------- @@ -247,8 +183,8 @@ subroutine iLayer_nrg(& do iLayer=1,nLayers ! get the liquid flux at layer interfaces select case(layerType(iLayer)) - case(ix_snow); qFlux = iLayerLiqFluxSnow(iLayer) - case(ix_soil); qFlux = iLayerLiqFluxSoil(iLayer-nSnow) + 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 @@ -257,7 +193,7 @@ subroutine iLayer_nrg(& ! compute fluxes within the domain -- positive downwards else iLayerAdvectiveFlux(iLayer) = -Cp_water*iden_water*qFlux*(mLayerTempTrial(iLayer+1) - mLayerTempTrial(iLayer)) - endif + end if end do ! looping through layers ! ------------------------------------------------------------------------------------------------------------------------- @@ -298,7 +234,7 @@ subroutine iLayer_nrg(& flux0 = -iLayerThermalC(iLayer)*(lowerBoundTemp - (mLayerTempTrial(iLayer) ))/dz flux1 = -iLayerThermalC(iLayer)*(lowerBoundTemp - (mLayerTempTrial(iLayer)+dx))/dz dFlux_dTempAbove(iLayer) = (flux1 - flux0)/dx - endif + end if ! * zero flux at the lower boundary case(zeroFlux) @@ -320,14 +256,16 @@ subroutine iLayer_nrg(& flux2 = -iLayerThermalC(iLayer)*((mLayerTempTrial(iLayer+1)+dx) - mLayerTempTrial(iLayer) ) / dz dFlux_dTempAbove(iLayer) = (flux1 - flux0)/dx dFlux_dTempBelow(iLayer) = (flux2 - flux0)/dx - endif + end if - endif ! type of layer (upper, internal, or lower) + end if ! type of layer (upper, internal, or lower) end do ! (looping through layers) - end subroutine iLayer_nrg + ! end association of local variables with information in the data structures + end associate + end subroutine ssdNrgFlux end module ssdNrgFlux_module diff --git a/build/source/engine/stomResist.f90 b/build/source/engine/stomResist.f90 new file mode 100755 index 000000000..739966c5a --- /dev/null +++ b/build/source/engine/stomResist.f90 @@ -0,0 +1,1268 @@ +! 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 stomResist_module +USE nrtype +! physical constants +USE multiconst, only: Rgas ! universal gas constant (J mol-1 K-1) +USE multiconst, only: Tfreeze ! freezing point of pure water (K) +USE multiconst, only: ave_slp ! standard pressure (Pa) +! conversion functions +USE conv_funcs_module,only:satVapPress ! function to compute the saturated vapor pressure (Pa) +! look-up values for the stomatal resistance formulation +USE mDecisions_module,only: & + simpleResistance, & ! simple resistance formulation + BallBerryFlex, & ! flexible Ball-Berry scheme + BallBerry, & ! Ball-Berry (from Noah-MP) + Jarvis ! Jarvis (from Noah-MP) +! look-up values for the leaf temperature controls on photosynthesis + stomatal resistance +USE mDecisions_module,only: & + q10Func, & ! the q10 function used in CLM4 and Noah-MP + Arrhenius ! the Arrhenius functions used in CLM5 and Cable +! look-up values for the humidity controls on stomatal resistance +USE mDecisions_module,only: & + humidLeafSurface, & ! humidity at the leaf surface [Bonan et al., 2011] + scaledHyperbolic ! scaled hyperbolic function [Leuning et al., 1995] +! look-up values for the electron transport function, dependence of photosynthesis on PAR +USE mDecisions_module,only: & + linear, & ! linear function used in CLM4 and Noah-MP + linearJmax, & ! linear jmax function used in Cable [Wang et al., Ag Forest Met 1998, eq D5] + quadraticJmax ! the quadratic Jmax function, used in SSiB and CLM5 +! look-up values for the CO2 compensation point to calculate stomatal resistance +USE mDecisions_module,only: & + origBWB, & ! the original BWB function + Leuning ! the Leuning function +! look up values to define the iterative numerical solution method used in the Ball-Berry stomatal resistance parameterization +USE mDecisions_module,only: & + NoahMPsolution, & ! the NoahMP solution (and CLM4): fixed point iteration; max 3 iterations + newtonRaphson ! full Newton-Raphson iterative solution to convergence +! look up values to define the controls on carbon assimilation +USE mDecisions_module,only: & + colimitation, & ! enable colimitation, as described by Collatz et al. (1991) and Sellers et al. (1996) + minFunc ! do not enable colimitation: use minimum of the three controls on carbon assimilation +! look up values to define the scaling of photosynthesis from the leaf to the canopy +USE mDecisions_module,only: & + constantScaling, & ! constant scaling factor + laiScaling ! exponential function of LAI (Leuning, Plant Cell Env 1995: "Scaling from..." [eq 9]) +implicit none +private +public::stomResist +! spatial indices +integer(i4b),parameter :: iLoc = 1 ! i-location +integer(i4b),parameter :: jLoc = 1 ! j-location +! conversion factors +real(dp),parameter :: joule2umolConv=4.6_dp ! conversion factor from joules to umol photons (umol J-1) +! algorithmic parameters +real(dp),parameter :: missingValue=-9999._dp ! missing value, used when diagnostic or state variables are undefined +real(dp),parameter :: mpe=1.e-6_dp ! prevents overflow error if division by zero +real(dp),parameter :: dx=1.e-6_dp ! finite difference increment + +contains + + + ! ************************************************************************************************ + ! public subroutine stomResist: compute stomatal resistance + ! ************************************************************************************************ + subroutine stomResist(& + ! input: state and diagnostic variables + 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) + ! 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,message) ! intent(out): error control + ! ------------------------------------------------------------------------------------------------------------------------------------------------------ + ! ------------------------------------------------------------------------------------------------------------------------------------------------------ + ! 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) + model_options ! defines the model decisions + ! provide access to indices that define elements of the data structures + USE var_lookup,only:iLookTYPE ! 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:iLookDECISIONS ! named variables for elements of the decision structure + ! ------------------------------------------------------------------------------------------------------------------------------------------------------ + ! input: state and diagnostic variables + real(dp),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) + real(dp),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) + real(dp),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 + ! 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 + ! 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),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(dp) :: absorbedPAR ! absorbed PAR (W m-2) + real(dp) :: scalarStomResist ! stomatal resistance (s m-1) + real(dp) :: scalarPhotosynthesis ! photosynthesis (umol CO2 m-2 s-1) + real(dp) :: ci ! intercellular co2 partial pressure (Pa) + ! ------------------------------------------------------------------------------------------------------------------------------------------------------ + + ! associate variables in the data structure + associate(& + + ! input: model decisions + ix_stomResist => model_decisions(iLookDECISIONS%stomResist)%iDecision, & ! intent(in): [i4b] choice of function for stomatal resistance + + ! input: physical attributes + vegTypeIndex => type_data%var(iLookTYPE%vegTypeIndex), & ! intent(in): [i4b] vegetation type index + minStomatalResistance => mpar_data%var(iLookPARAM%minStomatalResistance)%dat(1), & ! intent(in): [dp] mimimum stomatal resistance (s m-1) + vcmax25_canopyTop => mpar_data%var(iLookPARAM%vcmax25_canopyTop)%dat(1), & ! intent(in): [dp] potential carboxylation rate at 25 degrees C at the canopy top (umol co2 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) + 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) + + ! input: state and diagnostic variables + 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) + + ! output: stomatal resistance and photosynthesis + scalarStomResistSunlit => flux_data%var(iLookFLUX%scalarStomResistSunlit)%dat(1), & ! intent(out): [dp] stomatal resistance for sunlit leaves (s m-1) + scalarStomResistShaded => flux_data%var(iLookFLUX%scalarStomResistShaded)%dat(1), & ! intent(out): [dp] stomatal resistance for shaded leaves (s m-1) + scalarPhotosynthesisSunlit => flux_data%var(iLookFLUX%scalarPhotosynthesisSunlit)%dat(1), & ! intent(out): [dp] sunlit photosynthesis (umolco2 m-2 s-1) + scalarPhotosynthesisShaded => flux_data%var(iLookFLUX%scalarPhotosynthesisShaded)%dat(1), & ! intent(out): [dp] shaded photosynthesis (umolco2 m-2 s-1) + + ! output: carbon dioxide partial pressure of leaf interior (sunlit leaves) (Pa) + scalarIntercellularCO2Sunlit => diag_data%var(iLookDIAG%scalarIntercellularCO2Sunlit)%dat(1), & ! intent(out): [dp] carbon dioxide partial pressure of leaf interior (sunlit leaves) (Pa) + scalarIntercellularCO2Shaded => diag_data%var(iLookDIAG%scalarIntercellularCO2Shaded)%dat(1) & ! intent(out): [dp] carbon dioxide partial pressure of leaf interior (shaded leaves) (Pa) + + ) + ! ------------------------------------------------------------------------------------------------------------------------------------------------------ + ! initialize error control + err=0; message="stomResist/" + + ! identify option for stomatal resistance + select case(ix_stomResist) + + ! ******************************************************************************************************************************************* + + ! simple resistance formulation + case(simpleResistance) + ! check that we don't divide by zero -- should be set to minimum of tiny in routine soilResist + if(scalarTranspireLim < tiny(airpres))then; err=20; message=trim(message)//'soil moisture stress factor is < tiny -- this will cause problems'; return; end if + ! compute stomatal resistance (assume equal for sunlit and shaded leaves) + scalarStomResistSunlit = minStomatalResistance/scalarTranspireLim + scalarStomResistShaded = scalarStomResistSunlit + ! set photosynthesis to missing (not computed) + scalarPhotosynthesisSunlit = missingValue + scalarPhotosynthesisShaded = missingValue + + ! ******************************************************************************************************************************************* + + ! flexible Ball-Berry + case(BallBerryFlex) + + ! loop through sunlit and shaded leaves + do iSunShade=1,2 + + ! get appropriate input values + select case(iSunShade) + ! sunlit leaves + case(ixSunlit) + absorbedPAR = scalarCanopySunlitPAR ! average absorbed par for sunlit leaves (w m-2) + ci = scalarIntercellularCO2Sunlit ! co2 of the leaf interior for sunlit leaves (Pa) + ! shaded leaves + case(ixShaded) + absorbedPAR = scalarCanopyShadedPAR ! average absorbed par for shaded leaves (w m-2) + ci = scalarIntercellularCO2Shaded ! co2 of the leaf interior for shaded leaves (Pa) + ! check + case default; err=20; message=trim(message)//'unable to identify case for sunlit/shaded leaves'; return + end select + + ! compute photosynthesis and stomatal resistance + call stomResist_flex(& + ! input: state and diagnostic variables + 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) + absorbedPAR, & ! intent(in): absorbed PAR (W m-2) + ! input: data structures + forc_data, & ! intent(in): model forcing data + mpar_data, & ! intent(in): model parameters + diag_data, & ! intent(in): model diagnostic variables for a local HRU + flux_data, & ! intent(in): model fluxes for a local HRU + model_decisions, & ! intent(in): model decisions + ! input-output + ci, & ! intent(inout): co2 of the leaf interior (Pa) + ! output: + scalarStomResist, & ! intent(out): stomatal resistance (s m-1) + scalarPhotosynthesis, & ! intent(out): photosynthesis (umol CO2 m-2 s-1) + ! output: error control + err,cmessage) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + + ! assign output variables + select case(iSunShade) + case(ixSunlit) + scalarStomResistSunlit = scalarStomResist + scalarPhotosynthesisSunlit = scalarPhotosynthesis + scalarIntercellularCO2Sunlit = ci + case(ixShaded) + scalarStomResistShaded = scalarStomResist + scalarPhotosynthesisShaded = scalarPhotosynthesis + scalarIntercellularCO2Shaded = ci + 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 + + + ! ******************************************************************************************************************************************* + ! compute stomatal resistance (wrapper around the Noah-MP routines) + ! NOTE: canopy air vapor pressure is from the previous time step + case(BallBerry,Jarvis) + call stomResist_NoahMP(& + ! input (model decisions) + 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) + scalarO2air, & ! intent(in): atmospheric o2 concentration (Pa) + scalarCO2air, & ! intent(in): atmospheric co2 concentration (Pa) + scalarCanopySunlitPAR, & ! intent(in): average absorbed par for sunlit leaves (w m-2) + scalarCanopyShadedPAR, & ! intent(in): average absorbed par for shaded leaves (w m-2) + ! input (state and diagnostic variables) + scalarGrowingSeasonIndex, & ! intent(in): growing season index (0=off, 1=on) + scalarFoliageNitrogenFactor, & ! intent(in): foliage nitrogen concentration (1=saturated) + scalarTranspireLim, & ! intent(in): weighted average of the soil moiture factor controlling stomatal resistance (-) + scalarLeafResistance, & ! intent(in): leaf boundary layer resistance (s m-1) + scalarVegetationTemp, & ! intent(in): temperature of the vegetation canopy (K) + scalarSatVP_VegTemp, & ! intent(in): saturation vapor pressure at the temperature of the veg canopy (Pa) + scalarVP_CanopyAir, & ! intent(in): canopy air vapor pressure (Pa) + ! output + scalarStomResistSunlit, & ! intent(out): stomatal resistance for sunlit leaves (s m-1) + scalarStomResistShaded, & ! intent(out): stomatal resistance for shaded leaves (s m-1) + scalarPhotosynthesisSunlit, & ! intent(out): sunlit photosynthesis (umolco2 m-2 s-1) + scalarPhotosynthesisShaded, & ! intent(out): shaded photosynthesis (umolco2 m-2 s-1) + err,cmessage ) ! intent(out): error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + + ! ******************************************************************************************************************************************* + + ! error check + case default; err=20; message=trim(message)//'unable to identify option for stomatal resistance'; return + + ! ******************************************************************************************************************************************* + + 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 + + + ! ******************************************************************************************************* + ! ******************************************************************************************************* + ! *** PRIVATE SUBROUTINES ******************************************************************************* + ! ******************************************************************************************************* + ! ******************************************************************************************************* + + ! ******************************************************************************************************* + ! private subroutine stomResist_flex: flexible stomatal resistance routine to evaluate different options + ! ******************************************************************************************************* + subroutine stomResist_flex(& + ! input: state and diagnostic variables + 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) + absorbedPAR, & ! intent(in): absorbed PAR (W m-2) + ! input: data structures + forc_data, & ! intent(in): model forcing data + mpar_data, & ! intent(in): model parameters + diag_data, & ! intent(in): model diagnostic variables for a local HRU + flux_data, & ! intent(in): model fluxes for a local HRU + model_decisions, & ! intent(in): model decisions + ! output: stomatal resistance and photosynthesis + ci, & ! intent(out): co2 of the leaf interior (Pa) + scalarStomResist, & ! intent(out): stomatal resistance (s m-1) + scalarPhotosynthesis, & ! intent(out): photosynthesis (umol CO2 m-2 s-1) + ! output: error control + err,message) ! intent(out): error control + ! ------------------------------------------------------------------------------------------------------------------------------------------------------ + ! ------------------------------------------------------------------------------------------------------------------------------------------------------ + ! provide access to the 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) + model_options ! defines the model decisions + ! 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: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 + ! ------------------------------------------------------------------------------------------------------------------------------------------------------ + ! input: state and diagnostic variables + real(dp),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) + real(dp),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) + real(dp),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) + real(dp),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 + ! output: stomatal resistance and photosynthesis + real(dp),intent(inout) :: ci ! intercellular co2 partial pressure (Pa) + real(dp),intent(out) :: scalarStomResist ! stomatal resistance (s m-1) + real(dp),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 + ! ------------------------------------------------------------------------------------------------------------------------------------------------------ + ! general local variables + logical(lgt),parameter :: testDerivs=.false. ! flag to test the derivatives + real(dp) :: unitConv ! unit conversion factor (mol m-3, convert m s-1 --> mol H20 m-2 s-1) + real(dp) :: rlb ! leaf boundary layer rersistance (umol-1 m2 s) + real(dp) :: x0,x1,x2 ! temporary variables + real(dp) :: co2compPt ! co2 compensation point (Pa) + real(dp) :: 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 + real(dp),parameter :: convToler=0.0001_dp ! convergence tolerance (Pa) + real(dp),parameter :: umol_per_mol=1.e+6_dp ! factor to relate umol to mol + real(dp),parameter :: o2scaleFactor=0.105_dp ! scaling factor used to compute co2 compesation point (0.21/2) + real(dp),parameter :: h2o_co2__leafbl=1.37_dp ! factor to represent the different diffusivities of h2o and co2 in the leaf boundary layer (-) + real(dp),parameter :: h2o_co2__stomPores=1.65_dp ! factor to represent the different diffusivities of h2o and co2 in the stomatal pores (-) + real(dp),parameter :: Tref=298.16_dp ! reference temperature (25 deg C) + real(dp),parameter :: Tscale=10._dp ! scaling factor in q10 function (K) + real(dp),parameter :: c_ps2=0.7_dp ! curvature factor for electron transport (-) + real(dp),parameter :: fnf=0.6666666667_dp ! foliage nitrogen factor (-) + ! ------------------------------------------------------------------------------------------------------------------------------------------------------ + ! photosynthesis + real(dp) :: Kc,Ko ! Michaelis-Menten constants for co2 and o2 (Pa) + real(dp) :: vcmax25 ! maximum Rubisco carboxylation rate at 25 deg C (umol m-2 s-1) + real(dp) :: jmax25 ! maximum electron transport rate at 25 deg C (umol m-2 s-1) + real(dp) :: vcmax ! maximum Rubisco carboxylation rate (umol m-2 s-1) + real(dp) :: jmax ! maximum electron transport rate (umol m-2 s-1) + real(dp) :: aQuad ! the quadratic coefficient in the quadratic equation + real(dp) :: bQuad ! the linear coefficient in the quadratic equation + real(dp) :: cQuad ! the constant in the quadratic equation + real(dp) :: bSign ! sign of the linear coeffcient + real(dp) :: xTemp ! temporary variable in the quadratic equation + real(dp) :: qQuad ! the "q" term in the quadratic equation + real(dp) :: root1,root2 ! roots of the quadratic function + real(dp) :: Js ! scaled electron transport rate (umol co2 m-2 s-1) + real(dp) :: I_ps2 ! PAR absorbed by PS2 (umol photon m-2 s-1) + real(dp) :: awb ! Michaelis-Menten control (Pa) + real(dp) :: cp2 ! additional controls in light-limited assimilation (Pa) + real(dp) :: psn ! leaf gross photosynthesis rate (umol co2 m-2 s-1) + real(dp) :: dA_dc ! derivative in photosynthesis w.r.t. intercellular co2 concentration + ! ------------------------------------------------------------------------------------------------------------------------------------------------------ + ! stomatal resistance + real(dp) :: gMin ! scaled minimum conductance (umol m-2 s-1) + real(dp) :: cs ! co2 partial pressure at leaf surface (Pa) + real(dp) :: csx ! control of co2 partial pressure at leaf surface on stomatal conductance (Pa) + real(dp) :: g0 ! stomatal conductance in the absence of humidity controls (umol m-2 s-1) + real(dp) :: ci_old ! intercellular co2 partial pressure (Pa) + real(dp) :: rs ! stomatal resistance (umol-1 m2 s) + real(dp) :: dg0_dc ! derivative in g0 w.r.t intercellular co2 concentration (umol m-2 s-1 Pa-1) + real(dp) :: drs_dc ! derivative in stomatal resistance w.r.t. intercellular co2 concentration + real(dp) :: dci_dc ! final derivative (-) + ! ------------------------------------------------------------------------------------------------------------------------------------------------------ + ! iterative solution + real(dp) :: func1,func2 ! functions for numerical derivative calculation + real(dp) :: cMin,cMax ! solution brackets + real(dp) :: 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 + ix_bbElecFunc => model_decisions(iLookDECISIONS%bbElecFunc)%iDecision, & ! intent(in): [i4b] dependence of photosynthesis on PAR + ix_bbCO2point => model_decisions(iLookDECISIONS%bbCO2point)%iDecision, & ! intent(in): [i4b] use of CO2 compensation point to calculate stomatal resistance + 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) + Kc_qFac => mpar_data%var(iLookPARAM%Kc_qFac)%dat(1), & ! intent(in): [dp] factor in the q10 function defining temperature controls on Kc (-) + Ko_qFac => mpar_data%var(iLookPARAM%Ko_qFac)%dat(1), & ! intent(in): [dp] factor in the q10 function defining temperature controls on Ko (-) + kc_Ha => mpar_data%var(iLookPARAM%kc_Ha)%dat(1), & ! intent(in): [dp] activation energy for the Michaelis-Menten constant for CO2 (J mol-1) + ko_Ha => mpar_data%var(iLookPARAM%ko_Ha)%dat(1), & ! intent(in): [dp] activation energy for the Michaelis-Menten constant for O2 (J mol-1) + vcmax25_canopyTop => mpar_data%var(iLookPARAM%vcmax25_canopyTop)%dat(1), & ! intent(in): [dp] potential carboxylation rate at 25 degrees C at the canopy top (umol co2 m-2 s-1) + vcmax_qFac => mpar_data%var(iLookPARAM%vcmax_qFac)%dat(1), & ! intent(in): [dp] factor in the q10 function defining temperature controls on vcmax (-) + vcmax_Ha => mpar_data%var(iLookPARAM%vcmax_Ha)%dat(1), & ! intent(in): [dp] activation energy in the vcmax function (J mol-1) + vcmax_Hd => mpar_data%var(iLookPARAM%vcmax_Hd)%dat(1), & ! intent(in): [dp] deactivation energy in the vcmax function (J mol-1) + vcmax_Sv => mpar_data%var(iLookPARAM%vcmax_Sv)%dat(1), & ! intent(in): [dp] entropy term in the vcmax function (J mol-1 K-1) + vcmax_Kn => mpar_data%var(iLookPARAM%vcmax_Kn)%dat(1), & ! intent(in): [dp] foliage nitrogen decay coefficient (-) + jmax25_scale => mpar_data%var(iLookPARAM%jmax25_scale)%dat(1), & ! intent(in): [dp] scaling factor to relate jmax25 to vcmax25 (-) + jmax_Ha => mpar_data%var(iLookPARAM%jmax_Ha)%dat(1), & ! intent(in): [dp] activation energy in the jmax function (J mol-1) + jmax_Hd => mpar_data%var(iLookPARAM%jmax_Hd)%dat(1), & ! intent(in): [dp] deactivation energy in the jmax function (J mol-1) + jmax_Sv => mpar_data%var(iLookPARAM%jmax_Sv)%dat(1), & ! intent(in): [dp] entropy term in the jmax function (J mol-1 K-1) + fractionJ => mpar_data%var(iLookPARAM%fractionJ)%dat(1), & ! intent(in): [dp] fraction of light lost by other than the chloroplast lamellae (-) + quantamYield => mpar_data%var(iLookPARAM%quantamYield)%dat(1), & ! intent(in): [dp] quantam yield (mol e mol-1 q) + 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... + ! ****************** + + ! define unit conversion (m s-1 --> mol m-2 s-1) + ! NOTE: Rgas = J K-1 Mol-1 (J = kg m2 s-2); airtemp = K; airpres = Pa (kg m-1 s-2) + unitConv = airpres/(Rgas*airtemp) ! mol m-3 + + ! check there is light available for photosynthesis + if(absorbedPAR < tiny(absorbedPAR) .or. scalarGrowingSeasonIndex < tiny(absorbedPAR))then + scalarStomResist = unitConv*umol_per_mol/(scalarTranspireLim*minStomatalConductance) + scalarPhotosynthesis = 0._dp + ci = 0._dp + return + end if + + ! scale vcmax from the leaves to the canopy + ! exponential function of LAI is described in Leuning, Plant Cell Env 1995: "Scaling from..." [eq 9] + select case(ix_bbCanIntg8) + case(constantScaling); vcmax25 = vcmax25_canopyTop*fnf + case(laiScaling); vcmax25 = vcmax25_canopyTop*exp(-vcmax_Kn*scalarExposedLAI) + case default; err=20; message=trim(message)//'unable to identify option to scale lai from the leaves to the canopy'; return + end select + + ! compute the maximum electron transport rate at 25 deg C (umol m-2 s-1) + jmax25 = jmax25_scale * vcmax25 + + ! define the scaled minimum conductance + gMin = scalarTranspireLim*minStomatalConductance + + ! compute the leaf conductance (umol m-2 s-1) + rlb = scalarLeafResistance/(umol_per_mol*unitConv) ! s m-1 --> umol-1 m2 s + + ! ***** + ! * compute temperature controls on stomatal conductance... + ! ********************************************************* + + ! identify the temperature function + select case(ix_bbTempFunc) + + ! q10 function used in CLM4 and Noah-MP + case(q10Func) + ! compute the Michaelis-Menten constants (Pa) + Kc = ave_slp*(Kc25/umol_per_mol)*q10(Kc_qFac,scalarVegetationTemp,Tref,Tscale) ! umol mol-1 --> mol mol-1 --> Pa + Ko = ave_slp*Ko25*q10(Ko_qFac,scalarVegetationTemp,Tref,Tscale) ! mol mol-1 --> Pa + ! compute maximum Rubisco carboxylation rate (umol co2 m-2 s-1) + x0 = q10(vcmax_qFac,scalarVegetationTemp,Tref,Tscale) ! temperature function + x1 = fHigh(vcmax_Hd,vcmax_Sv,scalarVegetationTemp) ! high temperature inhibition function + vcmax = scalarTranspireLim*vcmax25*x0/x1 + + ! Arrhenius function used in CLM5 and Cable + case(Arrhenius) + ! compute the Michaelis-Menten constants (Pa) + Kc = airpres*(Kc25/umol_per_mol)*fT(kc_Ha,scalarVegetationTemp,Tref) ! umol mol-1 --> mol mol-1 --> Pa + Ko = airpres*Ko25*fT(ko_Ha,scalarVegetationTemp,Tref) ! mol mol-1 --> Pa + ! compute maximum Rubisco carboxylation rate (umol co2 m-2 s-1) + x0 = fT(vcmax_Ha,scalarVegetationTemp,Tref) + x1 = fhigh(vcmax_Hd,vcmax_Sv,Tref) / fhigh(vcmax_Hd,vcmax_Sv,scalarVegetationTemp) + vcmax = scalarTranspireLim*vcmax25*x0*x1 + + ! check found an appropriate option + case default; err=20; message=trim(message)//'unable to find option for leaf temperature controls on stomatal conductance'; return + + end select ! temperature controls + + ! ***** + ! * compute electron transport controls on stomatal conductance... + ! **************************************************************** + + ! compute the maximum electron transport rate (umol electron m-2 s-1) + x0 = fT(jmax_Ha,scalarVegetationTemp,Tref) + x1 = fhigh(jmax_Hd,jmax_Sv,Tref) / fhigh(jmax_Hd,jmax_Sv,scalarVegetationTemp) + jmax = jmax25*x0*x1 + + ! identify the electron transport function + select case(ix_bbElecFunc) + + ! 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) + x0 = quantamYield*joule2umolConv*absorbedPAR + x1 = x0*jmax / (x0 + 2.1_dp*jmax) + Js = x1/4._dp ! scaled electron transport + + ! quadraric function of jmax, as used in CLM5 (Bonan et al., JGR 2011, Table B2) + case(quadraticJmax) + ! PAR absorbed by PS2 (umol photon m-2 s-1) + I_ps2 = 0.5_dp*(1._dp - fractionJ) * joule2umolConv*absorbedPAR ! Farquar (1980), eq 8: PAR absorbed by PS2 (umol photon m-2 s-1) + ! define coefficients in the quadratic equation + aQuad = c_ps2 ! quadratic coefficient = cuurvature factor for electron transport + bQuad = -(I_ps2 + jmax) ! linear coefficient + cQuad = I_ps2 * jmax ! free term + ! compute the q term (NOTE: bQuad is always positive) + bSign = abs(bQuad)/bQuad + xTemp = bQuad*bQuad - 4._dp *aQuad*cQuad + qQuad = -0.5_dp * (bQuad + bSign*sqrt(xTemp)) + ! compute roots + root1 = qQuad / aQuad + root2 = cQuad / qQuad + ! select minimum root, required to ensure J=0 when par=0 + ! NOTE: Wittig et al. select the first root, which is the max in all cases I tried + Js = min(root1,root2) / 4._dp ! scaled J + + ! check found an appropriate option + case default; err=20; message=trim(message)//'unable to find option for electron transport controls on stomatal conductance'; return + + end select ! electron transport controls + + ! ***** + ! * define additional controls on stomatal conductance... + ! **************************************************************** + + ! define the humidity function + select case(ix_bbHumdFunc) + case(humidLeafSurface); fHum = min( max(0.25_dp, scalarVP_CanopyAir/scalarSatVP_VegTemp), 1._dp) + case(scaledHyperbolic); fHum = (scalarSatVP_VegTemp - scalarVP_CanopyAir)/vpScaleFactor + case default; err=20; message=trim(message)//'unable to identify humidity control on stomatal conductance'; return + end select + + ! compute the co2 compensation point (Pa) + co2compPt = (Kc/Ko)*scalarO2air*o2scaleFactor + + ! compute the Michaelis-Menten controls (Pa) + awb = Kc*(1._dp + scalarO2air/Ko) + + ! compute the additional controls in light-limited assimilation + cp2 = co2compPt*2._dp + + ! define trial value of intercellular co2 (Pa) + ! NOTE: only initialize if less than the co2 compensation point; otherwise, initialize with previous value + if(ix_bbNumerics==newtonRaphson)then + if(ci < co2compPt) ci = 0.7_dp*scalarCO2air + else + ci = 0.7_dp*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._dp + cMax = scalarCO2air + + ! ********************************************************************************************************************************* + ! ********************************************************************************************************************************* + ! ********************************************************************************************************************************* + ! ********************************************************************************************************************************* + ! ********************************************************************************************************************************* + ! ********************************************************************************************************************************* + + !print *, '**' + !print *, '**' + + ! *** + ! iterate + do iter=1,maxiter + + ! reset ci + ci_old = ci + + ! ***** + ! * compute photosynthesis and stomatal resistance... + ! *************************************************** + + ! compute gross photosynthesis [follow Farquar (Planta, 1980), as implemented in CLM4 and Noah-MP] + call photosynthesis(.true., ix_bbAssimFnc, ci, co2compPt, awb, cp2, vcmax, Js, psn, dA_dc) + + ! compute co2 concentration at leaf surface (Pa) + x1 = h2o_co2__leafbl * airpres * rlb ! Pa / (umol co2 m-2 s-1) + cs = max(scalarCO2air - (x1 * psn), mpe) ! Pa (avoid divide by zero) + + ! compute control of the compensation point on stomatal conductance + if(ix_bbCO2point == origBWB)then + csx = cs + else + csx = cs - co2compPt + end if + + ! compute conductance in the absence of humidity + g0 = cond2photo_slope*airpres*psn/csx + dg0_dc = cond2photo_slope*airpres*dA_dc*(x1*psn/cs + 1._dp)/csx + + ! use quadratic function to compute stomatal resistance + call quadResist(.true.,ix_bbHumdFunc,rlb,fHum,gMin,g0,dg0_dc,rs,drs_dc) + + ! compute intercellular co2 partial pressues (Pa) + x2 = h2o_co2__stomPores * airpres ! Pa + ci = max(cs - x2*psn*rs, 0._dp) ! 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) + else + dci_dc = 0._dp + end if + + ! test derivatives + if(testDerivs)then + func1 = testFunc(ci_old, cond2photo_slope, airpres, scalarCO2air, ix_bbHumdFunc, ix_bbCO2point, ix_bbAssimFnc) + func2 = testFunc(ci_old+dx, cond2photo_slope, airpres, scalarCO2air, ix_bbHumdFunc, ix_bbCO2point, ix_bbAssimFnc) + write(*,'(a,1x,20(e20.10,1x))') '(func2 - func1)/dx, dci_dc = ', & + (func2 - func1)/dx, dci_dc + end if ! if testing the derivatives + + ! ***** + ! * iterative solution... + ! *********************** + + ! case for Noah-MP (use fixed point iteration) + if(ix_bbNumerics==NoahMPsolution)then + if(iter==maxiter_NoahMP) exit ! exit after a specified number of iterations (normally 3) + cycle ! fixed-point iteration + end if + + ! CLM4 and Noah-MP use fixed point iteration, continuing the next iteration from this point + ! here we try and improve matters by using the derivatives + + ! update the brackets for the solution + if(ci_old > ci)then + cMax = ci_old + else + cMin = ci_old + end if + + ! compute iteration increment (Pa) + xInc = (ci - ci_old)/(1._dp - dci_dc) + + ! update + ci = max(ci_old + xInc, 0._dp) + + ! ensure that we stay within brackets + if(ci > cMax .or. ci < cMin)then + ci = 0.5_dp * (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 + message=trim(message)//'did not converge in stomatal conductance iteration' + err=20; return + end if + + end do ! iterating + !pause 'iterating' + + ! assign output variables + scalarStomResist = unitConv*umol_per_mol*rs ! umol-1 m2 s --> s/m + scalarPhotosynthesis = psn + + end associate + + contains + + ! ****************************************************** + ! ****************************************************** + + ! internal function used to test derivatives + function testFunc(ci, cond2photo_slope, airpres, scalarCO2air, ix_bbHumdFunc, ix_bbCO2point, ix_bbAssimFnc) + real(dp),intent(in) :: ci, cond2photo_slope, airpres, scalarCO2air + integer(i4b),intent(in) :: ix_bbHumdFunc, ix_bbCO2point, ix_bbAssimFnc + real(dp) :: testFunc + real(dp),parameter :: unUsedInput=0._dp + real(dp) :: unUsedOutput + + ! compute gross photosynthesis [follow Farquar (Planta, 1980), as implemented in CLM4 and Noah-MP] + call photosynthesis(.false., ix_bbAssimFnc, ci, co2compPt, awb, cp2, vcmax, Js, psn, unUsedOutput) + + ! compute co2 concentration at leaf surface (Pa) + x1 = h2o_co2__leafbl * airpres * rlb ! Pa / (umol co2 m-2 s-1) + cs = max(scalarCO2air - (x1 * psn), mpe) ! Pa (avoid divide by zero) + + ! compute control of the compensation point on stomatal conductance + if(ix_bbCO2point == origBWB)then + csx = cs + else + csx = cs - co2compPt + end if + + ! compute conductance in the absence of humidity + g0 = cond2photo_slope*airpres*psn/csx + + ! use quadratic function to compute stomatal resistance + call quadResist(.false.,ix_bbHumdFunc,rlb,fHum,gMin,g0,unUsedInput,rs,unUsedOutput) + + ! compute intercellular co2 partial pressues (Pa) + x2 = h2o_co2__stomPores * airpres ! Pa + testFunc = max(cs - x2*psn*rs, 0._dp) ! Pa + + end function testFunc + + end subroutine stomResist_flex + + ! ******************************************************************************************************* + ! private subroutine photosynthesis: compute gross photosynthesis + ! ******************************************************************************************************* + subroutine photosynthesis(desireDeriv, ix_bbAssimFnc, ci, co2compPt, awb, cp2, vcmax, Js, psn, dA_dc) + implicit none + ! dummy variables + logical(lgt),intent(in) :: desireDeriv ! .true. if the derivative is desired + integer(i4b),intent(in) :: ix_bbAssimFnc ! model option for the function used for co2 assimilation (min func, or colimtation) + real(dp),intent(in) :: ci ! intercellular co2 concentration (Pa) + real(dp),intent(in) :: co2compPt ! co2 compensation point (Pa) + real(dp),intent(in) :: awb ! Michaelis-Menten control (Pa) + real(dp),intent(in) :: cp2 ! additional controls in light-limited assimilation (Pa) + real(dp),intent(in) :: vcmax ! maximum Rubisco carboxylation rate (umol co2 m-2 s-1) + real(dp),intent(in) :: Js ! scaled electron transport rate (umol co2 m-2 s-1) + real(dp),intent(out) :: psn ! leaf gross photosynthesis rate (umol co2 m-2 s-1) + real(dp),intent(out) :: dA_dc ! derivative in photosynthesis w.r.t. intercellular co2 concentration (umol co2 m-2 s-1 Pa-1) + ! local variables + integer(i4b),parameter :: nFactors=3 ! number of limiting factors for assimilation (light, Rubisco, and export) + integer(i4b),parameter :: ixRubi=1 ! named variable for Rubisco-limited assimilation + integer(i4b),parameter :: ixLight=2 ! named variable for light-limited assimilation + integer(i4b),parameter :: ixExport=3 ! named variable for export-limited assimilation + integer(i4b) :: ixLimitVec(1),ixLimit ! index of factor limiting assimilation + real(dp) :: xFac(nFactors) ! temporary variable used to compute assimilation rate + real(dp) :: xPSN(nFactors) ! assimilation rate for different factors (light, Rubisco, and export) + real(dp) :: ciDiff ! difference between intercellular co2 and the co2 compensation point + real(dp) :: ciDer ! factor to account for constainted intercellular co2 in calculating derivatives + real(dp) :: x0 ! temporary variable + real(dp) :: xsPSN ! intermediate smoothed photosynthesis + real(dp) :: dAc_dc,dAj_dc,dAe_dc,dAi_dc ! derivatives in assimilation w.r.t. intercellular co2 concentration + real(dp),parameter :: theta_cj=0.98_dp ! coupling coefficient (see Sellers et al., 1996 [eq C6]; Bonan et al., 2011 [Table B1]) + real(dp),parameter :: theta_ie=0.95_dp ! coupling coefficient (see Sellers et al., 1996 [eq C6]; Bonan et al., 2011 [Table B1]) + ! ------------------------------------------------------------ + ! this method follows Farquar (Planta, 1980), as implemented in CLM4 and Noah-MP + + ! compute the difference between intercellular co2 concentraion and the compensation point + ciDiff = max(0._dp, ci - co2compPt) + + ! impose constraints (NOTE: derivative is zero if constraints are imposed) + if(ci < co2compPt)then; ciDer = 0._dp; else; ciDer = 1._dp; end if + + ! compute Rubisco-limited assimilation + xFac(ixRubi) = vcmax/(ci + awb) ! umol co2 m-2 s-1 Pa-1 + xPSN(ixRubi) = xFac(ixRubi)*ciDiff ! umol co2 m-2 s-1 + + ! compute light-limited assimilation + xFac(ixLight) = Js/(ci + cp2) ! umol co2 m-2 s-1 Pa-1 + xPSN(ixLight) = xFac(ixLight)*ciDiff ! umol co2 m-2 s-1 + + ! compute export limited assimilation + xFac(ixExport) = 0.5_dp + 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) + + ! minimum function, as used in NoahMP (from CLM4) + case(minFunc) + + ! identify limiting factor + ixLimitVec = minloc(xPSN) + ixLimit = ixLimitVec(1) + + ! define photosynthesis + x0 = xFac(ixLimit) + psn = xPSN(ixLimit) + + ! if derivatives are desired + if(desireDeriv)then + + ! compute derivatives in assimilation (no colimitation) + select case(ixLimit) + case(ixRubi); dA_dc = x0*ciDer - ciDiff*x0*x0/vcmax ! Rubisco-limited assimilation + case(ixLight); dA_dc = x0*ciDer - ciDiff*x0*x0/Js ! light-limited assimilation + case(ixExport); dA_dc = 0._dp ! export-limited assimilation + end select + + ! derivatives are not desired + else + dA_dc = 0._dp + end if + + ! colimitation (Collatz et al., 1991; Sellers et al., 1996; Bonan et al., 2011) + case(colimitation) + + ! compute derivatives for individual terms + if(desireDeriv)then + dAc_dc = xFac(ixRubi)*ciDer - ciDiff*xFac(ixRubi)*xFac(ixRubi)/vcmax + dAj_dc = xFac(ixLight)*ciDer - ciDiff*xFac(ixLight)*xFac(ixLight)/Js + dAe_dc = 0._dp + else + dAc_dc = 0._dp + dAj_dc = 0._dp + dAe_dc = 0._dp + end if + + ! smooth Rubisco-limitation and light limitation + if(ciDiff > tiny(ciDiff))then + call quadSmooth(desireDeriv, xPSN(ixRubi), xPSN(ixLight), theta_cj, dAc_dc, dAj_dc, xsPSN, dAi_dc) + else + xsPSN = 0._dp + dAi_dc = 0._dp + end if + + ! smooth intermediate-limitation and export limitation + call quadSmooth(desireDeriv, xsPSN, xPSN(ixExport), theta_ie, dAi_dc, dAe_dc, psn, dA_dc) + + ! check case is identified + case default; stop 'unknown option for carbon assimilation' ! abrupt stop: need to fix later + + end select ! option for carbon assimilation + + end subroutine photosynthesis + + ! ******************************************************************************************************* + ! private subroutine quadResist: compute stomatal resistance + ! ******************************************************************************************************* + + ! use quadratic function to compute stomatal resistance + + ! this method follows CLM4, described most fully in Oleson et al. (NCAR Tech. Note, 2010) + ! details are also provided in Sellers et al., part 1 (J. Climate, 1996) and Bonan et al. (JGR 2011) + + ! stomatal conductance can be given as + ! 1/rs = m * (A/cs) * (es/ei) * Patm + b * beta ! see Bonan et al. (2011) for inclusion of beta in the 2nd term + ! here es is the (unknown) vapor pressure at the leaf surface + + ! the photosynthesis (computed above) assumes equality in co2 gradients between the atmosphere and the leaf surface, + ! and between the leaf surface and the leaf interior, as + ! A = (ca - cs)/(1.37*rb*Patm) = (cs - ci)/(1.65*rs*Patm) + ! which requires that + ! (ea - ei)/(rb + rs) = (ea - es)/rb = (es - ei)/rb + ! where ea is the vapor pressure in the vegetation canopy, ei is the saturated vapor pressure at the leaf temperature, + ! and then + ! es = (ea*rs + ei*rb) / (rb + rs) + ! more details are in Appendix C of Sellers et al. (J. Climate 1996) and Oleson et al. (NCAR Tech. Note, 2010) + + ! substituting the expression for es in the eqn for stomatal conductance provides the quadratic function, + ! as described by Oleson et al. (2010) + + ! stomatal resistance is the larger of two roots in the quadratic equation + + ! ----------------------------------------------------------------------------------------------------------------- + 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 + real(dp),intent(in) :: rlb ! leaf boundary layer resistance (umol-1 m2 s) + real(dp),intent(in) :: fHum ! scaled humidity function (-) + real(dp),intent(in) :: gMin ! scaled minimum stomatal consuctance (umol m-2 s-1) + real(dp),intent(in) :: g0 ! stomatal conductance in the absence of humidity controls (umol m-2 s-1) + real(dp),intent(in) :: dg0_dc ! derivative in g0 w.r.t intercellular co2 concentration (umol m-2 s-1 Pa-1) + real(dp),intent(out) :: rs ! stomatal resistance ((umol-1 m2 s) + real(dp),intent(out) :: drs_dc ! derivaive in rs w.r.t intercellular co2 concentration (umol-1 m2 s Pa-1) + ! local variables + real(dp) :: aQuad,bQuad,cQuad ! coefficients in the quadratic function + real(dp) :: bSign,xTemp,qQuad ! q term in the quadratic + real(dp) :: root1,root2 ! roots of the quadratic + real(dp) :: dxT_dc,dqq_dc ! derivatives in the q term + + ! define terms for the quadratic function + select case(ix_bbHumdFunc) + + ! original Ball-Berry + case(humidLeafSurface) + aQuad = g0*fHum + gMin + bQuad = (g0 + gMin)*rlb - 1._dp + cQuad = -rlb + + ! Leuning 1995 + case(scaledHyperbolic) + aQuad = g0 + gMin*(1._dp + fHum) + bQuad = (g0 + gMin)*rlb - fHum - 1._dp + cQuad = -rlb + + end select + + ! compute the q term in the quadratic + bSign = abs(bQuad)/bQuad + xTemp = bQuad*bQuad - 4._dp *aQuad*cQuad + qquad = -0.5_dp * (bQuad + bSign*sqrt(xTemp)) + + ! compute roots + root1 = qQuad / aQuad + 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 + + ! compute derivatives in qquad w.r.t. ci + select case(ix_bbHumdFunc) + case(humidLeafSurface); dXt_dc = dg0_dc*(rlb*bQuad*2._dp - fHum*cQuad*4._dp) + case(scaledHyperbolic); dXt_dc = dg0_dc*(rlb*bQuad*2._dp - cQuad*4._dp) + end select + dqq_dc = -0.5_dp * (rlb*dg0_dc + bSign*dXt_dc*0.5_dp / sqrt(xTemp) ) + + ! compute derivatives in rs + if(root1 > root2)then + select case(ix_bbHumdFunc) + case(humidLeafSurface); drs_dc = (dqq_dc - root1*fHum*dg0_dc)/aQuad + case(scaledHyperbolic); drs_dc = (dqq_dc - root1*dg0_dc)/aQuad + end select + else + drs_dc = -root2*dqq_dc/qQuad + end if + + ! derivatives not desired + else + drs_dc = 0._dp + end if + + end subroutine quadResist + + ! ***** + ! * quadratic smoother... + ! *********************** + + subroutine quadSmooth(desireDeriv, x1, x2, xsFac, dx1_dc, dx2_dc, xs, dxs_dc) + implicit none + ! dummy variables + logical(lgt),intent(in) :: desireDeriv ! flag to denote if a derivative is desired + real(dp),intent(in) :: x1,x2 ! variables to be smoothed + real(dp),intent(in) :: xsFac ! smoothing factor + real(dp),intent(in) :: dx1_dc,dx2_dc ! derivatives in variables w.r.t. something important + real(dp),intent(out) :: xs ! smoothed variable + real(dp),intent(out) :: dxs_dc ! derivative w.r.t. something important + ! local variables + real(dp) :: aQuad,bQuad,cQuad ! coefficients in the quadratic function + real(dp) :: bSign,xTemp,qQuad ! q term in the quadratic + real(dp) :: root1,root2 ! roots of the quadratic + real(dp) :: dbq_dc,dcq_dc ! derivatives in quadratic coefficients + real(dp) :: dxT_dc,dqq_dc ! derivatives in the q term + + ! uses the quadratic of the form + ! xsFac*xs^2 - (x1 + x2)*xs + x1*x2 = 0 + ! to smooth variables x1 and x2 + + ! define the terms in the quadratic + aQuad = xsFac + bQuad = -(x1 + x2) + cQuad = x1*x2 + + ! compute the q term in the quadratic + bSign = abs(bQuad)/bQuad + xTemp = bQuad*bQuad - 4._dp *aQuad*cQuad + qquad = -0.5_dp * (bQuad + bSign*sqrt(xTemp)) + + ! compute roots + root1 = qQuad / aQuad + root2 = cQuad / qQuad + xs = min(root1,root2) + + ! compute derivatives + if(desireDeriv)then + + ! compute derivatives for the terms in the quadratic + dbq_dc = -(dx1_dc + dx2_dc) + dcq_dc = x1*dx2_dc + x2*dx1_dc + + ! compute derivatives for xTemp + dxT_dc = 2._dp*(bQuad*dbq_dc) - 4._dp*aQuad*dcq_dc + dqq_dc = -0.5_dp * (dbq_dc + bsign*dxT_dc/(2._dp*sqrt(xTemp))) + + ! compute derivatives in the desired root + if(root1 < root2)then + dxs_dc = dqq_dc/aQuad + else + dxs_dc = (dcq_dc - root2*dqq_dc)/qQuad + end if + + ! derivatives not required + else + dxs_dc = 0._dp + end if + + end subroutine quadSmooth + + + ! ***** + ! * temperature functions... + ! ************************** + + ! q10 function for temperature dependence + function q10(a,T,Tmid,Tscale) + implicit none + real(dp),intent(in) :: a ! scale factor + real(dp),intent(in) :: T ! temperature (K) + real(dp),intent(in) :: Tmid ! point where function is one (25 deg C) + real(dp),intent(in) :: Tscale ! scaling factor (K) + real(dp) :: q10 ! temperature dependence (-) + q10 = a**((T - Tmid)/Tscale) + end function q10 + + ! Arrhenius function for temperature dependence + function fT(delH,T,Tref) + implicit none + real(dp),intent(in) :: delH ! activation energy in temperature function (J mol-1) + real(dp),intent(in) :: T ! temperature (K) + real(dp),intent(in) :: Tref ! reference temperature (K) + real(dp) :: fT ! temperature dependence (-) + fT = exp((delH/(Tref*Rgas))*(1._dp - Tref/T)) ! NOTE: Rgas = J K-1 mol-1 + end function fT + + ! function for high temperature inhibition + function fHigh(delH,delS,T) + implicit none + real(dp),intent(in) :: delH ! deactivation energy in high temp inhibition function (J mol-1) + real(dp),intent(in) :: delS ! entropy term in high temp inhibition function (J K-1 mol-1) + real(dp),intent(in) :: T ! temperature (K) + real(dp) :: fHigh ! high temperature inhibition (-) + fHigh = 1._dp + exp( (delS*T - delH)/(Rgas*T) ) ! NOTE: Rgas = J K-1 mol-1 + end function fHigh + + + ! ******************************************************************************************************* + ! private subroutine stomResist_NoahMP: use Noah-MP routines to compute stomatal resistance + ! ******************************************************************************************************* + subroutine stomResist_NoahMP(& + ! input (model decisions) + 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) + scalarO2air, & ! intent(in): atmospheric o2 concentration (Pa) + scalarCO2air, & ! intent(in): atmospheric co2 concentration (Pa) + scalarCanopySunlitPAR, & ! intent(in): average absorbed par for sunlit leaves (w m-2) + scalarCanopyShadedPAR, & ! intent(in): average absorbed par for shaded leaves (w m-2) + ! input (state and diagnostic variables) + scalarGrowingSeasonIndex, & ! intent(in): growing season index (0=off, 1=on) + scalarFoliageNitrogenFactor, & ! intent(in): foliage nitrogen concentration (1=saturated) + scalarTranspireLim, & ! intent(in): weighted average of the soil moiture factor controlling stomatal resistance (-) + scalarLeafResistance, & ! intent(in): leaf boundary layer resistance (s m-1) + 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) + ! output + scalarStomResistSunlit, & ! intent(out): stomatal resistance for sunlit leaves (s m-1) + scalarStomResistShaded, & ! intent(out): stomatal resistance for shaded leaves (s m-1) + scalarPhotosynthesisSunlit, & ! intent(out): sunlit photosynthesis (umolco2 m-2 s-1) + scalarPhotosynthesisShaded, & ! intent(out): shaded photosynthesis (umolco2 m-2 s-1) + err,message ) ! intent(out): error control + ! ----------------------------------------------------------------------------------------------------------------------------------------- + ! Modified from Noah-MP + ! Compute stomatal resistance and photosynthesis using either + ! 1) Ball-Berry + ! 2) Jarvis + ! See Niu et al. JGR 2011 for more details + USE mDecisions_module, only: BallBerry,Jarvis ! options for the choice of function for stomatal resistance + USE NOAHMP_ROUTINES,only:stomata ! compute canopy resistance based on Ball-Berry + USE NOAHMP_ROUTINES,only:canres ! compute canopy resistance based Jarvis + implicit none + ! input (model decisions) + 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(dp),intent(in) :: airtemp ! measured air temperature at some height above the surface (K) + real(dp),intent(in) :: airpres ! measured air pressure at some height above the surface (Pa) + real(dp),intent(in) :: scalarO2air ! atmospheric o2 concentration (Pa) + real(dp),intent(in) :: scalarCO2air ! atmospheric co2 concentration (Pa) + real(dp),intent(in),target :: scalarCanopySunlitPAR ! average absorbed par for sunlit leaves (w m-2) + real(dp),intent(in),target :: scalarCanopyShadedPAR ! average absorbed par for shaded leaves (w m-2) + ! input (state and diagnostic variables) + real(dp),intent(in) :: scalarGrowingSeasonIndex ! growing season index (0=off, 1=on) + real(dp),intent(in) :: scalarFoliageNitrogenFactor ! foliage nitrogen concentration (1=saturated) + real(dp),intent(in) :: scalarTranspireLim ! weighted average of the soil moiture factor controlling stomatal resistance (-) + real(dp),intent(in) :: scalarLeafResistance ! leaf boundary layer resistance (s m-1) + real(dp),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) + real(dp),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) + real(dp),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) + ! output + real(dp),intent(out) :: scalarStomResistSunlit ! stomatal resistance for sunlit leaves (s m-1) + real(dp),intent(out) :: scalarStomResistShaded ! stomatal resistance for shaded leaves (s m-1) + real(dp),intent(out) :: scalarPhotosynthesisSunlit ! sunlit photosynthesis (umolco2 m-2 s-1) + real(dp),intent(out) :: scalarPhotosynthesisShaded ! sunlit photosynthesis (umolco2 m-2 s-1) + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! local variables + integer(i4b),parameter :: ixSunlit=1 ! named variable for sunlit leaves + integer(i4b),parameter :: ixShaded=2 ! named variable for shaded leaves + integer(i4b) :: iSunShade ! index for sunlit/shaded leaves + real(dp),pointer :: PAR ! average absorbed PAR for sunlit/shaded leaves (w m-2) + real(dp) :: scalarStomResist ! stomatal resistance for sunlit/shaded leaves (s m-1) + real(dp) :: scalarPhotosynthesis ! photosynthesis for sunlit/shaded leaves (umolco2 m-2 s-1) + ! initialize error control + err=0; message='stomResist_NoahMP/' + + ! loop through sunlit and shaded leaves + do iSunShade=1,2 + + ! get appropriate value for PAR + select case(iSunShade) + case(ixSunlit); PAR => scalarCanopySunlitPAR ! average absorbed par for sunlit leaves (w m-2) + case(ixShaded); PAR => scalarCanopyShadedPAR ! average absorbed par for shaded leaves (w m-2) + case default; err=20; message=trim(message)//'unable to identify case for sunlit/shaded leaves'; return + end select + + ! identify option for stomatal resistance + select case(ixStomResist) + + ! Ball-Berry + case(BallBerry) + call stomata(& + ! input + vegTypeIndex, & ! intent(in): vegetation type index + 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) + airtemp, & ! intent(in): air temperature at some height above the surface (K) + airpres, & ! intent(in): air pressure at some height above the surface (Pa) + scalarO2air, & ! intent(in): atmospheric o2 concentration (Pa) + scalarCO2air, & ! intent(in): atmospheric co2 concentration (Pa) + scalarGrowingSeasonIndex, & ! intent(in): growing season index (0=off, 1=on) + scalarTranspireLim, & ! intent(in): weighted average of the soil moiture factor controlling stomatal resistance (-) + scalarLeafResistance, & ! intent(in): leaf boundary layer resistance (s m-1) + ! output + scalarStomResist, & ! intent(out): stomatal resistance (s m-1) + scalarPhotosynthesis ) ! intent(out): photosynthesis (umolco2 m-2 s-1) + + ! Jarvis + case(Jarvis) + call canres(& + ! input + PAR, & ! intent(in): average absorbed par (w m-2) + scalarVegetationTemp, & ! intent(in): vegetation temperature (K) + scalarTranspireLim, & ! intent(in): weighted average of the soil moiture factor controlling stomatal resistance (-) + scalarVP_CanopyAir, & ! intent(in): canopy air vapor pressure (Pa) + 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 + + ! check identified an option + case default; err=20; message=trim(message)//'unable to identify case for stomatal resistance'; return + + end select ! (selecting option for stomatal resistance) + + ! assign output variables + select case(iSunShade) + case(ixSunlit) + scalarStomResistSunlit = scalarStomResist + scalarPhotosynthesisSunlit = scalarPhotosynthesis + case(ixShaded) + scalarStomResistShaded = scalarStomResist + scalarPhotosynthesisShaded = scalarPhotosynthesis + case default; err=20; message=trim(message)//'unable to identify case for sunlit/shaded leaves'; return + end select + + end do ! (looping through sunlit and shaded leaves) + + 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 new file mode 100755 index 000000000..19a656bbd --- /dev/null +++ b/build/source/engine/summaSolve.f90 @@ -0,0 +1,1154 @@ +! 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 summaSolve_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: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 + +! 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) + funcOnly, & ! intent(in): logical flag to only return the flux and function evaluation + 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 he 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 + ! input: state vectors + stateVecTrial, & ! intent(in): trial state vector + 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_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 + feasible, & ! intent(out): flag to denote the feasibility of the solution + 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 + USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure + implicit none + ! -------------------------------------------------------------------------------------------------------------------------------- + ! input: model control + real(dp),intent(in) :: dt ! length of the time step (seconds) + logical(lgt),intent(in) :: funcOnly ! logical flag to only return the flux and function evaluation + 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 + ! input: state vectors + real(dp),intent(in) :: stateVecTrial(:) ! trial state vector + real(dp),intent(in) :: fScale(:) ! function scaling vector + real(dp),intent(in) :: xScale(:) ! "variable" scaling vector, i.e., for state variables + real(qp),intent(in) :: rVec(:) ! NOTE: qp ! residual vector + real(qp),intent(in) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) + real(dp),intent(inout) :: dMat(:) ! diagonal matrix (excludes flux derivatives) + real(dp),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 + type(var_ilength), intent(in) :: indx_data ! indices defining model states and layers + ! 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: baseflow + integer(i4b),intent(inout) :: ixSaturation ! index of the lowest saturated layer (NOTE: only computed on the first iteration) + real(dp),intent(inout) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) + ! output: flux and residual vectors + real(dp),intent(out) :: stateVecNew(:) ! new state vector + real(dp),intent(out) :: fluxVecNew(:) ! new flux vector + real(dp),intent(out) :: resSinkNew(:) ! sink terms on the RHS of the flux equation + real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector + real(dp),intent(out) :: fNew ! new function evaluation + logical(lgt),intent(out) :: feasible ! flag to denote the feasibility of the solution + 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(dp) :: nJac(nState,nState) ! numerical Jacobian matrix + real(dp) :: aJac(nLeadDim,nState) ! Jacobian matrix + real(dp) :: aJacScaled(nLeadDim,nState) ! Jacobian matrix (scaled) + real(dp) :: aJacScaledTemp(nLeadDim,nState) ! Jacobian matrix (scaled) -- temporary copy since decomposed in lapack + ! solution/step vectors + real(dp),dimension(nState) :: rVecScaled ! residual vector (scaled) + real(dp),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) :: 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/' + + ! initialize the global print flag + globalPrintFlagInit=globalPrintFlag + + ! ----- + ! * only compute the function evaluation and return... + ! ---------------------------------------------------- + + ! this is done if using the explicit Euler solution + if(funcOnly)then + stateVecNew = stateVecTrial + 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) + return + endif + + ! ----- + ! * 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(:), dp) ! 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. + + ! 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) + 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(err<0)then + doRefine=.false.; call lineSearchRefinement( doRefine,stateVecTrial,newtStepScaled,aJacScaled,rVecScaled,fOld,stateVecNew,fluxVecNew,resVecNew,fNew,converged,err,cmessage) + end if + + ! 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(dp),intent(in) :: stateVecTrial(:) ! trial state vector + real(dp),intent(in) :: newtStepScaled(:) ! scaled newton step + real(dp),intent(in) :: aJacScaled(:,:) ! scaled jacobian matrix + real(dp),intent(in) :: rVecScaled(:) ! scaled residual vector + real(dp),intent(in) :: fOld ! old function value + ! output + real(dp),intent(out) :: stateVecNew(:) ! new state vector + real(dp),intent(out) :: fluxVecNew(:) ! new flux vector + real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector + real(dp),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(dp) :: gradScaled(nState) ! scaled gradient + real(dp) :: 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(dp),parameter :: alpha=1.e-4_dp ! check on gradient + real(dp) :: xLambda ! backtrack magnitude + real(dp) :: xLambdaTemp ! temporary backtrack magnitude + real(dp) :: slopeInit ! initial slope + real(dp) :: rhs1,rhs2 ! rhs used to compute the cubic + real(dp) :: aCoef,bCoef ! coefficients in the cubic + real(dp) :: disc ! temporary variable used in cubic + real(dp) :: xLambdaPrev ! previous lambda value (used in the cubic) + real(dp) :: 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._dp + + ! ***** 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._dp*(fNew - fOld - slopeInit) ) + if(xLambdaTemp > 0.5_dp*xLambda) xLambdaTemp = 0.5_dp*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._dp)then + xLambdaTemp = -slopeInit/(2._dp*bCoef) + + ! calculate cubic + else + disc = bCoef*bCoef - 3._dp*aCoef*slopeInit + if(disc < 0._dp)then + xLambdaTemp = 0.5_dp*xLambda + else + xLambdaTemp = (-bCoef + sqrt(disc))/(3._dp*aCoef) + end if + end if ! calculating cubic + + ! constrain to <= 0.5*xLambda + if(xLambdaTemp > 0.5_dp*xLambda) xLambdaTemp=0.5_dp*xLambda + + end if ! subsequent backtracks + + ! save results + xLambdaPrev = xLambda + fPrev = fNew + + ! constrain lambda + xLambda = max(xLambdaTemp, 0.1_dp*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(dp),intent(in) :: stateVecTrial(:) ! trial state vector + real(dp),intent(in) :: newtStepScaled(:) ! scaled newton step + real(dp),intent(in) :: aJacScaled(:,:) ! scaled jacobian matrix + real(dp),intent(in) :: rVecScaled(:) ! scaled residual vector + real(dp),intent(in) :: fOld ! old function value + ! output + real(dp),intent(out) :: stateVecNew(:) ! new state vector + real(dp),intent(out) :: fluxVecNew(:) ! new flux vector + real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector + real(dp),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 numJacobian: compute the numerical Jacobian matrix + ! ********************************************************************************************************* + subroutine numJacobian(stateVec,dMat,nJac,err,message) + implicit none + ! dummies + real(dp),intent(in) :: stateVec(:) ! trial state vector + real(dp),intent(in) :: dMat(:) ! diagonal matrix + ! output + real(dp),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(dp),parameter :: dx=1.e-8_dp ! finite difference increment + real(dp),dimension(nState) :: stateVecPerturbed ! perturbed state vector + real(dp),dimension(nState) :: fluxVecInit,fluxVecJac ! flux vector (mized units) + real(qp),dimension(nState) :: resVecInit,resVecJac ! qp ! residual vector (mixed units) + real(dp) :: 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(dp) )/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=iJac1,iJac2) + do iJac=iJac1,iJac2; write(*,'(i4,1x,100(e12.5,1x))') iJac, nJac(iJac1:iJac2,iJac); 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(dp) :: fullJac(nState,nState) ! full Jacobian matrix + real(dp) :: 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._dp + + ! 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(dp),intent(in) :: stateVecNew(:) ! updated state vector + ! output + real(dp),intent(out) :: fluxVecNew(:) ! updated flux vector + real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! updated residual vector + real(dp),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 + ! 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) + ! provide access to named variables that define elements of the structure + 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 + ! constants + USE multiconst,only:iden_water ! intrinsic density of liquid water (kg m-3) + implicit none + ! dummies + real(qp),intent(in) :: rVec(:) ! residual vector (mixed units) + real(dp),intent(in) :: xInc(:) ! iteration increment (mixed units) + real(dp),intent(in) :: xVec(:) ! state vector (mixed units) + logical(lgt) :: checkConv ! flag to denote convergence + ! locals + real(dp),dimension(nSoil) :: psiScale ! scaling factor for matric head + real(dp),parameter :: xSmall=1.e-0_dp ! a small offset + real(dp) :: soilWatbalErr ! error in the soil water balance + real(dp) :: canopy_max ! absolute value of the residual in canopy water (kg m-2) + real(dp),dimension(1) :: energy_max ! maximum absolute value of the energy residual (J m-3) + real(dp),dimension(1) :: liquid_max ! maximum absolute value of the volumetric liquid water content residual (-) + real(dp),dimension(1) :: matric_max ! maximum absolute value of the matric head iteration increment (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 + ! ------------------------------------------------------------------------------------------------------------------------------------------------- + ! 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 + 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)), dp)*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) )), dp) + 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) ) ), dp) + liquidConv = (liquid_max(1) < absConvTol_liquid) ! (based on the residual) + 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 = abs( sum( real(rVec(ixMatOnly), dp)*mLayerDepth(nSnow+ixMatricHead) ) ) + watbalConv = (soilWatbalErr < absConvTol_liquid) ! absolute error in total soil water balance (m) + else + soilWatbalErr = realMissing + watbalConv = .true. + endif + + ! final convergence check + checkConv = (canopyConv .and. watbalConv .and. matricConv .and. liquidConv .and. energyConv) + + ! print progress towards solution + if(globalPrintFlag)then + write(*,'(a,1x,i4,1x,6(e15.5,1x),6(L1,1x))') 'check convergence: ', iter, & + fNew, matric_max(1), liquid_max(1), energy_max(1), canopy_max, soilWatBalErr, matricConv, liquidConv, energyConv, watbalConv, canopyConv, 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) + ! named variables + USE var_lookup,only:iLookPROG ! named variables for elements of the prognostic structure + USE var_lookup,only:iLookPARAM ! named variables for elements of the parameter structure + USE var_lookup,only:iLookINDEX ! named variables for elements of the index structure + ! physical constants + USE multiconst,only:Tfreeze ! temperature at freezing (K) + ! external functions + USE soil_utils_module,only:crit_soilT ! compute the critical temperature below which ice exists + implicit none + ! dummies + real(dp),intent(in) :: stateVecTrial(:) ! trial state vector + real(dp),intent(inout) :: xInc(:) ! iteration increment + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! ----------------------------------------------------------------------------------------------------- + ! temporary variables for model constraints + real(dp) :: cInc ! constrained temperature increment (K) -- simplified bi-section + real(dp) :: xIncFactor ! scaling factor for the iteration increment (-) + integer(i4b) :: iMax(1) ! index of maximum temperature + real(dp) :: scalarTemp ! temperature of an individual snow layer (K) + real(dp) :: 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(dp) :: xPsi00 ! matric head after applying the iteration increment (m) + real(dp) :: TcSoil ! critical point when soil begins to freeze (K) + real(dp) :: critDiff ! temperature difference from critical (K) + real(dp),parameter :: epsT=1.e-7_dp ! small interval above/below critical (K) + real(dp),parameter :: zMaxTempIncrement=1._dp ! 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))) + epsT ) ! 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._dp)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._dp)then + ! scale iteration increment + cInc = -0.5_dp*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_dp*(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_dp*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._dp)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._dp .and. stateVecTrial(ixLiq) > 0._dp)then + xInc(ixLiq) = 1._dp + 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/sunGeomtry.f90 b/build/source/engine/sunGeomtry.f90 old mode 100644 new mode 100755 diff --git a/build/source/engine/systemSolv.f90 b/build/source/engine/systemSolv.f90 old mode 100644 new mode 100755 index b1070d020..0195050a0 --- a/build/source/engine/systemSolv.f90 +++ b/build/source/engine/systemSolv.f90 @@ -23,60 +23,81 @@ module systemSolv_module ! data types USE nrtype -! layer types -USE data_struc,only:ix_soil,ix_snow ! named variables for snow and soil - ! access the global print flag -USE data_struc,only:globalPrintFlag +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 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_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 +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 -! access the number of snow and soil layers -USE data_struc,only:& - nSnow, & ! number of snow layers - nSoil, & ! number of soil layers - nLayers ! total number of layers ! constants USE multiconst,only:& - gravity, & ! acceleration of gravity (m s-2) + LH_fus, & ! latent heat of fusion (J K-1) 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) +! provide access to indices that define elements of the data structures +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 + +! 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 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 - -! 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 boundary conditions for hydrology -USE mDecisions_module,only: & - 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: & + qbaseTopmodel, & ! TOPMODEL-ish baseflow parameterization + bigBucket, & ! a big bucket (lumped aquifer model) + noExplicit ! no explicit groundwater parameterization + +! safety: set private unless specified otherwise implicit none private public::systemSolv + ! control parameters real(dp),parameter :: valueMissing=-9999._dp ! missing value -real(dp),parameter :: verySmall=tiny(1.0_dp) ! a very small number +real(dp),parameter :: verySmall=1.e-12_dp ! a very small number (used to check consistency) real(dp),parameter :: veryBig=1.e+20_dp ! a very big number -real(dp),parameter :: dx = 1.e-8_dp ! finite difference increment +real(dp),parameter :: dx = 1.e-8_dp ! finite difference increment + contains @@ -85,400 +106,144 @@ module systemSolv_module ! ********************************************************************************************************** subroutine systemSolv(& ! input: model control - dt, & ! time step (s) - maxiter, & ! maximum number of iterations - firstSubstep, & ! flag to denote first sub-step - computeVegFlux, & ! flag to denote if computing energy flux over vegetation + 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 + explicitEuler, & ! intent(in): flag to denote computing the explicit Euler solution + 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(in): index data - mvar_data, & ! intent(inout): model variables for a local HRU - bvar_data, & ! intent(in): model variables for the local basin - model_decisions,& ! intent(in): model decisions - ! output: model control - niter, & ! number of iterations taken - err,message) ! error code and error message + 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 + explicitError, & ! intent(out): error in the explicit solution + 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 ! --------------------------------------------------------------------------------------- - ! provide access to the derived types to define the data structures - USE data_struc,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 - ! provide access to indices that define elements of the data structures - USE var_lookup,only:iLookATTR,iLookTYPE,iLookPARAM,iLookFORCE,iLookMVAR,iLookINDEX ! named variables for structure elements - USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure - ! provide access to the numerical recipes modules - USE nr_utility_module,only:arth ! creates a sequence of numbers (start, incr, n) - ! provide access to utility modules - USE soil_utils_module,only:volFracLiq ! compute volumetric fraction of liquid water - USE snow_utils_module,only:fracliquid ! compute the fraction of liquid water at a given temperature (snow) - USE snow_utils_module,only:templiquid ! compute the temperature at a given 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_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:dTheta_dTk ! differentiate the freezing curve w.r.t. temperature (soil) - USE soil_utils_module,only:matricHead ! compute the matric head based on volumetric water content - USE soil_utils_module,only:iceImpede ! compute the ice impedance factor (soil) - USE soil_utils_module,only:dIceImpede_dTemp ! differentiate the ice impedance factor w.r.t. temperature (soil) - ! provide access to the flux modules - USE updatState_module,only:updateSnow ! update snow states - USE updatState_module,only:updateSoil ! update soil states - 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 + ! structure allocations + USE globalData,only:flux_meta ! metadata on the model fluxes + 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 implicit none ! --------------------------------------------------------------------------------------- ! * dummy variables ! --------------------------------------------------------------------------------------- ! input: model control real(dp),intent(in) :: dt ! time step (seconds) - integer(i4b),intent(in) :: maxiter ! maximum number of iterations + 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) :: explicitEuler ! flag to denote computing the explicit Euler solution 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_d),intent(in) :: mpar_data ! model parameters - type(var_ilength),intent(in) :: indx_data - type(var_dlength),intent(inout) :: mvar_data ! model variables for a local HRU + 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(dp),intent(in) :: stateVecInit(:) ! initial state vector (mixed units) ! output: model control - integer(i4b),intent(out) :: niter ! number of iterations + 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(dp),intent(out) :: untappedMelt(:) ! un-tapped melt energy (J m-3 s-1) + real(dp),intent(out) :: stateVecTrial(:) ! trial state vector (mixed units) + real(dp),intent(out) :: explicitError ! error in the explicit solution + 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 - ! --------------------------------------------------------------------------------------- - ! * variables in the data structures - ! --------------------------------------------------------------------------------------- - ! model decisions structure - integer(i4b) :: ixRichards ! intent(in): choice of option for Richards eqn - integer(i4b) :: ixGroundwater ! intent(in): choice of groundwater parameterization - integer(i4b) :: ixSpatialGroundwater ! intent(in): spatial representation of groundwater (local-column or single-basin) - integer(i4b),dimension(nLayers) :: layerType ! intent(in): type of layer in the snow+soil domain (snow or soil) - ! domain boundary conditions - real(dp) :: upperBoundTemp ! intent(in): temperature of the upper boundary of the snow and soil domains (K) - real(dp) :: scalarRainfall ! intent(in): rainfall (kg m-2 s-1) - real(dp) :: scalarSfcMeltPond ! intent(in): ponded water caused by melt of the "snow without a layer" (kg m-2) - ! diagnostic variables - real(dp),dimension(nLayers) :: mLayerDepth ! intent(in): depth of each layer in the snow-soil sub-domain (m) - real(dp) :: scalarBulkVolHeatCapVeg ! intent(in): bulk volumetric heat capacity of vegetation (J m-3 K-1) - real(dp),dimension(nLayers) :: mLayerVolHtCapBulk ! intent(in): bulk volumetric heat capacity in each snow and soil layer (J m-3 K-1) - real(dp),dimension(nLayers) :: mLayerMeltFreeze ! intent(out): melt-freeze in each snow and soil layer (kg m-3) - real(dp),dimension(nSnow) :: mLayerThetaResid ! intent(out): residual volumetric liquid water content in each snow layer (-) - ! model fluxes - real(dp) :: scalarSurfaceRunoff ! intent(out): surface runoff (m s-1) - real(dp),dimension(0:nSnow) :: iLayerLiqFluxSnow ! intent(out): vertical liquid water flux at layer interfaces (m s-1) - real(dp),dimension(0:nSoil) :: iLayerLiqFluxSoil ! intent(out): liquid flux at soil layer interfaces (m s-1) - real(dp),dimension(nSoil) :: mLayerColumnOutflow ! intent(out): column outflow from each soil layer (m3 s-1) - real(dp),dimension(nSoil) :: mLayerBaseflow ! intent(out): baseflow from each soil layer -- only compute at the start of the step (m s-1) - real(dp),dimension(nSoil) :: mLayerCompress ! intent(out): change in storage associated with compression of the soil matrix (-) - real(dp) :: scalarCanopySublimation ! intent(out): sublimation of ice from the vegetation canopy (kg m-2 s-1) - real(dp) :: scalarSnowSublimation ! intent(out): sublimation of ice from the snow surface (kg m-2 s-1) - real(dp) :: scalarExfiltration ! intent(out): exfiltration from the soil profile (m s-1) - ! vegetation parameters - real(dp) :: heightCanopyTop ! intent(in): height of the top of the vegetation canopy (m) - real(dp) :: heightCanopyBottom ! intent(in): height of the bottom of the vegetation canopy (m) - ! soil parameters - real(dp) :: vGn_alpha ! intent(in): van Genutchen "alpha" parameter (m-1) - real(dp) :: vGn_n ! intent(in): van Genutchen "n" parameter (-) - real(dp) :: vGn_m ! intent(in): van Genutchen "m" parameter (-) - real(dp) :: theta_sat ! intent(in): soil porosity (-) - real(dp) :: theta_res ! intent(in): soil residual volumetric water content (-) - real(dp) :: specificStorage ! intent(in): specific storage coefficient (m-1) - real(dp) :: fImpede ! intent(in): ice impedance parameter (-) - ! snow parameters - real(dp) :: snowfrz_scale ! intent(in): scaling parameter for the snow freezing curve (K-1) - ! model state variables (vegetation canopy) - real(dp) :: scalarCanairTemp ! intent(inout): temperature of the canopy air space (K) - real(dp) :: scalarCanopyTemp ! intent(inout): temperature of the vegetation canopy (K) - real(dp) :: scalarCanopyIce ! intent(inout): mass of ice on the vegetation canopy (kg m-2) - real(dp) :: scalarCanopyLiq ! intent(inout): mass of liquid water on the vegetation canopy (kg m-2) - real(dp) :: scalarCanopyWat ! intent(inout): mass of total water on the vegetation canopy (kg m-2) - ! model state variables (snow and soil domains) - real(dp),dimension(nLayers) :: mLayerTemp ! intent(inout): temperature of each snow/soil layer (K) - real(dp),dimension(nLayers) :: mLayerVolFracIce ! intent(inout): volumetric fraction of ice (-) - real(dp),dimension(nLayers) :: mLayerVolFracLiq ! intent(inout): volumetric fraction of liquid water (-) - real(dp),dimension(nLayers) :: mLayerMatricHead ! intent(inout): matric head (m) - real(dp) :: scalarAquiferStorage ! intent(inout): aquifer storage (m) ! ********************************************************************************************************************************************************* ! ********************************************************************************************************************************************************* ! --------------------------------------------------------------------------------------- ! * general local variables ! --------------------------------------------------------------------------------------- - character(LEN=256) :: cmessage ! error message of downwind routine - real(dp) :: canopyDepth ! depth of the vegetation canopy (m) - integer(i4b) :: iter ! iteration index - integer(i4b) :: iLayer ! index of model layer - integer(i4b) :: jLayer ! index of model layer within the full state vector (hydrology) - integer(i4b) :: kLayer ! index of model layer within the snow-soil domain - integer(i4b) :: mLayer ! index of model layer within the full state vector (thermodynamics) - integer(i4b) :: local_ixGroundwater ! local index for groundwater representation - logical(lgt) :: printFlag ! flag to control printing (set to false for numerical jacobian) - logical(lgt) :: printFlagInit ! initialize flag to control printing - logical(lgt) :: pauseProgress ! flag to start looking at things more carefully - logical(lgt) :: crosTempVeg ! flag to denoote where temperature crosses the freezing point - real(dp),parameter :: xMinCanopyWater=0.0001_dp ! minimum value to initialize canopy water (kg m-2) - ! ------------------------------------------------------------------------------------------------------ - ! * model indices - ! ------------------------------------------------------------------------------------------------------ - integer(i4b) :: iPos ! position in vector desire to print - integer(i4b),parameter :: nVegNrg=2 ! number of energy state variables for vegetation - integer(i4b),parameter :: nVegLiq=1 ! number of hydrology state variables for vegetation - integer(i4b) :: nVegState ! number of vegetation state variables (defines position of snow-soil states in the state vector) - integer(i4b) :: nState ! total number of model state variables - integer(i4b),parameter :: ixCasNrg=1 ! index of the canopy air space state variable - integer(i4b),parameter :: ixVegNrg=2 ! index of the canopy energy state variable - integer(i4b),parameter :: ixVegWat=3 ! index of the canopy total water state variable - integer(i4b) :: ixTopNrg ! index of the upper-most energy state variable in the snow-soil subdomain - integer(i4b) :: ixTopLiq ! index of the upper-most liquid water state variable in the snow subdomain - integer(i4b) :: ixTopMat ! index of the upper-most matric head state variable in the soil subdomain - integer(i4b),dimension(nLayers) :: ixSnowSoilNrg ! indices for energy state variables in the snow-soil subdomain - integer(i4b),dimension(nLayers) :: ixSnowSoilWat ! indices for total water state variables in the snow-soil subdomain - integer(i4b),dimension(nSnow) :: ixSnowOnlyNrg ! indices for energy state variables in the snow subdomain - integer(i4b),dimension(nSnow) :: ixSnowOnlyWat ! indices for total water state variables in the snow subdomain - integer(i4b),dimension(nSoil) :: ixSoilOnlyNrg ! indices for energy state variables in the soil subdomain - integer(i4b),dimension(nSoil) :: ixSoilOnlyMat ! indices for matric head state variables in the soil subdomain - integer(i4b),parameter :: nVarSnowSoil=2 ! number of state variables in the snow and soil domain (energy and liquid water/matric head) - integer(i4b),parameter :: nRHS=1 ! number of unknown variables on the RHS of the linear system A.X=B - integer(i4b),parameter :: ku=3 ! number of super-diagonal bands - integer(i4b),parameter :: kl=3 ! number of sub-diagonal bands - integer(i4b),parameter :: ixSup3=kl+1 ! index for the 3rd super-diagonal band - integer(i4b),parameter :: ixSup2=kl+2 ! index for the 2nd super-diagonal band - integer(i4b),parameter :: ixSup1=kl+3 ! index for the 1st super-diagonal band - integer(i4b),parameter :: ixDiag=kl+4 ! index for the diagonal band - integer(i4b),parameter :: ixSub1=kl+5 ! index for the 1st sub-diagonal band - integer(i4b),parameter :: ixSub2=kl+6 ! index for the 2nd sub-diagonal band - integer(i4b),parameter :: ixSub3=kl+7 ! index for the 3rd sub-diagonal band - integer(i4b),parameter :: nBands=2*kl+ku+1 ! length of tyhe leading dimension of the band diagonal matrix - integer(i4b),parameter :: ixFullMatrix=1001 ! named variable for the full Jacobian matrix - integer(i4b),parameter :: ixBandMatrix=1002 ! named variable for the band diagonal matrix - integer(i4b) :: ixSolve ! the type of matrix used to solve the linear system A.X=B - integer(i4b),parameter :: iJac1=1 ! first layer of the Jacobian to print - integer(i4b),parameter :: iJac2=10 ! last layer of the Jacobian to print - !integer(i4b),parameter :: iJac1=457 ! first layer of the Jacobian to print - !integer(i4b),parameter :: iJac2=466 ! last layer of the Jacobian to print - ! ------------------------------------------------------------------------------------------------------ - ! * fluxes and derivatives - ! ------------------------------------------------------------------------------------------------------ - ! ice content (need to keep track of this, but not part of the state vector) - real(dp) :: theta ! liquid water equivalent of total water (liquid plus ice) - real(dp) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) - real(dp) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) - real(dp),dimension(nLayers) :: mLayerdTheta_dTk ! derivative of volumetric liquid water content w.r.t. temperature (K-1) - real(dp),dimension(nSoil) :: dPsiLiq_dTemp ! derivative in the liquid water matric potential w.r.t. temperature (m K-1) - real(dp),dimension(nSnow) :: fracLiqSnow ! fraction of liquid water in each snow layer (-) - real(dp) :: fracLiqVeg ! fraction of liquid water on vegetation (-) - real(dp) :: totalWaterVeg ! total water on vegetation (kg m-2) - real(dp) :: dTheta_dTkCanopy ! derivative of volumetric liquid water content w.r.t. temperature (K-1) - real(dp) :: dCanLiq_dTcanopy ! derivative of canopy liquid storage w.r.t. temperature (kg m-2 K-1) - ! volumetric liquid water content (need to keep track of this, but not part of the state vector for snow and soil) - real(dp),dimension(nSnow) :: mLayerVolFracWat ! initial value of mass fraction of total water (-) - real(dp),dimension(nLayers) :: mLayerVolFracIceTrial ! trial value for volumetric fraction of ice (-) - real(dp),dimension(nLayers) :: mLayerVolFracLiqTrial ! trial value for volumetric fraction of liquid water (-) - real(dp) :: fLiq0,fLiq1 ! fraction of liquid water -- used to compute numerical derivatives (-) - ! energy fluxes and derivatives for the vegetation domain - real(dp) :: canairNetNrgFlux ! net energy flux for the canopy air space (W m-2) - real(dp) :: canopyNetNrgFlux ! net energy flux for the vegetation canopy (W m-2) - real(dp) :: groundNetNrgFlux ! net energy flux for the ground surface (W m-2) - real(dp) :: dCanairNetFlux_dCanairTemp ! derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) - real(dp) :: dCanairNetFlux_dCanopyTemp ! derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) - real(dp) :: dCanairNetFlux_dGroundTemp ! derivative in net canopy air space flux w.r.t. ground temperature (W m-2 K-1) - real(dp) :: dCanopyNetFlux_dCanairTemp ! derivative in net canopy flux w.r.t. canopy air temperature (W m-2 K-1) - real(dp) :: dCanopyNetFlux_dCanopyTemp ! derivative in net canopy flux w.r.t. canopy temperature (W m-2 K-1) - real(dp) :: dCanopyNetFlux_dGroundTemp ! derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) - real(dp) :: dGroundNetFlux_dCanairTemp ! derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) - real(dp) :: dGroundNetFlux_dCanopyTemp ! derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) - real(dp) :: dGroundNetFlux_dGroundTemp ! derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) - real(dp) :: dCanopyNetFlux_dCanLiq ! derivative in net canopy fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - real(dp) :: dGroundNetFlux_dCanLiq ! derivative in net ground fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - ! liquid water fluxes and derivatives associated with transpiration - real(dp) :: scalarCanopyTranspiration ! canopy transpiration (kg m-2 s-1) - real(dp) :: scalarCanopyEvaporation ! canopy evaporation/condensation (kg m-2 s-1) - real(dp) :: scalarGroundEvaporation ! ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) - real(dp) :: dCanopyEvaporation_dCanLiq ! derivative in canopy evaporation w.r.t. canopy liquid water content (s-1) - ! energy fluxes and derivatives for the snow and soil domains - real(dp),dimension(nLayers) :: ssdNetNrgFlux ! net energy flux for each layer (J m-3 s-1) - real(dp),dimension(0:nLayers) :: iLayerNrgFlux ! energy flux at the layer interfaces (W m-2) - real(dp),dimension(0:nLayers) :: dNrgFlux_dTempAbove ! derivatives in the flux w.r.t. temperature in the layer above (J m-2 s-1 K-1) - real(dp),dimension(0:nLayers) :: dNrgFlux_dTempBelow ! derivatives in the flux w.r.t. temperature in the layer below (J m-2 s-1 K-1) - ! liquid water fluxes and derivatives for the vegetation domain - real(dp) :: canopyNetLiqFlux ! net liquid water flux for the vegetation canopy (kg m-2 s-1) - real(dp) :: scalarThroughfallRain ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) - real(dp) :: scalarCanopyLiqDrainage ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) - real(dp) :: scalarCanopyLiqDrainageDeriv ! derivative in canopy drainage w.r.t. canopy liquid water (s-1) - real(dp) :: dCanopyEvaporation_dTCanair ! derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) - real(dp) :: dCanopyEvaporation_dTCanopy ! derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) - real(dp) :: dCanopyEvaporation_dTGround ! derivative in canopy evaporation w.r.t. ground temperature (kg m-2 s-1 K-1) - ! liquid water fluxes and derivatives for the snow domain - real(dp),dimension(0:nSnow) :: iLayerLiqFluxSnowDeriv ! derivative in vertical liquid water flux at layer interfaces (m s-1) - real(dp) :: scalarRainPlusMelt ! surface water input to the soil zone (m s-1) - ! liquid water fluxes and derivatives for the soil domain - real(dp) :: xMaxInfilRate ! maximum infiltration rate (m s-1) - real(dp) :: scalarInfilArea ! fraction of unfrozen area where water can infiltrate (-) - real(dp) :: scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) - real(dp) :: scalarSoilBaseflow ! total baseflow from the soil profile (m s-1) - real(dp) :: soilControl ! soil control on infiltration (-) - real(dp) :: scalarSurfaceInfiltration ! surface infiltration rate (m s-1) -- only computed for iter==1 - real(dp),dimension(nSoil) :: mLayerTranspire ! transpiration loss from each soil layer (m s-1) - real(dp),dimension(nSoil) :: dVolTot_dPsi0 ! derivative in total water content w.r.t. total water matric potential (m-1) - real(dp),dimension(0:nSoil) :: dq_dHydStateAbove ! change in the flux in layer interfaces w.r.t. state variables in the layer above - real(dp),dimension(0:nSoil) :: dq_dHydStateBelow ! change in the flux in layer interfaces w.r.t. state variables in the layer below - real(dp),dimension(0:nSoil) :: dq_dNrgStateAbove ! change in the flux in layer interfaces w.r.t. state variables in the layer above - real(dp),dimension(0:nSoil) :: dq_dNrgStateBelow ! change in the flux in layer interfaces w.r.t. state variables in the layer below - real(dp),dimension(nSoil) :: mLayerHydCond ! hydraulic conductivity in each soil layer (m s-1) - real(dp),dimension(nSoil) :: dHydCond_dMatric ! derivative in hydraulic conductivity w.r.t matric head (s-1) - real(dp),dimension(nSoil) :: mLayerdTheta_dPsi ! derivative in the soil water characteristic w.r.t. psi (m-1) - real(dp),dimension(nSoil) :: mLayerdPsi_dTheta ! derivative in the soil water characteristic w.r.t. theta (m) - real(dp),dimension(nSoil) :: mLayerdIceImpede_dT ! derivative in the ice impedance factor w.r.t. temperature (K-1) - real(dp),dimension(nSoil) :: dCompress_dPsi ! derivative in compressibility w.r.t matric head (m-1) - real(dp),dimension(nSnow) :: snowNetLiqFlux ! net liquid water flux for each snow layer (s-1) - real(dp),dimension(nSoil) :: soilNetLiqFlux ! net liquid water flux for each soil layer (s-1) - real(dp),allocatable :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) - real(dp),dimension(nSoil) :: mLayerMatricHeadDiff ! iteration increment for the matric head (m) - integer(i4b) :: ixSaturation ! index of lowest saturated layer (NOTE: only computed on the first iteration) - ! liquid water fluxes and derivatives for the aquifer - real(dp) :: scalarAquiferTranspire ! transpiration loss from the aquifer at the start-of-step (m s-1) - real(dp) :: scalarAquiferRecharge ! recharge to the aquifer (m s-1) - real(dp) :: scalarAquiferBaseflow ! total baseflow from the aquifer (m s-1) + 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(dp),parameter :: tempAccelerate=0.00_dp ! factor to force initial canopy temperatures to be close to air temperature + real(dp),parameter :: xMinCanopyWater=0.0001_dp ! minimum value to initialize canopy water (kg m-2) + real(dp),parameter :: tinyStep=0.000001_dp ! stupidly small time step (s) ! ------------------------------------------------------------------------------------------------------ ! * model solver ! ------------------------------------------------------------------------------------------------------ - logical(lgt),parameter :: numericalJacobian=.false. ! flag to compute the Jacobian matrix - logical(lgt),parameter :: testBandDiagonal=.false. ! flag to test the band-diagonal matrix - logical(lgt) :: firstFluxCall ! flag to define the first flux call - real(dp),allocatable :: stateVecInit(:) ! initial state vector (mixed units) - real(dp),allocatable :: stateVecTrial(:) ! trial state vector (mixed units) - real(dp),allocatable :: stateVecNew(:) ! new state vector (mixed units) - real(dp),allocatable :: fluxVec0(:) ! flux vector (mixed units) - real(dp),allocatable :: fluxVec1(:) ! flux vector used in the numerical Jacobian calculations (mixed units) - real(dp),allocatable :: fScale(:) ! characteristic scale of the function evaluations (mixed units) - real(dp),allocatable :: xScale(:) ! characteristic scale of the state vector (mixed units) - real(dp),allocatable :: aJac_test(:,:) ! used to test the band-diagonal matrix structure - real(dp),allocatable :: aJac(:,:) ! analytical Jacobian matrix - real(qp),allocatable :: nJac(:,:) ! NOTE: qp ! numerical Jacobian matrix - real(dp),allocatable :: dMat(:) ! diagonal matrix (excludes flux derivatives) - real(qp),allocatable :: sMul(:) ! NOTE: qp ! multiplier for state vector for the residual calculations - real(qp),allocatable :: rAdd(:) ! NOTE: qp ! additional terms in the residual vector - real(qp),allocatable :: rVec(:) ! NOTE: qp ! residual vector - real(dp),allocatable :: xInc(:) ! iteration increment - real(dp),allocatable :: grad(:) ! gradient of the function vector = matmul(rVec,aJac) - real(dp),allocatable :: rhs(:,:) ! the nState-by-nRHS matrix of matrix B, for the linear system A.X=B - integer(i4b),allocatable :: iPiv(:) ! defines if row i of the matrix was interchanged with row iPiv(i) - real(dp) :: fOld,fNew ! function values (-); NOTE: dimensionless because scaled - real(dp) :: canopy_max ! absolute value of the residual in canopy water (kg m-2) - real(dp),dimension(1) :: energy_max ! maximum absolute value of the energy residual (J m-3) - real(dp),dimension(1) :: liquid_max ! maximum absolute value of the volumetric liquid water content residual (-) - real(dp),dimension(1) :: matric_max ! maximum absolute value of the matric head iteration increment (m) - integer(i4b),dimension(1) :: energy_loc ! location of maximum absolute value of the energy residual (-) - integer(i4b),dimension(1) :: liquid_loc ! location of maximum absolute value of the volumetric liquid water content residual (-) - integer(i4b),dimension(1) :: matric_loc ! location of maximum absolute value of the matric head increment (-) - real(dp),parameter :: absConvTol_energy=1.e-0_dp ! convergence tolerance for energy (J m-3) - real(dp),parameter :: absConvTol_liquid=1.e-8_dp ! convergence tolerance for volumetric liquid water content (-) - real(dp),parameter :: absConvTol_matric=1.e-3_dp ! convergence tolerance for matric head increment in soil layers (m) - real(dp),parameter :: absConvTol_watbal=1.e-8_dp ! convergence tolerance for soil water balance (m) - real(dp),parameter :: stepMax=1._dp ! maximum step size (K, m, -) - real(dp) :: stpmax ! scaled maximum step size - real(dp),parameter :: fScaleLiq=0.01_dp ! func eval: characteristic scale for volumetric liquid water content (-) - real(dp),parameter :: fScaleMat=10._dp ! func eval: characteristic scale for matric head (m) - real(dp),parameter :: fScaleNrg=1000000._dp ! func eval: characteristic scale for energy (J m-3) - real(dp),parameter :: xScaleLiq=0.1_dp ! state var: characteristic scale for volumetric liquid water content (-) - real(dp),parameter :: xScaleMat=10._dp ! state var: characteristic scale for matric head (m) - real(dp),parameter :: xScaleTemp=1._dp ! state var: characteristic scale for temperature (K) - logical(lgt) :: converged ! convergence flag - ! ------------------------------------------------------------------------------------------------------ - ! * solution constraints - ! ------------------------------------------------------------------------------------------------------ - real(dp),dimension(nSnow) :: mLayerTempCheck ! updated temperatures (K) -- used to check iteration increment for snow - real(dp),dimension(nSnow) :: mLayerVolFracLiqCheck ! updated volumetric liquid water content (-) -- used to check iteration increment for snow - real(dp) :: cInc ! constrained temperature increment (K) -- simplified bi-section - real(dp) :: xIncScale ! scaling factor for the iteration increment (-) - integer(i4b) :: iMin(1) ! index of most excessive drainage - integer(i4b) :: iMax(1) ! index of maximum temperature - 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) - integer(i4b) :: ixNrg,ixLiq ! index of energy and mass state variables in full state vector - real(dp) :: xPsi00 ! matric head after applying the iteration increment (m) - real(dp) :: TcSoil ! critical point when soil begins to freeze (K) - real(dp) :: critDiff ! temperature difference from critical (K) - real(dp),parameter :: epsT=1.e-7_dp ! small interval above/below critical (K) - ! ------------------------------------------------------------------------------------------------------ - ! * mass balance checks - ! ------------------------------------------------------------------------------------------------------ - logical(lgt),parameter :: checkMassBalance=.true. ! flag to check the mass balance - real(dp) :: soilWaterBalanceError ! water balance error for soil - real(dp) :: balance0,balance1 ! storage at start and end of time step - real(dp) :: vertFlux ! change in storage due to vertical fluxes - real(dp) :: tranSink,baseSink,compSink ! change in storage sue to sink terms - real(dp) :: liqError ! water balance error + 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) + type(var_dlength) :: flux_init ! model fluxes at the start of the time step + real(dp),allocatable :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! NOTE: allocatable, since not always needed + real(dp) :: stateVecNew(nState) ! new state vector (mixed units) + real(dp) :: rhsFlux0(nState) ! right-hand-side fluxes (start of step) + real(dp) :: rhsFlux1(nState) ! right-hand-side fluxes (end of step) + real(dp) :: cf0(nState),cf1(nState) ! conversion factor: factor to convert fluxes to states (different flux evaluations) + real(dp) :: fluxVec0(nState) ! flux vector (mixed units) + real(dp) :: fScale(nState) ! characteristic scale of the function evaluations (mixed units) + real(dp) :: xScale(nState) ! characteristic scale of the state vector (mixed units) + real(dp) :: dMat(nState) ! diagonal matrix (excludes flux derivatives) + real(qp) :: sMul(nState) ! NOTE: qp ! multiplier for state vector for the residual calculations + real(qp) :: rVec(nState) ! NOTE: qp ! residual vector + real(dp) :: rAdd(nState) ! additional terms in the residual vector + real(dp) :: fOld,fNew ! function values (-); NOTE: dimensionless because scaled + logical(lgt) :: stateConstrained ! flag to denote if the state was constrained in the explicit update + logical(lgt) :: feasible ! flag to define the feasibility of the solution + logical(lgt) :: converged ! convergence flag + real(dp) :: resSinkNew(nState) ! additional terms in the residual vector + real(dp) :: fluxVecNew(nState) ! new flux vector + real(qp) :: resVecNew(nState) ! NOTE: qp ! new residual vector + real(dp) :: solutionError(nState) ! vector of errors in the model solution + real(dp),dimension(1) :: errorTemp ! maximum error in explicit solution + real(dp) :: stateVecUpdate(nState) ! state vector update ! --------------------------------------------------------------------------------------- ! point to variables in the data structures ! --------------------------------------------------------------------------------------- - associate(& - + globalVars: associate(& ! model decisions - ixRichards => model_decisions(iLookDECISIONS%f_Richards)%iDecision ,& ! intent(in): [i4b] index of the form of Richards' equation - 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 => mvar_data%var(iLookMVAR%scalarRainfall)%dat(1) ,& ! intent(in): [dp] rainfall rate (kg m-2 s-1) - scalarSfcMeltPond => mvar_data%var(iLookMVAR%scalarSfcMeltPond)%dat(1) ,& ! intent(in): [dp] ponded water caused by melt of the "snow without a layer" (kg m-2) - - ! diagnostic variables - mLayerDepth => mvar_data%var(iLookMVAR%mLayerDepth)%dat ,& ! intent(in): [dp(:)] depth of each layer in the snow-soil sub-domain (m) - scalarBulkVolHeatCapVeg => mvar_data%var(iLookMVAR%scalarBulkVolHeatCapVeg)%dat(1),& ! intent(in): [dp ] bulk volumetric heat capacity of vegetation (J m-3 K-1) - mLayerVolHtCapBulk => mvar_data%var(iLookMVAR%mLayerVolHtCapBulk)%dat ,& ! intent(in): [dp(:)] bulk volumetric heat capacity in each snow and soil layer (J m-3 K-1) - mLayerMeltFreeze => mvar_data%var(iLookMVAR%mLayerMeltFreeze)%dat ,& ! intent(out): [dp(:)] melt-freeze in each snow and soil layer (kg m-3) - mLayerThetaResid => mvar_data%var(iLookMVAR%mLayerThetaResid)%dat ,& ! intent(out): [dp(:)] residual volumetric liquid water content in each snow layer (-) - - ! model fluxes - iLayerLiqFluxSnow => mvar_data%var(iLookMVAR%iLayerLiqFluxSnow)%dat ,& ! intent(out): [dp(0:)] vertical liquid water flux at snow layer interfaces (-) - iLayerLiqFluxSoil => mvar_data%var(iLookMVAR%iLayerLiqFluxSoil)%dat ,& ! intent(out): [dp(0:)] vertical liquid water flux at soil layer interfaces (-) - mLayerBaseflow => mvar_data%var(iLookMVAR%mLayerBaseflow)%dat ,& ! intent(out): [dp(:)] baseflow from each soil layer (m s-1) - mLayerCompress => mvar_data%var(iLookMVAR%mLayerCompress)%dat ,& ! intent(out): [dp(:)] change in storage associated with compression of the soil matrix (-) - scalarSoilBaseflow => mvar_data%var(iLookMVAR%scalarSoilBaseflow)%dat(1) ,& ! intent(out): [dp] total baseflow from the soil profile (m s-1) - scalarExfiltration => mvar_data%var(iLookMVAR%scalarExfiltration)%dat(1) ,& ! intent(out):[dp] exfiltration from the soil profile (m s-1) - - ! sublimation (needed to check mass balance constraints) - scalarCanopySublimation => mvar_data%var(iLookMVAR%scalarCanopySublimation)%dat(1),& ! intent(out): [dp] sublimation of ice from the vegetation canopy (kg m-2 s-1) - scalarSnowSublimation => mvar_data%var(iLookMVAR%scalarSnowSublimation)%dat(1) ,& ! intent(out): [dp] sublimation of ice from the snow surface (kg m-2 s-1) - - ! vegetation parameters - heightCanopyTop => mpar_data%var(iLookPARAM%heightCanopyTop) ,& ! intent(in): [dp] height of the top of the vegetation canopy (m) - heightCanopyBottom => mpar_data%var(iLookPARAM%heightCanopyBottom) ,& ! intent(in): [dp] height of the bottom of the vegetation canopy (m) - - ! soil parameters - vGn_alpha => mpar_data%var(iLookPARAM%vGn_alpha) ,& ! intent(in): [dp] van Genutchen "alpha" parameter (m-1) - vGn_n => mpar_data%var(iLookPARAM%vGn_n) ,& ! intent(in): [dp] van Genutchen "n" parameter (-) - vGn_m => mvar_data%var(iLookMVAR%scalarVGn_m)%dat(1) ,& ! intent(in): [dp] van Genutchen "m" parameter (-) - theta_sat => mpar_data%var(iLookPARAM%theta_sat) ,& ! intent(in): [dp] soil porosity (-) - theta_res => mpar_data%var(iLookPARAM%theta_res) ,& ! intent(in): [dp] soil residual volumetric water content (-) - specificStorage => mpar_data%var(iLookPARAM%specificStorage) ,& ! intent(in): [dp] specific storage coefficient (m-1) - fImpede => mpar_data%var(iLookPARAM%f_impede) ,& ! intent(in): [dp] ice impedance parameter (-) - - ! model state variables (vegetation canopy) - scalarCanairTemp => mvar_data%var(iLookMVAR%scalarCanairTemp)%dat(1) ,& ! intent(inout): [dp] temperature of the canopy air space (K) - scalarCanopyTemp => mvar_data%var(iLookMVAR%scalarCanopyTemp)%dat(1) ,& ! intent(inout): [dp] temperature of the vegetation canopy (K) - scalarCanopyIce => mvar_data%var(iLookMVAR%scalarCanopyIce)%dat(1) ,& ! intent(inout): [dp] mass of ice on the vegetation canopy (kg m-2) - scalarCanopyLiq => mvar_data%var(iLookMVAR%scalarCanopyLiq)%dat(1) ,& ! intent(inout): [dp] mass of liquid water on the vegetation canopy (kg m-2) - - ! model state variables (snow and soil domains) - mLayerTemp => mvar_data%var(iLookMVAR%mLayerTemp)%dat ,& ! intent(inout): [dp(:)] temperature of each snow/soil layer (K) - mLayerVolFracIce => mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat ,& ! intent(inout): [dp(:)] volumetric fraction of ice (-) - mLayerVolFracLiq => mvar_data%var(iLookMVAR%mLayerVolFracLiq)%dat ,& ! intent(inout): [dp(:)] volumetric fraction of liquid water (-) - mLayerMatricHead => mvar_data%var(iLookMVAR%mLayerMatricHead)%dat ,& ! intent(inout): [dp(:)] matric head (m) - scalarAquiferStorage => mvar_data%var(iLookMVAR%scalarAquiferStorage)%dat(1) & ! intent(inout): [dp ] aquifer storage (m) - + 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) + ! accelerate solutuion 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 + 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 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 @@ -488,40 +253,22 @@ subroutine systemSolv(& ! (0) PRELIMINARIES... ! ******************** - !print*, 'kl, ku, nBands = ', kl, ku, nBands - !print*, 'ixSup3, ixSup2, ixSup1, ixDiag = ', ixSup3, ixSup2, ixSup1, ixDiag - !print*, 'ixSub1, ixSub2, ixSub3 = ', ixSub1, ixSub2, ixSub3 - !pause - - ! initialize the first flux call - firstFluxCall=.true. - - ! set the flag to control printing - printFlagInit=.false. - printFlag=printFlagInit - - ! set the flag for pausing - pauseProgress=.false. + ! ----- + ! * initialize... + ! --------------- - ! identify the matrix solution method - ! (the type of matrix used to solve the linear system A.X=B) - if(ixGroundwater==qbaseTopmodel)then - ixSolve=ixFullMatrix ! full Jacobian matrix - else - ixSolve=ixBandMatrix ! band-diagonal matrix + ! check + if(dt < tinyStep)then + message=trim(message)//'dt is tiny' + err=20; return endif - if(globalPrintFlag) print*, '(ixSolve==ixFullMatrix) = ', (ixSolve==ixFullMatrix) - ! print states - !do iLayer=1,nLayers - ! write(*,'(a10,1x,2(f12.7,1x),f10.3,1x,f17.6,1x,f16.6,1x,f16.6)') 'soil', mvar_data%var(iLookMVAR%iLayerHeight)%dat(iLayer-1), mLayerDepth(iLayer), & - ! mLayerTemp(iLayer), mLayerVolFracIce(iLayer), mLayerVolFracLiq(iLayer), mLayerMatricHead(iLayer) - !end do + ! initialize the flags + tooMuchMelt = .false. ! too much melt + reduceCoupledStep = .false. ! need to reduce the length of the coupled step - ! check that dx is less that epsT - if(dx>epsT)then - err=20; message=trim(message)//'dx>epsT; will cause problems testing numerical derivatives'; return - endif + ! 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) @@ -530,2605 +277,747 @@ subroutine systemSolv(& 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) - ! define canopy depth (m) - canopyDepth = heightCanopyTop - heightCanopyBottom - - ! get an initial canopy temperature if veg just starts protruding through snow on the ground - if(computeVegFlux)then - ! (NOTE: if canopy temperature is below absolute zero then canopy was previously buried by snow) - if(scalarCanopyTemp < 0._dp .or. scalarCanairTemp < 0._dp)then - ! check there is snow (there really has to be) - if(nSnow == 0)then - message=trim(message)//'no snow when canopy temperature or canopy air temperature is undefined -- canopy temps can only be undefined when buried with snow' - err=20; return - endif - ! set canopy temperature to the temperature of the top snow layer + small offset to check derivative calculations - scalarCanairTemp = mLayerTemp(1) + 0.1_dp - scalarCanopyTemp = mLayerTemp(1) + 0.1_dp - endif ! (if canopy temperature undefined -- means canopy previously buried with snow) - endif ! (if computing vegetation fluxes -- canopy exposed) - - ! define the number of vegetation state variables (defines position of snow-soil states in the state vector) - if(computeVegFlux)then - nVegState = nVegNrg + nVegLiq - else - nVegState = 0 - endif - - ! define the number of model state variables - nState = nVegState + nLayers*nVarSnowSoil ! *nVarSnowSoil (both energy and liquid water) - - ! check indices - if(iJac1 > nState .or. iJac2 > nState)then - err=20; message=trim(message)//'index iJac1 or iJac2 is out of range'; return - endif - - ! allocate space for the state vectors - allocate(stateVecInit(nState),stateVecTrial(nState),stateVecNew(nState),stat=err) - if(err/=0)then; err=20; message=trim(message)//'unable to allocate space for the state vector'; return; endif + ! 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) - if(err/=0)then; err=20; message=trim(message)//'unable to allocate space for the baseflow derivatives'; return; endif - endif - - ! allocate space for the Jacobian matrix - select case(ixSolve) - case(ixFullMatrix); allocate(aJac(nState,nState),stat=err) - case(ixBandMatrix); allocate(aJac(nBands,nState),stat=err) - case default; err=20; message=trim(message)//'unable to identify option for the type of matrix' - end select - if(err/=0)then; err=20; message=trim(message)//'unable to allocate space for the Jacobian matrix'; return; endif - - ! allocate space for the band-diagonal matrix that is constructed from the full Jacobian matrix - if(testBandDiagonal)then - allocate(aJac_test(nBands,nState),stat=err) - if(err/=0)then; err=20; message=trim(message)//'unable to allocate space for the band diagonal matrix'; return; endif - endif - - ! allocate space for the flux vectors and Jacobian matrix - allocate(dMat(nState),sMul(nState),rAdd(nState),fScale(nState),xScale(nState),fluxVec0(nState),grad(nState),rVec(nState),rhs(nState,nRHS),iPiv(nState),xInc(nState),stat=err) - if(err/=0)then; err=20; message=trim(message)//'unable to allocate space for the solution vectors'; return; endif - - ! define variables to calculate the numerical Jacobian matrix - if(numericalJacobian)then - ! (allocate space for the flux vector and Jacobian matrix - allocate(fluxVec1(nState),nJac(nState,nState),stat=err) - if(err/=0)then; err=20; message=trim(message)//'unable to allocate space for the flux vector and numerical Jacobian matrix'; return; endif - endif ! if calculating the numerical approximation of the Jacobian matrix - - ! define the index of the top layer - ixTopNrg = nVegState + 1 ! energy - ixTopLiq = nVegState + 2 ! total water (only snow) - ixTopMat = nVegState + nSnow*nVarSnowSoil + 2 ! matric head (only soil) - - ! define the indices within the snow-soil domain - ixSnowSoilNrg = arth(ixTopNrg,nVarSnowSoil,nLayers) ! energy - ixSnowSoilWat = arth(ixTopLiq,nVarSnowSoil,nLayers) ! total water - - ! define indices just for the snow and soil domains - ixSoilOnlyNrg = arth(ixTopNrg + nSnow*nVarSnowSoil,nVarSnowSoil,nSoil) ! matric head - ixSoilOnlyMat = arth(ixTopMat,nVarSnowSoil,nSoil) ! matric head - - if(nSnow>0)then ! (liquid water in snow only defined if snow layers exist) - ixSnowOnlyNrg = arth(ixTopNrg,nVarSnowSoil,nSnow) ! energy - ixSnowOnlyWat = arth(ixTopLiq,nVarSnowSoil,nSnow) ! total water - endif - !print*, 'nLayers = ', nLayers - !print*, 'nVegState = ', nVegState - !print*, 'nSnow, nSoil = ', nSnow, nSoil - !print*, 'ixSnowSoilNrg = ', ixSnowSoilNrg - !print*, 'ixSoilOnlyNrg = ', ixSoilOnlyNrg - !print*, 'ixSoilOnlyMat = ', ixSoilOnlyMat - !print*, 'ixSnowOnlyNrg = ', ixSnowOnlyNrg - !print*, 'ixSnowOnlyWat = ', ixSnowOnlyWat - - ! define the scaled maximum step size (used in the line search) - stpmax = stepMax*real(nState,dp) - - ! define additional vectors used in the residual calculations - sMul(:) = 1._dp ! multiplier for the state vector - rAdd(:) = 0._dp ! additional terms in the residual calculations (phase change, compressibility, etc.) - - ! define the multiplier for the state vector for residual calculations (vegetation canopy) - if(computeVegFlux)then - sMul(ixCasNrg) = Cp_air*iden_air ! volumetric heat capacity of air (J m-3 K-1) - sMul(ixVegNrg) = scalarBulkVolHeatCapVeg ! volumetric heat capacity of the vegetation (J m-3 K-1) - sMul(ixVegWat) = 1._dp ! nothing else on the left hand side - endif - - ! define the multiplier for the state vector for residual calculations (snow-soil domain) - sMul(ixSnowSoilNrg) = mLayerVolHtCapBulk(1:nLayers) - sMul(ixSnowSoilWat) = 1._dp - - ! 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 - if(computeVegFlux)then - dMat(ixCasNrg) = Cp_air*iden_air ! volumetric heat capacity of air (J m-3 K-1) - dMat(ixVegWat) = 1._dp ! nothing else on the left hand side - endif - - ! compute terms in the Jacobian for the snow domain (excluding fluxes) - ! NOTE: this is computed outside the iteration loop because it does not depend on state variables - if(nSnow>0)& ! (liquid water in snow only defined if snow layers exist) - dMat(ixSnowOnlyWat) = 1._dp - - ! initialize - xInc(:) = 0._dp ! iteration increment - - ! compute the total water in the vegetation canopy - if(computeVegFlux)then - scalarCanopyWat = scalarCanopyLiq + scalarCanopyIce ! kg m-2 - endif - - ! compute the total water in snow - if(nSnow>0)& - mLayerVolFracWat(1:nSnow) = mLayerVolFracLiq(1:nSnow) + mLayerVolFracIce(1:nSnow)*(iden_ice/iden_water) - - ! define the scaling for the function evaluation -- vegetation - if(computeVegFlux)then - fScale(ixCasNrg) = fScaleNrg ! (J m-3) - fScale(ixVegNrg) = fScaleNrg ! (J m-3) - fScale(ixVegWat) = fScaleLiq*canopyDepth*iden_water ! (kg m-2) - endif - - ! define the scaling for the function evaluation -- snow and soil - fScale(ixSnowSoilNrg) = fScaleNrg ! (J m-3) - fScale(ixSnowSoilWat) = fScaleLiq ! (-) - - ! define scaling for the state vector -- vegetation - if(computeVegFlux)then - xScale(ixCasNrg) = xScaleTemp ! (K) - xScale(ixVegNrg) = xScaleTemp ! (K) - xScale(ixVegWat) = xScaleLiq*canopyDepth*iden_water ! (kg m-2) - endif - - ! define the scaling for the function evaluation -- snow and soil - xScale(ixSnowSoilNrg) = xScaleTemp ! (K) - xScale(ixSnowOnlyWat) = xScaleLiq ! (-) - xScale(ixSoilOnlyMat) = xScaleMat ! (m) + 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 - ! build the state vector for the vegetation canopy - if(computeVegFlux)then - stateVecInit(ixCasNrg) = scalarCanairTemp - stateVecInit(ixVegNrg) = scalarCanopyTemp - stateVecInit(ixVegWat) = scalarCanopyWat ! kg m-2 + ! identify the matrix solution method + ! (the type of matrix used to solve the linear system A.X=B) + if(local_ixGroundwater==qbaseTopmodel .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 - - ! build the state vector for the snow and soil domain - stateVecInit(ixSnowSoilNrg) = mLayerTemp(1:nLayers) - stateVecInit(ixSoilOnlyMat) = mLayerMatricHead(1:nSoil) - if(nSnow>0)& - stateVecInit(ixSnowOnlyWat) = mLayerVolFracWat(1:nSnow) - + + ! 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(computeVegFlux)then - if(scalarCanopyWat < xMinCanopyWater) stateVecTrial(ixVegWat) = scalarCanopyWat + xMinCanopyWater + 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 + .true., & ! 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 + ! 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) - ! initialize the volumetric fraction of liquid water and ice in the vegetation canopy - !print*, 'scalarCanopyIce = ', scalarCanopyIce - !scalarCanopyLiqTrial = scalarCanopyLiq - !scalarCanopyIceTrial = scalarCanopyIce - - ! initialize the volumetric fraction of liquid water and ice in snow and soil layers - !mLayerVolFracLiqTrial(1:nLayers) = mLayerVolFracLiq(1:nLayers) ! additional state variable for all layers - !mLayerVolFracIceTrial(1:nLayers) = mLayerVolFracIce(1:nLayers) ! additional state variable for all layers + ! check feasibility (state vector SHOULD be feasible at this point) + if(.not.feasible)then + reduceCoupledStep=.true. + 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 + + ! ** if explicit Euler, then estimate state vector at the end of the time step + if(explicitEuler)then + + ! --> compute the RHS fluxes and conversion factor + call rhsFluxes(indx_data,deriv_data,sMul,fluxVec0,rAdd/dt, & ! intent(in) : state indices and derivatives, and the state vector multiplier + cf0,rhsFlux0,err,cmessage) ! intent(out) : conversion factor, and error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (check for errors) - ! initialize the function variable - fOld=veryBig ! initialize to a very big number + ! --> update states using the explicit Euler method + call explicitUpdate(indx_data,mpar_data,prog_data,stateVecInit, & ! intent(in) : indices, parameters, prognostic variables, and initial state vector + dt*fluxVec0/cf0, & ! intent(in) : state vector update + stateVecTrial,stateConstrained, & ! intent(out) : trial state vector and flag to denote that it was constrained + err,cmessage) ! intent(out) : error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (check for errors) + endif ! if explicit Euler + ! ========================================================================================================================================== ! ========================================================================================================================================== ! ========================================================================================================================================== ! ========================================================================================================================================== - - ! (1) MAIN ITERATION LOOP... + ! ************************** - + ! *** MAIN ITERATION LOOP... + ! ************************** + ! iterate - do iter=1,maxiter + ! NOTE: this do loop is skipped in the explicitEuler solution (localMaxIter=0) + do iter=1,maxIter + + ! print iteration count + !print*, '*** iter, maxiter, dt = ', iter, maxiter, dt ! keep track of the number of iterations - niter = iter - - ! test - !print*, '***' - !print*, '***' - !print*, '***' - !print*, '***' - !print*, '***' - !print*, '***' - !print*, '***' - !write(*,'(a,1x,f10.2,1x,2(i4,1x),l1)') '*** new iteration: dt, iter, nstate, computeVegFlux = ', dt, iter, nstate, computeVegFlux - !write(*,'(a,1x,10(e15.5,1x))') 'stateVecInit(1:10) = ', stateVecInit(1:10) - !write(*,'(a,1x,10(e15.5,1x))') 'stateVecTrial(1:10) = ', stateVecTrial(1:10) - !write(*,'(a,1x,10(e15.5,1x))') 'xInc(1:10) = ', xInc(1:10) - - ! ----- - ! * compute model fluxes and residual - ! NOTE: refine residual with line search... - ! -------------------------------------------- - call lineSearch(& - ! input - (iter>1), & ! intent(in): flag to denote the need to perform line search - stateVecTrial, & ! intent(in): initial state vector - fOld, & ! intent(in): function value for trial state vector (mixed units) - grad, & ! intent(in): gradient of the function vector (mixed units) - xInc, & ! intent(in): iteration increment (mixed units) + 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 + ! NOTE: only returns the flux vector and function evaluation when the solution method is explicitEuler + call summaSolve(& + ! input: model control + dt, & ! intent(in): length of the time step (seconds) + explicitEuler, & ! intent(in): logical flag to only return the flux and function evaluation + 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 + ! input: state vectors + stateVecTrial, & ! intent(in): trial state vector + 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 (m) - fluxVec0, & ! intent(out): new flux vector (mixed units) - rVec, & ! intent(out): new residual vector (mixed units) - fNew, & ! intent(out): new function value (mixed units) - 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) - - ! use full iteration increment if converged all the way to the original value - if(err<0)then - call lineSearch(& - ! input - .false., & ! intent(in): flag to denote the need to perform line search - stateVecTrial, & ! intent(in): initial state vector - fOld, & ! intent(in): function value for trial state vector (mixed units) - grad, & ! intent(in): gradient of the function vector (mixed units) - xInc, & ! intent(in): iteration increment (mixed units) - ! output - stateVecNew, & ! intent(out): new state vector (m) - fluxVec0, & ! intent(out): new flux vector (mixed units) - rVec, & ! intent(out): new residual vector (mixed units) - fNew, & ! intent(out): new function value (mixed units) - 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) - endif - - ! update function evaluation and states - fOld = fNew - stateVecTrial = stateVecNew - - ! exit iteration loop if converged - if(converged) exit - - ! ----- - ! * compute Jacobian... - ! --------------------- - - ! 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(computeVegFlux)then - dMat(ixVegNrg) = scalarBulkVolHeatCapVeg + LH_fus*iden_water*dTheta_dTkCanopy ! volumetric heat capacity of the vegetation (J m-3 K-1) - endif - - ! compute additional terms for the Jacobian for the snow-soil domain (excluding fluxes) - ! NOTE: energy for vegetation is computed *within* the iteration loop as it includes phase change - dMat(ixSnowSoilNrg) = mLayerVolHtCapBulk(1:nLayers) + LH_fus*iden_water*mLayerdTheta_dTk(1:nLayers) - !do iLayer=1,nLayers - ! write(*,'(a,1x,i4,1x,100(e15.5,1x))') 'iLayer, LH_fus*iden_water*mLayerdTheta_dTk(iLayer) = ', iLayer, LH_fus*iden_water*mLayerdTheta_dTk(iLayer) - !end do - !write(*,'(a,1x,100(e15.5,1x))')'dMat(ixSoilOnlyNrg) = ', dMat(ixSoilOnlyNrg) - - ! compute additional terms for the Jacobian for the soil domain (excluding fluxes) - if(ixRichards==moisture)then; err=20; message=trim(message)//'have not implemented the moisture-based form of RE yet'; return; endif - dMat(ixSoilOnlyMat) = dVolTot_dPsi0(1:nSoil) + dCompress_dPsi(1:nSoil) - !print*, 'dVolTot_dPsi0(1:nSoil) = ', dVolTot_dPsi0(1:nSoil) - !print*, 'dCompress_dPsi(1:nSoil) = ', dCompress_dPsi(1:nSoil) - - ! compute the analytical Jacobian matrix - select case(ixSolve) - case(ixFullMatrix); call analJacob(err,cmessage) - case(ixBandMatrix); call cpactBand(err,cmessage) - case default; err=20; message=trim(message)//'unable to identify option for the type of matrix' - end select - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (check for errors) - !pause ' after analytical jacobian' - - ! *** testing: compute the numerical approximation of the Jacobian matrix - if(numericalJacobian)then - printFlag=.false. - call numlJacob(stateVecTrial,fluxVec0,rVec,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (check for errors) - printFlag=printFlagInit - endif ! if computing the numerical Jacobian matrix - - ! ----- - ! * solve linear system... - ! ------------------------ - - ! use the lapack routines to solve the linear system A.X=B - call lapackSolv(aJac,rVec,grad,xInc,err,cmessage) + 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 + feasible, & ! intent(out): flag to denote that the state vector is feasible + 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) - !if(computeVegFlux .and. printFlag)then - ! write(*,'(a,1x,10(e15.5,1x))') 'xInc(ixCasNrg) = ', xInc(ixCasNrg) - ! write(*,'(a,1x,10(e15.5,1x))') 'xInc(ixVegNrg) = ', xInc(ixVegNrg) - ! write(*,'(a,1x,10(e15.5,1x))') 'xInc(ixVegWat) = ', xInc(ixVegWat) - !endif - - !write(*,'(a,1x,10(e15.5,1x))') 'rVec(ixSoilOnlyMat) = ', rVec(ixSoilOnlyMat) - !write(*,'(a,1x,10(e15.5,1x))') 'grad(ixSoilOnlyMat) = ', grad(ixSoilOnlyMat) - - !if(printFlag)then - ! write(*,'(a,1x,10(e15.5,1x))') 'xInc(ixSoilOnlyMat) = ', xInc(ixSoilOnlyMat) - ! write(*,'(a,1x,10(e15.5,1x))') 'xInc(ixSnowOnlyWat) = ', xInc(ixSnowOnlyWat) - ! write(*,'(a,1x,10(e15.5,1x))') 'xInc(ixSnowSoilNrg) = ', xInc(ixSnowSoilNrg) - ! pause - ! if(pauseProgress) pause - !endif - - ! print iteration increment - !write(*,'(a,1x,10(f20.12,1x))') 'xInc(iJac1:iJac2) = ', xInc(iJac1:iJac2) - - ! ----- - ! * impose solution constraints... - ! -------------------------------- - - ! ** limit temperature increment to 1K - - ! vegetation - if(computeVegFlux)then - if(abs(xInc(ixVegNrg)) > 1._dp)then - !write(*,'(a,1x,10(f20.12,1x))') 'before scale: xInc(iJac1:iJac2) = ', xInc(iJac1:iJac2) - xIncScale = abs(1._dp/xInc(ixVegNrg)) ! scaling factor for the iteration increment (-) - xInc = xIncScale*xInc ! scale iteration increments - !write(*,'(a,1x,10(f20.12,1x))') 'after scale: xInc(iJac1:iJac2) = ', xInc(iJac1:iJac2) - endif - endif - - ! snow and soil - if(any(abs(xInc(ixSnowSoilNrg)) > 1._dp))then - !write(*,'(a,1x,10(f20.12,1x))') 'before scale: xInc(iJac1:iJac2) = ', xInc(iJac1:iJac2) - iMax = maxloc( abs(xInc(ixSnowSoilNrg)) ) ! index of maximum temperature increment - xIncScale = abs( 1._dp/xInc(ixSnowSoilNrg(iMax(1))) ) ! scaling factor for the iteration increment (-) - xInc = xIncScale*xInc - !write(*,'(a,1x,10(f20.12,1x))') 'after scale: xInc(iJac1:iJac2) = ', xInc(iJac1:iJac2) - endif - - ! ** impose solution constraints for vegetation - ! (stop just above or just below the freezing point if crossing) - if(computeVegFlux)then - - ! -------------------------------------------------------------------------------------------------------------------- - ! canopy temperatures - - ! initialize - critDiff = Tfreeze - stateVecTrial(ixVegNrg) - crosTempVeg = .false. - - ! initially frozen (T < Tfreeze) - if(critDiff > 0._dp)then - if(xInc(ixVegNrg) > critDiff)then - crosTempVeg = .true. - cInc = critDiff + epsT ! constrained temperature increment (K) - endif - - ! initially unfrozen (T > Tfreeze) - else - if(xInc(ixVegNrg) < critDiff)then - crosTempVeg = .true. - cInc = critDiff - epsT ! constrained temperature increment (K) - endif - - endif ! switch between frozen and unfrozen - - ! scale iterations - if(crosTempVeg)then - xIncScale = cInc/xInc(ixVegNrg) ! scaling factor for the iteration increment (-) - xInc = xIncScale*xInc ! scale iteration increments - endif - - !print*, 'crosTempVeg = ', crosTempVeg - - ! -------------------------------------------------------------------------------------------------------------------- - ! canopy liquid water - - ! check if new value of storage will be negative - if(stateVecTrial(ixVegWat)+xInc(ixVegWat) < 0._dp)then - ! scale iteration increment - cInc = -0.5_dp*stateVecTrial(ixVegWat) ! constrained iteration increment (K) -- simplified bi-section - xIncScale = cInc/xInc(ixVegWat) ! scaling factor for the iteration increment (-) - xInc = xIncScale*xInc ! new iteration increment - !print*, 'canopy liquid water constraint' - endif - - endif ! if computing fluxes through vegetation - - ! ** impose solution constraints for snow - if(nSnow > 0)then - - ! -------------------------------------------------------------------------------------------------------------------- - ! get new temperatures - mLayerTempCheck = stateVecTrial(ixSnowOnlyNrg) + xInc(ixSnowOnlyNrg) - - ! - check sub-freezing temperatures for snow - if(any(mLayerTempCheck > Tfreeze))then - ! scale iteration increment - iMax = maxloc(mLayerTempCheck) ! index of maximum temperature - cInc = 0.5_dp*(Tfreeze - stateVecTrial(ixSnowOnlyNrg(iMax(1))) ) ! constrained temperature increment (K) -- simplified bi-section - xIncScale = cInc/xInc(ixSnowOnlyNrg(iMax(1))) ! scaling factor for the iteration increment (-) - xInc = xIncScale*xInc - !print*, 'stateVecTrial(ixSnowOnlyNrg(iMax(1))), mLayerTempCheck(iMax(1)), cInc, xIncScale = ', & - ! stateVecTrial(ixSnowOnlyNrg(iMax(1))), mLayerTempCheck(iMax(1)), cInc, xIncScale - endif ! if snow temperature > freezing - - ! -------------------------------------------------------------------------------------------------------------------- - ! - check if drain more than what is available - ! NOTE: change in total water is only due to liquid flux - - ! get new volumetric fraction of liquid water - mLayerVolFracLiqCheck = mLayerVolFracLiqTrial(1:nSnow)+xInc(ixSnowOnlyWat) - drainFlag(:) = .false. - - do iLayer=1,nSnow - if(mLayerVolFracLiqCheck(iLayer) < 0._dp)then - drainFlag(iLayer) = .true. - xInc(ixSnowOnlyWat(iLayer)) = -0.5_dp*mLayerVolFracLiqTrial(iLayer) - endif - !write(*,'(a,1x,i4,1x,l1,1x,10(f15.8,1x))') 'iLayer, drainFlag(iLayer), xInc(ixSnowOnlyWat(iLayer)), mLayerVolFracLiqTrial(iLayer), mLayerThetaResid(iLayer) = ',& - ! iLayer, drainFlag(iLayer), xInc(ixSnowOnlyWat(iLayer)), mLayerVolFracLiqTrial(iLayer), mLayerThetaResid(iLayer) - end do - - ! check if the iteration increment removes all the water - !if(any(mLayerVolFracLiqCheck < 0._dp))then - ! ! print original iteration increment - ! do iLayer=1,nSnow - ! write(*,'(a,1x,i4,1x,10(f15.8,1x))') 'iLayer, xInc(ixSnowOnlyWat(iLayer)) = ', iLayer, xInc(ixSnowOnlyWat(iLayer)) - ! end do - ! ! scale iteration increment - ! iMin = minloc(mLayerVolFracLiqCheck) ! index of the most excessive drainage - ! cInc = -0.5_dp*mLayerVolFracLiqTrial(iMin(1)) ! constrained drainage increment (-) -- simplified bi-secion - ! xIncScale = cInc/xInc(ixSnowOnlyWat(iMin(1))) ! scaling factor for the iteration increment (-) - ! xInc = xIncScale*xInc - ! drainFlag(iMin(1)) = .true. - ! ! print results - ! do iLayer=1,nSnow - ! write(*,'(a,1x,i4,1x,l1,1x,10(f15.8,1x))') 'iLayer, drainFlag(iLayer), xInc(ixSnowOnlyWat(iLayer)), mLayerVolFracLiqTrial(iLayer), mLayerThetaResid(iLayer) = ',& - ! iLayer, drainFlag(iLayer), xInc(ixSnowOnlyWat(iLayer)), mLayerVolFracLiqTrial(iLayer), mLayerThetaResid(iLayer) - ! end do - ! !pause - !endif ! if iteration increment removes all the water - - endif ! if snow layers exist - - - ! -------------------------------------------------------------------------------------------------------------------- - ! ** impose solution constraints for soil - do iLayer=1,nSoil - - ! initialize crossing flag - crosFlag(iLayer) = .false. - - ! identify indices for energy and mass state variables - ixNrg = ixSnowSoilNrg(nSnow+iLayer) - ixLiq = ixSnowSoilWat(nSnow+iLayer) - - ! identify the critical point when soil begins to freeze (TcSoil) - xPsi00 = stateVecTrial(ixLiq) + xInc(ixLiq) - TcSoil = Tfreeze + min(xPsi00,0._dp)*gravity*Tfreeze/LH_fus ! (NOTE: J = kg m2 s-2, so LH_fus is in units of m2 s-2) - - ! get the difference from the current state and the crossing point (K) - critDiff = TcSoil - stateVecTrial(ixNrg) - - !write(*,'(i4,3x,a20,1x,f20.10)') iLayer, ' - ', xInc(ixNrg) - - ! * initially frozen (T < TcSoil) - if(critDiff > 0._dp)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) - !write(*,'(i4,1x,l1,1x,2(f20.10,1x))') iLayer, crosFlag(iLayer), TcSoil, xInc(ixNrg) - - ! place constraint for matric head - if(xInc(ixLiq) > 1._dp .and. stateVecTrial(ixLiq) > 0._dp)then - xInc(ixLiq) = 1._dp - pauseProgress=.true. - endif ! if constraining matric head - - end do ! (loop through soil layers - - !print*, ' SWE = ', sum( (mLayerVolFracLiqTrial(1:nSnow)*iden_water + mLayerVolFracIceTrial(1:nSnow)*iden_ice) * mLayerDepth(1:nSnow) ) - + !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 + if(.not.explicitEuler)then + ! save functions and residuals + fOld = fNew + rVec = resVecNew + stateVecTrial = stateVecNew + ! check feasibility + if(.not.feasible)then + message=trim(message)//'expect feasible solution in implicit Euler' + err=20; return + endif ! check feasibility + endif ! check explicit Euler + + ! 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(*,*) + + ! exit iteration loop if converged + if(converged .or. explicitEuler) exit + ! check convergence - if(niter==maxiter)then; err=-20; message=trim(message)//'failed to converge'; return; endif - !pause 'iterating' - - + if(iter==maxiter)then + message=trim(message)//'failed to converge' + err=-20; return + endif + !print*, 'PAUSE: iterating'; read(*,*) + end do ! iterating - - !print*, 'endIter' - !print*, '**************************************' - !print*, '**************************************' - !print*, '**************************************' - - !pause 'after iterations' - - ! check that we got baseflow - !print*, 'mLayerBaseflow(:) = ', mLayerBaseflow(:) - - ! ----- - ! * update states and compute total volumetric melt... - ! ---------------------------------------------------- - - ! update temperatures (ensure new temperature is consistent with the fluxes) - stateVecTrial(ixSnowSoilNrg) = stateVecInit(ixSnowSoilNrg) + (fluxVec0(ixSnowSoilNrg)*dt + real(rAdd(ixSnowSoilNrg), dp))/real(sMul(ixSnowSoilNrg), dp) - - ! 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(nSnow>0)& - stateVecTrial(ixSnowOnlyWat) = stateVecInit(ixSnowOnlyWat) + (fluxVec0(ixSnowOnlyWat)*dt + real(rAdd(ixSnowOnlyWat), dp)) - - ! compute total baseflow from the soil zone (needed for mass balance checks) - scalarSoilBaseflow = sum(mLayerBaseflow) - !write(*,'(a,1x,e20.10)') 'scalarSoilBaseflow = ', scalarSoilBaseflow - - ! update states: compute liquid water and ice content from total water content - call updatState(& - stateVecTrial, & ! intent(in): full state vector (mixed units) - mLayerVolFracLiqTrial, & ! intent(out): volumetric fraction of liquid water (-) - mLayerVolFracIceTrial, & ! intent(out): volumetric fraction of ice (-) - scalarCanopyLiqTrial, & ! intent(out): mass of canopy liquid (kg m-2) - scalarCanopyIceTrial, & ! intent(out): mass of canopy ice (kg m-2) - err,cmessage) ! intent(out): error code and error message - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (check for errors) - - ! check the mass balance for the soil domain - ! NOTE: this should never fail since did not converge if water balance was not within tolerance=absConvTol_watbal - if(checkMassBalance)then - balance0 = sum( (mLayerVolFracLiq(nSnow+1:nLayers) + mLayerVolFracIce(nSnow+1:nLayers) )*mLayerDepth(nSnow+1:nLayers) ) - balance1 = 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 = balance1 - (balance0 + vertFlux + tranSink - baseSink - compSink) - if(abs(liqError) > absConvTol_watbal*10._dp)then ! *10 to avoid precision issues - message=trim(message)//'water balance error in the soil domain' - err=-20; return ! negative error code forces time step reduction and another trial - endif ! if there is a water balance error - endif ! checking mass balance - - ! compute the melt in each snow and soil layer - if(nSnow>0) mLayerMeltFreeze( 1:nSnow ) = -(mLayerVolFracIceTrial( 1:nSnow ) - mLayerVolFracIce( 1:nSnow ))*iden_ice - mLayerMeltFreeze(nSnow+1:nLayers) = -(mLayerVolFracIceTrial(nSnow+1:nLayers) - mLayerVolFracIce(nSnow+1:nLayers))*iden_water - !write(*,'(a,1x,10(f20.10,1x))') 'mLayerVolFracIce(1), mLayerVolFracLiq(1) = ', mLayerVolFracIce(1)*iden_ice, mLayerVolFracLiq(1)*iden_water - !write(*,'(a,1x,10(f20.10,1x))') 'mLayerVolFracIceTrial(1), mLayerVolFracLiqTrial(1) = ', mLayerVolFracIceTrial(1)*iden_ice, mLayerVolFracLiqTrial(1)*iden_water - !write(*,'(a,1x,10(f20.10,1x))') 'mLayerMeltFreeze( 1:nSnow ) = ', mLayerMeltFreeze( 1:nSnow ) - - ! ----- - ! * check that there is sufficient ice content to support the converged sublimation rate... - ! ----------------------------------------------------------------------------------------- - - ! check that sublimation does not exceed the available water on the canopy - if(computeVegFlux)then - if(-dt*scalarCanopySublimation > scalarCanopyLiqTrial + scalarCanopyIceTrial)then ! try again - message=trim(message)//'insufficient water to support converged canopy sublimation rate' - err=-20; return ! negative error code means "try again" - endif ! if insufficient water for sublimation - endif ! if computing the veg flux - - ! check that sublimation does not exceed the available ice in the top snow layer - if(nSnow > 0)then ! snow layers exist - if(-dt*(scalarSnowSublimation/mLayerDepth(1))/iden_ice > mLayerVolFracIceTrial(1))then ! try again - message=trim(message)//'insufficient water to support converged surface sublimation rate' - err=-20; return ! negative error code means "try again" - endif ! if insufficient water for sublimation - endif ! if computing the veg flux - - + !print*, 'PAUSE: after iterations'; read(*,*) + ! ----- - ! * extract state variables for the start of the next time step... - ! ---------------------------------------------------------------- - - ! extract the vegetation states from the state vector - if(computeVegFlux)then - scalarCanairTemp = stateVecTrial(ixCasNrg) - scalarCanopyTemp = stateVecTrial(ixVegNrg) - scalarCanopyLiq = scalarCanopyLiqTrial - scalarCanopyIce = scalarCanopyIceTrial - endif - - ! extract state variables for the snow and soil domain - mLayerTemp(1:nLayers) = stateVecTrial(ixSnowSoilNrg) - mLayerMatricHead(1:nSoil) = stateVecTrial(ixSoilOnlyMat) - - ! save the volumetric liquid water and ice content - mLayerVolFracLiq = mLayerVolFracLiqTrial ! computed in updatState - mLayerVolFracIce = mLayerVolFracIceTrial ! computed in updatState - !print*, 'mLayerVolFracLiq = ', mLayerVolFracLiq - - ! ========================================================================================================================================== - ! ========================================================================================================================================== - ! ========================================================================================================================================== - ! ========================================================================================================================================== - - ! deallocate space for the state vectors etc. - deallocate(stateVecInit,stateVecTrial,stateVecNew,dMat,sMul,rAdd,fScale,xScale,fluxVec0,aJac,grad,rVec,rhs,iPiv,xInc,stat=err) - if(err/=0)then; err=20; message=trim(message)//'unable to deallocate space for the state/flux vectors and analytical Jacobian matrix'; return; endif - - ! deallocate space for the baseflow derivatives - if(ixGroundwater==qbaseTopmodel)then - deallocate(dBaseflow_dMatric,stat=err) - if(err/=0)then; err=20; message=trim(message)//'unable to deallocate space for the baseflow derivatives'; return; endif - endif - - ! deallocate space for the variables used to create the numerical Jacobian matrix - if(numericalJacobian)then - deallocate(fluxVec1,nJac,stat=err) - if(err/=0)then; err=20; message=trim(message)//'unable to allocate space for the flux vector and numerical Jacobian matrix'; return; endif - endif - - if(testBandDiagonal)then - deallocate(aJac_test,stat=err) - if(err/=0)then; err=20; message=trim(message)//'unable to allocate space for the band diagonal matrix'; return; endif - endif - - ! end associate statement - end associate - - contains - - - ! ********************************************************************************************************* - ! internal subroutine updatState: update model states - ! ********************************************************************************************************* - subroutine updatState(& - stateVecTrial, & ! intent(in): full state vector (mixed units) - mLayerVolFracLiqTrial, & ! intent(out): volumetric fraction of liquid water (-) - mLayerVolFracIceTrial, & ! intent(out): volumetric fraction of ice (-) - scalarCanopyLiqTrial, & ! intent(out): liquid water storage in the canopy (kg m-2) - scalarCanopyIceTrial, & ! intent(out): ice storage in the canopy (kg m-2) - err,message) ! intent(out): error code and error message - ! -------------------------------------------------------------- - implicit none - ! input - real(dp),intent(in) :: stateVecTrial(:) ! full model state vector (mixed units) - real(dp),intent(out) :: mLayerVolFracLiqTrial(:) ! volumetric fraction of liquid water (-) - real(dp),intent(out) :: mLayerVolFracIceTrial(:) ! volumetric fraction of ice (-) - real(dp),intent(out) :: scalarCanopyLiqTrial ! liquid water storage in the canopy (kg m-2) - real(dp),intent(out) :: scalarCanopyIceTrial ! ice storage in the canopy (kg m-2) - ! output - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! local - character(LEN=256) :: cmessage ! error message of downwind routine - real(dp),dimension(nSoil) :: mLayerPsiLiq ! liquid water matric potential (m) - ! initialize error control - err=0; message='updatState/' - - ! get the necessary variables from the data structures - associate(& - - ! layer type (snow or soil) - layerType => indx_data%var(iLookINDEX%layerType)%dat ,& ! intent(in): [i4b(:)] type of each layer in the snow+soil domain (snow or soil) - - ! layer depth - mLayerDepth => mvar_data%var(iLookMVAR%mLayerDepth)%dat ,& ! intent(in): [dp] depth of each layer (m) - - ! snow parameters - snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale) ,& ! intent(in): [dp] scaling parameter for the snow freezing curve (K-1) - - ! model state variables (vegetation canopy) - scalarCanopyIce => mvar_data%var(iLookMVAR%scalarCanopyIce)%dat(1) ,& ! intent(inout): [dp] mass of ice on the vegetation canopy (kg m-2) - scalarCanopyLiq => mvar_data%var(iLookMVAR%scalarCanopyLiq)%dat(1) ,& ! intent(inout): [dp] mass of liquid water on the vegetation canopy (kg m-2) - - ! soil parameters - vGn_alpha => mpar_data%var(iLookPARAM%vGn_alpha) ,& ! intent(in): [dp] van Genutchen "alpha" parameter (m-1) - vGn_n => mpar_data%var(iLookPARAM%vGn_n) ,& ! intent(in): [dp] van Genutchen "n" parameter (-) - vGn_m => mvar_data%var(iLookMVAR%scalarVGn_m)%dat(1) ,& ! intent(in): [dp] van Genutchen "m" parameter (-) - theta_sat => mpar_data%var(iLookPARAM%theta_sat) ,& ! intent(in): [dp] soil porosity (-) - theta_res => mpar_data%var(iLookPARAM%theta_res) & ! intent(in): [dp] soil residual volumetric water content (-) - ) - - ! update states for the vegetation canopy - if(computeVegFlux)then - fracLiqVeg = fracliquid(stateVecTrial(ixVegNrg),snowfrz_scale) ! fraction of liquid water (-) - totalWaterVeg = stateVecTrial(ixVegWat) ! total water (kg m-2) - scalarCanopyLiqTrial = fracLiqVeg*totalWaterVeg ! mass of liquid water on the canopy (kg m-2) - scalarCanopyIceTrial = (1._dp - fracLiqVeg)*totalWaterVeg ! mass of ice on the canopy (kg m-2) - !write(*,'(a,1x,10(f20.15,1x))') 'fracLiqVeg, totalWaterVeg, stateVecTrial(ixVegWat), scalarCanopyLiqTrial, scalarCanopyIceTrial = ', & - ! fracLiqVeg, totalWaterVeg, stateVecTrial(ixVegWat), scalarCanopyLiqTrial, scalarCanopyIceTrial - - ! ensure that states for the veg canopy are defined - else - scalarCanopyLiqTrial = scalarCanopyLiq - scalarCanopyIceTrial = scalarCanopyIce - endif - - ! loop through layers in the snow+soil sub-domain - do iLayer=1,nLayers - select case(layerType(iLayer)) - - !** snow - case(ix_snow) - ! update states - call updateSnow(& - ! input - stateVecTrial(ixSnowSoilNrg(iLayer)), & ! intent(in): layer temperature (K) - stateVecTrial(ixSnowSoilWat(iLayer)), & ! intent(in): volumetric fraction of total water (-) - snowfrz_scale, & ! intent(in): scaling parameter for the snow freezing curve (K-1) - ! output - mLayerVolFracLiqTrial(iLayer), & ! intent(out): volumetric fraction of liquid water (-) - mLayerVolFracIceTrial(iLayer), & ! intent(out): volumetric fraction of ice (-) - fracLiqSnow(iLayer), & ! intent(out): fraction of liquid water in each snow layer (-) - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (check for errors) - - !if(printflag .and. iLayer < 5)then - ! if(iLayer==1) write(*,'(a,1x)') 'iLayer, ixSnowOnlyWat(iLayer), mLayerDepth(iLayer), mLayerVolFracLiqTrial(iLayer), mLayerVolFracIceTrial(iLayer), stateVecTrial(ixSnowSoilNrg(iLayer)), stateVecTrial(ixSnowSoilWat(iLayer)) = ' - ! write(*,'(2(i4,1x),10(f20.10,1x))') iLayer, ixSnowOnlyWat(iLayer), mLayerDepth(iLayer), mLayerVolFracLiqTrial(iLayer), mLayerVolFracIceTrial(iLayer), stateVecTrial(ixSnowSoilNrg(iLayer)), stateVecTrial(ixSnowSoilWat(iLayer)) - !endif - - !** soil - case(ix_soil) - - !if(printflag)& - !write(*,'(a,1x,2(i4,1x),2(f20.10,1x))') 'iLayer, ixSnowSoilWat(iLayer), mLayerVolFracLiqTrial(iLayer), mLayerVolFracIceTrial(iLayer) = ', & - ! iLayer, ixSnowSoilWat(iLayer), mLayerVolFracLiqTrial(iLayer), mLayerVolFracIceTrial(iLayer) - - call updateSoil(& - ! input - stateVecTrial(ixSnowSoilNrg(iLayer)), & ! intent(in): layer temperature (K) - stateVecTrial(ixSoilOnlyMat(iLayer-nSnow)),& ! intent(in): matric head (m) - vGn_alpha,vGn_n,theta_sat,theta_res,vGn_m, & ! intent(in): van Genutchen soil parameters - ! output - mLayerPsiLiq(iLayer-nSnow), & ! intent(out): liquid water matric potential - mLayerVolFracLiqTrial(iLayer), & ! intent(out): volumetric fraction of liquid water (-) - mLayerVolFracIceTrial(iLayer), & ! intent(out): volumetric fraction of ice (-) - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (check for errors) - - !if(printFlag)& - !if(iLayer==1) write(*,'(a)') 'stateVecTrial(ixSnowSoilNrg(iLayer)), stateVecTrial(ixSoilOnlyMat(iLayer-nSnow)), mLayerPsiLiq(iLayer-nSnow), mLayerVolFracLiqTrial(iLayer), mLayerVolFracIceTrial(iLayer) = ' - !write(*,'(i4,1x,10(f20.10,1x))') iLayer, stateVecTrial(ixSnowSoilNrg(iLayer)), stateVecTrial(ixSoilOnlyMat(iLayer-nSnow)), mLayerPsiLiq(iLayer-nSnow), mLayerVolFracLiqTrial(iLayer), mLayerVolFracIceTrial(iLayer) - - !** check errors - case default; err=40; message=trim(message)//"cannot identify the layer as snow or soil"; return - - endselect ! identifying type of layer - - ! sanity check - if(mLayerVolFracIceTrial(iLayer) < -tiny(theta_sat))then - write(message,'(a,i0,a,e20.10,a)')trim(message)//"volumetric ice content < 0; iLayer=",iLayer,"; mLayerVolFracIce =",mLayerVolFracIceTrial(iLayer),"]" - err=10; return - endif - - end do ! looping through layers - - ! end association to the variables in the data structures - end associate - - end subroutine updatState - - - ! ********************************************************************************************************* - ! internal subroutine xFluxResid: compute fluxes and the residual - ! ********************************************************************************************************* - subroutine xFluxResid(& - ! input - stateVec, & ! intent(in): full state vector (mixed units) - scalarCanopyLiqLocal, & ! intent(in): trial value for the liquid water on the vegetation canopy (kg m-2) - scalarCanopyIceLocal, & ! intent(in): trial value for the ice on the vegetation canopy (kg m-2) - mLayerVolFracLiqLocal, & ! intent(in): trial value for the volumetric liquid water content in each snow and soil layer (-) - mLayerVolFracIceLocal, & ! intent(in): trial value for the volumetric ice in each snow and soil layer (-) - ! output - fVec, & ! intent(out): flux vector (mixed units) - rVec, & ! intent(out): residual vector (mixed units) - err,message) ! intent(out): error code and error message - ! -------------------------------------------------------------- - implicit none - ! input variables - real(dp),intent(in) :: stateVec(:) ! model state vector (mixed units) - real(dp),intent(in) :: scalarCanopyLiqLocal ! trial value for mass of liquid water on the vegetation canopy (kg m-2) - real(dp),intent(in) :: scalarCanopyIceLocal ! trial value for mass of ice on the vegetation canopy (kg m-2) - real(dp),intent(in) :: mLayerVolFracLiqLocal(:) ! trial value for volumetric fraction of liquid water (-) - real(dp),intent(in) :: mLayerVolFracIceLocal(:) ! trial value for volumetric fraction of ice (-) - ! output variabes - real(dp),intent(out) :: fVec(:) ! flux vector (mixed units) - real(qp),intent(out) :: rVec(:) ! residual vector (mixed units) - 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 - ! trial state variables (vegetation canopy) - real(dp) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) - real(dp) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) - real(dp) :: scalarCanopyWatTrial ! trial value for mass of total water on the vegetation canopy (kg m-2) - ! trial state variables (snow and soil domains) - real(dp),dimension(nLayers) :: mLayerTempTrial ! trial value for temperature of each snow/soil layer (K) - real(dp),dimension(nSnow) :: mLayerVolFracWatTrial ! trial value for volumetric fraction of total water (-) - real(dp),dimension(nSoil) :: mLayerMatricHeadTrial ! trial value for matric head (m) - ! temporary vectors for the soil sub-domain - real(dp),dimension(nSoil) :: vThetaInit ! liquid equivalent of total water at the start of the step - real(dp),dimension(nSoil) :: vThetaTrial ! liquid equivalent of total water at the current iteration - ! variables for testing - real(dp) :: xCompress ! compression in a given layer (m) - real(dp) :: xFlux0,xFlux1 ! fluxes at the layer boundaries (m) - real(dp) :: xBalance ! water balance (m) - real(dp) :: xTotSink ! total water sink (m) - real(dp) :: xTotFlux ! total water flux (m) - ! initialize error control - err=0; message='xFluxResid/' - - ! ----- - ! * associate desired variables from data structures... - ! ----------------------------------------------------- - associate(& - ! model decisions - ixRichards => model_decisions(iLookDECISIONS%f_Richards)%iDecision ,& ! intent(in): [i4b] index of the form of Richards' equation - - ! soil parameters - vGn_alpha => mpar_data%var(iLookPARAM%vGn_alpha) ,& ! intent(in): [dp] van Genutchen "alpha" parameter (m-1) - vGn_n => mpar_data%var(iLookPARAM%vGn_n) ,& ! intent(in): [dp] van Genutchen "n" parameter (-) - vGn_m => mvar_data%var(iLookMVAR%scalarVGn_m)%dat(1) ,& ! intent(in): [dp] van Genutchen "m" parameter (-) - theta_sat => mpar_data%var(iLookPARAM%theta_sat) ,& ! intent(in): [dp] soil porosity (-) - theta_res => mpar_data%var(iLookPARAM%theta_res) ,& ! intent(in): [dp] soil residual volumetric water content (-) - specificStorage => mpar_data%var(iLookPARAM%specificStorage) ,& ! intent(in): [dp] specific storage coefficient (m-1) - - ! layer depth - mLayerDepth => mvar_data%var(iLookMVAR%mLayerDepth)%dat ,& ! intent(in): [dp(:)] depth of each layer in the snow-soil sub-domain (m) - - ! model fluxes - mLayerBaseflow => mvar_data%var(iLookMVAR%mLayerBaseflow)%dat, & ! intent(out): [dp(:)] baseflow from each soil layer (m s-1) - mLayerCompress => mvar_data%var(iLookMVAR%mLayerCompress)%dat, & ! intent(out): [dp(:)] change in storage associated with compression of the soil matrix (-) - scalarSoilCompress => mvar_data%var(iLookMVAR%scalarSoilCompress)%dat(1), & ! intent(out): [dp] total change in storage associated with compression of the soil matrix (kg m-2) - iLayerLiqFluxSoil => mvar_data%var(iLookMVAR%iLayerLiqFluxSoil)%dat, & ! intent(out): [dp] liquid soil fluxes (m s-1) - - ! model state variables (vegetation canopy) - scalarCanairTemp => mvar_data%var(iLookMVAR%scalarCanairTemp)%dat(1) ,& ! intent(inout): [dp] temperature of the canopy air space (K) - scalarCanopyTemp => mvar_data%var(iLookMVAR%scalarCanopyTemp)%dat(1) ,& ! intent(inout): [dp] temperature of the vegetation canopy (K) - scalarCanopyIce => mvar_data%var(iLookMVAR%scalarCanopyIce)%dat(1) ,& ! intent(inout): [dp] mass of ice on the vegetation canopy (kg m-2) - scalarCanopyLiq => mvar_data%var(iLookMVAR%scalarCanopyLiq)%dat(1) ,& ! intent(inout): [dp] mass of liquid water on the vegetation canopy (kg m-2) - - ! model state variables (snow and soil domains) - mLayerTemp => mvar_data%var(iLookMVAR%mLayerTemp)%dat ,& ! intent(inout): [dp(:)] temperature of each snow/soil layer (K) - mLayerVolFracIce => mvar_data%var(iLookMVAR%mLayerVolFracIce)%dat ,& ! intent(inout): [dp(:)] volumetric fraction of ice (-) - mLayerVolFracLiq => mvar_data%var(iLookMVAR%mLayerVolFracLiq)%dat ,& ! intent(inout): [dp(:)] volumetric fraction of liquid water (-) - mLayerMatricHead => mvar_data%var(iLookMVAR%mLayerMatricHead)%dat ,& ! intent(inout): [dp(:)] matric head (m) - scalarAquiferStorage => mvar_data%var(iLookMVAR%scalarAquiferStorage)%dat(1) & ! intent(inout): [dp ] aquifer storage (m) - ) - - ! ----- - ! * compute model fluxes... - ! ------------------------- - - ! NOTE: Need to increase cleverness and avoid copying vectors - ! --> can we do this as an associate statement? - - ! extract the vegetation states from the state vector - if(computeVegFlux)then - scalarCanairTempTrial = stateVec(ixCasNrg) - scalarCanopyTempTrial = stateVec(ixVegNrg) - scalarCanopyWatTrial = stateVec(ixVegWat) - - ! ensure that input values to flux routines are defined - else - scalarCanairTempTrial = scalarCanairTemp - scalarCanopyTempTrial = scalarCanopyTemp - scalarCanopyWatTrial = scalarCanopyIce + scalarCanopyLiq + ! * update states... + ! ------------------ + + ! special case of explicit Euler + if(explicitEuler)then + + ! --> check feasibility + if(.not.feasible)then + message=trim(message)//'state is not feasible in explicit Euler (reduce time step)' + err=-20; return endif - ! extract state variables for the snow and soil domain - mLayerTempTrial(1:nLayers) = stateVec(ixSnowSoilNrg) - mLayerMatricHeadTrial(1:nSoil) = stateVec(ixSoilOnlyMat) - if(nSnow>0)& - mLayerVolFracWatTrial(1:nSnow) = stateVec(ixSnowOnlyWat) - ! (test) - !if(printFlag)then - ! write(*,'(a,1x,f20.10)') 'iden_water*mLayerVolFracWatTrial(1:nSnow)*mLayerDepth(1:nSnow) = ', & - ! iden_water*mLayerVolFracWatTrial(1:nSnow)*mLayerDepth(1:nSnow) - !endif - - ! compute model flux for a given state vector - call computFlux(& - ! 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) - mLayerMatricHeadTrial, & ! intent(in): trial value for the matric head in each soil layer (m) - ! input: diagnostic variables defining the liquid water and ice content - scalarCanopyLiqLocal, & ! intent(in): trial value for the liquid water on the vegetation canopy (kg m-2) - scalarCanopyIceLocal, & ! intent(in): trial value for the ice on the vegetation canopy (kg m-2) - mLayerVolFracLiqLocal, & ! intent(in): trial value for the volumetric liquid water content in each snow and soil layer (-) - mLayerVolFracIceLocal, & ! intent(in): trial value for the volumetric ice in each snow and soil layer (-) - ! output: flux vector - fVec, & ! 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; endif ! (check for errors) - - !if(printFlag)then - !write(*,'(a,1x,100(e25.15,1x))') 'mLayerVolFracLiqLocal(1), mLayerVolFracLiqLocal(1) - mLayerVolFracLiq(1) = ', mLayerVolFracLiqLocal(1), mLayerVolFracLiqLocal(1) - mLayerVolFracLiq(1) - !write(*,'(a,1x,100(e25.15,1x))') 'mLayerVolFracIceLocal(1), mLayerVolFracIceLocal(1) - mLayerVolFracIce(1) = ', mLayerVolFracIceLocal(1), (mLayerVolFracIceLocal(1) - mLayerVolFracIce(1))*(iden_ice/iden_water) - !write(*,'(a,1x,100(e25.15,1x))') 'mLayerMatricHeadTrial = ', mLayerMatricHeadTrial - !write(*,'(a,1x,10(e15.5,1x))') 'mLayerMatricHeadTrial(1:13) = ', mLayerMatricHeadTrial(1:13) - !write(*,'(a,1x,10(e15.5,1x))') 'fVec(ixSnowSoilNrg) = ', fVec(ixSnowSoilNrg) - !write(*,'(a,1x,10(e15.5,1x))') 'fVec(ixSnowSoilWat) = ', fVec(ixSnowSoilWat) - !endif - - ! 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 - 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) - mLayerVolFracLiqLocal(nSnow+1:nLayers), & ! intent(in): trial value for the volumetric liquid water content in each soil layer (-) - mLayerVolFracIceLocal(nSnow+1:nLayers), & ! intent(in): trial value for the volumetric ice content in each soil layer (-) - dVolTot_dPsi0, & ! intent(in): derivative in the soil water characteristic (m-1) - specificStorage, & ! intent(in): specific storage coefficient (m-1) - theta_sat, & ! intent(in): soil porosity (-) - ! output: - mLayerCompress, & ! intent(out): compressibility of the soil matrix (-) - dCompress_dPsi, & ! intent(out): derivative in compressibility w.r.t. matric head (m-1) - err,cmessage) ! intent(out): error code and error message + ! --> compute the RHS fluxes and conversion factor + call rhsFluxes(indx_data,deriv_data,sMul,fluxVecNew,resSinkNew/dt, & ! intent(in) : state indices and derivatives, and the state vector multiplier + cf1,rhsFlux1,err,cmessage) ! intent(out) : conversion factor, and error control if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (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 - !print*, 'scalarSoilCompress = ', scalarSoilCompress + ! --> compute state vector update + stateVecUpdate = 0.5_dp*( dt*fluxVec0/cf0 + dt*fluxVecNew/cf1 ) - ! ----- - ! * compute residual vector... - ! ---------------------------- - - !write(*,'(a,1x,10(f25.15,1x))') 'scalarCanopyLiqLocal - scalarCanopyLiq = ', scalarCanopyLiqLocal - scalarCanopyLiq - !write(*,'(a,1x,10(f25.15,1x))') 'scalarCanopyIceLocal - scalarCanopyIce = ', scalarCanopyIceLocal - scalarCanopyIce - !write(*,'(a,1x,10(f25.15,1x))') 'change in energy (J m-3) = ', LH_fus*(scalarCanopyIceLocal - scalarCanopyIce)/canopyDepth ! J m-3 - - ! intialize additional terms on the RHS as zero - rAdd(:) = 0._dp + ! compute melt energy for the explicit Euler method + call explicitMelt(dt,indx_data,diag_data,prog_data, & ! intent(in) : time step and data structures + 0.5_dp*(fluxVec0 + fluxVecNew),sMul, & ! intent(in) : total flux, and state vector multipler + stateVecUpdate, & ! intent(inout) : state vector update (modified if ice cannot support melt) + untappedMelt, & ! intent(out) : untapped melt energy (J m-3 s-1) + tooMuchMelt, & ! intent(out) : flag to denote that ice is insufficient to support available melt + err,cmessage) ! intent(out) : error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (check for errors) - ! compute energy associated with melt freeze for the vegetation canopy - if(computeVegFlux)then - rAdd(ixVegNrg) = rAdd(ixVegNrg) + LH_fus*(scalarCanopyIceLocal - scalarCanopyIce)/canopyDepth ! energy associated with melt/freeze (J m-3) - !if(printFlag)then - ! print*, 'rAdd(ixVegNrg), scalarCanopyIceLocal, scalarCanopyIce = ', rAdd(ixVegNrg), scalarCanopyIceLocal, scalarCanopyIce - ! pause - !endif + ! if too much melt 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)then + reduceCoupledStep=.true. + return endif - ! compute energy associated with melt/freeze for snow - if(nSnow>0)& - rAdd(ixSnowOnlyNrg) = rAdd(ixSnowOnlyNrg) + LH_fus*iden_ice*(mLayerVolFracIceLocal(1:nSnow) - mLayerVolFracIce(1:nSnow)) ! energy associated with melt/freeze (J m-3) - if(printFlag)then - !write(*,'(a,1x,10(e20.10,1x))') 'rAdd(ixSnowOnlyNrg) = ', rAdd(ixSnowOnlyNrg) - !write(*,'(a,1x,10(e20.10,1x))') 'mLayerVolFracIce(1:5) = ', mLayerVolFracIce(1:5) - !write(*,'(a,1x,10(e20.10,1x))') 'mLayerVolFracIceLocal(1:5) = ', mLayerVolFracIceLocal(1:5) - !write(*,'(a,1x,10(e20.10,1x))') 'delIce = ', mLayerVolFracIceLocal(1:5) - mLayerVolFracIce(1:5) - endif + ! --> update states using the explicit Euler method + call explicitUpdate(indx_data,mpar_data,prog_data, & ! intent(in) : indices, parameters, prognostic variables + stateVecInit,stateVecUpdate,stateVecTrial,& ! intent(in) : initial state vector, state update, and new state vector + stateConstrained,err,cmessage) ! intent(out) : flag for state contraint, and error control + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (check for errors) - ! compute energy associated with melt/freeze for soil - rAdd(ixSoilOnlyNrg) = rAdd(ixSoilOnlyNrg) + LH_fus*iden_water*(mLayerVolFracIceLocal(nSnow+1:nLayers) - mLayerVolFracIce(nSnow+1:nLayers)) ! energy associated with melt/freeze (J m-3) - !if(printFlag)then - ! write(*,'(a,1x,10(e30.15,1x))') 'vIce01 = ', mLayerVolFracIce(nSnow+1:nLayers) - ! write(*,'(a,1x,10(e30.15,1x))') 'vIce02 = ', mLayerVolFracIceLocal(nSnow+1:nLayers) - ! write(*,'(a,1x,10(e15.5,1x))') 'delIce = ', mLayerVolFracIceLocal(nSnow+1:nLayers) - mLayerVolFracIce(nSnow+1:nLayers) - ! write(*,'(a,1x,10(e15.5,1x))') 'delNrg = ', LH_fus*iden_water*(mLayerVolFracIceLocal(nSnow+1:nLayers) - mLayerVolFracIce(nSnow+1:nLayers)) - ! print*, 'precision(mLayerVolFracIce) = ', precision(mLayerVolFracIce) - !endif - - ! sink terms (-) - ! NOTE: state variable is volumetric water content, so melt-freeze is not included - ! NOTE: ground evaporation was already included in the flux at the upper boundary - !print*, 'mLayerTranspire(1:nSoil) = ', mLayerTranspire(1:nSoil) - !print*, 'mLayerBaseflow(1:nSoil) = ', mLayerBaseflow(1:nSoil) - !print*, 'mLayerCompress(1:nSoil) = ', mLayerCompress(1:nSoil) - - !mLayerCompress(:) = 0._dp - !mLayerTranspire(:) = 0._dp - !mLayerBaseflow(:) = 0._dp - rAdd(ixSoilOnlyMat) = rAdd(ixSoilOnlyMat) + dt*(mLayerTranspire(1:nSoil) - mLayerBaseflow(1:nSoil) )/mLayerDepth(nSnow+1:nLayers) - mLayerCompress(1:nSoil) - !print*, 'rAdd(ixSoilOnlyMat) = ', rAdd(ixSoilOnlyMat) - - ! liquid water equivalent of melt/freeze for snow layers (-) - ! NOTE: state equation for soil is based on the total equivalent liquid water content (liquid plus ice) - !if(nSnow>0)& - !rAdd(ixSnowOnlyWat) = rAdd(ixSnowOnlyWat) - (iden_ice/iden_water)*(mLayerVolFracIceLocal(1:nSnow) - mLayerVolFracIce(1:nSnow)) ! liquid water equivalent of melt/freeze (-) - !if(printFlag)then - ! write(*,'(a,1x,10(e20.10,1x))') 'rAdd(ixSnowOnlyWat) = ', rAdd(ixSnowOnlyWat) - !endif - - ! compute the residual vector for the vegetation canopy - ! NOTE: sMul(ixVegWat) = 1, but include as it converts all variables to quadruple precision - if(computeVegFlux)then - ! --> energy balance - rVec(ixCasNrg) = sMul(ixCasNrg)*scalarCanairTempTrial - ( (sMul(ixCasNrg)*scalarCanairTemp + fVec(ixCasNrg)*dt) + rAdd(ixCasNrg) ) - rVec(ixVegNrg) = sMul(ixVegNrg)*scalarCanopyTempTrial - ( (sMul(ixVegNrg)*scalarCanopyTemp + fVec(ixVegNrg)*dt) + rAdd(ixVegNrg) ) - ! --> mass balance - rVec(ixVegWat) = sMul(ixVegWat)*scalarCanopyWatTrial - ( (sMul(ixVegWat)*scalarCanopyWat + fVec(ixVegWat)*dt) + rAdd(ixVegWat) ) - endif - !write(*,'(a,1x,2(e20.10,1x))') 'rVec(ixVegWat), fVec(ixVegWat) = ', rVec(ixVegWat), fVec(ixVegWat) - - ! compute the residual vector for the snow and soil sub-domains for energy - !rAdd(ixSnowSoilNrg) = 0._dp - !fVec(ixSnowSoilNrg) = 0._dp - !print*, 'fVec(ixSnowSoilNrg) = ', fVec(ixSnowSoilNrg) - rVec(ixSnowSoilNrg) = sMul(ixSnowSoilNrg)*mLayerTempTrial(1:nLayers) - ( (sMul(ixSnowSoilNrg)*mLayerTemp(1:nLayers) + fVec(ixSnowSoilNrg)*dt) + rAdd(ixSnowSoilNrg) ) - !if(printFlag)then - ! write(*,'(a,1x,10(e25.15,1x))') 'fVec(1:2)*dt = ', fVec(1:2)*dt - ! write(*,'(a,1x,10(e20.10,1x))') 'rAdd(1:8) = ', rAdd(1:8) - !endif - - !if(printFlag)then - ! do iLayer=nSnow+1,nLayers - ! jLayer = ixSnowSoilNrg(iLayer) - ! write(*,'(a,1x,2(i4,1x),10(e20.10,1x))') 'iLayer, jLayer, fVec(jLayer), sMul(jLayer), rAdd(jLayer), rVec(jLayer), mLayerVolFracIceLocal(iLayer) = ', & - ! iLayer, jLayer, fVec(jLayer), sMul(jLayer), rAdd(jLayer), rVec(jLayer), mLayerVolFracIceLocal(iLayer) - ! end do - !endif - - ! compute the residual vector for the **snow** sub-domain for liquid water - if(nSnow>0)& - rVec(ixSnowOnlyWat) = mLayerVolFracWatTrial(1:nSnow) - ( (mLayerVolFracWat(1:nSnow) + fVec(ixSnowOnlyWat)*dt) + rAdd(ixSnowOnlyWat) ) - !if(printFlag)then - ! do iLayer=1,min(nSnow,5) - ! jLayer = ixSnowOnlyWat(iLayer) - ! write(*,'(a,1x,2(i4,1x),10(e20.10,1x))') 'iLayer, jLayer, fVec(jLayer), sMul(jLayer), rAdd(jLayer), rVec(jLayer), mLayerVolFracIceLocal(iLayer) = ', & - ! iLayer, jLayer, fVec(jLayer), sMul(jLayer), rAdd(jLayer), rVec(jLayer), mLayerVolFracIceLocal(iLayer) - ! end do - !endif - - ! compute the residual vector for the **soil** sub-domain for liquid water - !fVec(ixSoilOnlyMat) = 0._dp - vThetaInit(1:nSoil) = mLayerVolFracLiq(nSnow+1:nLayers) + mLayerVolFracIce(nSnow+1:nLayers) ! liquid equivalent of total water at the start of the step - vThetaTrial(1:nSoil) = mLayerVolFracLiqLocal(nSnow+1:nLayers) + mLayerVolFracIceLocal(nSnow+1:nLayers) ! liquid equivalent of total water at the current iteration - rVec(ixSoilOnlyMat) = vThetaTrial(1:nSoil) - ( (vThetaInit(1:nSoil) + fVec(ixSoilOnlyMat)*dt) + rAdd(ixSoilOnlyMat) ) - - ! compute the soil water balance error (m) - ! NOTE: declared in the main routine so accessible in all internal routines - soilWaterBalanceError = abs( sum(real(rVec(ixSoilOnlyMat), dp)*mLayerDepth(nSnow+1:nSoil)) ) - - !if(printFlag)then - ! write(*,'(a,1x,10(e20.10,1x))') 'vThetaInit(1:nSoil) = ', vThetaInit(1:nSoil) - ! write(*,'(a,1x,10(e20.10,1x))') 'vThetaTrial(1:nSoil) = ', vThetaTrial(1:nSoil) - ! write(*,'(a,1x,10(e20.10,1x))') 'fVec(ixSnowSoilWat) = ', fVec(ixSnowSoilWat) - ! write(*,'(a,1x,10(e20.10,1x))') 'rAdd(ixSnowSoilWat) = ', rAdd(ixSnowSoilWat) - ! write(*,'(a,1x,10(e20.10,1x))') 'rVec(ixSnowSoilWat) = ', rVec(ixSnowSoilWat) - !endif - - ! test - !write(*,'(a,1x,10(e15.5,1x))') 'rVec(1:10) = ', rVec(1:10) - !write(*,'(a,1x,10(e15.5,1x))') 'rAdd(1:10) = ', rAdd(1:10) - !write(*,'(a,1x,10(e15.5,1x))') 'fVec(1:10) = ', fVec(1:10) - - !print*, '***' - !write(*,'(a,1x,10(e15.5,1x))') 'mLayerVolFracLiqTrial(1:10) = ', mLayerVolFracLiqTrial(1:10) - - ! end association to variables in the data structures - end associate - - end subroutine xFluxResid - - - ! ********************************************************************************************************* - ! internal subroutine computFlux: compute model fluxes - ! ********************************************************************************************************* - subroutine computFlux(& - ! 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) - mLayerMatricHeadTrial, & ! intent(in): trial value for the matric head in each soil layer (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 (-) - ! output: flux vector - fluxVec, & ! intent(out): flux vector (mixed units) - ! output: error control - err,message) ! intent(out): error code and error message - implicit none - ! --------------------------------------------------------------------------------------- - ! * dummy variables - ! --------------------------------------------------------------------------------------- - ! input: state variables - real(dp),intent(in) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) - real(dp),intent(in) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) - real(dp),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) - real(dp),intent(in) :: mLayerMatricHeadTrial(:) ! trial value for matric head (m) - ! input: diagnostic variables - real(dp),intent(in) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) - real(dp),intent(in) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) - real(dp),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) - real(dp),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) - ! output: flux vector - real(dp),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) :: iSoil ! index of soil layer - character(LEN=256) :: cmessage ! error message of downwind routine - real(dp),parameter :: canopyTempMax=500._dp ! expected maximum value for the canopy temperature (K) - real(dp) :: xNum ! temporary variable: numerator - real(dp) :: xDen ! temporary variable: denominator - real(dp) :: effSat ! effective saturation of the soil matrix (-) - real(dp),dimension(nSoil) :: mLayerMatricHeadLiq ! matric head associated with liquid water (m), f(psi0, T) - real(dp) :: dPsiLiq_dEffSat ! derivative in liquid water matric potential w.r.t. effective saturation (m) - real(dp) :: dEffSat_dVolTot ! derivative in effective saturation w.r.t. total water content (-) - real(dp) :: dEffSat_dTemp ! derivative in effective saturation w.r.t. temperature (K-1) - real(dp),dimension(nSoil) :: dPsiLiq_dPsi0 ! derivative in the liquid water matric potential w.r.t. the total water matric potential (-) - !real(dp) :: vTheta1,volIce1,effSat1,psiLiq1 ! test derivatives (-) - ! -------------------------------------------------------------- - ! initialize error control - err=0; message='computFlux/' - - ! ***** - ! (0) PRELIMINARIES... - ! ******************** - - ! get the necessary variables for the flux computations - associate(& - - ! 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 => mvar_data%var(iLookMVAR%scalarRainfall)%dat(1) ,& ! intent(in): [dp] rainfall rate (kg m-2 s-1) - scalarSfcMeltPond => mvar_data%var(iLookMVAR%scalarSfcMeltPond)%dat(1) ,& ! intent(in): [dp] ponded water caused by melt of the "snow without a layer" (kg m-2) - - ! layer type (snow or soil) - layerType => indx_data%var(iLookINDEX%layerType)%dat ,& ! intent(in): [i4b(:)] type of each layer in the snow+soil domain (snow or soil) - - ! layer depth - mLayerDepth => mvar_data%var(iLookMVAR%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) ,& ! intent(in): [dp] scaling parameter for the snow freezing curve (K-1) - - ! soil parameters - vGn_alpha => mpar_data%var(iLookPARAM%vGn_alpha) ,& ! intent(in): [dp] van Genutchen "alpha" parameter (m-1) - vGn_n => mpar_data%var(iLookPARAM%vGn_n) ,& ! intent(in): [dp] van Genutchen "n" parameter (-) - vGn_m => mvar_data%var(iLookMVAR%scalarVGn_m)%dat(1) ,& ! intent(in): [dp] van Genutchen "m" parameter (-) - theta_sat => mpar_data%var(iLookPARAM%theta_sat) ,& ! intent(in): [dp] soil porosity (-) - theta_res => mpar_data%var(iLookPARAM%theta_res) ,& ! intent(in): [dp] soil residual volumetric water content (-) - - ! model diagnostic variables - scalarThroughfallRain => mvar_data%var(iLookMVAR%scalarThroughfallRain)%dat(1) ,& ! intent(out): [dp] rain that reaches the ground without ever touching the canopy (kg m-2 s-1) - scalarCanopyLiqDrainage => mvar_data%var(iLookMVAR%scalarCanopyLiqDrainage)%dat(1),& ! intent(out): [dp] drainage of liquid water from the vegetation canopy (kg m-2 s-1) - scalarSurfaceRunoff => mvar_data%var(iLookMVAR%scalarSurfaceRunoff)%dat(1) ,& ! intent(out): [dp] surface runoff (m s-1) - scalarRainPlusMelt => mvar_data%var(iLookMVAR%scalarRainPlusMelt)%dat(1) ,& ! intent(out): [dp] rain plus melt (m s-1) - scalarExfiltration => mvar_data%var(iLookMVAR%scalarExfiltration)%dat(1) ,& ! intent(out): [dp] exfiltration from the soil profile (m s-1) - mLayerColumnOutflow => mvar_data%var(iLookMVAR%mLayerColumnOutflow)%dat ,& ! intent(out): [dp(:)] column outflow from each soil layer (m3 s-1) - - ! soil fluxes - iLayerLiqFluxSnow => mvar_data%var(iLookMVAR%iLayerLiqFluxSnow)%dat ,& ! intent(out): [dp(0:)] vertical liquid water flux at snow layer interfaces (-) - iLayerLiqFluxSoil => mvar_data%var(iLookMVAR%iLayerLiqFluxSoil)%dat ,& ! intent(out): [dp(0:)] vertical liquid water flux at soil layer interfaces (-) - mLayerBaseflow => mvar_data%var(iLookMVAR%mLayerBaseflow)%dat ,& ! intent(out): [dp(:)] baseflow from each soil layer (m s-1) - - ! aquifer fluxes - scalarAquiferTranspire => mvar_data%var(iLookMVAR%scalarAquiferTranspire)%dat(1) ,& ! intent(out): [dp] transpiration loss from the aquifer (m s-1 - scalarAquiferRecharge => mvar_data%var(iLookMVAR%scalarAquiferRecharge)%dat(1) ,& ! intent(out): [dp] recharge to the aquifer (m s-1) - scalarAquiferBaseflow => mvar_data%var(iLookMVAR%scalarAquiferBaseflow)%dat(1) & ! intent(out): [dp] total baseflow from the aquifer (m s-1) - - ) ! association to data in structures - - ! check that canopy temperature is reasonable - if(scalarCanopyTempTrial > canopyTempMax)then - print*, 'scalarCanopyTempTrial = ', scalarCanopyTempTrial - message=trim(message)//'canopy temperature is > expected maximum' - err=20; return - endif + ! --> estimate the solution error + ! NOTE: done before the constraints check to return the error + solutionError(:) = abs(fluxVec0*dt - cf1*stateVecUpdate) + errorTemp = maxval(solutionError) + explicitError = max(errorTemp(1), verySmall) - ! * vegetation domain: compute derivative of volumetric liquid water content w.r.t. temperature (K-1) - if(computeVegFlux)then - if(scalarCanopyIceTrial > verySmall)then - theta = (scalarCanopyIceTrial + scalarCanopyLiqTrial)/(canopyDepth*iden_water) - dTheta_dTkCanopy = dFracLiq_dTk(scalarCanopyTempTrial,snowfrz_scale)*theta ! K-1 - dCanLiq_dTcanopy = dTheta_dTkCanopy*iden_water*canopyDepth ! kg m-2 K-1 - else - dTheta_dTkCanopy = 0._dp - dCanLiq_dTcanopy = 0._dp - endif + ! print progress in the explicit Euler solution + if(globalPrintFlag)then + write(*,'(a,1x,10(f20.12,1x))') 'cf0 = ', cf0 ( min(nState,iJac1) : min(nState,iJac2) ) + write(*,'(a,1x,10(f20.12,1x))') 'cf1 = ', cf1 ( min(nState,iJac1) : min(nState,iJac2) ) + write(*,'(a,1x,10(f20.12,1x))') 'fluxVec0 = ', fluxVec0 ( min(nState,iJac1) : min(nState,iJac2) ) + write(*,'(a,1x,10(f20.12,1x))') 'fluxVecNew = ', fluxVecNew ( min(nState,iJac1) : min(nState,iJac2) ) + write(*,'(a,1x,10(f20.12,1x))') 'rAdd = ', rAdd ( min(nState,iJac1) : min(nState,iJac2) ) + write(*,'(a,1x,10(f20.12,1x))') 'resSinkNew = ', resSinkNew ( min(nState,iJac1) : min(nState,iJac2) ) + write(*,'(a,1x,10(f20.12,1x))') 'stateVecInit = ', stateVecInit ( min(nState,iJac1) : min(nState,iJac2) ) + write(*,'(a,1x,10(f20.12,1x))') 'stateVecTrial = ', stateVecTrial ( min(nState,iJac1) : min(nState,iJac2) ) + write(*,'(a,1x,10(f20.12,1x))') 'stateVecNew = ', stateVecNew ( min(nState,iJac1) : min(nState,iJac2) ) + write(*,'(a,1x,10(f20.12,1x))') 'solutionError = ', solutionError ( min(nState,iJac1) : min(nState,iJac2) ) + print*, 'dt = ', dt + !print*, 'PAUSE: checking state vector for the explicit Euler solution'; read(*,*) + endif ! (if printing) + + + + ! check if the state is constrained + if(stateConstrained)then + message=trim(message)//'state is constrained in explicit Heun (reduce time step)' + err=-20; return endif - ! * snow+soil domain: compute derivative of volumetric liquid water content w.r.t. temperature (K-1) - do iLayer=1,nLayers ! loop through all snow and soil layers - select case(layerType(iLayer)) - case(ix_snow) ! (snow layers) - theta = mLayerVolFracIceTrial(iLayer)*(iden_ice/iden_water) + mLayerVolFracLiqTrial(iLayer) - mLayerdTheta_dTk(iLayer) = dFracLiq_dTk(mLayerTempTrial(iLayer),snowfrz_scale)*theta - ! compute numerical derivative (testing) - !if(printFlag .and. iLayer==1)then - ! fLiq0 = fracliquid(mLayerTempTrial(iLayer),snowfrz_scale) - ! fLiq1 = fracliquid(mLayerTempTrial(iLayer)+dx,snowfrz_scale) - ! print*, 'testderivative', (fLiq1*theta - fLiq0*theta)/dx, mLayerdTheta_dTk(iLayer) - !endif - case(ix_soil) ! (soil layers) - if(mLayerVolFracIceTrial(iLayer)>verySmall)then - mLayerdTheta_dTk(iLayer) = dTheta_dTk(mLayerTempTrial(iLayer),theta_res,theta_sat,vGn_alpha,vGn_n,vGn_m) ! assume no volume expansion - else - mLayerdTheta_dTk(iLayer) = 0._dp - endif - case default; err=40; message=trim(message)//"cannot identify the layer as snow or soil"; return - endselect - ! (check) - !if(printFlag .and. iLayer==58)& - !write(*,'(a,1x,i4,1x,2(f20.10,1x))') 'mLayerdTheta_dTk(iLayer) = ', iLayer, mLayerVolFracIceTrial(iLayer), mLayerdTheta_dTk(iLayer) - end do ! (looping through snow+soil layers) - - ! * compute the matric head associated with liquid water - do iSoil=1,nSoil ! loop through soil layers - - ! - compute derivative in total water content w.r.t. total water matric potential (m-1) - dVolTot_dPsi0(iSoil) = dTheta_dPsi(mLayerMatricHeadTrial(iSoil),vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) ! valid for both frozen and unfrozen conditions - !if(printFlag.and.iSoil<5) print*, 'iSoil, dVolTot_dPsi0 = ', iSoil, dVolTot_dPsi0(iSoil) - !if(printFlag.and.iSoil<5) print*, 'mLayerVolFracIceTrial(nSnow+iSoil), mLayerVolFracLiqTrial(nSnow+iSoil) = ', mLayerVolFracIceTrial(nSnow+iSoil), mLayerVolFracLiqTrial(nSnow+iSoil) - - ! ** partially frozen soil - if(mLayerVolFracIceTrial(nSnow+iSoil) > verySmall .and. mLayerMatricHeadTrial(iSoil) < 0._dp)then ! check that ice exists and that the soil is unsaturated - ! - 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 = mLayerVolFracLiqTrial(nSnow+iSoil) - theta_res - xDen = theta_sat - mLayerVolFracIceTrial(nSnow+iSoil) - theta_res - effSat = xNum/xDen ! effective saturation - ! - matric head associated with liquid water - mLayerMatricHeadLiq(iSoil) = matricHead(effSat,vGn_alpha,0._dp,1._dp,vGn_n,vGn_m) ! argument is effective saturation, so theta_res=0 and theta_sat=1 - !if(printFlag) print*, 'mLayerMatricHeadLiq(iSoil) = ', mLayerMatricHeadLiq(iSoil) - ! - compute derivative in the liquid water matric potential w.r.t. the total water matric potential - dPsiLiq_dEffSat = dPsi_dTheta(effSat,vGn_alpha,0._dp,1._dp,vGn_n,vGn_m) ! derivative in liquid water matric potential w.r.t. effective saturation (m) - dEffSat_dVolTot = xNum/(xDen**2._dp) ! derivative in effective saturation w.r.t. total water content (-) - dPsiLiq_dPsi0(iSoil) = dVolTot_dPsi0(iSoil)*dPsiLiq_dEffSat*dEffSat_dVolTot - ! compute the derivative in the liquid water matric potential w.r.t. temperature (m K-1) - dEffSat_dTemp = -mLayerdTheta_dTk(nSnow+iSoil)*xNum/(xDen**2._dp) + mLayerdTheta_dTk(nSnow+iSoil)/xDen - dPsiLiq_dTemp(iSoil) = dPsiLiq_dEffSat*dEffSat_dTemp - ! ** unfrozen soil - else ! (no ice) - dPsiLiq_dPsi0(iSoil) = 1._dp ! derivative=1 because values are identical - dPsiLiq_dTemp(iSoil) = 0._dp ! derivative=0 because no impact of temperature for unfrozen conditions - mLayerMatricHeadLiq(iSoil) = mLayerMatricHeadTrial(iSoil) ! liquid water matric potential is equal to the total water matic potential when there is no ice - endif ! (if ice exists) - - end do ! (looping through soil layers) - - ! initialize liquid water fluxes throughout the snow and soil domains - ! NOTE: used in the energy routines, which is called before the hydrology routines - if(iter==1)then - if(nSnow > 0)& - iLayerLiqFluxSnow(0:nSnow) = 0._dp - iLayerLiqFluxSoil(0:nSoil) = 0._dp + ! average start-of-step and end-of-step fluxes for explicit Euler + do iVar=1,size(flux_temp%var) + flux_temp%var(iVar)%dat(:) = 0.5_dp*(flux_init%var(iVar)%dat(:) + flux_temp%var(iVar)%dat(:) ) + end do + + ! standard implicit solution + else ! switch between explicit and implicit Euler + + ! set explicit error to missing + explicitError = realMissing + + ! set untapped melt energy to zero + untappedMelt(:) = 0._dp + + ! 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), dp) + end do ! looping through non-missing energy state variables in the snow+soil domain endif - ! print volumetric ice content - !if(printFlag)then - ! write(*,'(a,1x,100(f20.12,1x))') 'mLayerMatricHeadTrial(1:nSoil) = ', mLayerMatricHeadTrial(1:nSoil) - ! write(*,'(a,1x,100(f20.12,1x))') 'mLayerVolFracLiqTrial(nSnow+1:nLayers) = ', mLayerVolFracLiqTrial(nSnow+1:nLayers) - ! write(*,'(a,1x,100(f20.12,1x))') 'mLayerVolFracIceTrial(nSnow+1:nLayers) = ', mLayerVolFracIceTrial(nSnow+1:nLayers) - !endif - - ! ***** - ! (1) CALCULATE 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 - attr_data, & ! intent(in): spatial attributes - forc_data, & ! intent(in): model forcing data - mpar_data, & ! intent(in): model parameters - mvar_data, & ! intent(inout): model variables 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 - canairNetNrgFlux, & ! intent(out): net energy flux for the canopy air space (W m-2) - canopyNetNrgFlux, & ! intent(out): net energy flux for the vegetation canopy (W m-2) - groundNetNrgFlux, & ! 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 derivarives - 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: 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) - if(printFlag)then - write(*,'(a,1x,f30.20)') 'canairNetNrgFlux = ', canairNetNrgFlux - write(*,'(a,1x,f30.20)') 'canopyNetNrgFlux = ', canopyNetNrgFlux - write(*,'(a,1x,f30.20)') 'groundNetNrgFlux = ', groundNetNrgFlux - write(*,'(a,1x,f30.20)') 'dGroundNetFlux_dGroundTemp = ', dGroundNetFlux_dGroundTemp + ! 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 energy state variables in the snow domain) + iState = ixSnowSoilHyd(iLayer) + stateVecTrial(iState) = stateVecInit(iState) + (fluxVecNew(iState)*dt + resSinkNew(iState)) + end do ! looping through non-missing energy state variables in the snow+soil domain endif - !if(printFlag)then - !print*, 'in systemSolv: scalarGroundEvaporation = ', scalarGroundEvaporation - !print*, 'in systemSolv: scalarCanopyEvaporation = ', scalarCanopyEvaporation - !print*, 'in systemSolv: dCanopyEvaporation_dCanLiq = ', dCanopyEvaporation_dCanLiq - !endif - - ! ***** - ! (2) CALCULATE ENERGY FLUXES THROUGH THE SNOW-SOIL DOMAIN... - ! *********************************************************** - ! calculate energy fluxes at layer interfaces through the snow and soil domain - call ssdNrgFlux(& - ! input: fluxes and derivatives at the upper boundary - groundNetNrgFlux, & ! 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) - ! 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) - - !iLayerNrgFlux(0) = 0._dp - - do iLayer=1,nLayers - ssdNetNrgFlux(iLayer) = -(iLayerNrgFlux(iLayer) - iLayerNrgFlux(iLayer-1))/mLayerDepth(iLayer) - if(printFlag)then - if(iLayer < 3) write(*,'(a,1x,i4,1x,10(f25.15,1x))') 'iLayer, iLayerNrgFlux(iLayer-1:iLayer), ssdNetNrgFlux(iLayer) = ', iLayer, iLayerNrgFlux(iLayer-1:iLayer), ssdNetNrgFlux(iLayer) - endif - end do - !print*, 'iLayerNrgFlux = ', iLayerNrgFlux - !print*, 'ssdNetNrgFlux = ', ssdNetNrgFlux - - - ! ***** - ! (3) CALCULATE THE LIQUID FLUX 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) - ! 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) - 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 - canopyNetLiqFlux = scalarRainfall + scalarCanopyEvaporation - scalarThroughfallRain - scalarCanopyLiqDrainage - ! test - if(printFlag)then - print*, 'scalarRainfall = ', scalarRainfall - print*, 'scalarThroughfallRain = ', scalarThroughfallRain - print*, 'scalarCanopyEvaporation = ', scalarCanopyEvaporation - print*, 'scalarCanopyLiqDrainage = ', scalarCanopyLiqDrainage - endif + endif ! switch between explicit and implicit Euler + + ! end associate statements + end associate globalVars - ! ***** - ! (4) CALCULATE THE LIQUID FLUX THROUGH SNOW... - ! ********************************************* - - if(nSnow > 0)then - ! compute liquid fluxes - call snowLiqFlx(& - ! input: model control - iter, & ! intent(in): iteration index - ! 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 (-) - ! output: fluxes and derivatives - iLayerLiqFluxSnow(0:nSnow), & ! intent(out): vertical liquid water flux at layer interfaces (m s-1) - iLayerLiqFluxSnowDeriv(0:nSnow), & ! intent(out): 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 - snowNetLiqFlux(iLayer) = -(iLayerLiqFluxSnow(iLayer) - iLayerLiqFluxSnow(iLayer-1))/mLayerDepth(iLayer) - end do - else - ! define forcing for the soil domain - scalarRainPlusMelt = (scalarThroughfallRain + scalarCanopyLiqDrainage)/iden_water & ! liquid flux from the canopy (m s-1) - + (scalarSfcMeltPond/dt)/iden_water ! melt of the snow without a layer (m s-1) - endif - !if(printFlag)then - ! write(*,'(a,1x,10(e20.10,1x))') 'fracLiqSnow(1), mLayerVolFracLiqTrial(1), iLayerLiqFluxSnow(1), iLayerLiqFluxSnowDeriv(1) = ', & - ! fracLiqSnow(1), mLayerVolFracLiqTrial(1), iLayerLiqFluxSnow(1), iLayerLiqFluxSnowDeriv(1) - !endif - !if(printFlag)then - ! print*, 'scalarRainPlusMelt = ', scalarRainPlusMelt - !endif - - ! ***** - ! (5) CALCULATE THE LIQUID FLUX THROUGH SOIL... - ! ********************************************* - call soilLiqFlx(& - ! input: model control - firstFluxCall, & ! intent(in): flag indicating first call - .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) - mLayerMatricHeadLiq(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) - ! 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) -- only computed for iter==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 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(out): derivatives in the flux w.r.t. matric head in the layer above (s-1) - dq_dHydStateBelow, & ! intent(out): 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(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,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 - soilNetLiqFlux(iLayer) = -(iLayerLiqFluxSoil(iLayer) - iLayerLiqFluxSoil(iLayer-1))/mLayerDepth(iLayer+nSnow) - !if(printFlag .and. iLayer==1)& - !write(*,'(a,1x,i4,1x,10(f25.15,1x))') 'iLayer, soilNetLiqFlux(iLayer), scalarSurfaceInfiltration, iLayerLiqFluxSoil(iLayer-1), iLayerLiqFluxSoil(iLayer) = ', & - ! iLayer, soilNetLiqFlux(iLayer), scalarSurfaceInfiltration, iLayerLiqFluxSoil(iLayer-1), iLayerLiqFluxSoil(iLayer) - end do - ! calculate the soil control on infiltration - if(nSnow==0) then - ! * case of infiltration into soil - if(xMaxInfilRate > scalarRainPlusMelt)then ! infiltration is not rate-limited - soilControl = (1._dp - scalarFrozenArea)*scalarInfilArea - else - soilControl = 0._dp ! (scalarRainPlusMelt exceeds maximum infiltration rate - endif + end subroutine systemSolv + + ! ********************************************************************************************************** + ! private subroutine: compute the right-hand-side fluxes and conversion factors + ! ********************************************************************************************************** + subroutine rhsFluxes(& + ! input + indx_data, & ! intent(in) : state indices + deriv_data, & ! intent(in) : state derivatives + stateVecMult, & ! intent(in) : state vector multiplier + fluxVec, & ! intent(in) : flux vector + sink, & ! intent(in) : sink + ! output + conversionFactor, & ! intent(out) : flux2state conversion factor + rhsFlux, & ! intent(out) : right-hand-side fluxes + err,message) ! intent(out) : error control + USE var_lookup,only:iLookINDEX ! named variables for structure elements + USE var_lookup,only:iLookDERIV ! named variables for structure elements + implicit none + ! input + type(var_ilength),intent(in) :: indx_data ! state indices + type(var_dlength),intent(in) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + real(qp) ,intent(in) :: stateVecMult(:) ! state vector multiplier + real(dp) ,intent(in) :: fluxVec(:) ! flux vector + real(dp) ,intent(in) :: sink(:) ! sink + ! output + real(dp) ,intent(out) :: conversionFactor(:) ! change in state w.r.t. time (dS/dt) + real(dp) ,intent(out) :: rhsFlux(:) ! right-hand-side flux + integer(i4b) ,intent(out) :: err ! error code + character(*) ,intent(out) :: message ! error message + ! local variables + integer(i4b) :: iState ! state index + integer(i4b) :: ixFullVector ! index in the full state vector + integer(i4b) :: ixControlIndex ! index of the control volume for different domains (veg, snow, soil) + real(dp) :: meltDeriv ! melt derivative (J m-3 K-1) + ! make association with model indices and model derivatives + associate(& + ! 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 + dTheta_dTkCanopy => deriv_data%var(iLookDERIV%dTheta_dTkCanopy)%dat(1), & ! intent(in): [dp] derivative of volumetric liquid water content w.r.t. temperature (K-1) + mLayerdTheta_dTk => deriv_data%var(iLookDERIV%mLayerdTheta_dTk)%dat, & ! intent(in): [dp(:)] derivative of volumetric liquid water content w.r.t. temperature (K-1) + ! indices + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1), & ! intent(in): [i4b] number of snow layers + 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 + 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] type of desired model state variables + ) ! associations + ! --------------------------------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message='rhsFluxes/' + + ! loop through model states + do iState=1,size(stateVecMult) + + ! get index of the control volume within the domain + ixFullVector = ixMapSubset2Full(iState) ! index within full state vector + ixControlIndex = ixControlVolume(ixFullVector) ! index within a given domain + + ! if ice included in the energy equation, then get the melt derivative + if(ixStateType_subset(iState)==iname_nrgCanopy .or. ixStateType_subset(iState)==iname_nrgLayer)then + select case( ixDomainType_subset(iState) ) + case(iname_veg); meltDeriv = LH_fus*iden_water*dTheta_dTkCanopy + case(iname_snow); meltDeriv = LH_fus*iden_water*mLayerdTheta_dTk(ixControlIndex) + case(iname_soil); meltDeriv = LH_fus*iden_water*mLayerdTheta_dTk(ixControlIndex+nSnow) + case default; err=20; message=trim(message)//'expect domain type to be iname_veg, iname_snow or iname_soil'; return + end select else - ! * case of infiltration into snow - soilControl = 1._dp + meltDeriv = 0._dp endif - !do iLayer=1,nSoil - !vTheta1 = volFracLiq(mLayerMatricHeadTrial(iLayer)+dx,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) - !volIce1 = vTheta1 - mLayerVolFracLiqTrial(nSnow+iLayer) - !effSat1 = (mLayerVolFracLiqTrial(nSnow+iLayer) - theta_res) / (theta_sat - volIce1 - theta_res) - !psiLiq1 = matricHead(effSat1,vGn_alpha,0._dp,1._dp,vGn_n,vGn_m) ! use effective saturation, so theta_res=0 and theta_sat=1 - !print*, 'numerical derivative = ', (psiLiq1 - mLayerMatricHeadLiq(iLayer))/dx - !print*, 'analytical derivative = ', dPsiLiq_dPsi0(iLayer) - !end do - ! expand derivatives to the total water matric potential - 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) - - ! ***** - ! (6) CALCULATE THE GROUNDWATER FLOW... - ! ************************************* - - ! set baseflow fluxes to zero if the baseflow routine is not used - if(local_ixGroundwater/=qbaseTopmodel)then - ! (diagnostic variables in the data structures) - scalarExfiltration = 0._dp ! exfiltration from the soil profile (m s-1) - mLayerColumnOutflow(:) = 0._dp ! column outflow from each soil layer (m3 s-1) - ! (variables needed for the numerical solution) - mLayerBaseflow(:) = 0._dp ! baseflow from each soil layer (m s-1) - - ! compute the basdeflow flux - else ! local_ixGroundwater==qbaseTopmodel - call groundwatr(& - ! input: model control - 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) - mLayerMatricHeadLiq, & ! 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 - mvar_data, & ! intent(inout): model variables 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 - !write(*,'(a,1x,10(e20.10,1x))') 'iter, mLayerBaseflow(:) = ', mLayerBaseflow(:) - !pause 'computing baseflow fluxes' - - ! check - if(printFlag)then - ! check baseflow - write(*,'(a,1x,10(e30.20,1x))') 'baseflow: ', mLayerBaseflow(:) - ! check baseflow derivatives - !do iLayer=1,nSoil - ! write(*,'(a,1x,i4,1x,100(e20.10,1x))') 'dBaseflow: ', iLayer, dBaseflow_dMatric(:,iLayer) - !end do - endif + ! get the flux-2-state conversion factor + select case( ixStateType_subset(iState) ) + case(iname_matLayer,iname_lmpLayer); conversionFactor(iState) = dVolTot_dPsi0(ixControlIndex) + case(iname_nrgCanair,iname_nrgCanopy,iname_nrgLayer); conversionFactor(iState) = real(stateVecMult(iState), dp) + meltDeriv + case(iname_watCanopy,iname_liqCanopy,iname_watLayer,iname_liqLayer); conversionFactor(iState) = 1._dp + case default; err=20; message=trim(message)//'unable to identify the state type'; return + end select - endif + ! get the right-hand-side flux + select case( ixStateType_subset(iState) ) + case(iname_matLayer,iname_lmpLayer,iname_watLayer,iname_liqLayer); rhsFlux(iState) = fluxVec(iState) + sink(iState) ! include transpiration and lateral flow sinks as part of the flux + case(iname_nrgCanair,iname_nrgCanopy,iname_nrgLayer); rhsFlux(iState) = fluxVec(iState) + case(iname_watCanopy,iname_liqCanopy); rhsFlux(iState) = fluxVec(iState) + case default; err=20; message=trim(message)//'unable to identify the state type'; return + end select - ! ***** - ! (7) CALCUALTE FLUXES FOR THE DEEP AQUIFER... - ! ******************************************** + end do ! looping through state variables - ! identify modeling decision - if(ixGroundwater==bigBucket)then - ! deep aquifer is not yet transfered from old code structure - message=trim(message)//'bigBucket groundwater parameterization is not yet transfered from old code structure' - err=20; return - else - ! if no quifer, then fluxes are zero - scalarAquiferTranspire = 0._dp ! transpiration loss from the aquifer (m s-1 - scalarAquiferRecharge = 0._dp ! recharge to the aquifer (m s-1) - scalarAquiferBaseflow = 0._dp ! total baseflow from the aquifer (m s-1) - endif + ! end association with data structures + end associate - ! ***** - ! (X) WRAP UP... - ! ************** + end subroutine rhsFluxes - ! define model flux vector for the vegetation sub-domain - if(computeVegFlux)then - fluxVec(ixCasNrg) = canairNetNrgFlux/canopyDepth - fluxVec(ixVegNrg) = canopyNetNrgFlux/canopyDepth - fluxVec(ixVegWat) = canopyNetLiqFlux ! NOTE: solid fluxes are handled separately - endif + ! ********************************************************************************************************** + ! private subroutine explicitMelt: calaculate the melt in the explicit solution + ! ********************************************************************************************************** + subroutine explicitMelt(& + dt, & ! intent(in) : time step (s) + indx_data, & ! intent(in) : state indices + diag_data, & ! intent(in) : model diagnostic variables + prog_data, & ! intent(in) : model prognostic variables + totalFlux, & ! intent(in) : total flux + stateVecMult, & ! intent(in) : state vector multiplier + stateVecUpdate, & ! intent(inout) : state vector update + untappedMelt, & ! intent(out) : untapped melt energy (J m-3 s-1) + tooMuchMelt, & ! intent(out) : flag to denote that ice is insufficient to support available melt + err,message) ! intent(out) : error control + USE var_lookup,only:iLookDIAG ! 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 + implicit none + ! input + real(dp) ,intent(in) :: dt ! time step (s) + type(var_ilength),intent(in) :: indx_data ! state indices + type(var_dlength),intent(in) :: diag_data ! model diagnostic variables + type(var_dlength),intent(in) :: prog_data ! model prognostic variables + real(dp) ,intent(in) :: totalFlux(:) ! total flux + real(qp) ,intent(in) :: stateVecMult(:) ! state vector multiplier + ! output + real(dp) ,intent(inout) :: stateVecUpdate(:) ! state vector update + real(dp) ,intent(out) :: untappedMelt(:) ! untapped melt energy (J m-3 s-1) + logical(lgt) ,intent(out) :: tooMuchMelt ! flag to denote that ice is insufficient to support available melt + integer(i4b) ,intent(out) :: err ! error code + character(*) ,intent(out) :: message ! error message + ! local variables + integer(i4b) :: iState ! state index + integer(i4b) :: ixFullVector ! index in the full state vector + integer(i4b) :: ixControlIndex ! index of the control volume for different domains (veg, snow, soil) + real(dp) :: tempNrg ! energy associated with the temperature increase (J m-3 s-1) + real(dp) :: nrg2meltIce ! energy required to melt all of the ice (J m-3) + real(dp) :: nrg2freezeWater ! energy required to freeze all of the liquid water (J m-3) + real(dp) :: untappedNrg ! untapped energy (J m-3) + real(dp) :: xIce ! ice at the start of the step (kg m-2 [canopy] or dimensionless [snow+soil]) + real(dp) :: xLiq ! liquid water at the start of the step (kg m-2 [canopy] or dimensionless [snow+soil]) + ! -------------------------------------------------------------------------------------------------------------- + ! make association with model indices defined in indexSplit + associate(& + ! diagnostic and prognostic variables + canopyDepth => diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1), & ! intent(in): [dp] canopy depth (m) + scalarCanopyIce => prog_data%var(iLookPROG%scalarCanopyIce)%dat(1), & ! intent(in): [dp] ice stored on the vegetation canopy (-) + scalarCanopyLiq => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1), & ! intent(in): [dp] liquid water stored on the vegetation canopy (-) + 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 (-) + ! indices + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1), & ! intent(in): [i4b] number of snow layers + 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 + 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] type of desired model state variables + ) ! associations - ! define the model flux vector for the snow and soil sub-domains - fluxVec(ixSnowSoilNrg) = ssdNetNrgFlux(1:nLayers) - fluxVec(ixSoilOnlyMat) = soilNetLiqFlux(1:nSoil) - if(nSnow>0)& - fluxVec(ixSnowOnlyWat) = snowNetLiqFlux(1:nSnow) + ! initialize error control + err=0; message='explicitMelt/' + + ! initialize the flag to denote that ice is insufficient to support available melt + tooMuchMelt=.false. + + ! loop through model states + do iState=1,size(totalFlux) + + ! --> get index of the control volume within the domain + ixFullVector = ixMapSubset2Full(iState) ! index within full state vector + ixControlIndex = ixControlVolume(ixFullVector) ! index within a given domain + + ! restrict attention to the energy state variables in domains where ice can me be present + if(ixStateType_subset(iState)==iname_nrgCanopy .or. ixStateType_subset(iState)==iname_nrgLayer)then + + ! --> compute the un-tapped melt energy + tempNrg = stateVecUpdate(iState)*real(stateVecMult(iState), dp)/dt ! energy associated with the temperature increase (J m-3 s-1) + untappedMelt(iState) = totalFlux(iState) - tempNrg + + ! ***** + ! melting + if(untappedMelt(iState) > 0._dp)then + + ! --> get the ice at the start of the time step + select case( ixDomainType_subset(iState) ) + case(iname_veg); xIce = scalarCanopyIce ! kg m-2 + case(iname_snow); xIce = mLayerVolFracIce(ixControlIndex) ! (-) + case(iname_soil); xIce = mLayerVolFracIce(ixControlIndex+nSnow) ! (-) + case default; err=20; message=trim(message)//'cannot find the domain'; return + end select + + ! --> get the energy required to melt all of the ice (J m-3) + if(xIce > epsilon(dt))then + select case( ixDomainType_subset(iState) ) + case(iname_veg); nrg2meltIce = LH_fus*xIce/canopyDepth ! J m-3 + case(iname_snow); nrg2meltIce = iden_ice *LH_fus*xIce ! J m-3 + case(iname_soil); nrg2meltIce = iden_water*LH_fus*xIce ! J m-3 + case default; err=20; message=trim(message)//'cannot find the domain'; return + end select + else + nrg2meltIce = 0._dp + endif - ! print progress - !print*, '**' - !if(printFlag)then - ! write(*,'(a,1x,100(f15.9,1x))') 'stateVec(:) = ', stateVec(:) - ! write(*,'(a,1x,100(e15.9,1x))') 'fluxVec(:) = ', fluxVec(:) - !endif - - ! end association to variables in the data structures - end associate - - ! set the first flux call to false - firstFluxCall=.false. - - end subroutine computFlux - - - ! ********************************************************************************************************* - ! internal subroutine cpactBand: compute the compact band-diagonal matric - ! ********************************************************************************************************* - subroutine cpactBand(err,message) - ! dummy variables - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! -------------------------------------------------------------- - ! initialize error control - err=0; message='cpactBand/' - - ! associate variables from data structures - associate(mLayerDepth => mvar_data%var(iLookMVAR%mLayerDepth)%dat) ! intent(in): [dp(:)] depth of each layer in the snow-soil sub-domain (m) - - ! initialize the Jacobian - ! NOTE: this needs to be done every time, since Jacobian matrix is modified in the solver - aJac(:,:) = 0._dp ! analytical Jacobian matrix - - ! ----- - ! * energy and liquid fluxes over vegetation... - ! --------------------------------------------- - if(computeVegFlux)then ! (derivatives only defined when vegetation protrudes over the surface) - - ! liquid water fluxes for vegetation canopy (-) - aJac(ixDiag,ixVegWat) = -fracLiqVeg*(dCanopyEvaporation_dCanLiq - scalarCanopyLiqDrainageDeriv)*dt + 1._dp ! ixVegWat: CORRECT - - ! cross-derivative terms w.r.t. system temperatures (kg m-2 K-1) - aJac(ixSub2,ixCasNrg) = -dCanopyEvaporation_dTCanair*dt ! ixCasNrg: CORRECT - aJac(ixSub1,ixVegNrg) = -dCanopyEvaporation_dTCanopy*dt + dt*scalarCanopyLiqDrainageDeriv*dCanLiq_dTcanopy ! ixVegNrg: CORRECT - aJac(ixSup1,ixTopNrg) = -dCanopyEvaporation_dTGround*dt ! ixTopNrg: CORRECT - - ! cross-derivative terms w.r.t. canopy water (kg-1 m2) - aJac(ixSub2,ixVegWat) = (dt/mLayerDepth(1))*(-soilControl*fracLiqVeg*scalarCanopyLiqDrainageDeriv)/iden_water ! ixVegWat: CORRECT - - ! cross-derivative terms w.r.t. canopy temperature (K-1) - aJac(ixSub3,ixVegNrg) = (dt/mLayerDepth(1))*(-soilControl*scalarCanopyLiqDrainageDeriv*dCanLiq_dTcanopy)/iden_water ! ixVegNrg: CORRECT - !print*, 'soilControl, scalarCanopyLiqDrainageDeriv, dCanLiq_dTcanopy = ', soilControl, scalarCanopyLiqDrainageDeriv, dCanLiq_dTcanopy - - ! cross-derivative terms w.r.t. canopy liquid water (J m-1 kg-1) - ! NOTE: dIce/dLiq = (1 - fracLiqVeg); dIce*LH_fus/canopyDepth = J m-3; dLiq = kg m-2 - aJac(ixSup1,ixVegWat) = (dt/canopyDepth) *(-dCanopyNetFlux_dCanLiq) - (1._dp - fracLiqVeg)*LH_fus/canopyDepth ! dF/dLiq ! ixVegWat: CORRECT - aJac(ixSub1,ixVegWat) = (dt/mLayerDepth(1))*(-dGroundNetFlux_dCanLiq) ! ixVegWat: CORRECT - - ! energy fluxes with the canopy air space (J m-3 K-1) - aJac(ixDiag,ixCasNrg) = (dt/canopyDepth)*(-dCanairNetFlux_dCanairTemp) + dMat(ixCasNrg) ! ixCasNrg: CORRECT - aJac(ixSup1,ixVegNrg) = (dt/canopyDepth)*(-dCanairNetFlux_dCanopyTemp) ! ixVegNrg: CORRECT - aJac(ixSup3,ixTopNrg) = (dt/canopyDepth)*(-dCanairNetFlux_dGroundTemp) ! ixTopNrg: CORRECT - - ! energy fluxes with the vegetation canopy (J m-3 K-1) - aJac(ixSub1,ixCasNrg) = (dt/canopyDepth)*(-dCanopyNetFlux_dCanairTemp) ! ixCasNrg: CORRECT - aJac(ixDiag,ixVegNrg) = (dt/canopyDepth)*(-dCanopyNetFlux_dCanopyTemp) + dMat(ixVegNrg) ! ixVegNrg: CORRECT - aJac(ixSup2,ixTopNrg) = (dt/canopyDepth)*(-dCanopyNetFlux_dGroundTemp) ! ixTopNrg: CORRECT - - ! energy fluxes with the surface (J m-3 K-1) - aJac(ixSub3,ixCasNrg) = (dt/mLayerDepth(1))*(-dGroundNetFlux_dCanairTemp) ! ixCasNrg: CORRECT - aJac(ixSub2,ixVegNrg) = (dt/mLayerDepth(1))*(-dGroundNetFlux_dCanopyTemp) ! ixVegNrg: CORRECT - - ! test - !print*, 'aJac(ixSub2,ixVegWat) = ', aJac(ixSub2,ixVegWat) - !print*, 'aJac(ixSub3,ixVegNrg) = ', aJac(ixSub3,ixVegNrg) - - endif ! if there is a need to compute energy fluxes within vegetation - - ! ----- - ! * energy fluxes for the snow-soil domain... - ! ------------------------------------------- - do iLayer=1,nLayers ! loop through layers in the snow-soil domain - ! (define layer indices) - jLayer = ixSnowSoilNrg(iLayer) ! layer index within the full state vector - ! (define the compact band-diagonal matrix) - if(iLayer > 1) aJac(ixSup2,jLayer) = (dt/mLayerDepth(iLayer-1))*( dNrgFlux_dTempBelow(iLayer-1) ) - aJac(ixDiag,jLayer) = (dt/mLayerDepth(iLayer)) *(-dNrgFlux_dTempBelow(iLayer-1) + dNrgFlux_dTempAbove(iLayer)) + dMat(jLayer) - if(iLayer < nLayers) aJac(ixSub2,jLayer) = (dt/mLayerDepth(iLayer+1))*(-dNrgFlux_dTempAbove(iLayer ) ) - end do ! (looping through layers in the snow-soil system) - - ! ----- - ! * liquid water fluxes for the snow domain... - ! -------------------------------------------- - do iLayer=1,nSnow - ! - define layer indices - jLayer = ixSnowOnlyWat(iLayer) ! layer index within the full state vector - mLayer = ixSnowSoilNrg(iLayer) ! energy layer index within the full state vector - ! - compute the diagonal - aJac(ixDiag,jLayer) = (dt/mLayerDepth(iLayer))*iLayerLiqFluxSnowDeriv(iLayer)*fracLiqSnow(iLayer) + dMat(jLayer) - ! - compute cross-derivative terms for the current layer - aJac(ixSub1,mLayer) = (dt/mLayerDepth(iLayer))*iLayerLiqFluxSnowDeriv(iLayer)*mLayerdTheta_dTk(iLayer) ! (dVol/dT) -- increase in volumetric liquid water content balanced by a decrease in volumetric ice content - aJac(ixSup1,jLayer) = -(1._dp - fracLiqSnow(iLayer))*LH_fus*iden_water ! (dF/dLiq) - ! - compute cross-derivative terms for the layer below (w.r.t. state in the current layer) - if(iLayer < nSnow)then - aJac(ixSub3,mLayer) = -(dt/mLayerDepth(iLayer+1))*iLayerLiqFluxSnowDeriv(iLayer)*mLayerdTheta_dTk(iLayer) ! dVol(below)/dT(above) -- K-1 - aJac(ixSub2,jLayer) = (dt/mLayerDepth(iLayer+1))*iLayerLiqFluxSnowDeriv(iLayer)*fracLiqSnow(iLayer) ! dVol(below)/dLiq(above) -- (-) - endif - end do ! (looping through snow layers) - - ! ----- - ! * liquid water fluxes for the soil domain... - ! -------------------------------------------- - do iLayer=1,nSoil ! loop through layers in the soil domain - ! - define layer indices - jLayer = ixSoilOnlyMat(iLayer) ! layer index within the full state vector - kLayer = iLayer+nSnow ! layer index within the full snow-soil vector - ! - compute the Jacobian - if(kLayer > nSnow+1) aJac(ixSup2,jLayer) = (dt/mLayerDepth(kLayer-1))*( dq_dHydStateBelow(iLayer-1)) - aJac(ixDiag,jLayer) = (dt/mLayerDepth(kLayer)) *(-dq_dHydStateBelow(iLayer-1) + dq_dHydStateAbove(iLayer)) + dMat(jLayer) - if(kLayer < nLayers) aJac(ixSub2,jLayer) = (dt/mLayerDepth(kLayer+1))*(-dq_dHydStateAbove(iLayer)) - end do ! (looping through soil layers) - - ! ----- - ! * derivative in liquid water fluxes w.r.t. temperature for the soil domain... - ! ----------------------------------------------------------------------------- - do iLayer=1,nSoil ! loop through layers in the soil domain - ! - define layer indices - kLayer = iLayer+nSnow ! layer index within the full snow-soil vector - jLayer = ixSoilOnlyMat(iLayer) ! hydrology layer index within the full state vector - mLayer = ixSnowSoilNrg(kLayer) ! thermodynamics layer index within the full state vector - !write(*,'(a,1x,10(i4,1x))') 'iLayer, jLayer, jLayer-nVarSnowSoil, jLayer+nVarSnowSoil, kLayer, mLayer = ', & - ! iLayer, jLayer, jLayer-nVarSnowSoil, jLayer+nVarSnowSoil, kLayer, mLayer - ! - compute the Jacobian for the layer itself - aJac(ixSub1,mLayer) = (dt/mLayerDepth(kLayer))*(-dq_dNrgStateBelow(iLayer-1) + dq_dNrgStateAbove(iLayer)) ! dVol/dT (K-1) -- flux depends on ice impedance - if(mLayerVolFracIceTrial(kLayer) > tiny(dt))then - aJac(ixSup1,jLayer) = -dVolTot_dPsi0(iLayer)*LH_fus*iden_water ! dNrg/dMat (J m-3 m-1) -- dMat changes volumetric water, and hence ice content + ! check if the required melt can be satisfied by the available ice + if(untappedMelt(iState)*dt > nrg2meltIce)then + + ! domain-specfic adjustments + select case( ixDomainType_subset(iState) ) + + ! --> vegetation and soil have physical structure, so can recover + case(iname_veg, iname_soil) + untappedNrg = untappedMelt(iState)*dt - nrg2meltIce ! extra energy not used in melt (J m-3) + untappedMelt(iState) = nrg2meltIce/dt ! truncate melt to the energy required to melt all ice (J m-3 s-1) + stateVecUpdate(iState) = stateVecUpdate(iState) + untappedNrg/real(stateVecMult(iState), dp) ! use the extra energy to update the state vector + + ! --> snow is a problem, as we cannot melt all of the ice in a single time step + case(iname_snow) + tooMuchMelt = .true. + + ! --> checks + case default; err=20; message=trim(message)//'cannot find the domain'; return + end select + + endif ! if melt is less than that required to melt all of the ice + + ! ***** + ! freezing else - aJac(ixSup1,jLayer) = 0._dp - endif - ! - compute the Jacobian for neighboring layers (dVol/dT) - if(kLayer > nSnow+1) aJac(ixSup1,mLayer) = (dt/mLayerDepth(kLayer-1))*( dq_dNrgStateBelow(iLayer-1)) ! K-1 - if(kLayer < nLayers) aJac(ixSub3,mLayer) = (dt/mLayerDepth(kLayer+1))*(-dq_dNrgStateAbove(iLayer)) ! K-1 - - end do ! (looping through soil layers) - - ! ----- - ! * testing..... - ! -------------- - !print*, '** analytical Jacobian:' - !write(*,'(a4,1x,100(i11,1x))') 'xCol', (iLayer, iLayer=iJac1,iJac2) - !do iLayer=kl+1,nBands; write(*,'(i4,1x,100(e11.5,1x))') iLayer, aJac(iLayer,iJac1:iJac2); end do - !pause - - - ! end association to variables in the data structures - end associate - - end subroutine cpactBand - - ! ********************************************************************************************************* - ! internal subroutine analJacob: compute the Jacobian matrix (analytical) - ! ********************************************************************************************************* - subroutine analJacob(err,message) - implicit none - ! dummy variables - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! local variables - integer(i4b) :: pLayer,qLayer ! indices of model layers - ! -------------------------------------------------------------- - ! initialize error control - err=0; message='analJacob/' - - ! associate variables from data structures - associate(mLayerDepth => mvar_data%var(iLookMVAR%mLayerDepth)%dat) ! intent(in): [dp(:)] depth of each layer in the snow-soil sub-domain (m) - - ! initialize the Jacobian - ! NOTE: this needs to be done every time, since Jacobian matrix is modified in the solver - aJac(:,:) = 0._dp ! analytical Jacobian matrix - - ! ----- - ! * energy and liquid fluxes over vegetation... - ! --------------------------------------------- - if(computeVegFlux)then ! (derivatives only defined when vegetation protrudes over the surface) - - ! liquid water fluxes for vegetation canopy (-) - aJac(ixVegWat,ixVegWat) = -fracLiqVeg*(dCanopyEvaporation_dCanLiq - scalarCanopyLiqDrainageDeriv)*dt + 1._dp - - ! cross-derivative terms w.r.t. system temperatures (kg m-2 K-1) - aJac(ixVegWat,ixCasNrg) = -dCanopyEvaporation_dTCanair*dt - aJac(ixVegWat,ixVegNrg) = -dCanopyEvaporation_dTCanopy*dt + dt*scalarCanopyLiqDrainageDeriv*dCanLiq_dTcanopy - aJac(ixVegWat,ixTopNrg) = -dCanopyEvaporation_dTGround*dt - - ! cross-derivative terms w.r.t. canopy water (kg-1 m2) - aJac(ixTopLiq,ixVegWat) = (dt/mLayerDepth(1))*(-soilControl*fracLiqVeg*scalarCanopyLiqDrainageDeriv)/iden_water - - ! cross-derivative terms w.r.t. canopy temperature (K-1) - aJac(ixTopLiq,ixVegNrg) = (dt/mLayerDepth(1))*(-soilControl*scalarCanopyLiqDrainageDeriv*dCanLiq_dTcanopy)/iden_water - !print*, 'soilControl, scalarCanopyLiqDrainageDeriv, dCanLiq_dTcanopy = ', soilControl, scalarCanopyLiqDrainageDeriv, dCanLiq_dTcanopy - - ! cross-derivative terms w.r.t. canopy liquid water (J m-1 kg-1) - ! NOTE: dIce/dLiq = (1 - fracLiqVeg); dIce*LH_fus/canopyDepth = J m-3; dLiq = kg m-2 - aJac(ixVegNrg,ixVegWat) = (dt/canopyDepth) *(-dCanopyNetFlux_dCanLiq) - (1._dp - fracLiqVeg)*LH_fus/canopyDepth ! dF/dLiq - aJac(ixTopNrg,ixVegWat) = (dt/mLayerDepth(1))*(-dGroundNetFlux_dCanLiq) - !print*, '(dt/canopyDepth) *(-dCanopyNetFlux_dCanLiq) = ', (dt/canopyDepth) *(-dCanopyNetFlux_dCanLiq) - !print*, '(1._dp - fracLiqVeg)*LH_fus/canopyDepth = ', (1._dp - fracLiqVeg)*LH_fus/canopyDepth - - ! energy fluxes with the canopy air space (J m-3 K-1) - aJac(ixCasNrg,ixCasNrg) = (dt/canopyDepth)*(-dCanairNetFlux_dCanairTemp) + dMat(ixCasNrg) - aJac(ixCasNrg,ixVegNrg) = (dt/canopyDepth)*(-dCanairNetFlux_dCanopyTemp) - aJac(ixCasNrg,ixTopNrg) = (dt/canopyDepth)*(-dCanairNetFlux_dGroundTemp) - - ! energy fluxes with the vegetation canopy (J m-3 K-1) - aJac(ixVegNrg,ixCasNrg) = (dt/canopyDepth)*(-dCanopyNetFlux_dCanairTemp) - aJac(ixVegNrg,ixVegNrg) = (dt/canopyDepth)*(-dCanopyNetFlux_dCanopyTemp) + dMat(ixVegNrg) - aJac(ixVegNrg,ixTopNrg) = (dt/canopyDepth)*(-dCanopyNetFlux_dGroundTemp) - - ! energy fluxes with the surface (J m-3 K-1) - aJac(ixTopNrg,ixCasNrg) = (dt/mLayerDepth(1))*(-dGroundNetFlux_dCanairTemp) - aJac(ixTopNrg,ixVegNrg) = (dt/mLayerDepth(1))*(-dGroundNetFlux_dCanopyTemp) - - !print*, 'aJac(ixVegWat,ixVegNrg) = ', aJac(ixVegWat,ixVegNrg) - !print*, 'aJac(ixVegNrg,ixVegWat) = ', aJac(ixVegNrg,ixVegWat) - !print*, 'aJac(ixTopNrg,ixVegWat) = ', aJac(ixTopNrg,ixVegWat) - !print*, 'aJac(ixTopNrg,ixVegNrg) = ', aJac(ixTopNrg,ixVegNrg) - !print*, 'aJac(ixTopLiq,ixVegNrg) = ', aJac(ixTopLiq,ixVegNrg) - !print*, 'aJac(ixTopLiq,ixVegWat) = ', aJac(ixTopLiq,ixVegWat) - - endif ! if there is a need to compute energy fluxes within vegetation - - ! ----- - ! * energy fluxes for the snow-soil domain... - ! ------------------------------------------- - do iLayer=1,nLayers ! loop through layers in the snow-soil domain - ! - define layer indices - jLayer = ixSnowSoilNrg(iLayer) - ! - compute the Jacobian - aJac(jLayer,jLayer) = (dt/mLayerDepth(iLayer))*(-dNrgFlux_dTempBelow(iLayer-1) + dNrgFlux_dTempAbove(iLayer)) + dMat(jLayer) - if(iLayer > 1) aJac(jLayer-nVarSnowSoil,jLayer) = (dt/mLayerDepth(iLayer-1))*( dNrgFlux_dTempBelow(iLayer-1) ) - if(iLayer < nLayers) aJac(jLayer+nVarSnowSoil,jLayer) = (dt/mLayerDepth(iLayer+1))*(-dNrgFlux_dTempAbove(iLayer ) ) - end do ! (looping through layers in the snow-soil system) - - ! ----- - ! * liquid water fluxes for the snow domain... - ! -------------------------------------------- - do iLayer=1,nSnow - ! - define layer indices - jLayer = ixSnowOnlyWat(iLayer) ! hydrology layer index within the full state vector - mLayer = ixSnowSoilNrg(iLayer) ! energy layer index within the full state vector - ! - compute the Jacobian - aJac(jLayer,jLayer) = (dt/mLayerDepth(iLayer))*iLayerLiqFluxSnowDeriv(iLayer)*fracLiqSnow(iLayer) + dMat(jLayer) - if(iLayer > 1) aJac(jLayer-nVarSnowSoil,jLayer) = 0._dp ! sub-diagonal: no dependence on other layers - ! - compute cross-derivative terms for the current layer - aJac(mLayer,jLayer) = -(1._dp - fracLiqSnow(iLayer))*LH_fus*iden_water ! (dF/dLiq) - aJac(jLayer,mLayer) = (dt/mLayerDepth(iLayer))*iLayerLiqFluxSnowDeriv(iLayer)*mLayerdTheta_dTk(iLayer) ! (dVol/dT) -- increase in volumetric liquid water content balanced by a decrease in volumetric ice content - ! - compute cross-derivative terms for the layer below (w.r.t. state in the current layer) - if(iLayer < nSnow)then - aJac(jLayer+nVarSnowSoil,mLayer) = -(dt/mLayerDepth(iLayer+1))*iLayerLiqFluxSnowDeriv(iLayer)*mLayerdTheta_dTk(iLayer) ! dVol(below)/dT(above) -- K-1 - aJac(jLayer+nVarSnowSoil,jLayer) = -(dt/mLayerDepth(iLayer+1))*iLayerLiqFluxSnowDeriv(iLayer)*fracLiqSnow(iLayer) ! dVol(below)/dLiq(above) -- (-) - !print*, 'aJac(jLayer+nVarSnowSoil,jLayer) = ', aJac(jLayer+nVarSnowSoil,jLayer) - endif - end do - - ! ----- - ! * liquid water fluxes for the soil domain... - ! -------------------------------------------- - do iLayer=1,nSoil ! loop through layers in the soil domain - - ! - define layer indices - jLayer = ixSoilOnlyMat(iLayer) ! layer index within the full state vector - kLayer = iLayer+nSnow ! layer index within the full snow-soil vector - - ! - compute the Jacobian - ! all terms *excluding* baseflow - aJac(jLayer,jLayer) = (dt/mLayerDepth(kLayer))*(-dq_dHydStateBelow(iLayer-1) + dq_dHydStateAbove(iLayer)) + dMat(jLayer) - if(kLayer > nSnow+1) aJac(jLayer-nVarSnowSoil,jLayer) = (dt/mLayerDepth(kLayer-1))*( dq_dHydStateBelow(iLayer-1)) - if(kLayer < nLayers) aJac(jLayer+nVarSnowSoil,jLayer) = (dt/mLayerDepth(kLayer+1))*(-dq_dHydStateAbove(iLayer)) - - ! include terms for baseflow - do pLayer=1,nSoil - qLayer = ixSoilOnlyMat(pLayer) ! layer index within the full state vector - aJac(jLayer,qLayer) = aJac(jLayer,qLayer) + (dt/mLayerDepth(kLayer))*dBaseflow_dMatric(iLayer,pLayer) - end do - - end do ! (looping through soil layers) - - ! ----- - ! * derivative in liquid water fluxes w.r.t. temperature for the soil domain... - ! ----------------------------------------------------------------------------- - do iLayer=1,nSoil ! loop through layers in the soil domain - ! - define layer indices - kLayer = iLayer+nSnow ! layer index within the full snow-soil vector - jLayer = ixSoilOnlyMat(iLayer) ! hydrology layer index within the full state vector - mLayer = ixSnowSoilNrg(kLayer) ! thermodynamics layer index within the full state vector - ! - compute the Jacobian for the layer itself - aJac(jLayer,mLayer) = (dt/mLayerDepth(kLayer))*(-dq_dNrgStateBelow(iLayer-1) + dq_dNrgStateAbove(iLayer)) ! dVol/dT (K-1) -- flux depends on ice impedance - if(mLayerVolFracIceTrial(iLayer+nSnow) > tiny(dt))then - aJac(mLayer,jLayer) = -dVolTot_dPsi0(iLayer)*LH_fus*iden_water ! dNrg/dMat (J m-3 m-1) -- dMat changes volumetric water, and hence ice content - else - aJac(mLayer,jLayer) = 0._dp - endif - !if(iLayer==1) write(*,'(a)') 'iLayer, jLayer, jLayer-nVarSnowSoil, jLayer+nVarSnowSoil, kLayer, mLayer, aJac(mLayer,jLayer), aJac(jLayer,mLayer), dq_dNrgStateBelow(iLayer-1), dq_dNrgStateAbove(iLayer) = ' - !write(*,'(6(i4,1x),10(e20.10,1x))') iLayer, jLayer, jLayer-nVarSnowSoil, jLayer+nVarSnowSoil, kLayer, mLayer, aJac(mLayer,jLayer), aJac(jLayer,mLayer), dq_dNrgStateBelow(iLayer-1), dq_dNrgStateAbove(iLayer) + ! --> get the liquid water at the start of the time step + select case( ixDomainType_subset(iState) ) + case(iname_veg); xLiq = scalarCanopyLiq ! kg m-2 + case(iname_snow); xLiq = mLayerVolFracLiq(ixControlIndex) ! (-) + case(iname_soil); xLiq = mLayerVolFracLiq(ixControlIndex+nSnow) ! (-) + case default; err=20; message=trim(message)//'cannot find the domain'; return + end select + + ! --> get the energy required to freeze all of the liquid water (J m-3) + if(xLiq > epsilon(dt))then + select case( ixDomainType_subset(iState) ) + case(iname_veg); nrg2freezeWater = LH_fus*xLiq/canopyDepth ! J m-3 + case(iname_snow); nrg2freezeWater = iden_water*LH_fus*xLiq ! J m-3 + case(iname_soil); nrg2freezeWater = iden_water*LH_fus*xLiq ! J m-3 + case default; err=20; message=trim(message)//'cannot find the domain'; return + end select + else + nrg2freezeWater = 0._dp + endif - ! - compute the Jacobian for neighboring layers - if(kLayer > nSnow+1) aJac(jLayer-nVarSnowSoil,mLayer) = (dt/mLayerDepth(kLayer-1))*( dq_dNrgStateBelow(iLayer-1)) ! K-1 - if(kLayer < nLayers) aJac(jLayer+nVarSnowSoil,mLayer) = (dt/mLayerDepth(kLayer+1))*(-dq_dNrgStateAbove(iLayer)) ! K-1 + ! check if the required melt can be satisfied by the available ice + ! NOTE 1: negative untappedMelt + ! NOTE 2: insufficient liquid water to freeze is never a problem as temperatures just decrease + if(-untappedMelt(iState)*dt > nrg2freezeWater)then + untappedNrg = -untappedMelt(iState)*dt - nrg2freezeWater ! extra energy not used in melt (J m-3) + untappedMelt(iState) = -nrg2freezeWater/dt ! truncate melt to the energy required to melt all ice (J m-3 s-1) + stateVecUpdate(iState) = stateVecUpdate(iState) - untappedNrg/real(stateVecMult(iState), dp) ! use the extra energy to update the state vector + endif ! if freeze is greater than that required to freeze all of the water - end do ! (looping through soil layers) + endif ! if freezing - ! print the Jacobian - if(globalPrintFlag)then - print*, '** analytical Jacobian:' - write(*,'(a4,1x,100(i12,1x))') 'xCol', (iLayer, iLayer=iJac1,iJac2) - do iLayer=iJac1,iJac2; write(*,'(i4,1x,100(e12.5,1x))') iLayer, aJac(iJac1:iJac2,iLayer); end do + ! not a relevant energy state (or not an energy state at all!) + else + untappedMelt(iState) = 0._dp endif - !pause 'testing analytical jacobian' - - ! end the association to data structures - end associate - - end subroutine analJacob - - - ! ********************************************************************************************************* - ! internal subroutine numlJacob: compute the Jacobian matrix (numerical) - ! ********************************************************************************************************* - subroutine numlJacob(stateVec,fluxVec,resVec,err,message) - implicit none - ! dummy - real(dp),intent(in) :: stateVec(:) ! model state vector (mixed units) - real(dp),intent(in) :: fluxVec(:) ! model flux vector (mixed units) - real(qp),intent(in) :: resVec(:) ! model residual vector (mixed units) - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! local - character(len=256) :: cmessage ! error message of downwind routine - real(dp),dimension(nState) :: stateVecPerturbed ! perturbed state vector - real(dp),dimension(nState) :: fluxVecJac ! flux vector - real(qp),dimension(nState) :: resVecJac ! residual vector (mixed units) - integer(i4b) :: iJac ! index of row of the Jacobian matrix - integer(i4b),parameter :: iTry=-999 ! index of trial model state variable (used for testing) - integer(i4b) :: ixDesire ! index of a desired layer (used for testing) - ! trial state variables (vegetation canopy) - real(dp) :: scalarCanairTempLocal ! trial value for temperature of the canopy air space (K) - real(dp) :: scalarCanopyTempLocal ! trial value for temperature of the vegetation canopy (K) - real(dp) :: scalarCanopyLiqLocal ! trial value for mass of liquid water on the vegetation canopy (kg m-2) - real(dp) :: scalarCanopyIceLocal ! trial value for mass of ice on the vegetation canopy (kg m-2) - ! trial state variables (snow and soil domains) - real(dp),dimension(nLayers) :: mLayerTempLocal ! trial value for temperature of each snow/soil layer (K) - real(dp),dimension(nLayers) :: mLayerVolFracLiqLocal ! trial value for volumetric fraction of liquid water (-) - real(dp),dimension(nLayers) :: mLayerVolFracIceLocal ! trial value for volumetric fraction of ice (-) - real(dp),dimension(nSoil) :: mLayerMatricHeadLocal ! trial value for matric head (m) - ! model control -- swith between flux-based form and residual-based form of the numerical Jacobian - 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 - !integer(i4b) :: ixNumType=ixNumFlux ! method used to calculate the numerical Jacobian - ! -------------------------------------------------------------- - ! initialize error control - err=0; message='numlJacob/' - - ! get a copy of the state vector to perturb - stateVecPerturbed(:) = stateVec(:) - - ! get a copy of the canopy ice storage - scalarCanopyLiqLocal = scalarCanopyLiqTrial - scalarCanopyIceLocal = scalarCanopyIceTrial - - ! get a copy of the volumetric liquid water and ice content - mLayerVolFracLiqLocal = mLayerVolFracLiqTrial - mLayerVolFracIceLocal = mLayerVolFracIceTrial - - ! loop through state variables - do iJac=1,nState - - ! print progress - !print*, '*** iJac = ', iJac - - ! define printFlag - if(iJac==iTry) printFlag=.true. - if(iJac/=iTry) printFlag=.false. - - ! (perturb state vector) - stateVecPerturbed(iJac) = stateVec(iJac) + dx - - ! (use constitutive functions to compute unknown terms removed from the state equations...) - call updatState(& - stateVecPerturbed, & ! intent(in): full state vector (mixed units) - mLayerVolFracLiqLocal, & ! intent(out): volumetric fraction of liquid water (-) - mLayerVolFracIceLocal, & ! intent(out): volumetric fraction of ice (-) - scalarCanopyLiqLocal, & ! intent(out): mass of canopy liquid (kg m-2) - scalarCanopyIceLocal, & ! intent(out): mass of canopy ice (kg m-2) - err,cmessage) ! intent(out): error code and error message - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (check for errors) - - ! ** - ! ** residual-based calculation of the numerical Jacobian - if(ixNumType==ixNumRes)then ! switch between the residual-based form and flux-based form - - ! (compute residual vector) - call xFluxResid(& - ! input - stateVecPerturbed, & ! intent(in): full state vector (mixed units) - scalarCanopyLiqLocal, & ! intent(in): trial value for the liquid water on the vegetation canopy (kg m-2) - scalarCanopyIceLocal, & ! intent(in): trial value for the ice on the vegetation canopy (kg m-2) - mLayerVolFracLiqLocal, & ! intent(in): trial value for the volumetric liquid water content in each snow and soil layer (-) - mLayerVolFracIceLocal, & ! intent(in): trial value for the volumetric ice in each snow and soil layer (-) - ! output - fluxVecJac, & ! intent(out): flux vector (mixed units) - resVecJac, & ! intent(out): residual vector (mixed units) - err,cmessage) ! intent(out): error code and error message - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (check for errors) - - - if(iJac==iTry)then - - !write(*,'(a)') 'fluxVecJac(iTry), fluxVec(iTry), (fluxVecJac(iTry) - fluxVec(iTry))/dx, (LH_fus*iden_water*(mLayerVolFracIceLocal(15)-mLayerVolFracIceTrial(15)))/dx = ' - !write(*,'(100(e25.15,1x))') fluxVecJac(iTry), fluxVec(iTry), (fluxVecJac(iTry) - fluxVec(iTry))/dx, (LH_fus*iden_water*(mLayerVolFracIceLocal(15)-mLayerVolFracIceTrial(15)))/dx - !write(*,'(a,1x,100(e25.15,1x))') 'fluxVecJac(4), fluxVec(4), (fluxVecJac(4) - fluxVec(4))/dx = ', & - ! fluxVecJac(4), fluxVec(4), (fluxVecJac(4) - fluxVec(4))/dx - write(*,'(a,1x,i4,1x,100(e25.15,1x))') 'test: iJac; resVec(iJac1:iJac2): ', iJac, resVec(iJac1:iJac2) - write(*,'(a,1x,i4,1x,100(e25.15,1x))') 'test: iJac; resVecJac(iJac1:iJac2): ', iJac, resVecJac(iJac1:iJac2) - write(*,'(a,1x,i4,1x,100(e25.15,1x))') 'test: iJac; resVecJac(iJac1:iJac2) - resVec(iJac1:iJac2): ', iJac, resVecJac(iJac1:iJac2) - resVec(iJac1:iJac2) - endif + end do ! looping through state variables - ! (compute the row of the Jacobian matrix) - nJac(:,iJac) = (resVecJac - resVec)/dx + ! end association with data structures + end associate - ! ** - ! ** flux-based calculation of the numerical Jacobian - else + end subroutine explicitMelt - ! NOTE: Need to increase cleverness and avoid copying vectors - ! --> can we do this as an associate statement? - ! extract the vegetation states from the state vector - if(computeVegFlux)then - scalarCanairTempLocal = stateVecPerturbed(ixCasNrg) - scalarCanopyTempLocal = stateVecPerturbed(ixVegNrg) - endif + ! ********************************************************************************************************** + ! private subroutine explicitUpdate: update the states using the explicit Euler method + ! ********************************************************************************************************** + subroutine explicitUpdate(& + indx_data, & ! intent(in) : state indices + mpar_data, & ! intent(in) : model parameters + prog_data, & ! intent(in) : model prognostic variables + stateVecInit, & ! intent(in) : initial state vector + stateVecUpdate, & ! intent(in) : state vector update + stateVecNew, & ! intent(out) : new state vector + constrained, & ! intent(out) : flag to denote if the state was constrained + err,message) ! intent(out) : error control + 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 + implicit none + ! input + type(var_ilength),intent(in) :: indx_data ! state indices + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_dlength),intent(in) :: prog_data ! model prognostic variables + real(dp) ,intent(in) :: stateVecInit(:) ! initial state vector + real(dp) ,intent(in) :: stateVecUpdate(:) ! state vector update + ! output + real(dp) ,intent(out) :: stateVecNew(:) ! new state vector + logical(lgt) ,intent(out) :: constrained ! flag to denote if the state was constrained + integer(i4b) ,intent(out) :: err ! error code + character(*) ,intent(out) :: message ! error message + ! local variables + integer(i4b) :: iState ! state index + integer(i4b) :: ixFullVector ! index in the full state vector + integer(i4b) :: ixControlIndex ! index of the control volume for different domains (veg, snow, soil) + real(dp) :: valueMin,valueMax ! minimum and maximum state values + real(dp),parameter :: tempChangeMax=1._dp ! maximum temperature change + ! -------------------------------------------------------------------------------------------------------------- + + ! make association with model indices defined in indexSplit + associate(& + 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 (-) + mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat, & ! intent(in): [dp(:)] volumetric fraction of ice (-) + 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 + 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] type of desired model state variables + ) ! associations - ! extract state variables for the snow and soil domain - mLayerTempLocal(1:nLayers) = stateVecPerturbed(ixSnowSoilNrg) - mLayerMatricHeadLocal(1:nSoil) = stateVecPerturbed(ixSoilOnlyMat) - - ! (compute fluxes) - call computFlux(& - ! input: state variables - scalarCanairTempLocal, & ! intent(in): trial value for the temperature of the canopy air space (K) - scalarCanopyTempLocal, & ! intent(in): trial value for the temperature of the vegetation canopy (K) - mLayerTempLocal, & ! intent(in): trial value for the temperature of each snow and soil layer (K) - mLayerMatricHeadLocal, & ! intent(in): trial value for the matric head in each soil layer (m) - ! input: diagnostic variables defining the liquid water and ice content - scalarCanopyLiqLocal, & ! intent(in): trial value for the liquid water on the vegetation canopy (kg m-2) - scalarCanopyIceLocal, & ! intent(in): trial value for the ice on the vegetation canopy (kg m-2) - mLayerVolFracLiqLocal, & ! intent(in): trial value for the volumetric liquid water content in each snow and soil layer (-) - mLayerVolFracIceLocal, & ! intent(in): trial value for the volumetric ice in each snow and soil layer (-) - ! output: flux vector - fluxVecJac, & ! 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; endif ! (check for errors) - - !if(iJac==iTry)then - ! write(*,'(a,1x,100(e25.15,1x))') 'mLayerMatricHeadLocal = ', mLayerMatricHeadLocal - ! write(*,'(a,1x,i4,1x,100(e25.15,1x))') 'test: iJac; fluxVec: ', iJac, fluxVec(iJac1:iJac2) - ! write(*,'(a,1x,i4,1x,100(e25.15,1x))') 'test: iJac; fluxVecJac: ', iJac, fluxVecJac(iJac1:iJac2) - !endif - - ! (compute the row of the Jacobian matrix) - nJac(:,iJac) = -dt*(fluxVecJac(:) - fluxVec(:))/dx - !if(iJac==iTry)then - ! write(*,'(a,1x,i4,1x,100(e15.5,1x))') 'test: iJac; nJac: ', iJac, nJac(iJac1:iJac2,iJac) - !endif - - ! (add in the diagonal matrix) - nJac(iJac,iJac) = nJac(iJac,iJac) + dMat(iJac) + ! initialize error control + err=0; message='explicitUpdate/' - endif + ! initialize the flag to denote if the state is constrained + constrained=.false. - ! (print progress) - if(iJac==iTry)then - write(*,'(a,1x,3(f20.10,1x))') 'stateVec(iJac), stateVecPerturbed(iJac), dx = ', stateVec(iJac), stateVecPerturbed(iJac), dx - write(*,'(a,1x,2(e20.10,1x))') 'fluxVec(iJac), fluxVecJac(iJac) = ', fluxVec(iJac), fluxVecJac(iJac) - write(*,'(a,1x,2(e20.10,1x))') 'fluxVec(iJac+1), fluxVecJac(iJac+1) = ', fluxVec(iJac+1), fluxVecJac(iJac+1) - write(*,'(a,1x,i4,1x,100(e15.5,1x))') 'iJac; nJac: ', iJac, nJac(iJac1:iJac2,iJac) - endif + ! loop through model states + do iState=1,size(stateVecInit) - ! (test) - !if(iJac<10) write(*,'(a,1x,10(e15.5,1x))') 'fluxVecJac(1:10) = ', fluxVecJac(1:10) - !if(iJac==iTry) write(*,'(a,1x,i4,1x,10(f20.14,1x))') 'iTry, stateVec(iTry), stateVecPerturbed(iTry) = ', iTry, stateVec(iTry), stateVecPerturbed(iTry) - !if(iJac==iTry) write(*,'(a,1x,i4,1x,10(f20.8,1x))'), 'iTry, -dt*(fluxVecJac(iTry) - fluxVec(iTry))/dx = ', iTry, -dt*(fluxVecJac(iTry) - fluxVec(iTry))/dx - !if(iJac==iTry) pause ' in numerical Jacobian calculations' - - ! (set the state back to the input value) - stateVecPerturbed(iJac) = stateVec(iJac) - - ! (set the liquid water content back to the input value) - mLayerVolFracLiqLocal = mLayerVolFracLiqTrial - - ! (set the ice content back to the input value) - scalarCanopyIceLocal = scalarCanopyIceTrial - mLayerVolFracIceLocal = mLayerVolFracIceTrial - - end do ! (looping through state variables) - - ! print the Jacobian - print*, '** numerical Jacobian:', ixNumType==ixNumRes - write(*,'(a4,1x,100(i12,1x))') 'xCol', (iLayer, iLayer=iJac1,iJac2) - do iJac=iJac1,iJac2; write(*,'(i4,1x,100(e12.5,1x))') iJac, nJac(iJac1:iJac2,iJac); end do - !pause 'testing Jacobian' - - end subroutine numlJacob - - - ! ********************************************************************************************************* - ! internal subroutine lapackSolv: use the lapack routines to solve the linear system A.X=B - ! ********************************************************************************************************* - subroutine lapackSolv(aJac,rVec,grad,xInc,err,message) - implicit none - ! dummy - real(dp),intent(inout) :: aJac(:,:) ! input = the Jacobian matrix A; output = decomposed matrix - real(qp),intent(in) :: rVec(:) ! the residual vector B - real(dp),intent(out) :: grad(:) ! gradient of the function vector - real(dp),intent(out) :: xInc(:) ! the solution vector X - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! local - integer(i4b) :: iJac ! index of row of the Jacobian matrix - integer(i4b) :: iState,jState,kState ! indices of state variables - ! initialize error control - select case(ixSolve) - case(ixFullMatrix); message='lapackSolv/dgesv/' - case(ixBandMatrix); message='lapackSolv/dgbsv/' - case default; err=20; message=trim(message)//'unable to identify option for the type of matrix' - end select + ! get index of the control volume within the domain + ixFullVector = ixMapSubset2Full(iState) ! index within full state vector + ixControlIndex = ixControlVolume(ixFullVector) ! index within a given domain - ! -------------------------------------------------------------- - ! * scale variables - ! -------------------------------------------------------------- - - ! select the option used to solve the linear system A.X=B - select case(ixSolve) - - ! * full Jacobian matrix - case(ixFullMatrix) - do iJac=1,nState - aJac(iJac,1:nState) = aJac(iJac,1:nState)/fscale(iJac) - end do - !print*, '** analytical Jacobian:' - !write(*,'(a4,1x,100(i12,1x))') 'xCol', (iLayer, iLayer=iJac1,iJac2) - !do iLayer=iJac1,iJac2; write(*,'(i4,1x,100(e12.5,1x))') iLayer, aJac(iJac1:iJac2,iLayer); end do - - ! ** test band diagonal matrix - if(testBandDiagonal)then - - aJac_test(:,:)=0._dp - ! form band-diagonal matrix - do iState=1,nState - do jState=max(1,iState-ku),min(nState,iState+kl) - aJac_test(kl + ku + 1 + jState - iState, iState) = aJac(jState,iState) - if(iState<6 .or. jState<6) write(*,'(2(i4,1x),e11.5)') jState,iState,aJac(jState,iState) - end do - end do - print*, '** test banded analytical Jacobian:' - write(*,'(a4,1x,100(i11,1x))') 'xCol', (iLayer, iLayer=iJac1,iJac2) - do iLayer=kl+1,nBands; write(*,'(i4,1x,100(e11.5,1x))') iLayer, aJac_test(iLayer,iJac1:iJac2); end do - !pause - - endif ! (if desire to test band-diagonal matric - - - - ! * band-diagonal matrix - case(ixBandMatrix) - do iJac=1,nState ! (loop through state variables) - do iState=kl+1,nBands ! (loop through elements of the band-diagonal matrix) - kState = iState + iJac - kl - ku - 1 - if(kState<1 .or. kState>nState)cycle - aJac(iState,iJac) = aJac(iState,iJac)/fscale(kState) - end do ! looping through elements of the band-diagonal matric - end do ! looping through state variables - !print*, '** analytical Jacobian:' - !write(*,'(a4,1x,100(i11,1x))') 'xCol', (iLayer, iLayer=iJac1,iJac2) - !do iLayer=kl+1,nBands; write(*,'(i4,1x,100(e11.5,1x))') iLayer, aJac(iLayer,iJac1:iJac2); end do - !pause - - end select ! (option to solve the linear system A.X=B) - - - ! form the rhs matrix - ! NOTE: scale the residual vector - rhs(1:nState,1) = -real(rVec(1:nState), dp)/fScale(1:nState) - - ! -------------------------------------------------------------- - ! * compute the gradient of the function vector - ! -------------------------------------------------------------- - - ! compute the gradient of the function vector - select case(ixSolve) - - ! full Jacobian matrix - case(ixFullMatrix) - grad = matmul(-rhs(1:nState,1),aJac) - - ! band-diagonal matrix - case(ixBandMatrix) - do iJac=1,nState ! (loop through state variables) - - grad(iJac) = 0._dp - do iState=kl+1,nBands ! (loop through elements of the band-diagonal matrix) - - ! identify indices in the band-diagonal matrix - kState = iJac + iState-2*kl - if(kState < 1 .or. kState > nState)cycle - !if(iJac>99)& - !write(*,'(a,1x,3(i4,1x),e15.5)') 'iJac,iState,kState = ', iJac,iState,kState,aJac(iState,iJac) - - ! calculate gradient (long-hand matrix multiplication) - grad(iJac) = grad(iJac) - aJac(iState,iJac)*rhs(kState,1) - - end do ! looping through elements of the band-diagonal matric - end do ! looping through state variables - - end select ! (option to solve the linear system A.X=B) - - !print*, '(ixSolve == ixFullMatrix) = ', (ixSolve == ixFullMatrix) - !do iLayer=100,nState - ! write(*,'(i4,1x,f20.10)') iLayer, grad(iLayer) - !end do - !pause - - ! -------------------------------------------------------------- - ! * solve the linear system A.X=B - ! -------------------------------------------------------------- - - ! identify option to solve the linear system A.X=B - select case(ixSolve) - - ! lapack: use the full Jacobian matrix to solve the linear system A.X=B - case(ixFullMatrix) - call dgesv(nState, & ! intent(in): [i4b] number of state variables - nRHS, & ! intent(in): [i4b] number of columns of the matrix B - aJac, & ! intent(inout): [dp(nState,nState)] input = the nState-by-nState Jacobian matrix A; output = decomposed matrix - nState, & ! intent(in): [i4b] the leading dimension of aJac - iPiv, & ! intent(out): [i4b(nState)] defines if row i of the matrix was interchanged with row iPiv(i) - rhs, & ! intent(inout): [dp(nState,nRHS)] input = the nState-by-nRHS matrix of matrix B; output: the solution matrix X - nState, & ! intent(in): [i4b] the leading dimension of matrix rhs - err) ! intent(out) [i4b] error code - - ! lapack: use the band diagonal matrix to solve the linear system A.X=B - case(ixBandMatrix) - call dgbsv(nState, & ! intent(in): [i4b] number of state variables - kl, & ! intent(in): [i4b] number of subdiagonals within the band of A - ku, & ! intent(in): [i4b] number of superdiagonals within the band of A - nRHS, & ! intent(in): [i4b] number of columns of the matrix B - aJac, & ! intent(inout): [dp(nBands,nState)] input = the nBands-by-nState Jacobian matrix A; output = decomposed matrix - nBands, & ! intent(in): [i4b] the leading dimension of aJac - iPiv, & ! intent(out): [i4b(nState)] defines if row i of the matrix was interchanged with row iPiv(i) - rhs, & ! intent(inout): [dp(nState,nRHS)] input = the nState-by-nRHS matrix of matrix B; output: the solution matrix X - nState, & ! intent(in): [i4b] the leading dimension of matrix rhs - err) ! intent(out) [i4b] error code - - ! check that we found a valid option (should not get here because of the check above; included for completeness) - case default; err=20; message=trim(message)//'unable to identify option for the type of matrix' - - end select ! (option to solve the linear system A.X=B) - - ! -------------------------------------------------------------- - ! * wrap-up - ! -------------------------------------------------------------- - - ! identify any errors - if(err/=0)then - if(err<0)then - write(message,'(a,i0,a)') trim(message)//'the ',err,'-th argument had an illegal value' - err=abs(err); return - else - write(message,'(a,i0,a,i0,a)') trim(message)//'U(',err,',',err,') is exactly zero - factorization complete, but U is singular so the solution could not be completed' - return - endif - endif + ! update the state vector + stateVecNew(iState) = stateVecInit(iState) + stateVecUpdate(iState) - ! extract the iteration increment - xInc(1:nState) = rhs(1:nState,1) - - !print*, 'xInc: (ixSolve == ixFullMatrix) = ', (ixSolve == ixFullMatrix) - !do iLayer=1,nState - ! write(*,'(i4,1x,f20.10)') iLayer, xInc(iLayer) - !end do - !pause - - end subroutine lapackSolv - - - ! ********************************************************************************************************* - ! internal subroutine lineSearch: perform the line search - ! ********************************************************************************************************* - ! Routine modified extentively from Numerical Recipes in Fortran (Press et al. 1998) to - ! 1) Make use of local variables for the flux and residual calculations; - ! 2) Scale function evaluations and state vectors; - ! 3) Return error code and message; - ! 4) Additonal comments. - ! ************************************************************************************************ - subroutine lineSearch(& - ! input - doLineSearch, & ! intent(in): flag to denote the need to perform line search - xOld, & ! intent(in): initial state vector - fOld, & ! intent(in): function value for trial state vector (mixed units) - g, & ! intent(in): gradient of the function vector (mixed units) - p, & ! intent(in): iteration increment (mixed units) - ! output - x, & ! intent(out): new state vector (m) - fVec, & ! intent(out): new flux vector (mixed units) - rVec, & ! intent(out): new residual vector (mixed units) - f, & ! intent(out): new function value (mixed units) - converged, & ! intent(out): convergence flag - err,message) ! intent(out): error control - IMPLICIT NONE - ! input variables - logical(lgt),intent(in) :: doLineSearch - REAL(DP), DIMENSION(:), INTENT(IN) :: xOld,g - REAL(DP), DIMENSION(:), INTENT(INOUT) :: p - REAL(DP), INTENT(IN) :: fOld - ! output variables - REAL(DP), DIMENSION(:), INTENT(OUT) :: x,fVec - REAL(QP), DIMENSION(:), INTENT(OUT) :: rVec - REAL(DP), INTENT(OUT) :: f - logical(lgt) :: 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 - ! variables for the line search - REAL(DP), PARAMETER :: ALF=1.0e-4_dp,TOLX=epsilon(x),xTolInc=1.0e-4_dp - INTEGER(I4B) :: ndum,iterLS,iMax(1) - integer(i4b),parameter :: maxiterLS=5 - REAL(DP) :: a,alam,alam2,alamin,b,disc,f2,fold2,pabs,rhs1,rhs2,slope,& - tmplam - ! NOTE: these variables are only used for testing - !real(dp),dimension(size(xOld)) :: rVecOld - !integer(i4b) :: iCheck - ! initialize error control - err=0; message="lineSearch/" - - ! check arguments - if ( all((/size(g),size(p),size(x)/) == size(xold)) ) then - ndum=size(xold) - else - err=20; message=trim(message)//"sizeMismatch"; return + ! impose non-negativity constraints for the mass of water on the vegetation canopy + if(ixStateType_subset(iState)==iname_watCanopy .or. ixStateType_subset(iState)==iname_liqCanopy)then + if(stateVecNew(iState) < 0._dp)then + stateVecNew(iState)=0._dp + constrained=.true. + endif endif - ! define step size and initialize tolerances - if(doLineSearch)then - pabs=norm2(p/xscale) ! NOTE: norm2 is the Euclidean norm - if (pabs > stpmax) p(:)=p(:)*stpmax/pabs ! reduce step if it is too big - slope=dot_product(g,p) - alamin=TOLX/maxval(abs(p(:))/max(abs(xold(:)),xscale)) ! minimum lambda - endif - alam=1.0_dp - - ! backtrack - do iterLS=1,maxIterLS - - ! update the state vector - x(:)=xold(:)+alam*p(:) - - ! use constitutive functions to compute unknown terms removed from the state equations... - call updatState(& - x, & ! intent(in): full state vector (mixed units) - mLayerVolFracLiqTrial, & ! intent(out): volumetric fraction of liquid water (-) - mLayerVolFracIceTrial, & ! intent(out): volumetric fraction of ice (-) - scalarCanopyLiqTrial, & ! intent(out): mass of canopy liquid (kg m-2) - scalarCanopyIceTrial, & ! intent(out): mass of canopy ice (kg m-2) - err,cmessage) ! intent(out): error code and error message - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (check for errors) - - ! compute flux vector and residual - call xFluxResid(& - ! input - x, & ! intent(in): full state vector (mixed units) - 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 (-) - ! output - fVec, & ! intent(out): flux vector (mixed units) - rVec, & ! intent(out): residual vector (mixed units) - err,cmessage) ! intent(out): error code and error message - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (check for errors) - - ! compute the function evaluation - f=0.5_dp*norm2(real(rVec, dp)/fScale) ! NOTE: norm2 = sqrt(sum((rVec/fScale)**2._dp)) - - ! check - if(globalPrintFlag)then - print*, '***' - write(*,'(a,1x,100(e14.5,1x))') trim(message)//': alam, fOld, f = ', alam, fOld, f - write(*,'(a,1x,100(f20.8,1x))') trim(message)//': x(iJac1:iJac2) = ', x(iJac1:iJac2) - write(*,'(a,1x,100(f20.12,1x))') trim(message)//': p(iJac1:iJac2) = ', p(iJac1:iJac2) - write(*,'(a,1x,100(e20.5,1x))') trim(message)//': rVec(iJac1:iJac2) = ', rVec(iJac1:iJac2) + ! impose minimum and maximum storage constraints for volumetric water + if(ixStateType_subset(iState)==iname_watLayer .or. ixStateType_subset(iState)==iname_liqLayer)then + select case( ixDomainType_subset(iState) ) + case(iname_snow) + valueMin = 0._dp + valueMax = merge(iden_ice/iden_water, 1._dp - mLayerVolFracIce(ixControlIndex), ixStateType_subset(iState)==iname_watLayer) + case(iname_soil) + valueMin = theta_res(ixControlIndex) + valueMax = theta_sat(ixControlIndex) + case default; err=20; message=trim(message)//'expect domain type to be iname_snow or iname_soil'; return + end select + if(stateVecNew(iState) < valueMin)then + stateVecNew(iState)=valueMin + constrained=.true. endif - - ! check - !if(iterLS>1)then !.and. printFlag)then - ! do iCheck=1,size(xOld) - ! write(*,'(i4,1x,10(e20.10,1x))') iCheck, rVec(iCheck), rVecOld(iCheck), fScale(iCheck) - ! end do - !endif - !rVecOld = rVec - - ! return if not doing the line search - if(.not.doLineSearch)then - converged = checkConv(rVec,p,x,soilWaterBalanceError) - return + if(stateVecNew(iState) > valueMax)then + stateVecNew(iState)=valueMax + constrained=.true. endif - - ! check convergence - ! NOTE: this must be after the first flux call - converged = checkConv(rVec,p,x,soilWaterBalanceError) - if(converged) return - - ! check if backtracked all the way to the original value - if (iterLS==maxIterLS) then !if (alam < alamin) then - x(:)=xold(:) - !print*, '*****************************************************************************' - !print*, '*****************************************************************************' - !print*, '*****************************************************************************' - !print*, '*****************************************************************************' - !print*, '** backtrack' - err=-10; message=trim(message)//'warning: check convergence' - RETURN - - ! check if improved the solution sufficiently - else if (f <= fold+ALF*alam*slope) then - RETURN - - ! build another trial vector - else - if (alam == 1.0_dp) then - tmplam=-slope/(2.0_dp*(f-fold-slope)) - if (tmplam > 0.5_dp*alam) tmplam=0.5_dp*alam - else - rhs1=f-fold-alam*slope - rhs2=f2-fold2-alam2*slope - a=(rhs1/alam**2-rhs2/alam2**2)/(alam-alam2) - b=(-alam2*rhs1/alam**2+alam*rhs2/alam2**2)/& - (alam-alam2) - if (a == 0.0_dp) then - tmplam=-slope/(2.0_dp*b) - else - disc=b*b-3.0_dp*a*slope - if (disc < 0.0_dp)then; err=-10; message=trim(message)//'warning: roundoff problem in lnsrch'; return; endif - tmplam=(-b+sqrt(disc))/(3.0_dp*a) - end if - if (tmplam > 0.5_dp*alam) tmplam=0.5_dp*alam - end if - end if - alam2=alam - f2=f - fold2=fold - alam=max(tmplam,0.1_dp*alam) - - end do - END SUBROUTINE lineSearch - - - ! ********************************************************************************************************* - ! internal function checkConv: check convergence based on the residual vector - ! ********************************************************************************************************* - function checkConv(rVec,xInc,xVec,soilWatbalErr) - implicit none - ! dummies - real(qp),intent(in) :: rVec(:) ! residual vector (mixed units) - real(dp),intent(in) :: xInc(:) ! iteration increment (mixed units) - real(dp),intent(in) :: xVec(:) ! state vector (mixed units) - real(dp),intent(in) :: soilWatbalErr ! soil water balance error (m) - logical(lgt) :: checkConv ! flag to denote convergence - ! locals - real(dp),dimension(nSoil) :: psiScale ! scaling factor for matric head - real(dp),parameter :: xSmall=1.e-0_dp ! a small offset - logical(lgt) :: watbalConv ! flag for total 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 - - ! check convergence based on the residuals for energy (J m-3) - if(computeVegFlux)then - !canopy_max = abs(rVec(ixVegWat)) - energy_max = real(maxval(abs( (/rVec(ixCasNrg), rVec(ixVegNrg), rVec(ixSnowSoilNrg)/) ) ), dp) - energy_loc = maxloc(abs( (/rVec(ixCasNrg), rVec(ixVegNrg), rVec(ixSnowSoilNrg)/) ) ) - else - energy_max = real(maxval(abs( rVec(ixSnowSoilNrg) ) ), dp) - energy_loc = maxloc(abs( rVec(ixSnowSoilNrg) ) ) endif - ! check convergence based on the residuals for volumetric liquid water content (-) - liquid_max = real(maxval(abs( rVec(ixSnowSoilWat) ) ), dp) - liquid_loc = maxloc(abs( rVec(ixSnowSoilWat) ) ) - - ! 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 - psiScale = abs(xVec(ixSoilOnlyMat)) + xSmall ! avoid divide by zero - matric_max = maxval(abs( xInc(ixSoilOnlyMat)/psiScale ) ) - matric_loc = maxloc(abs( xInc(ixSoilOnlyMat)/psiScale ) ) + ! impose below-freezing constraints for snow temperature + if(ixDomainType_subset(iState)==iname_snow .and. ixStateType_subset(iState)==iname_nrgLayer)then + if(stateVecNew(iState) > Tfreeze)then + stateVecNew(iState)=Tfreeze + constrained=.true. + endif + endif - ! convergence check - watbalConv = (soilWatbalErr < absConvTol_watbal) ! absolute error in total soil water balance (m) - matricConv = (matric_max(1) < absConvTol_matric) ! NOTE: based on iteration increment - liquidConv = (liquid_max(1) < absConvTol_liquid) ! (based on the residual) - energyConv = (energy_max(1) < absConvTol_energy) ! (based on the residual) + ! ensure that temperature change is less than a specified threshold + if(ixStateType_subset(iState)==iname_nrgCanair .or. ixStateType_subset(iState)==iname_nrgCanopy .or. ixStateType_subset(iState)==iname_nrgLayer)then + if(abs( stateVecUpdate(iState) ) > tempChangeMax)then + stateVecNew(iState)=stateVecInit(iState) + sign(tempChangeMax,stateVecUpdate(iState)) + constrained=.true. + endif ! if constraining temperatures + endif ! if an energy state - ! print progress towards solution - if(globalPrintFlag)then - print*, 'iter, dt = ', iter, dt - write(*,'(a,1x,4(e15.5,1x),3(i4,1x),3(L1,1x))') 'fNew, matric_max(1), liquid_max(1), energy_max(1), matric_loc(1), liquid_loc(1), energy_loc(1), matricConv, liquidConv, energyConv = ', & - fNew, matric_max(1), liquid_max(1), energy_max(1), matric_loc(1), liquid_loc(1), energy_loc(1), matricConv, liquidConv, energyConv - endif + end do ! looping through states - ! final convergence check - checkConv = (matricConv .and. liquidConv .and. energyConv) + ! end association to the information in the data structures + end associate - end function checkConv + end subroutine explicitUpdate - end subroutine systemSolv - ! ********************************************************************************************************** - ! private 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 - 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 (-) - mLayerdTheta_dPsi, & ! intent(in): derivative in the soil water characteristic (m-1) - 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 - real(dp),intent(in) :: mLayerMatricHead(:) ! matric head at the start of the time step (m) - real(dp),intent(in) :: mLayerMatricHeadTrial(:) ! trial value for matric head (m) - real(dp),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) - real(dp),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) - real(dp),intent(in) :: mLayerdTheta_dPsi(:) ! derivative in the soil water characteristic (m-1) - real(dp),intent(in) :: specificStorage ! specific storage coefficient (m-1) - real(dp),intent(in) :: theta_sat ! soil porosity (-) - ! output: - real(dp),intent(out) :: compress(:) ! soil compressibility (-) - real(dp),intent(out) :: 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 - character(LEN=256) :: cmessage ! error message of downwind routine - real(dp) :: volFracWat ! total volumetric fraction of water (-) - real(dp) :: fPart1,fPart2 ! different parts of the function - real(dp) :: dPart1,dPart2 ! derivatives for different parts of the function - 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,nSoil - ! compute the total volumetric fraction of water (-) - volFracWat = mLayerVolFracLiqTrial(iLayer) + mLayerVolFracIceTrial(iLayer) - ! compute the compressibility term (-) - compress(iLayer) = (specificStorage*volFracWat/theta_sat) * (mLayerMatricHeadTrial(iLayer) - mLayerMatricHead(iLayer)) - ! compute the derivative for the compressibility term (m-1) - fPart1 = specificStorage*(volFracWat/theta_sat) ! function for the 1st part (m-1) - fPart2 = mLayerMatricHeadTrial(iLayer) - mLayerMatricHead(iLayer) ! function for the 2nd part (m) - dPart1 = mLayerdTheta_dPsi(iLayer)*specificStorage/theta_sat ! derivative for the 1st part (m-2) - dPart2 = 1._dp ! derivative for the 2nd part (-) - dCompress_dPsi(iLayer) = fPart1*dPart2 + dPart1*fPart2 ! m-1 - end do - else - compress(:) = 0._dp - dCompress_dPsi(:) = 0._dp - endif - end subroutine soilCmpres end module systemSolv_module diff --git a/build/source/engine/tempAdjust.f90 b/build/source/engine/tempAdjust.f90 old mode 100644 new mode 100755 index c25082522..787d80108 --- a/build/source/engine/tempAdjust.f90 +++ b/build/source/engine/tempAdjust.f90 @@ -42,16 +42,17 @@ subroutine tempAdjust(& canopyDepth, & ! intent(in): canopy depth (m) ! input/output: data structures mpar_data, & ! intent(in): model parameters - mvar_data, & ! intent(inout): model variables for a local HRU + 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,message) ! intent(out): error control ! ------------------------------------------------------------------------------------------------ ! provide access to the derived types to define the data structures - USE data_struc,only:& + USE data_types,only:& var_d, & ! data vector (dp) var_dlength ! data vector with variable length dimension (dp) ! provide access to named variables defining elements in the data structures - USE var_lookup,only:iLookPARAM,iLookMVAR ! named variables for structure elements + USE var_lookup,only:iLookPARAM,iLookPROG,iLookDIAG ! named variables for structure elements ! utility routines USE snow_utils_module,only:fracliquid ! compute fraction of liquid water USE snow_utils_module,only:dFracLiq_dTk ! differentiate the freezing curve w.r.t. temperature (snow) @@ -60,8 +61,9 @@ subroutine tempAdjust(& ! input: derived parameters real(dp),intent(in) :: canopyDepth ! depth of the vegetation canopy (m) ! input/output: data structures - type(var_d),intent(in) :: mpar_data ! model parameters - type(var_dlength),intent(inout) :: mvar_data ! model variables for a local HRU + 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 @@ -70,7 +72,6 @@ subroutine tempAdjust(& integer(i4b) :: iTry ! trial index integer(i4b) :: iter ! iteration index integer(i4b),parameter :: maxiter=100 ! maximum number of iterations - real(dp),parameter :: dx=1.e-6_dp ! finite difference increment (used to test derivatives) real(dp) :: fLiq ! fraction of liquid water (-) real(dp) :: tempMin,tempMax ! solution constraints for temperature (K) real(dp) :: nrgMeltFreeze ! energy required to melt-freeze the water to the current canopy temperature (J m-3) @@ -87,17 +88,17 @@ subroutine tempAdjust(& associate(& ! model parameters for canopy thermodynamics (input) - snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale), & ! intent(in): [dp] scaling factor for snow freezing curve (K) - specificHeatVeg => mpar_data%var(iLookPARAM%specificHeatVeg), & ! intent(in): [dp] specific heat of vegetation mass (J kg-1 K-1) - maxMassVegetation => mpar_data%var(iLookPARAM%maxMassVegetation), & ! 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 => mvar_data%var(iLookMVAR%scalarCanopyLiq)%dat(1), & ! intent(inout): [dp] mass of liquid water on the vegetation canopy (kg m-2) - scalarCanopyIce => mvar_data%var(iLookMVAR%scalarCanopyIce)%dat(1), & ! intent(inout): [dp] mass of ice on the vegetation canopy (kg m-2) - scalarCanopyTemp => mvar_data%var(iLookMVAR%scalarCanopyTemp)%dat(1), & ! intent(inout): [dp] temperature of the vegetation canopy (K) + 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 => mvar_data%var(iLookMVAR%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 ! ----------------------------------------------------------------------------------------------------------------------------------------------------- @@ -152,9 +153,9 @@ subroutine tempAdjust(& if(iter==maxiter)then message=trim(message)//'unable to bracket the root' err=20; return - endif + end if end do ! trying to bracket the root - endif ! first check that we bracketed the root + end if ! first check that we bracketed the root !print*, 'x1, x2 = ', x1, x2 !print*, 'f1, f2 = ', f1, f2 @@ -165,7 +166,7 @@ subroutine tempAdjust(& else tempMin = x2 tempMax = x1 - endif + end if !print*, 'tempMin, tempMax = ', tempMin, tempMax ! get starting trial @@ -196,7 +197,7 @@ subroutine tempAdjust(& xTry = xTry + xInc fBis = .false. - endif ! (switch between bi-section and newton) + end if ! (switch between bi-section and newton) ! compute new function and derivative fTry = resNrgFunc(xTry,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) @@ -208,7 +209,7 @@ subroutine tempAdjust(& tempMax = min(xTry,tempMax) else tempMin = max(tempMin,xTry) - endif + end if ! check the functions at the limits (should be of opposing sign) !f1 = resNrgFunc(tempMax,scalarCanopyTemp,scalarBulkVolHeatCapVeg,snowfrz_scale) @@ -232,7 +233,7 @@ subroutine tempAdjust(& ! (return with error) message=trim(message)//'unable to converge' err=20; return - endif + end if end do ! iterating ! ----------------------------------------------------------------------------------------------------------------------------------------------------- diff --git a/build/source/engine/time_utils.f90 b/build/source/engine/time_utils.f90 old mode 100644 new mode 100755 index b9372ea7c..5b33759d5 --- a/build/source/engine/time_utils.f90 +++ b/build/source/engine/time_utils.f90 @@ -24,6 +24,8 @@ module time_utils_module private public::extractTime public::compjulday +public::compcalday +public::elapsedSec contains @@ -53,45 +55,46 @@ subroutine extractTime(refdate,iyyy,im,id,ih,imin,dsec,err,message) istart = istart+iend else istart=1 - endif + end if ! get the year call extract(refdate(istart:n),"-",iend,iyyy,err,message); if (err/=0) return - if(iyyy < 1900)then; err=20; message=trim(message)//'year < 1900'; return; endif - if(iyyy > 2100)then; err=20; message=trim(message)//'year > 2100'; return; endif + if(iyyy < 1900)then; err=20; message=trim(message)//'year < 1900'; return; end if + if(iyyy > 2100)then; err=20; message=trim(message)//'year > 2100'; return; end if ! get the month istart=istart+iend call extract(refdate(istart:n),"-",iend,im,err,message); if (err/=0) return - if(im < 1)then; err=20; message=trim(message)//'month < 1'; return; endif - if(im > 12)then; err=20; message=trim(message)//'month > 12'; return; endif + if(im < 1)then; err=20; message=trim(message)//'month < 1'; return; end if + if(im > 12)then; err=20; message=trim(message)//'month > 12'; return; end if ! get the day istart=istart+iend call extract(refdate(istart:n)," ",iend,id,err,message); if (err/=0) return - if(id < 1)then; err=20; message=trim(message)//'day < 1'; return; endif - if(id > 31)then; err=20; message=trim(message)//'day > 31'; return; endif + if(id < 1)then; err=20; message=trim(message)//'day < 1'; return; end if + if(id > 31)then; err=20; message=trim(message)//'day > 31'; return; end if ! check if we are at the end of the string if (istart+(iend-2)==n) then ih=0; imin=0; dsec=0._dp; return - endif - print*, 'iyyy, im, id = ', iyyy, im, id + end if ! get the hour (":" at end of hour) istart = istart+iend - if(istart > len_trim(refdate))then; err=20; message=trim(message)//'string does not include hours'; return; endif + if(istart > len_trim(refdate))then; err=20; message=trim(message)//'string does not include hours'; return; end if call extract(refdate(istart:n),":",iend,ih,err,message); if (err/=0) return - if(ih < 0)then; err=20; message=trim(message)//'hour < 0'; return; endif - if(ih > 24)then; err=20; message=trim(message)//'hour > 24'; return; endif + if(ih < 0)then; err=20; message=trim(message)//'hour < 0'; return; end if + if(ih > 24)then; err=20; message=trim(message)//'hour > 24'; return; end if ! get the minute (":" at end of minute) istart = istart+iend - if(istart > len_trim(refdate))then; err=20; message=trim(message)//'string does not include minutes'; return; endif + if(istart > len_trim(refdate))then; err=20; message=trim(message)//'string does not include minutes'; return; end if call extract(refdate(istart:n),":",iend,imin,err,message); if (err/=0) return - if(imin < 0)then; err=20; message=trim(message)//'minute < 0'; return; endif - if(imin > 60)then; err=20; message=trim(message)//'minute > 60'; return; endif + if(imin < 0)then; err=20; message=trim(message)//'minute < 0'; return; end if + if(imin > 60)then; err=20; message=trim(message)//'minute > 60'; return; end if + ! get the second istart = istart+iend if(istart > len_trim(refdate)) return iend = index(refdate(istart:n)," ") read(refdate(istart:n),*) dsec + !write(*,'(a,i4,1x,4(i2,1x))') 'refdate: iyyy, im, id, ih, imin = ', iyyy, im, id, ih, imin contains @@ -119,8 +122,8 @@ subroutine extract(substring,cdelim,iend,itemp,err,message) read(substring(1:iend-1),*,iostat=err) itemp ! read error if (err/=0) then - err=20; message=trim(message)//"unexpectedCharacters/[string='"//trim(substring)//"']"; return - endif + err=20; message=trim(message)//"unexpected characters [string='"//trim(substring)//"']"; return + end if end subroutine extract end subroutine extractTime @@ -152,19 +155,19 @@ subroutine compjulday(iyyy,mm,id,ih,imin,dsec,& ! input ! compute julian day jy=iyyy - if (jy.eq.0) then; err=10; message=trim(message)//"noYearZero/"; return; endif + if (jy.eq.0) then; err=10; message=trim(message)//"noYearZero/"; return; end if if (jy.lt.0) jy=jy+1 if (mm.gt.2) then jm=mm+1 else jy=jy-1 jm=mm+13 - endif + end if julday=int(365.25*jy)+int(30.6001*jm)+id+1720995 if (id+31*(mm+12*iyyy).ge.IGREG) then ja=int(0.01*jy) julday=julday+2-ja+int(0.25*ja) - endif + end if ! compute fraction of the day jfrac = (real(ih,kind(dp))*secprhour + real(imin,kind(dp))*secprmin + dsec) / secprday @@ -174,5 +177,131 @@ subroutine compjulday(iyyy,mm,id,ih,imin,dsec,& ! input end subroutine compjulday + ! *************************************************************************************** + ! public subroutine compgregcal: convert julian day (units of days) to calendar date + ! source: https://en.wikipedia.org/wiki/Julian_day#Julian_or_Gregorian_calendar_from_Julian_day_number + ! *************************************************************************************** + + subroutine compcalday(julday, & !input + iyyy,mm,id,ih,imin,dsec,err,message) !output + USE multiconst,only:secprmin ! seconds in an (day, hour, minute) + implicit none + + ! input variables + real(dp), intent(in) :: julday ! julian day + + ! output varibles + integer(i4b), intent(out) :: iyyy ! year + integer(i4b), intent(out) :: mm ! month + integer(i4b), intent(out) :: id ! day + integer(i4b), intent(out) :: ih ! hour + integer(i4b), intent(out) :: imin ! minute + real(dp), intent(out) :: dsec ! seconds + integer(i4b), intent(out) :: err ! error code + character(*), intent(out) :: message ! error message + + ! local parameters + integer(i4b),parameter :: y = 4716 + integer(i4b),parameter :: j = 1401 + integer(i4b),parameter :: m = 2 + integer(i4b),parameter :: n = 12 + integer(i4b),parameter :: r = 4 + integer(i4b),parameter :: p = 1461 + integer(i4b),parameter :: v = 3 + integer(i4b),parameter :: u = 5 + integer(i4b),parameter :: s = 153 + integer(i4b),parameter :: w = 2 + integer(i4b),parameter :: b = 274277 + integer(i4b),parameter :: c = -38 + real(dp),parameter :: hr_per_day = 24.0_dp + real(dp),parameter :: min_per_hour = 60.0_dp + + ! local variables + integer(i4b) :: f,e,g,h ! various step variables from wikipedia + integer(i4b) :: step_1a,step_1b,step_1c,step_1d ! temporary variables for calendar calculations + real(dp) :: frac_day ! fractional day + real(dp) :: remainder ! remainder of modulus operation + + ! initialize errors + err=0; message="compcalday" + if(julday<=0)then;err=10;message=trim(message)//"no negative julian days/"; return; end if + + ! step 1 + step_1a = 4*int(julday)+b + step_1b = step_1a/146097 + step_1c = step_1b*3 + step_1d = step_1c/4 + + f = int(julday)+j+step_1d+c + + ! step 2 + e = r * f + v + + ! step 3 + g = mod(e,p)/r + + ! step 4 + h = u * g + w + + ! find day + id = (mod(h,s))/u + 1 + + ! find month + mm = mod(h/s+m,n)+1 + + ! find year + iyyy = (e/p)-y + (n+m-mm)/n + + ! now find hour,min,second + + frac_day = julday - floor(julday) + ih = floor((frac_day+1e-9)*hr_per_day) + + remainder = (frac_day+1e-9)*hr_per_day - ih + imin = floor(remainder*min_per_hour) + + remainder = remainder*min_per_hour - imin + dsec = nint(remainder*secprmin) + + end subroutine compcalday + + ! *************************************************************************************** + ! public function elapsedSec: calculate difference of two time marks obtained by date_and_time() + ! *************************************************************************************** + function elapsedSec(startTime, endTime) + USE multiconst,only : secprday,secprhour,secprmin ! seconds in an (day, hour, minute) + integer(i4b),intent(in) :: startTime(8),endTime(8) ! state time and end time + real(dp) :: elapsedSec ! elapsed time in seconds + ! local variables + integer(i4b) :: elapsedDay ! elapsed full days + integer(i4b) :: yy ! index of year + ! number of days of each month + integer(i4b) :: days1(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/) + integer(i4b) :: days2(12) = (/31,28,31,30,31,30,31,31,30,31,30,31/) + + ! calculate the elapsed time smaller than a day + elapsedSec = (endTime(8)-startTime(8))*.001_dp + (endTime(7)-startTime(7)) + (endTime(6)-startTime(6))*secprmin + (endTime(5)-startTime(5))*secprhour + + ! check if the run is within the same day otherwise calculate how many days + if (endTime(1) > startTime(1) .or. endTime(2) > startTime(2) .or. endTime(3) > startTime(3)) then + + elapsedDay = 0 + ! diffenece in year + do yy = startTime(1), endTime(1) - 1 + elapsedDay = elapsedDay + 365 + if ((mod(yy,4)==0 .and. .not. mod(yy,100)==0) .or. (mod(yy,400)==0)) elapsedDay = elapsedDay + 1 + end do + if ((mod(startTime(1),4)==0 .and. .not. mod(startTime(1),100)==0) .or. (mod(startTime(1),400)==0)) days1(2) = 29 + if ((mod(endTime(1),4)==0 .and. .not. mod(endTime(1),100)==0) .or. (mod(endTime(1),400)==0)) days2(2) = 29 + ! difference in month + if (startTime(2) > 1) elapsedDay = elapsedDay - sum(days1(1:(startTime(2)-1))) + elapsedDay = elapsedDay - startTime(3) + ! difference in day + if (endTime(2) > 1) elapsedDay = elapsedDay + sum(days2(1:(endTime(2)-1))) + elapsedDay = elapsedDay + endTime(3) + ! convert to seconds + elapsedSec = elapsedSec + elapsedDay * secprday + end if + end function end module time_utils_module diff --git a/build/source/engine/updatState.f90 b/build/source/engine/updatState.f90 old mode 100644 new mode 100755 index 7a3dc33b5..824f919af --- a/build/source/engine/updatState.f90 +++ b/build/source/engine/updatState.f90 @@ -28,8 +28,6 @@ module updatState_module iden_water, & ! intrinsic density of water (kg m-3) gravity, & ! gravitational acceleteration (m s-2) LH_fus ! latent heat of fusion (J kg-1) -! named variables -USE data_struc,only:ix_soil,ix_snow ! named variables for snow and soil implicit none private public::updateSnow @@ -38,7 +36,7 @@ module updatState_module ! ************************************************************************************************************* - ! public subroutine updateSnow: compute phase change impacts on matric head and volumetric liquid water and ice + ! public subroutine updateSnow: compute phase change impacts on volumetric liquid water and ice ! ************************************************************************************************************* subroutine updateSnow(& ! input @@ -92,7 +90,7 @@ subroutine updateSoil(& theta_res ,& ! intent(in): soil residual volumetric water content (-) vGn_m ,& ! intent(in): van Genutchen "m" parameter (-) ! output - mLayerPsiLiq, & ! intent(out): liquid water matric potential (m) + 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 @@ -109,21 +107,21 @@ subroutine updateSoil(& real(dp),intent(in) :: theta_res ! soil residual volumetric water content (-) real(dp),intent(in) :: vGn_m ! van Genutchen "m" parameter (-) ! output variables - real(dp),intent(out) :: mLayerPsiLiq ! liquid water matric potential (m) + real(dp),intent(out) :: mLayerVolFracWat ! fractional volume of total water (-) real(dp),intent(out) :: mLayerVolFracLiq ! volumetric fraction of liquid water (-) real(dp),intent(out) :: mLayerVolFracIce ! volumetric fraction of ice (-) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! define local variables - real(dp) :: vTheta ! fractional volume of total water (-) real(dp) :: TcSoil ! critical soil temperature when all water is unfrozen (K) real(dp) :: xConst ! constant in the freezing curve function (m K-1) + real(dp) :: mLayerPsiLiq ! liquid water matric potential (m) ! initialize error control err=0; message="updateSoil/" ! compute fractional **volume** of total water (liquid plus ice) - vTheta = volFracLiq(mLayerMatricHead,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) - if(vTheta > theta_sat)then; err=20; message=trim(message)//'volume of liquid and ice exceeds porosity'; return; endif + mLayerVolFracWat = volFracLiq(mLayerMatricHead,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) + if(mLayerVolFracWat > theta_sat)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) @@ -133,22 +131,24 @@ subroutine updateSoil(& if(mLayerTemp < TcSoil)then ! (check if soil temperature is less than the critical temperature) ! - volumetric liquid water content (-) - xConst = LH_fus/(gravity*Tfreeze) ! m K-1 (NOTE: J = kg m2 s-2) - mLayerPsiLiq = xConst*(mLayerTemp - Tfreeze) + ! 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) ! - volumetric ice content (-) - mLayerVolFracIce = vTheta - mLayerVolFracLiq + mLayerVolFracIce = mLayerVolFracWat - mLayerVolFracLiq ! *** compute volumetric fraction of liquid water and ice for unfrozen soil else ! all water is unfrozen mLayerPsiLiq = mLayerMatricHead - mLayerVolFracLiq = vTheta + mLayerVolFracLiq = mLayerVolFracWat mLayerVolFracIce = 0._dp - endif ! (check if soil is partially frozen) + end if ! (check if soil is partially frozen) end subroutine updateSoil diff --git a/build/source/engine/updateVars.f90 b/build/source/engine/updateVars.f90 new file mode 100755 index 000000000..5a7ce334a --- /dev/null +++ b/build/source/engine/updateVars.f90 @@ -0,0 +1,715 @@ +! 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 updateVars_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 + +! 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:& + 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_ilength, & ! data vector with variable length dimension (i4b) + var_dlength ! data vector with variable length dimension (dp) + +! 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 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) +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 + +! IEEE checks +USE, intrinsic :: ieee_arithmetic ! check values (NaN, etc.) + +implicit none +private +public::updateVars + +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 + explicitEuler, & ! intent(in): flag to denote computing the explicit Euler solution + 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 + logical(lgt) ,intent(in) :: explicitEuler ! flag to denote computing the explicit Euler solution + 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(dp),intent(inout) :: scalarCanopyTempTrial ! trial value of canopy temperature (K) + real(dp),intent(inout) :: scalarCanopyWatTrial ! trial value of canopy total water (kg m-2) + real(dp),intent(inout) :: scalarCanopyLiqTrial ! trial value of canopy liquid water (kg m-2) + real(dp),intent(inout) :: scalarCanopyIceTrial ! trial value of canopy ice content (kg m-2) + ! output: variables for the snow-soil domain + real(dp),intent(inout) :: mLayerTempTrial(:) ! trial vector of layer temperature (K) + real(dp),intent(inout) :: mLayerVolFracWatTrial(:) ! trial vector of volumetric total water content (-) + real(dp),intent(inout) :: mLayerVolFracLiqTrial(:) ! trial vector of volumetric liquid water content (-) + real(dp),intent(inout) :: mLayerVolFracIceTrial(:) ! trial vector of volumetric ice water content (-) + real(dp),intent(inout) :: mLayerMatricHeadTrial(:) ! trial vector of total water matric potential (m) + real(dp),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(dp) :: scalarVolFracLiq ! volumetric fraction of liquid water (-) + real(dp) :: scalarVolFracIce ! volumetric fraction of ice (-) + real(dp) :: Tcrit ! critical soil temperature below which ice exists (K) + real(dp) :: xTemp ! temporary temperature (K) + real(dp) :: effSat ! effective saturation (-) + real(dp) :: 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(dp) :: meltNrg ! energy for melt+freeze (J m-3) + real(dp) :: residual ! residual in the energy equation (J m-3) + real(dp) :: derivative ! derivative in the energy equation (J m-3 K-1) + real(dp) :: 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(dp),parameter :: nrgConvTol=1.e-4_dp ! convergence tolerance for energy (J m-3) + real(dp),parameter :: tempConvTol=1.e-6_dp ! convergence tolerance for temperature (K) + real(dp) :: critDiff ! temperature difference from critical (K) + real(dp) :: tempMin ! minimum bracket for temperature (K) + real(dp) :: tempMax ! maximum bracket for temperature (K) + logical(lgt) :: bFlag ! flag to denote that iteration increment was constrained using bi-section + real(dp),parameter :: epsT=1.e-7_dp ! 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 default; err=20; message=trim(message)//'expect case to be iname_cas, iname_veg, iname_snow, iname_soil'; 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._dp,1._dp,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._dp + tempMax = xTemp + 10._dp + + ! 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_dp*(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._dp,1._dp,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._dp + case(iname_snow, iname_soil); mLayerdTheta_dTk(iLayer) = 0._dp + 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) + ! NOTE: do not go in here if we have the explicit Euler solution for energy state variables (isNrgState or isCoupled) + ! --> the explicit Euler updates for ice are done separately, based on the energy partitioning into melt and temperature at the start of the step + elseif(do_adjustTemp .or. ( (isNrgState .or. isCoupled) .and. .not.explicitEuler ) )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._dp - 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 + + ! explicit Euler solution where energy state variables exist + else + + ! do nothing (input = output) -- but check that we got here correctly + if(explicitEuler .and. (isNrgState .or. isCoupled) )then + scalarVolFracLiq = realMissing + scalarVolFracIce = realMissing + else + message=trim(message)//'unexpected else branch: expect explicit Euler solution where energy state variables exist' + 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._dp)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_dp ! 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._dp)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 + 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._dp ! exact correspondence (psiLiq=psi0) + dPsiLiq_dTemp(ixControlIndex) = 0._dp ! 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 + + 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(dp),intent(in) :: meltNrg ! energy for melt+freeze (J m-3) + real(dp),intent(in) :: heatCap ! volumetric heat capacity (J m-3 K-1) + real(dp),intent(in) :: tempInit ! initial temperature (K) + real(dp),intent(in) :: volFracIceInit ! initial volumetric fraction of ice (-) + ! input-output: trial values + real(dp),intent(inout) :: xTemp ! trial value for temperature + real(dp),intent(in) :: dLiq_dT ! derivative in liquid water content w.r.t. temperature (K-1) + real(dp),intent(in) :: volFracIceTrial ! trial value for the volumetric fraction of ice (-) + ! output: residual and derivative + real(dp),intent(out) :: residual ! residual (J m-3) + real(dp),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/varSubstep.f90 b/build/source/engine/varSubstep.f90 new file mode 100755 index 000000000..c88bfbbfd --- /dev/null +++ b/build/source/engine/varSubstep.f90 @@ -0,0 +1,944 @@ +! 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 varSubstep_module + +! data types +USE nrtype + +! 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 the global print flag +USE globalData,only:globalPrintFlag + +! 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 + +! 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 + +! provide access to indices that define elements of the data structures +USE var_lookup,only:iLookFLUX ! 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:iLookPARAM ! named variables for structure elements +USE var_lookup,only:iLookINDEX ! named variables for structure elements + +! 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) + +! safety: set private unless specified otherwise +implicit none +private +public::varSubstep + +! algorithmic parameters +real(dp),parameter :: verySmall=1.e-6_dp ! 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) + dt_min, & ! intent(in) : minimum time step (seconds) + errTol, & ! intent(in) : error tolerance for the explicit solution + 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 + explicitEuler, & ! intent(in) : flag to denote computing the explicit Euler solution + computeVegFlux, & ! intent(in) : flag to denote if computing energy flux over vegetation + fluxMask, & ! intent(in) : mask for the fluxes used in this given state subset + ! 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 globalData,only:flux_meta ! metadata on the model fluxes + 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 + implicit none + ! --------------------------------------------------------------------------------------- + ! * dummy variables + ! --------------------------------------------------------------------------------------- + ! input: model control + real(dp),intent(in) :: dt ! time step (seconds) + real(dp),intent(in) :: dt_min ! minimum time step (seconds) + real(dp),intent(in) :: errTol ! error tolerance in the explicit solution + 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) :: explicitEuler ! flag to denote computing the explicit Euler solution + 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) :: fluxMask(:) ! flags to denote if the flux is calculated in the given state subset + ! 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(dp),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 + ! time stepping + real(dp) :: dtSum ! sum of time from successful steps (seconds) + real(dp) :: dt_wght ! weight given to a given flux calculation + real(dp) :: dtSubstep ! length of a substep (s) + integer(i4b) :: iVar ! index of variables in data structures + ! adaptive sub-stepping for the explicit solution + logical(lgt) :: failedSubstep ! flag to denote success of substepping for a given split + real(dp) :: explicitError ! error in the explicit solution + real(dp),parameter :: safety=0.85_dp ! safety factor in adaptive sub-stepping + real(dp),parameter :: reduceMin=0.1_dp ! mimimum factor that time step is reduced + real(dp),parameter :: increaseMax=4.0_dp ! 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(dp),parameter :: F_inc = 1.25_dp ! factor used to increase time step + real(dp),parameter :: F_dec = 0.90_dp ! factor used to decrease time step + ! state and flux vectors + real(dp) :: untappedMelt(nState) ! un-tapped melt energy (J m-3 s-1) + real(dp) :: stateVecInit(nState) ! initial state vector (mixed units) + real(dp) :: stateVecTrial(nState) ! trial state vector (mixed units) + type(var_dlength) :: flux_temp ! temporary model fluxes + ! flags + 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(dp) :: sumCanopyEvaporation ! sum of canopy evaporation/condensation (kg m-2 s-1) + real(dp) :: sumLatHeatCanopyEvap ! sum of latent heat flux for evaporation from the canopy to the canopy air space (W m-2) + real(dp) :: sumSenHeatCanopy ! sum of sensible heat flux from the canopy to the canopy air space (W m-2) + real(dp) :: sumSoilCompress + real(dp),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 + 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) + ) ! 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 = dt + + ! 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._dp ! canopy evaporation/condensation (kg m-2 s-1) + sumLatHeatCanopyEvap = 0._dp ! latent heat flux for evaporation from the canopy to the canopy air space (W m-2) + sumSenHeatCanopy = 0._dp ! sensible heat flux from the canopy to the canopy air space (W m-2) + sumSoilCompress = 0._dp ! total soil compression + allocate(sumLayerCompress(nSoil)); sumLayerCompress = 0._dp ! soil compression by layer + + ! initialize subStep + dtSum = 0._dp ! 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 + + ! initialize error control + err=0; message='varSubstep/' + + ! increment substep + nSubsteps = nSubsteps+1 + + !print*, '** new substep' + !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 + explicitEuler, & ! intent(in): flag to denote computing the explicit Euler solution + 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_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 + explicitError, & ! intent(out): error in the explicit solution + 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) + if(explicitEuler .and. explicitError > errTol) failedSubstep=.true. + + ! check + if(globalPrintFlag)then + print*, 'niter, failedSubstep, dtSubstep = ', niter, failedSubstep, dtSubstep + print*, trim(cmessage) + endif + + ! reduce step based on failure + if(failedSubstep)then + + ! get time step reduction + ! solver failure + if(err<0)then + err=0; message='varSubstep/' ! recover from failed convergence + dtMultiplier = 0.5_dp ! system failure: step halving + ! large error in explicit solution + elseif(explicitEuler .and. explicitError > errTol)then + dtMultiplier = max(safety*sqrt(errTol/explicitError), reduceMin) ! intolerable errors: MUST be explicit Euler + ! nothing else defined + else + message=trim(message)//'unknown failure' + err=20; return + endif + + ! successful step + else + + ! ** implicit Euler: adjust step length based on iteration count + if(.not.explicitEuler)then + if(nitern_dec)then + dtMultiplier = F_dec + else + dtMultiplier = 1._dp + endif + + ! ** explicit Euler: adjust step based on error estimate + else + dtMultiplier = min(safety*sqrt(errTol/explicitError), increaseMax) + endif ! switch between explicit and implicit Euler + 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 if not explicit Euler, then exit and try another solution method + if(.not.explicitEuler)then + failedMinimumStep=.true. + exit subSteps + endif + + 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 + + ! update prognostic variables + call updateProg(dtSubstep,nSnow,nSoil,nLayers,doAdjustTemp,explicitEuler,computeVegFlux,untappedMelt,stateVecTrial, & ! input: model control + mpar_data,indx_data,flux_temp,prog_data,diag_data,deriv_data, & ! input-output: data structures + waterBalanceError,nrgFluxModified,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)then + reduceCoupledStep=.true. + 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._dp + + ! check minimum: fail minimum step if there is an error in the update + if(dtSubstep0) then + sumSoilCompress = sumSoilCompress + diag_data%var(iLookDIAG%scalarSoilCompress)%dat(1) ! total soil compression + sumLayerCompress = sumLayerCompress + diag_data%var(iLookDIAG%mLayerCompress)%dat ! soil compression in layers + 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(fluxMask(iVar)) flux_data%var(iVar)%dat(:) = flux_data%var(iVar)%dat(:) + flux_temp%var(iVar)%dat(:)*dt_wght + end do + + ! ------------------------------------------------------ + ! ------------------------------------------------------ + + ! increment sub-step + dtSum = dtSum + dtSubstep + !print*, 'dtSum, dtSubstep, dt = ', dtSum, dtSubstep, dt + + ! 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 + diag_data%var(iLookDIAG%mLayerCompress)%dat = sumLayerCompress + deallocate(sumLayerCompress) + + ! end associate statements + end associate globalVars + + end subroutine varSubstep + + + ! ********************************************************************************************************** + ! private subroutine updateProg: update prognostic variables + ! ********************************************************************************************************** + subroutine updateProg(dt,nSnow,nSoil,nLayers,doAdjustTemp,explicitEuler,computeVegFlux,untappedMelt,stateVecTrial, & ! input: model control + mpar_data,indx_data,flux_data,prog_data,diag_data,deriv_data, & ! input-output: data structures + waterBalanceError,nrgFluxModified,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(dp) ,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) :: explicitEuler ! flag to denote computing the explicit Euler solution + logical(lgt) ,intent(in) :: computeVegFlux ! flag to compute the vegetation flux + real(dp) ,intent(in) :: untappedMelt(:) ! un-tapped melt energy (J m-3 s-1) + real(dp) ,intent(in) :: stateVecTrial(:) ! trial state vector (mixed units) + ! 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 + 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(dp) :: volMelt ! volumetric melt (kg m-3) + real(dp),parameter :: verySmall=epsilon(1._dp)*2._dp ! a very small number (deal with precision issues) + ! mass balance + logical(lgt),parameter :: checkMassBalance=.true. ! flag to check the mass balance + real(dp) :: canopyBalance0,canopyBalance1 ! canopy storage at start/end of time step + real(dp) :: soilBalance0,soilBalance1 ! soil storage at start/end of time step + real(dp) :: vertFlux ! change in storage due to vertical fluxes + real(dp) :: tranSink,baseSink,compSink ! change in storage due to sink terms + real(dp) :: liqError ! water balance error + real(dp) :: fluxNet ! net water fluxes (kg m-2 s-1) + real(dp) :: superflousWat ! superflous water used for evaporation (kg m-2 s-1) + real(dp) :: 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(dp) :: scalarCanairTempTrial ! trial value for temperature of the canopy air space (K) + real(dp) :: scalarCanopyTempTrial ! trial value for temperature of the vegetation canopy (K) + real(dp) :: scalarCanopyWatTrial ! trial value for liquid water storage in the canopy (kg m-2) + real(dp),dimension(nLayers) :: mLayerTempTrial ! trial vector for temperature of layers in the snow and soil domains (K) + real(dp),dimension(nLayers) :: mLayerVolFracWatTrial ! trial vector for volumetric fraction of total water (-) + real(dp),dimension(nSoil) :: mLayerMatricHeadTrial ! trial vector for total water matric potential (m) + real(dp),dimension(nSoil) :: mLayerMatricHeadLiqTrial ! trial vector for liquid water matric potential (m) + ! diagnostic variables + real(dp) :: scalarCanopyLiqTrial ! trial value for mass of liquid water on the vegetation canopy (kg m-2) + real(dp) :: scalarCanopyIceTrial ! trial value for mass of ice on the vegetation canopy (kg m-2) + real(dp),dimension(nLayers) :: mLayerVolFracLiqTrial ! trial vector for volumetric fraction of liquid water (-) + real(dp),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%ixSnowSoilHyd)%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) + ! 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: 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) + + ! update diagnostic variables + call updateVars(& + ! input + doAdjustTemp, & ! intent(in): logical flag to adjust temperature to account for the energy used in melt+freeze + explicitEuler, & ! intent(in): flag to denote computing the explicit Euler solution + 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._dp)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._dp + scalarCanopyEvaporation = scalarCanopyEvaporation + superflousWat + scalarLatHeatCanopyEvap = scalarLatHeatCanopyEvap + superflousNrg + scalarSenHeatCanopy = scalarSenHeatCanopy - superflousNrg + endif + + ! --> next, remove canopy drainage + canopyBalance1 = canopyBalance1 - scalarCanopyLiqDrainage*dt + if(canopyBalance1 < 0._dp)then + superflousWat = -canopyBalance1/dt ! kg m-2 s-1 + canopyBalance1 = 0._dp + 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 + + ! 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._dp)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)>0)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) + !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 + if(abs(liqError) > absConvTol_liquid*10._dp)then ! *10 because of precision issues + 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 (in the explicit Euler method)... + ! --------------------------------------------------------------- + + ! 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._dp .or. any(mLayerVolFracIceTrial < 0._dp) )then + + ! ** + ! canopy within numerical precision + if(scalarCanopyIceTrial < 0._dp)then + + if(scalarCanopyIceTrial > -verySmall)then + scalarCanopyLiqTrial = scalarCanopyLiqTrial - scalarCanopyIceTrial + scalarCanopyIceTrial = 0._dp + + ! 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._dp)then + + if(mLayerVolFracIceTrial(iState) > -verySmall)then + mLayerVolFracLiqTrial(iState) = mLayerVolFracLiqTrial(iState) - mLayerVolFracIceTrial(iState) + mLayerVolFracIceTrial(iState) = 0._dp + + ! 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._dp .or. any(mLayerVolFracLiqTrial < 0._dp) )then + + ! ** + ! canopy within numerical precision + if(scalarCanopyLiqTrial < 0._dp)then + + if(scalarCanopyLiqTrial > -verySmall)then + scalarCanopyIceTrial = scalarCanopyIceTrial - scalarCanopyLiqTrial + scalarCanopyLiqTrial = 0._dp + + ! 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._dp)then + + if(mLayerVolFracLiqTrial(iState) > -verySmall)then + mLayerVolFracIceTrial(iState) = mLayerVolFracIceTrial(iState) - mLayerVolFracLiqTrial(iState) + mLayerVolFracLiqTrial(iState) = 0._dp + + ! 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... + ! -------------------------------- + + ! build elements of the state vector 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) + + ! build elements of the state vector 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) + + ! 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 100644 new mode 100755 index 76e4019da..83f7b8292 --- a/build/source/engine/var_derive.f90 +++ b/build/source/engine/var_derive.f90 @@ -20,10 +20,6 @@ module var_derive_module USE nrtype -USE data_struc,only:& - nSnow, & ! number of snow layers - nSoil, & ! number of soil layers - nLayers ! total number of layers implicit none private public::calcHeight @@ -40,31 +36,29 @@ module var_derive_module subroutine calcHeight(& ! input/output: data structures indx_data, & ! intent(in): layer type - mvar_data, & ! intent(inout): model variables for a local HRU + prog_data, & ! intent(inout): model variables for a local HRU ! output: error control err,message) - ! access the number of snow and soil layers - USE data_struc,only:& - nLayers ! total number of layers ! access named variables for snow and soil - USE data_struc,only:ix_soil,ix_snow ! named variables for snow and soil + USE globalData,only:iname_snow ! named variables for snow + USE globalData,only:iname_soil ! named variables for soil ! access to the derived types to define the data structures - USE data_struc,only:& - var_ilength, & ! data vector with variable length dimension (i4b) - var_dlength ! data vector with variable length dimension (dp) + USE data_types,only:var_ilength ! x%var(:)%dat (i4b) + USE data_types,only:var_dlength ! x%var(:)%dat (dp) ! provide access to named variables defining elements in the data structures - USE var_lookup,only:iLookMVAR,iLookINDEX ! named variables for structure elements + USE var_lookup,only:iLookPROG,iLookINDEX ! named variables for structure elements implicit none ! ---------------------------------------------------------------------------------- ! dummy variables ! input/output: data structures - type(var_ilength),intent(in) :: indx_data ! type of model layer - type(var_dlength),intent(inout) :: mvar_data ! model variables for a local HRU + type(var_ilength),intent(in) :: indx_data ! type of model layer + type(var_dlength),intent(inout) :: prog_data ! model 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) :: iLayer ! loop through layers + integer(i4b) :: iLayer ! loop through layers + integer(i4b) :: ixLower(1) ! index of the lower bound ! ---------------------------------------------------------------------------------- ! initialize error control err=0; message='calcHeight/' @@ -72,16 +66,18 @@ subroutine calcHeight(& ! associate variables in data structure associate(& ! associate the model index structures - layerType => indx_data%var(iLookINDEX%layerType)%dat, & ! layer type (ix_soil or ix_snow) + nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1), & ! total number of layers + layerType => indx_data%var(iLookINDEX%layerType)%dat, & ! layer type (iname_soil or iname_snow) ! associate the values in the model variable structures - mLayerDepth => mvar_data%var(iLookMVAR%mLayerDepth)%dat, & ! depth of the layer (m) - mLayerHeight => mvar_data%var(iLookMVAR%mLayerHeight)%dat, & ! height of the layer mid-point (m) - iLayerHeight => mvar_data%var(iLookMVAR%iLayerHeight)%dat & ! height of the layer interface (m) + mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat, & ! depth of the layer (m) + mLayerHeight => prog_data%var(iLookPROG%mLayerHeight)%dat, & ! height of the layer mid-point (m) + iLayerHeight => prog_data%var(iLookPROG%iLayerHeight)%dat & ! height of the layer interface (m) ) ! end associate ! ---------------------------------------------------------------------------------- ! initialize layer height as the top of the snowpack -- positive downward - iLayerHeight(0) = -sum(mLayerDepth, mask=layerType==ix_snow) + ixLower=lbound(iLayerHeight); if(ixLower(1) > 0)then; err=20; message=trim(message)//'unexpected lower bound for iLayerHeight'; return; endif + iLayerHeight(0) = -sum(mLayerDepth, mask=layerType==iname_snow) ! loop through layers do iLayer=1,nLayers @@ -106,89 +102,137 @@ end subroutine calcHeight ! ********************************************************************************************************** ! public subroutine rootDensty: compute vertical distribution of root density ! ********************************************************************************************************** - subroutine rootDensty(err,message) + subroutine rootDensty(mpar_data,indx_data,prog_data,diag_data,err,message) ! model decision structures - USE data_struc,only:model_decisions ! model decision structure + USE globalData,only:model_decisions ! model decision structure USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure + ! look-up values for the choice of the rooting profile + USE mDecisions_module,only: & + powerLaw, & ! simple power-law rooting profile + doubleExp ! the double exponential function of Xeng et al. (JHM 2001) ! 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 - ! model variables, parameters, forcing data, etc. - USE data_struc,only:mpar_data,mvar_data,indx_data,ix_soil,ix_snow ! data structures - USE var_lookup,only:iLookPARAM,iLookMVAR,iLookINDEX ! named variables for structure elements + ! named variables + USE var_lookup,only:iLookPARAM,iLookINDEX,iLookPROG,iLookDIAG ! named variables for structure elements + ! data types + USE data_types,only:var_dlength ! x%var(:)%dat (dp) + USE data_types,only:var_ilength ! x%var(:)%dat (i4b) implicit none - ! declare dummy variables - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + ! declare input variables + type(var_dlength),intent(in) :: mpar_data ! data structure of model parameters for a local HRU + type(var_ilength),intent(in) :: indx_data ! data structure of model indices for a local HRU + type(var_dlength),intent(in) :: prog_data ! data structure of model prognostic (state) variables for a local HRU + type(var_dlength),intent(inout) :: diag_data ! data structure of model diagnostic variables for a local HRU + ! declare output variables + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message ! declare local variables - integer(i4b) :: iLayer ! loop through layers - real(dp) :: fracRootLower ! fraction of the rooting depth at the lower interface - real(dp) :: fracRootUpper ! fraction of the rooting depth at the upper interface - real(dp) :: checkCalcs ! check calculations for aquifer roots + integer(i4b) :: iLayer ! loop through layers + real(dp) :: fracRootLower ! fraction of the rooting depth at the lower interface + real(dp) :: fracRootUpper ! fraction of the rooting depth at the upper interface + real(dp), parameter :: rootTolerance = 0.05_dp ! tolerance for error in doubleExp rooting option + real(dp) :: error ! machine precision error in rooting distribution ! initialize error control err=0; message='rootDensty/' + ! ---------------------------------------------------------------------------------- ! associate variables in data structure associate(& - ! associate the model index structures - nLayers =>indx_data%var(iLookINDEX%nLayers)%dat(1), & ! number of layers - layerType =>indx_data%var(iLookINDEX%layerType)%dat, & ! layer type (ix_soil or ix_snow) + ! associate the model decisions + ixRootProfile =>model_decisions(iLookDECISIONS%rootProfil)%iDecision, & ! choice of the rooting profile + ixGroundwater =>model_decisions(iLookDECISIONS%groundwatr)%iDecision, & ! choice of groundwater parameterization ! associate the values in the model parameter structures - rootingDepth =>mpar_data%var(iLookPARAM%rootingDepth), & ! rooting depth (m) - rootDistExp =>mpar_data%var(iLookPARAM%rootDistExp), & ! root distribution exponent (-) + rootScaleFactor1 =>mpar_data%var(iLookPARAM%rootScaleFactor1)%dat(1), & ! 1st scaling factor (m-1) + rootScaleFactor2 =>mpar_data%var(iLookPARAM%rootScaleFactor2)%dat(1), & ! 2nd scaling factor (m-1) + rootingDepth =>mpar_data%var(iLookPARAM%rootingDepth)%dat(1), & ! rooting depth (m) + rootDistExp =>mpar_data%var(iLookPARAM%rootDistExp)%dat(1), & ! root distribution exponent (-) + ! associate the model index structures + nSoil =>indx_data%var(iLookINDEX%nSoil)%dat(1), & ! number of soil layers + nSnow =>indx_data%var(iLookINDEX%nSnow)%dat(1), & ! number of snow layers + nLayers =>indx_data%var(iLookINDEX%nLayers)%dat(1), & ! total number of layers + iLayerHeight =>prog_data%var(iLookPROG%iLayerHeight)%dat, & ! height of the layer interface (m) ! associate the values in the model variable structures - scalarAquiferRootFrac =>mvar_data%var(iLookMVAR%scalarAquiferRootFrac)%dat(1), & ! fraction of roots below the soil profile (in the aquifer) - mLayerRootDensity =>mvar_data%var(iLookMVAR%mLayerRootDensity)%dat, & ! fraction of roots in each soil layer (-) - iLayerHeight =>mvar_data%var(iLookMVAR%iLayerHeight)%dat & ! height of the layer interface (m) + scalarAquiferRootFrac =>diag_data%var(iLookDIAG%scalarAquiferRootFrac)%dat(1), & ! fraction of roots below the soil profile (in the aquifer) + mLayerRootDensity =>diag_data%var(iLookDIAG%mLayerRootDensity)%dat & ! fraction of roots in each soil layer (-) ) ! end associate ! ---------------------------------------------------------------------------------- - ! check that the rooting depth is less than the soil depth - if(model_decisions(iLookDECISIONS%groundwatr)%iDecision /= bigBucket)then - if(rootingDepth>iLayerHeight(nLayers))then; err=10; message=trim(message)//'rooting depth can ONLY exceed soil depth for the big bucket gw parameterization'; return; endif - endif +! print*, 'nSnow = ', nSnow +! print*, 'nLayers = ', nLayers ! compute the fraction of roots in each soil layer do iLayer=nSnow+1,nLayers - if(iLayerHeight(iLayer-1)1._dp) fracRootUpper=1._dp - ! compute the root density - mLayerRootDensity(iLayer-nSnow) = fracRootUpper**rootDistExp - fracRootLower**rootDistExp - else - mLayerRootDensity(iLayer-nSnow) = 0._dp - endif - !print*, 'iLayerHeight(iLayer-1:iLayer) = ', iLayerHeight(iLayer-1:iLayer) - !write(*,'(a,10(f11.5,1x))') 'mLayerRootDensity(iLayer-nSnow), fracRootUpper, fracRootLower, fracRootUpper**rootDistExp, fracRootLower**rootDistExp = ', & - ! mLayerRootDensity(iLayer-nSnow), fracRootUpper, fracRootLower, fracRootUpper**rootDistExp, fracRootLower**rootDistExp + + ! different options for the rooting profile + select case(ixRootProfile) + + ! ** option 1: simple power-law profile + case(powerLaw) + if(iLayerHeight(iLayer-1)1._dp) fracRootUpper=1._dp + ! compute the root density + mLayerRootDensity(iLayer-nSnow) = fracRootUpper**rootDistExp - fracRootLower**rootDistExp + else + mLayerRootDensity(iLayer-nSnow) = 0._dp + end if + + ! ** option 2: double expoential profile of Zeng et al. (JHM 2001) + case(doubleExp) + ! compute the cumulative fraction of roots at the top and bottom of the layer + fracRootLower = 1._dp - 0.5_dp*(exp(-iLayerHeight(iLayer-1)*rootScaleFactor1) + exp(-iLayerHeight(iLayer-1)*rootScaleFactor2) ) + fracRootUpper = 1._dp - 0.5_dp*(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 + + end select + end do ! (looping thru layers) - !pause + + ! check that root density is within some reaosnable 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._dp + if (error > 2._dp*epsilon(rootingDepth)) then + message=trim(message)//'problem with the root density calaculation' + err=20; return + else + mLayerRootDensity = mLayerRootDensity - error/real(nSoil,kind(dp)) + end if ! compute fraction of roots in the aquifer - if(rootingDepth > iLayerHeight(nLayers))then - scalarAquiferRootFrac = 1._dp - sum(mLayerRootDensity(1:nSoil)) - checkCalcs = 1._dp - ( min(iLayerHeight(nLayers),rootingDepth) / rootingDepth)**rootDistExp - if(abs(checkCalcs - scalarAquiferRootFrac) > epsilon(checkCalcs))then - err=20; message=trim(message)//'problem with the aquifer root density calculations'; return - endif - - ! set fraction of aquifer roots to zero, and check everything is OK + if(sum(mLayerRootDensity) < 1._dp)then + scalarAquiferRootFrac = 1._dp - sum(mLayerRootDensity) else scalarAquiferRootFrac = 0._dp - if(abs(sum(mLayerRootDensity) - 1._dp) > epsilon(rootingDepth))then - print*, 'sum of root density = ', sum(mLayerRootDensity) - print*, 'rootingDepth = ', rootingDepth - message=trim(message)//'root density does not sum to one when rooting depth is within the soil profile' - err=20; return - endif - endif - - !print*, 'iLookMVAR%scalarAquiferRootFrac = ', iLookMVAR%scalarAquiferRootFrac - !print*, 'iLayerHeight(nLayers), rootingDepth, scalarAquiferRootFrac = ', iLayerHeight(nLayers), rootingDepth, scalarAquiferRootFrac - !pause + end if + + ! check that roots in the aquifer are appropriate + if ((ixGroundwater /= bigBucket).and.(scalarAquiferRootFrac > 2._dp*epsilon(rootingDepth)))then + if(scalarAquiferRootFrac < rootTolerance) then + mLayerRootDensity = mLayerRootDensity + scalarAquiferRootFrac/real(nSoil, kind(dp)) + scalarAquiferRootFrac = 0._dp + else + select case(ixRootProfile) + case(powerLaw); message=trim(message)//'roots in the aquifer only allowed for the big bucket gw parameterization: check that rooting depth < soil depth' + case(doubleExp); message=trim(message)//'roots in the aquifer only allowed for the big bucket gw parameterization: increase soil depth to alow for exponential roots' + end select + err=10; return + end if ! if roots in the aquifer + end if ! if not the big bucket + end associate end subroutine rootDensty @@ -197,42 +241,53 @@ end subroutine rootDensty ! ********************************************************************************************************** ! public subroutine satHydCond: compute vertical profile of saturated hydraulic conductivity ! ********************************************************************************************************** - subroutine satHydCond(err,message) + subroutine satHydCond(mpar_data,indx_data,prog_data,flux_data,err,message) ! model decision structures - USE data_struc,only:model_decisions ! model decision structure + USE globalData,only:model_decisions ! model decision structure USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure ! look-up values for the choice of groundwater parameterization USE mDecisions_module,only: & constant, & ! constant hydraulic conductivity with depth powerLaw_profile ! power-law profile - ! model variables, parameters, forcing data, etc. - USE data_struc,only:mpar_data,mvar_data,indx_data,ix_soil,ix_snow ! data structures - USE var_lookup,only:iLookPARAM,iLookMVAR,iLookINDEX ! named variables for structure elements + ! named variables + USE var_lookup,only:iLookPARAM,iLookINDEX,iLookPROG,iLookFLUX ! named variables for structure elements + ! data types + USE data_types,only:var_dlength ! x%var(:)%dat (dp) + USE data_types,only:var_ilength ! x%var(:)%dat (i4b) implicit none - ! declare dummy variables - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + ! declare input variables + type(var_dlength),intent(in) :: mpar_data ! data structure of model parameters for a local HRU + type(var_ilength),intent(in) :: indx_data ! data structure of model indices for a local HRU + type(var_dlength),intent(in) :: prog_data ! data structure of model prognostic (state) variables for a local HRU + type(var_dlength),intent(inout) :: flux_data ! data structure of model fluxes for a local HRU + ! declare output variables + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message ! declare local variables - integer(i4b) :: iLayer ! loop through layers + integer(i4b) :: iLayer ! loop through layers + real(dp) :: ifcDepthScaleFactor ! depth scaling factor (layer interfaces) + real(dp) :: midDepthScaleFactor ! depth scaling factor (layer midpoints) ! initialize error control err=0; message='satHydCond/' ! ---------------------------------------------------------------------------------- ! associate variables in data structure associate(& - ! associate the model index structures - nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1), & ! number of layers - layerType => indx_data%var(iLookINDEX%layerType)%dat, & ! layer type (ix_soil or ix_snow) ! associate the values in the parameter structures - k_soil => mpar_data%var(iLookPARAM%k_soil), & ! saturated hydraulic conductivity at the compacted depth (m s-1) - k_macropore => mpar_data%var(iLookPARAM%k_macropore), & ! saturated hydraulic conductivity at the compacted depth for macropores (m s-1) - compactedDepth => mpar_data%var(iLookPARAM%compactedDepth), & ! the depth at which k_soil reaches the compacted value given by CH78 (m) - zScale_TOPMODEL => mpar_data%var(iLookPARAM%zScale_TOPMODEL), & ! exponent for the TOPMODEL-ish baseflow parameterization (-) + k_soil => mpar_data%var(iLookPARAM%k_soil)%dat, & ! saturated hydraulic conductivity at the compacted depth (m s-1) + k_macropore => mpar_data%var(iLookPARAM%k_macropore)%dat, & ! saturated hydraulic conductivity at the compacted depth for macropores (m s-1) + compactedDepth => mpar_data%var(iLookPARAM%compactedDepth)%dat(1), & ! the depth at which k_soil reaches the compacted value given by CH78 (m) + zScale_TOPMODEL => mpar_data%var(iLookPARAM%zScale_TOPMODEL)%dat(1),& ! exponent for the TOPMODEL-ish baseflow parameterization (-) + ! associate the model index structures + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1), & ! number of snow layers + nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1), & ! number of soil layers + nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1), & ! total number of layers + ! associate the coordinate variables + mLayerHeight => prog_data%var(iLookPROG%mLayerHeight)%dat, & ! height at the mid-point of each layer (m) + iLayerHeight => prog_data%var(iLookPROG%iLayerHeight)%dat, & ! height at the interface of each layer (m) ! associate the values in the model variable structures - mLayerSatHydCondMP => mvar_data%var(iLookMVAR%mLayerSatHydCondMP)%dat, & ! saturated hydraulic conductivity for macropores at the mid-point of each layer (m s-1) - mLayerSatHydCond => mvar_data%var(iLookMVAR%mLayerSatHydCond)%dat, & ! saturated hydraulic conductivity at the mid-point of each layer (m s-1) - iLayerSatHydCond => mvar_data%var(iLookMVAR%iLayerSatHydCond)%dat, & ! saturated hydraulic conductivity at the interface of each layer (m s-1) - mLayerHeight => mvar_data%var(iLookMVAR%mLayerHeight)%dat, & ! height at the mid-point of each layer (m) - iLayerHeight => mvar_data%var(iLookMVAR%iLayerHeight)%dat & ! height at the interface of each layer (m) + mLayerSatHydCondMP => flux_data%var(ilookFLUX%mlayersathydcondmp)%dat, & ! saturated hydraulic conductivity for macropores at the mid-point of each layer (m s-1) + mLayerSatHydCond => flux_data%var(ilookFLUX%mlayersathydcond)%dat, & ! saturated hydraulic conductivity at the mid-point of each layer (m s-1) + iLayerSatHydCond => flux_data%var(ilookFLUX%ilayersathydcond)%dat & ! saturated hydraulic conductivity at the interface of each layer (m s-1) ) ! end associate ! ---------------------------------------------------------------------------------- @@ -240,39 +295,58 @@ subroutine satHydCond(err,message) ! NOTE: could do constant profile with the power-law profile with exponent=1, but keep constant profile decision for clarity do iLayer=nSnow,nLayers select case(model_decisions(iLookDECISIONS%hc_profile)%iDecision) + ! constant hydraulic conductivity with depth case(constant) - iLayerSatHydCond(iLayer-nSnow) = k_soil - if(iLayer > nSnow)then ! avoid layer 0 - mLayerSatHydCond(iLayer-nSnow) = k_soil - mLayerSatHydCondMP(iLayer-nSnow) = k_macropore - endif ! if the mid-point of a layer + ! - conductivity at layer interfaces + ! --> NOTE: Do we need a weighted average based on layer depth for interior layers? + if(iLayer==nSnow)then + iLayerSatHydCond(iLayer-nSnow) = k_soil(1) + else + if(iLayer==nLayers)then + iLayerSatHydCond(iLayer-nSnow) = k_soil(nSoil) + else + iLayerSatHydCond(iLayer-nSnow) = 0.5_dp * (k_soil(iLayer-nSnow) + k_soil(iLayer+1-nSnow) ) + endif + ! - conductivity at layer midpoints + mLayerSatHydCond(iLayer-nSnow) = k_soil(iLayer-nSnow) + mLayerSatHydCondMP(iLayer-nSnow) = k_macropore(iLayer-nSnow) + end if ! if iLayer>nSnow + ! power-law profile case(powerLaw_profile) - ! (saturated hydraulic conductivity at layer interfaces) - iLayerSatHydCond(iLayer-nSnow) = k_soil * ( (1._dp - iLayerHeight(iLayer)/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._dp) ) & - / ( (1._dp - compactedDepth/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._dp) ) - ! (saturated hydraulic conductivity at layer mid-points) - if(iLayer > nSnow)then ! avoid layer 0 - ! (--> micropores) - mLayerSatHydCond(iLayer-nSnow) = k_soil * ( (1._dp - mLayerHeight(iLayer)/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._dp) ) & - / ( (1._dp - compactedDepth/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._dp) ) - ! (--> macropores) - mLayerSatHydCondMP(iLayer-nSnow) = k_macropore * ( (1._dp - mLayerHeight(iLayer)/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._dp) ) & - / ( (1._dp - compactedDepth/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._dp) ) + ! - conductivity at layer interfaces + ! --> NOTE: Do we need a weighted average based on layer depth for interior layers? + ifcDepthScaleFactor = ( (1._dp - iLayerHeight(iLayer)/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._dp) ) / & + ( (1._dp - compactedDepth/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._dp) ) + if(iLayer==nSnow)then + iLayerSatHydCond(iLayer-nSnow) = k_soil(1) * ifcDepthScaleFactor + else + if(iLayer==nLayers)then + iLayerSatHydCond(iLayer-nSnow) = k_soil(nSoil) * ifcDepthScaleFactor + else + iLayerSatHydCond(iLayer-nSnow) = 0.5_dp * (k_soil(iLayer-nSnow) + k_soil(iLayer+1-nSnow) ) * ifcDepthScaleFactor + endif + ! - conductivity at layer midpoints + midDepthScaleFactor = ( (1._dp - mLayerHeight(iLayer)/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._dp) ) / & + ( (1._dp - compactedDepth/iLayerHeight(nLayers))**(zScale_TOPMODEL - 1._dp) ) + mLayerSatHydCond(iLayer-nSnow) = k_soil(iLayer-nSnow) * midDepthScaleFactor + mLayerSatHydCondMP(iLayer-nSnow) = k_macropore(iLayer-nSnow) * midDepthScaleFactor !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) - endif ! if the mid-point of a layer + end if ! if the mid-point of a layer + ! 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)//"]" err=10; return + end select !if(iLayer > nSnow)& ! avoid layer 0 - ! write(*,'(i4,1x,2(f11.5,1x,e20.10,1x))') iLayer, mLayerHeight(iLayer), mLayerSatHydCond(iLayer-nSnow), iLayerHeight(iLayer), iLayerSatHydCond(iLayer-nSnow) + ! 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 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 @@ -285,49 +359,53 @@ end subroutine satHydCond ! ********************************************************************************************************** ! public subroutine fracFuture: compute the fraction of runoff in future time steps ! ********************************************************************************************************** - subroutine fracFuture(err,message) + 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 ! model decision structures - USE data_struc,only:model_decisions ! model decision structure + USE globalData,only:model_decisions ! model decision structure USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure ! look-up values for the sub-grid routing method USE mDecisions_module,only: & timeDelay,& ! time-delay histogram qInstant ! instantaneous routing - ! model variables, parameters, forcing data, etc. - USE data_struc,only:data_step ! time step of forcing data - USE data_struc,only:bvar_data,bpar_data ! data structures for model variables and parameters + ! named variables + USE globalData,only:data_step ! time step of forcing data USE var_lookup,only:iLookBVAR,iLookBPAR ! named variables for structure elements + ! data types + USE data_types,only:var_dlength ! x%var(:)%dat (dp) implicit none - ! dummy variables - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! pointers to model structures - real(dp) :: dt ! data time step (s) + ! input variables + real(dp),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 ! internal - integer(i4b) :: nTDH ! number of points in the time-delay histogram - integer(i4b) :: iFuture ! index in time delay histogram - real(dp) :: aLambda ! scale parameter in the Gamma distribution - real(dp) :: tFuture ! future time (end of step) - real(dp) :: pSave ! cumulative probability at the start of the step - real(dp) :: cumProb ! cumulative probability at the end of the step - real(dp) :: sumFrac ! sum of runoff fractions in all steps - real(dp),parameter :: tolerFrac=0.01_dp ! tolerance for fractional runoff + real(dp) :: 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(dp) :: aLambda ! scale parameter in the Gamma distribution + real(dp) :: tFuture ! future time (end of step) + real(dp) :: pSave ! cumulative probability at the start of the step + real(dp) :: cumProb ! cumulative probability at the end of the step + real(dp) :: sumFrac ! sum of runoff fractions in all steps + real(dp),parameter :: tolerFrac=0.01_dp ! tolerance for fractional runoff ! initialize error control err=0; message='fracFuture/' ! ---------------------------------------------------------------------------------- ! associate variables in data structure associate(& ixRouting => model_decisions(iLookDECISIONS%subRouting)%iDecision, & ! index for routing method - routingGammaShape => bpar_data%var(iLookBPAR%routingGammaShape), & ! shape parameter in Gamma distribution used for sub-grid routing (-) - routingGammaScale => bpar_data%var(iLookBPAR%routingGammaScale), & ! scale parameter in Gamma distribution used for sub-grid routing (s) + routingGammaShape => bpar_data(iLookBPAR%routingGammaShape), & ! shape parameter in Gamma distribution used for sub-grid routing (-) + routingGammaScale => bpar_data(iLookBPAR%routingGammaScale), & ! scale parameter in Gamma distribution used for sub-grid routing (s) runoffFuture => bvar_data%var(iLookBVAR%routingRunoffFuture)%dat, & ! runoff in future time steps (m s-1) fractionFuture => bvar_data%var(iLookBVAR%routingFractionFuture)%dat & ! fraction of runoff in future time steps (-) ) ! end associate ! ---------------------------------------------------------------------------------- - dt = data_step ! get the legth of the data step (s) + ! define time step + dt = data_step ! length of the data step (s) ! identify number of points in the time-delay histogram nTDH = size(runoffFuture) @@ -353,7 +431,7 @@ subroutine fracFuture(err,message) if(routingGammaShape <= 0._dp .or. aLambda < 0._dp)then message=trim(message)//'bad arguments for the Gamma distribution' err=20; return - endif + end if ! loop through time steps and compute fraction of runoff in future steps do iFuture = 1,nTDH tFuture = real(iFuture, kind(dt))*dt ! future time (end of step) @@ -363,7 +441,7 @@ subroutine fracFuture(err,message) if(fractionFuture(iFuture) < tiny(dt))then fractionFuture(iFuture:nTDH) = 0._dp exit - endif + end if !write(*,'(a,1x,i4,1x,3(f20.10,1x))') trim(message), iFuture, tFuture, cumProb, fractionFuture(iFuture) end do ! (looping through future time steps) ! check that we have enough bins @@ -371,7 +449,7 @@ subroutine fracFuture(err,message) if(abs(1._dp - sumFrac) > tolerFrac)then message=trim(message)//'not enough bins for the time delay histogram -- fix hard-coded parameter in alloc_bvar' err=20; return - endif + end if ! ensure the fraction sums to one fractionFuture = fractionFuture/sumFrac @@ -388,73 +466,31 @@ end subroutine fracFuture ! ********************************************************************************************************** ! public subroutine v_shortcut: compute "short-cut" variables ! ********************************************************************************************************** - subroutine v_shortcut(err,message) - ! used to compute derived model variables - USE multiconst, only:& - LH_fus, & ! latent heat of fusion (J kg-1) - Cp_air, & ! specific heat of air (J kg-1 K-1) - Cp_ice, & ! specific heat of ice (J kg-1 K-1) - Cp_soil, & ! specific heat of soil (J kg-1 K-1) - Cp_water, & ! specific heat of liquid water (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) - gravity, & ! gravitational acceleration (m s-2) - Tfreeze ! freezing point of pure water (K) - USE data_struc,only:mpar_data,mvar_data,ix_soil,ix_snow ! data structures - USE var_lookup,only:iLookPARAM,iLookMVAR,iLookINDEX ! named variables for structure elements + subroutine v_shortcut(mpar_data,diag_data,err,message) + ! named variables + USE var_lookup,only:iLookPARAM,iLookDIAG ! named variables for structure elements + ! data types + USE data_types,only:var_dlength ! x%var(:)%dat (dp) implicit none - ! declare dummy variables - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - real(dp) :: bulkden_soil ! bulk density of soil (kg m-3) + ! declare input variables + type(var_dlength),intent(in) :: mpar_data ! data structure of model parameters for a local HRU + type(var_dlength),intent(inout) :: diag_data ! data structure of model variables for a local HRU + ! declare output variables + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message ! initialize error control err=0; message='v_shortcut/' ! ---------------------------------------------------------------------------------- ! associate variables in data structure associate(& ! associate values in the parameter structures - iden_soil =>mpar_data%var(iLookPARAM%soil_dens_intr), & ! intrinsic soil density (kg m-3) - frac_sand =>mpar_data%var(iLookPARAM%frac_sand), & ! fraction of sand (-) - frac_silt =>mpar_data%var(iLookPARAM%frac_silt), & ! fraction of silt (-) - frac_clay =>mpar_data%var(iLookPARAM%frac_clay), & ! fraction of clay (-) - theta_sat =>mpar_data%var(iLookPARAM%theta_sat), & ! soil porosity (-) - vGn_n =>mpar_data%var(iLookPARAM%vGn_n), & ! van Genutchen "n" parameter (-) - ! associate values in the model variable structures - vGn_m =>mvar_data%var(iLookMVAR%scalarVGn_m)%dat(1), & ! van Genutchen "m" parameter (-) - kappa =>mvar_data%var(iLookMVAR%scalarKappa)%dat(1), & ! constant in the freezing curve function (m K-1) - volHtCap_air =>mvar_data%var(iLookMVAR%scalarVolHtCap_air)%dat(1), & ! volumetric heat capacity of air (J m-3 K-1) - volHtCap_ice =>mvar_data%var(iLookMVAR%scalarVolHtCap_ice)%dat(1), & ! volumetric heat capacity of ice (J m-3 K-1) - volHtCap_soil =>mvar_data%var(iLookMVAR%scalarVolHtCap_soil)%dat(1), & ! volumetric heat capacity of soil (J m-3 K-1) - volHtCap_water =>mvar_data%var(iLookMVAR%scalarVolHtCap_water)%dat(1), & ! volumetric heat capacity of water (J m-3 K-1) - lambda_drysoil =>mvar_data%var(iLookMVAR%scalarLambda_drysoil)%dat(1), & ! thermal conductivity of dry soil (W m-1) - lambda_wetsoil =>mvar_data%var(iLookMVAR%scalarLambda_wetsoil)%dat(1), & ! thermal conductivity of wet soil (W m-1) - volLatHt_fus =>mvar_data%var(iLookMVAR%scalarvolLatHt_fus)%dat(1) & ! volumetric latent heat of fusion (J m-3) + 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 ! ---------------------------------------------------------------------------------- - ! ************************************************************************************************************************ ! compute the van Genutchen "m" parameter vGn_m = 1._dp - 1._dp/vGn_n - ! ************************************************************************************************************************ - ! compute the constant in the freezing curve function (m K-1) - kappa = (iden_ice/iden_water)*(LH_fus/(gravity*Tfreeze)) ! NOTE: J = kg m2 s-2 - ! ************************************************************************************************************************ - ! compute volumetric heat capacity (J m-3 K-1) - volHtCap_air = iden_air * Cp_air - volHtCap_ice = iden_ice * Cp_Ice - volHtCap_soil = iden_soil * Cp_soil - volHtCap_water = iden_water * Cp_water - ! compute the thermal conductivity of dry and wet soils (W m-1) - bulkden_soil = iden_soil*(1._dp - theta_sat) - lambda_drysoil = (0.135_dp*bulkden_soil + 64.7_dp) / (iden_soil - 0.947_dp*bulkden_soil) - lambda_wetsoil = (8.80_dp*frac_sand + 2.92_dp*frac_clay) / (frac_sand + frac_clay) - !print*, 'frac_sand, frac_silt, frac_clay = ', frac_sand, frac_silt, frac_clay - !print*, 'lambda_drysoil, lambda_wetsoil = ', lambda_drysoil, lambda_wetsoil - !print*, 'volHtCap_soil = ', volHtCap_soil - ! compute the volumetric latent heat of fusion (J m-3) - volLatHt_fus = iden_ice * LH_fus - ! ************************************************************************************************************************ end associate end subroutine v_shortcut diff --git a/build/source/engine/vegLiqFlux.f90 b/build/source/engine/vegLiqFlux.f90 old mode 100644 new mode 100755 index ed243e50e..6c083cdf4 --- a/build/source/engine/vegLiqFlux.f90 +++ b/build/source/engine/vegLiqFlux.f90 @@ -20,6 +20,11 @@ module vegLiqFlux_module USE nrtype +! look-up values for the choice of canopy shortwave radiation method +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 implicit none private public::vegLiqFlux @@ -34,94 +39,90 @@ subroutine vegLiqFlux(& 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 - ! model variables, parameters, forcing data, etc. - USE data_struc,only:mpar_data,mvar_data ! data structures - USE var_lookup,only:iLookATTR,iLookTYPE,iLookPARAM,iLookFORCE,iLookMVAR,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 + ! named variables + USE var_lookup,only:iLookPARAM,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) 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(dp),intent(in) :: scalarCanopyLiqTrial ! trial mass of liquid water on the vegetation canopy at the current iteration (kg m-2) - real(dp),intent(in) :: scalarRainfall ! rainfall (kg m-2 s-1) + logical(lgt),intent(in) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) + real(dp),intent(in) :: scalarCanopyLiqTrial ! trial mass of liquid water on the vegetation canopy at the current iteration (kg m-2) + real(dp),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(dp),intent(out) :: scalarThroughfallRain ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) - real(dp),intent(out) :: scalarCanopyLiqDrainage ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) - real(dp),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 + real(dp),intent(out) :: scalarThroughfallRain ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) + real(dp),intent(out) :: scalarCanopyLiqDrainage ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) + real(dp),intent(out) :: scalarThroughfallRainDeriv ! derivative in throughfall w.r.t. canopy liquid water (s-1) + real(dp),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 ! ------------------------------------------------------------------------------------------------------------------------------------------------------ - ! local variables - character(LEN=256) :: cmessage ! error message of downwind routine - ! ---------------------------------------------------------------------------------------------------- ! initialize error control err=0; message="vegLiqFlux/" - ! wrapper routine (makes use of data structures and protects variables with the intent attribute) - call vegLiqFlux_muster(& - ! 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: forcing and parameters from data structures - mvar_data%var(iLookMVAR%scalarCanopyLiqMax)%dat(1), & ! intent(in): maximum storage before canopy drainage begins (kg m-2 s-1) - mpar_data%var(iLookPARAM%canopyDrainageCoeff), & ! intent(in): canopy drainage coefficient (s-1) - ! 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) - 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 - - - end subroutine vegLiqFlux - - - ! ************************************************************************************************ - ! private subroutine vegLiqFlux_muster: compute water balance for the vegetation canopy - ! ************************************************************************************************ - subroutine vegLiqFlux_muster(& - ! 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 (kg m-2 s-1) - scalarCanopyLiqMax, & ! intent(in): maximum storage before canopy drainage begins (kg m-2 s-1) - scalarCanopyDrainageCoeff, & ! intent(in): canopy drainage coefficient (s-1) - ! 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) - 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(dp),intent(in) :: scalarCanopyLiqTrial ! trial mass of liquid water on the vegetation canopy at the current iteration (kg m-2) - real(dp),intent(in) :: scalarRainfall ! rainfall (kg m-2 s-1) - real(dp),intent(in) :: scalarCanopyLiqMax ! maximum storage before canopy drainage begins (kg m-2 s-1) - real(dp),intent(in) :: scalarCanopyDrainageCoeff ! canopy drainage coefficient (s-1) - ! output - real(dp),intent(out) :: scalarThroughfallRain ! rain that reaches the ground without ever touching the canopy (kg m-2 s-1) - real(dp),intent(out) :: scalarCanopyLiqDrainage ! drainage of liquid water from the vegetation canopy (kg m-2 s-1) - real(dp),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 - ! ---------------------------------------------------------------------------------------------------- - ! initialize error control - err=0; message="vegLiqFlux_muster/" - ! set throughfall to inputs if vegetation is completely buried with snow if(.not.computeVegFlux)then scalarThroughfallRain = scalarRainfall scalarCanopyLiqDrainage = 0._dp + scalarThroughfallRainDeriv = 0._dp scalarCanopyLiqDrainageDeriv = 0._dp return - endif + 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._dp + scalarThroughfallRainDeriv = 0._dp + + ! fraction of rainfall hits the ground without ever touching the canopy + case(sparseCanopy) + scalarThroughfallRain = scalarThroughfallScaleRain*scalarRainfall + scalarThroughfallRainDeriv = 0._dp + + ! throughfall a function of canopy storage + case(storageFunc) + + ! throughfall during wetting-up phase + if(scalarCanopyLiqTrial < scalarCanopyLiqMax)then + scalarThroughfallRain = scalarRainfall*(scalarCanopyLiqTrial/scalarCanopyLiqMax) + scalarThroughfallRainDeriv = scalarRainfall/scalarCanopyLiqMax - ! set throughfall to zero (throughfall only used where there is no canopy) - scalarThroughfallRain = 0._dp + ! all rain falls through the canopy when the canopy is at capacity + else + scalarThroughfallRain = scalarRainfall + scalarThroughfallRainDeriv = 0._dp + 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 @@ -130,9 +131,14 @@ subroutine vegLiqFlux_muster(& else scalarCanopyLiqDrainage = 0._dp scalarCanopyLiqDrainageDeriv = 0._dp - endif + end if + + !write(*,'(a,1x,f25.15)') 'scalarCanopyLiqDrainage = ', scalarCanopyLiqDrainage - end subroutine vegLiqFlux_muster + ! end association of local variables with information in the data structures + end associate + + end subroutine vegLiqFlux end module vegLiqFlux_module diff --git a/build/source/engine/vegNrgFlux.f90 b/build/source/engine/vegNrgFlux.f90 old mode 100644 new mode 100755 index a2b13f320..52f0be16a --- a/build/source/engine/vegNrgFlux.f90 +++ b/build/source/engine/vegNrgFlux.f90 @@ -38,11 +38,6 @@ module vegNrgFlux_module 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) -! access the number of snow and soil layers -USE data_struc,only:& - nSnow, & ! number of snow layers - nSoil, & ! number of soil layers - nLayers ! total number of layers ! look-up values for method used to compute derivative USE mDecisions_module,only: & numerical, & ! numerical solution @@ -65,11 +60,6 @@ module vegNrgFlux_module USE mDecisions_module,only: & exponential, & ! exponential wind profile extends to the surface logBelowCanopy ! logarithmic profile below the vegetation canopy -! look-up values for the stomatal resistance formulation -USE mDecisions_module,only: & - BallBerry, & ! Ball-Berry - Jarvis, & ! Jarvis - simpleResistance ! simple resistance formulation ! look-up values for choice of stability function USE mDecisions_module,only: & standard, & ! standard MO similarity, a la Anderson (1976) @@ -79,8 +69,6 @@ module vegNrgFlux_module USE mDecisions_module,only: & localColumn, & ! separate groundwater representation in each local soil column singleBasin ! single groundwater store over the entire basin -! named variables for snow and soil -USE data_struc,only:ix_soil,ix_snow ! named variables for snow and soil ! ------------------------------------------------------------------------------------------------- implicit none private @@ -130,7 +118,10 @@ subroutine vegNrgFlux(& attr_data, & ! intent(in): spatial attributes forc_data, & ! intent(in): model forcing data mpar_data, & ! intent(in): model parameters - mvar_data, & ! intent(inout): model variables for a local HRU + 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 @@ -155,34 +146,53 @@ subroutine vegNrgFlux(& 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 + ! 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 + ! provide access to the derived types to define the data structures - USE data_struc,only:& + 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 - ! provide access to named variables defining elements in the data structures - USE var_lookup,only:iLookTIME,iLookTYPE,iLookATTR,iLookFORCE,iLookPARAM,iLookMVAR,iLookBVAR,iLookINDEX ! named variables for structure elements + ! 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:iLookBVAR ! named variables for structure elements USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure ! 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 ! --------------------------------------------------------------------------------------- @@ -190,6 +200,7 @@ subroutine vegNrgFlux(& 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(dp),intent(in) :: upperBoundTemp ! temperature of the upper boundary (K) --> NOTE: use air temperature real(dp),intent(in) :: canairTempTrial ! trial value of canopy air space temperature (K) @@ -197,24 +208,32 @@ subroutine vegNrgFlux(& real(dp),intent(in) :: groundTempTrial ! trial value of ground temperature (K) real(dp),intent(in) :: canopyIceTrial ! trial value of mass of ice on the vegetation canopy (kg m-2) real(dp),intent(in) :: canopyLiqTrial ! trial value of mass of liquid water on the vegetation canopy (kg m-2) + ! input: model derivatives real(dp),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) :: attr_data ! spatial attributes type(var_d),intent(in) :: forc_data ! model forcing data - type(var_d),intent(in) :: mpar_data ! model parameters - type(var_dlength),intent(inout) :: mvar_data ! model variables for a local HRU + 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(dp),intent(out) :: returnCanopyTranspiration ! canopy transpiration (kg m-2 s-1) real(dp),intent(out) :: returnCanopyEvaporation ! canopy evaporation/condensation (kg m-2 s-1) real(dp),intent(out) :: returnGroundEvaporation ! ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) + ! output: fluxes real(dp),intent(out) :: canairNetFlux ! net energy flux for the canopy air space (W m-2) real(dp),intent(out) :: canopyNetFlux ! net energy flux for the vegetation canopy (W m-2) real(dp),intent(out) :: groundNetFlux ! net energy flux for the ground surface (W m-2) + ! output: energy flux derivatives real(dp),intent(out) :: dCanairNetFlux_dCanairTemp ! derivative in net canopy air space flux w.r.t. canopy air temperature (W m-2 K-1) real(dp),intent(out) :: dCanairNetFlux_dCanopyTemp ! derivative in net canopy air space flux w.r.t. canopy temperature (W m-2 K-1) @@ -225,17 +244,27 @@ subroutine vegNrgFlux(& real(dp),intent(out) :: dGroundNetFlux_dCanairTemp ! derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) real(dp),intent(out) :: dGroundNetFlux_dCanopyTemp ! derivative in net ground flux w.r.t. canopy temperature (W m-2 K-1) real(dp),intent(out) :: dGroundNetFlux_dGroundTemp ! derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) - ! output: liquid flux derivatives + + ! output: liquid flux derivatives (canopy evap) real(dp),intent(out) :: dCanopyEvaporation_dCanLiq ! derivative in canopy evaporation w.r.t. canopy liquid water content (s-1) real(dp),intent(out) :: dCanopyEvaporation_dTCanair ! derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) real(dp),intent(out) :: dCanopyEvaporation_dTCanopy ! derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) real(dp),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(dp),intent(out) :: dGroundEvaporation_dCanLiq ! derivative in ground evaporation w.r.t. canopy liquid water content (s-1) + real(dp),intent(out) :: dGroundEvaporation_dTCanair ! derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + real(dp),intent(out) :: dGroundEvaporation_dTCanopy ! derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + real(dp),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(dp),intent(out) :: dCanopyNetFlux_dCanLiq ! derivative in net canopy fluxes w.r.t. canopy liquid water content (J kg-1 s-1) real(dp),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 ! --------------------------------------------------------------------------------------- @@ -244,8 +273,8 @@ subroutine vegNrgFlux(& real(dp) :: VAI ! vegetation area index (m2 m-2) real(dp) :: exposedVAI ! exposed vegetation area index (m2 m-2) real(dp) :: totalCanopyWater ! total water on the vegetation canopy (kg m-2) - real(dp),parameter :: scalarVegFraction=1._dp ! vegetation fraction (=1 forces no canopy gaps and open areas in radiation routine) real(dp) :: 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 @@ -258,31 +287,37 @@ subroutine vegNrgFlux(& real(dp) :: canopyTemp ! value of canopy temperature used in flux calculations (may be perturbed) real(dp) :: canairTemp ! value of canopy air temperature used in flux calculations (may be perturbed) real(dp) :: try0,try1 ! trial values to evaluate specific derivatives (testing only) + ! local (saturation vapor pressure of veg) real(dp) :: TV_celcius ! vegetaion temperature (C) real(dp) :: TG_celcius ! ground temperature (C) real(dp) :: dSVPCanopy_dCanopyTemp ! derivative in canopy saturated vapor pressure w.r.t. vegetation temperature (Pa/K) real(dp) :: dSVPGround_dGroundTemp ! derivative in ground saturated vapor pressure w.r.t. ground temperature (Pa/K) + ! local (wetted canopy area) real(dp) :: fracLiquidCanopy ! fraction of liquid water in the canopy (-) real(dp) :: canopyWetFraction ! trial value of the canopy wetted fraction (-) real(dp) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) real(dp) :: dCanopyWetFraction_dT ! derivative in wetted fraction w.r.t. canopy temperature (K-1) + ! local (longwave radiation) real(dp) :: expi ! exponential integral real(dp) :: scaleLAI ! scaled LAI (computing diffuse transmissivity) real(dp) :: diffuseTrans ! diffuse transmissivity (-) real(dp) :: groundEmissivity ! emissivity of the ground surface (-) - real(dp),parameter :: vegEmissivity=0.98_dp ! emissivity of vegetation (-) - real(dp),parameter :: soilEmissivity=0.98_dp ! emmisivity of the soil (-) + real(dp),parameter :: vegEmissivity=0.98_dp ! emissivity of vegetation (0.9665 in JULES) (-) + real(dp),parameter :: soilEmissivity=0.98_dp ! emmisivity of the soil (0.9665 in JULES) (-) real(dp),parameter :: snowEmissivity=0.99_dp ! emissivity of snow (-) real(dp) :: dLWNetCanopy_dTCanopy ! derivative in net canopy radiation w.r.t. canopy temperature (W m-2 K-1) real(dp) :: dLWNetGround_dTGround ! derivative in net ground radiation w.r.t. ground temperature (W m-2 K-1) real(dp) :: dLWNetCanopy_dTGround ! derivative in net canopy radiation w.r.t. ground temperature (W m-2 K-1) real(dp) :: dLWNetGround_dTCanopy ! derivative in net ground radiation w.r.t. canopy temperature (W m-2 K-1) + ! local (aerodynamic resistance) real(dp) :: scalarCanopyStabilityCorrection_old ! stability correction for the canopy (-) real(dp) :: scalarGroundStabilityCorrection_old ! stability correction for the ground surface (-) + real(dp) :: uHeight ! height of windspeed measurement adjusted to be above vegetation canopy + ! local (turbulent heat transfer) real(dp) :: z0Ground ! roughness length of the ground (ground below the canopy or non-vegetated surface) (m) real(dp) :: soilEvapFactor ! soil water control on evaporation from non-vegetated surfaces @@ -303,6 +338,7 @@ subroutine vegNrgFlux(& real(dp) :: turbFluxCanair ! total turbulent heat fluxes exchanged at the canopy air space (W m-2) real(dp) :: turbFluxCanopy ! total turbulent heat fluxes from the canopy to the canopy air space (W m-2) real(dp) :: 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(dp) :: trialLeafResistance ! mean leaf boundary layer resistance per unit leaf area (s m-1) @@ -324,6 +360,7 @@ subroutine vegNrgFlux(& real(dp) :: notUsed_dGroundResistance_dTCanair ! derivative in ground resistance w.r.t. canopy air temperature (s m-1 K-1) real(dp) :: notUsed_dCanopyResistance_dTCanopy ! derivative in canopy resistance w.r.t. canopy temperature (s m-1 K-1) real(dp) :: 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(dp) :: turbFluxCanair_dStateCanair ! turbulent exchange from the canopy air space to the atmosphere, after canopy air temperature is perturbed (W m-2) real(dp) :: turbFluxCanair_dStateCanopy ! turbulent exchange from the canopy air space to the atmosphere, after canopy temperature is perturbed (W m-2) @@ -334,36 +371,49 @@ subroutine vegNrgFlux(& real(dp) :: turbFluxCanopy_dStateCanopy ! total turbulent heat fluxes from the canopy to the canopy air space, after canopy temperature is perturbed (W m-2) real(dp) :: turbFluxCanopy_dStateGround ! total turbulent heat fluxes from the canopy to the canopy air space, after ground temperature is perturbed (W m-2) real(dp) :: 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(dp) :: turbFluxGround_dStateCanair ! total turbulent heat fluxes from the ground to the canopy air space, after canopy air temperature is perturbed (W m-2) real(dp) :: turbFluxGround_dStateCanopy ! total turbulent heat fluxes from the ground to the canopy air space, after canopy temperature is perturbed (W m-2) real(dp) :: turbFluxGround_dStateGround ! total turbulent heat fluxes from the ground to the canopy air space, after ground temperature is perturbed (W m-2) real(dp) :: 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(dp) :: latHeatCanEvap_dStateCanair ! canopy evaporation after canopy air temperature is perturbed (W m-2) real(dp) :: latHeatCanEvap_dStateCanopy ! canopy evaporation after canopy temperature is perturbed (W m-2) real(dp) :: latHeatCanEvap_dStateGround ! canopy evaporation after ground temperature is perturbed (W m-2) real(dp) :: latHeatCanEvap_dStateCanLiq ! canopy evaporation after canopy liquid water content is perturbed (W m-2) + ! (flux derivatives -- canopy air space) real(dp) :: dTurbFluxCanair_dTCanair ! derivative in net canopy air space fluxes w.r.t. canopy air temperature (W m-2 K-1) real(dp) :: dTurbFluxCanair_dTCanopy ! derivative in net canopy air space fluxes w.r.t. canopy temperature (W m-2 K-1) real(dp) :: dTurbFluxCanair_dTGround ! derivative in net canopy air space fluxes w.r.t. ground temperature (W m-2 K-1) real(dp) :: 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(dp) :: dTurbFluxCanopy_dTCanair ! derivative in net canopy turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) real(dp) :: dTurbFluxCanopy_dTCanopy ! derivative in net canopy turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) real(dp) :: dTurbFluxCanopy_dTGround ! derivative in net canopy turbulent fluxes w.r.t. ground temperature (W m-2 K-1) real(dp) :: 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(dp) :: dTurbFluxGround_dTCanair ! derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) real(dp) :: dTurbFluxGround_dTCanopy ! derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) real(dp) :: dTurbFluxGround_dTGround ! derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) real(dp) :: dTurbFluxGround_dCanLiq ! derivative in net ground turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) - ! (liquid water flux derivatives) + + ! (liquid water flux derivatives -- canopy evap) real(dp) :: dLatHeatCanopyEvap_dCanLiq ! derivative in latent heat of canopy evaporation w.r.t. canopy liquid water content (W kg-1) real(dp) :: dLatHeatCanopyEvap_dTCanair ! derivative in latent heat of canopy evaporation w.r.t. canopy air temperature (W m-2 K-1) real(dp) :: dLatHeatCanopyEvap_dTCanopy ! derivative in latent heat of canopy evaporation w.r.t. canopy temperature (W m-2 K-1) real(dp) :: 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(dp) :: dLatHeatGroundEvap_dCanLiq ! derivative in latent heat of ground evaporation w.r.t. canopy liquid water content (J kg-1 s-1) + real(dp) :: dLatHeatGroundEvap_dTCanair ! derivative in latent heat of ground evaporation w.r.t. canopy air temperature (W m-2 K-1) + real(dp) :: dLatHeatGroundEvap_dTCanopy ! derivative in latent heat of ground evaporation w.r.t. canopy temperature (W m-2 K-1) + real(dp) :: 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 ! --------------------------------------------------------------------------------------- @@ -381,46 +431,53 @@ subroutine vegNrgFlux(& 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), & ! intent(in): [dp] height at the top of the vegetation canopy (m) - heightCanopyBottom => mpar_data%var(iLookPARAM%heightCanopyBottom), & ! intent(in): [dp] height at the bottom of the vegetation canopy (m) - scalarCanopyIceMax => mvar_data%var(iLookMVAR%scalarCanopyIceMax)%dat(1), & ! intent(in): [dp] maximum interception storage capacity for ice (kg m-2) - scalarCanopyLiqMax => mvar_data%var(iLookMVAR%scalarCanopyLiqMax)%dat(1), & ! intent(in): [dp] maximum interception storage capacity for liquid water (kg m-2) + 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 => mvar_data%var(iLookMVAR%scalarLAI)%dat(1), & ! intent(in): [dp] one-sided leaf area index (m2 m-2) - scalarSAI => mvar_data%var(iLookMVAR%scalarSAI)%dat(1), & ! intent(in): [dp] one-sided stem area index (m2 m-2) - scalarExposedLAI => mvar_data%var(iLookMVAR%scalarExposedLAI)%dat(1), & ! intent(in): [dp] exposed leaf area index after burial by snow (m2 m-2) - scalarExposedSAI => mvar_data%var(iLookMVAR%scalarExposedSAI)%dat(1), & ! intent(in): [dp] exposed stem area index after burial by snow (m2 m-2) - scalarGrowingSeasonIndex => mvar_data%var(iLookMVAR%scalarGrowingSeasonIndex)%dat(1), & ! intent(in): [dp] growing season index (0=off, 1=on) - scalarFoliageNitrogenFactor => mvar_data%var(iLookMVAR%scalarFoliageNitrogenFactor)%dat(1), & ! intent(in): [dp] foliage nitrogen concentration (1.0 = saturated) + 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), & ! intent(in): [dp] roughness length of snow (m) - z0Soil => mpar_data%var(iLookPARAM%z0Soil), & ! intent(in): [dp] roughness length of soil (m) - z0CanopyParam => mpar_data%var(iLookPARAM%z0Canopy), & ! intent(in): [dp] roughness length of the canopy (m) - zpdFraction => mpar_data%var(iLookPARAM%zpdFraction), & ! intent(in): [dp] zero plane displacement / canopy height (-) - critRichNumber => mpar_data%var(iLookPARAM%critRichNumber), & ! intent(in): [dp] critical value for the bulk Richardson number where turbulence ceases (-) - Louis79_bparam => mpar_data%var(iLookPARAM%Louis79_bparam), & ! intent(in): [dp] parameter in Louis (1979) stability function - Louis79_cStar => mpar_data%var(iLookPARAM%Louis79_cStar), & ! intent(in): [dp] parameter in Louis (1979) stability function - Mahrt87_eScale => mpar_data%var(iLookPARAM%Mahrt87_eScale), & ! intent(in): [dp] exponential scaling factor in the Mahrt (1987) stability function - windReductionParam => mpar_data%var(iLookPARAM%windReductionParam), & ! intent(in): [dp] canopy wind reduction parameter (-) - leafExchangeCoeff => mpar_data%var(iLookPARAM%leafExchangeCoeff), & ! intent(in): [dp] turbulent exchange coeff between canopy surface and canopy air ( m s-(1/2) ) - leafDimension => mpar_data%var(iLookPARAM%leafDimension), & ! intent(in): [dp] characteristic leaf dimension (m) + 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), & ! intent(in): [dp] soil porosity (-) - theta_res => mpar_data%var(iLookPARAM%theta_res), & ! intent(in): [dp] residual volumetric liquid water content (-) - plantWiltPsi => mpar_data%var(iLookPARAM%plantWiltPsi), & ! intent(in): [dp] matric head at wilting point (m) - soilStressParam => mpar_data%var(iLookPARAM%soilStressParam), & ! intent(in): [dp] parameter in the exponential soil stress function (-) - critSoilWilting => mpar_data%var(iLookPARAM%critSoilWilting), & ! intent(in): [dp] critical vol. liq. water content when plants are wilting (-) - critSoilTranspire => mpar_data%var(iLookPARAM%critSoilTranspire), & ! intent(in): [dp] critical vol. liq. water content when transpiration is limited (-) - critAquiferTranspire => mpar_data%var(iLookPARAM%critAquiferTranspire), & ! intent(in): [dp] critical aquifer storage value when transpiration is limited (m) - minStomatalResistance => mpar_data%var(iLookPARAM%minStomatalResistance), & ! intent(in): [dp] mimimum stomatal resistance (s m-1) + 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 => attr_data%var(iLookATTR%mHeight), & ! intent(in): [dp] measurement height (m) @@ -428,116 +485,119 @@ subroutine vegNrgFlux(& 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 => mvar_data%var(iLookMVAR%scalarVPair)%dat(1), & ! intent(in): [dp] vapor pressure at some height above the surface (Pa) - scalarO2air => mvar_data%var(iLookMVAR%scalarO2air)%dat(1), & ! intent(in): [dp] atmospheric o2 concentration (Pa) - scalarCO2air => mvar_data%var(iLookMVAR%scalarCO2air)%dat(1), & ! intent(in): [dp] atmospheric co2 concentration (Pa) - scalarTwetbulb => mvar_data%var(iLookMVAR%scalarTwetbulb)%dat(1), & ! intent(in): [dp] wetbulb temperature (K) - scalarRainfall => mvar_data%var(iLookMVAR%scalarRainfall)%dat(1), & ! intent(in): [dp] computed rainfall rate (kg m-2 s-1) - scalarSnowfall => mvar_data%var(iLookMVAR%scalarSnowfall)%dat(1), & ! intent(in): [dp] computed snowfall rate (kg m-2 s-1) - scalarThroughfallRain => mvar_data%var(iLookMVAR%scalarThroughfallRain)%dat(1), & ! intent(in): [dp] rainfall through the vegetation canopy (kg m-2 s-1) - scalarThroughfallSnow => mvar_data%var(iLookMVAR%scalarThroughfallSnow)%dat(1), & ! intent(in): [dp] snowfall through the vegetation canopy (kg m-2 s-1) + 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 => mvar_data%var(iLookMVAR%scalarSWE)%dat(1), & ! intent(in): [dp] snow water equivalent on the ground (kg m-2) - scalarSnowDepth => mvar_data%var(iLookMVAR%scalarSnowDepth)%dat(1), & ! intent(in): [dp] snow depth on the ground surface (m) - mLayerVolFracLiq => mvar_data%var(iLookMVAR%mLayerVolFracLiq)%dat(nSnow+1:nLayers), & ! intent(in): [dp(:)] volumetric fraction of liquid water in each soil layer (-) - mLayerMatricHead => mvar_data%var(iLookMVAR%mLayerMatricHead)%dat, & ! intent(in): [dp(:)] matric head in each layer (m) - localAquiferStorage => mvar_data%var(iLookMVAR%scalarAquiferStorage)%dat(1), & ! intent(in): [dp] aquifer storage for the local column (m) + 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 => mvar_data%var(iLookMVAR%scalarCanopySunlitLAI)%dat(1), & ! intent(in): [dp] sunlit leaf area (-) - scalarCanopyShadedLAI => mvar_data%var(iLookMVAR%scalarCanopyShadedLAI)%dat(1), & ! intent(in): [dp] shaded leaf area (-) - scalarCanopySunlitPAR => mvar_data%var(iLookMVAR%scalarCanopySunlitPAR)%dat(1), & ! intent(in): [dp] average absorbed par for sunlit leaves (w m-2) - scalarCanopyShadedPAR => mvar_data%var(iLookMVAR%scalarCanopyShadedPAR)%dat(1), & ! intent(in): [dp] average absorbed par for shaded leaves (w m-2) - scalarCanopyAbsorbedSolar => mvar_data%var(iLookMVAR%scalarCanopyAbsorbedSolar)%dat(1), & ! intent(in): [dp] solar radiation absorbed by canopy (W m-2) - scalarGroundAbsorbedSolar => mvar_data%var(iLookMVAR%scalarGroundAbsorbedSolar)%dat(1), & ! intent(in): [dp] solar radiation absorbed by ground (W m-2) + 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 => mvar_data%var(iLookMVAR%scalarCanopyWetFraction)%dat(1), & ! intent(out): [dp] fraction of canopy that is wet - scalarGroundSnowFraction => mvar_data%var(iLookMVAR%scalarGroundSnowFraction)%dat(1), & ! intent(out): [dp] fraction of ground covered with snow (-) + 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 => mvar_data%var(iLookMVAR%scalarCanopyEmissivity)%dat(1), & ! intent(out): [dp] effective emissivity of the canopy (-) - scalarLWRadCanopy => mvar_data%var(iLookMVAR%scalarLWRadCanopy)%dat(1), & ! intent(out): [dp] longwave radiation emitted from the canopy (W m-2) - scalarLWRadGround => mvar_data%var(iLookMVAR%scalarLWRadGround)%dat(1), & ! intent(out): [dp] longwave radiation emitted at the ground surface (W m-2) - scalarLWRadUbound2Canopy => mvar_data%var(iLookMVAR%scalarLWRadUbound2Canopy)%dat(1), & ! intent(out): [dp] downward atmospheric longwave radiation absorbed by the canopy (W m-2) - scalarLWRadUbound2Ground => mvar_data%var(iLookMVAR%scalarLWRadUbound2Ground)%dat(1), & ! intent(out): [dp] downward atmospheric longwave radiation absorbed by the ground (W m-2) - scalarLWRadUbound2Ubound => mvar_data%var(iLookMVAR%scalarLWRadUbound2Ubound)%dat(1), & ! intent(out): [dp] atmospheric radiation reflected by the ground and lost thru upper boundary (W m-2) - scalarLWRadCanopy2Ubound => mvar_data%var(iLookMVAR%scalarLWRadCanopy2Ubound)%dat(1), & ! intent(out): [dp] longwave radiation emitted from canopy lost thru upper boundary (W m-2) - scalarLWRadCanopy2Ground => mvar_data%var(iLookMVAR%scalarLWRadCanopy2Ground)%dat(1), & ! intent(out): [dp] longwave radiation emitted from canopy absorbed by the ground (W m-2) - scalarLWRadCanopy2Canopy => mvar_data%var(iLookMVAR%scalarLWRadCanopy2Canopy)%dat(1), & ! intent(out): [dp] canopy longwave reflected from ground and absorbed by the canopy (W m-2) - scalarLWRadGround2Ubound => mvar_data%var(iLookMVAR%scalarLWRadGround2Ubound)%dat(1), & ! intent(out): [dp] longwave radiation emitted from ground lost thru upper boundary (W m-2) - scalarLWRadGround2Canopy => mvar_data%var(iLookMVAR%scalarLWRadGround2Canopy)%dat(1), & ! intent(out): [dp] longwave radiation emitted from ground and absorbed by the canopy (W m-2) - scalarLWNetCanopy => mvar_data%var(iLookMVAR%scalarLWNetCanopy)%dat(1), & ! intent(out): [dp] net longwave radiation at the canopy (W m-2) - scalarLWNetGround => mvar_data%var(iLookMVAR%scalarLWNetGround)%dat(1), & ! intent(out): [dp] net longwave radiation at the ground surface (W m-2) - scalarLWNetUbound => mvar_data%var(iLookMVAR%scalarLWNetUbound)%dat(1), & ! intent(out): [dp] net longwave radiation at the upper boundary (W m-2) + 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 => mvar_data%var(iLookMVAR%scalarZ0Canopy)%dat(1), & ! intent(out): [dp] roughness length of the canopy (m) - scalarWindReductionFactor => mvar_data%var(iLookMVAR%scalarWindReductionFactor)%dat(1), & ! intent(out): [dp] canopy wind reduction factor (-) - scalarZeroPlaneDisplacement => mvar_data%var(iLookMVAR%scalarZeroPlaneDisplacement)%dat(1), & ! intent(out): [dp] zero plane displacement (m) - scalarRiBulkCanopy => mvar_data%var(iLookMVAR%scalarRiBulkCanopy)%dat(1), & ! intent(out): [dp] bulk Richardson number for the canopy (-) - scalarRiBulkGround => mvar_data%var(iLookMVAR%scalarRiBulkGround)%dat(1), & ! intent(out): [dp] bulk Richardson number for the ground surface (-) - scalarEddyDiffusCanopyTop => mvar_data%var(iLookMVAR%scalarEddyDiffusCanopyTop)%dat(1), & ! intent(out): [dp] eddy diffusivity for heat at the top of the canopy (m2 s-1) - scalarFrictionVelocity => mvar_data%var(iLookMVAR%scalarFrictionVelocity)%dat(1), & ! intent(out): [dp] friction velocity (m s-1) - scalarWindspdCanopyTop => mvar_data%var(iLookMVAR%scalarWindspdCanopyTop)%dat(1), & ! intent(out): [dp] windspeed at the top of the canopy (m s-1) - scalarWindspdCanopyBottom => mvar_data%var(iLookMVAR%scalarWindspdCanopyBottom)%dat(1), & ! intent(out): [dp] windspeed at the height of the bottom of the canopy (m s-1) - scalarLeafResistance => mvar_data%var(iLookMVAR%scalarLeafResistance)%dat(1), & ! intent(out): [dp] mean leaf boundary layer resistance per unit leaf area (s m-1) - scalarGroundResistance => mvar_data%var(iLookMVAR%scalarGroundResistance)%dat(1), & ! intent(out): [dp] below canopy aerodynamic resistance (s m-1) - scalarCanopyResistance => mvar_data%var(iLookMVAR%scalarCanopyResistance)%dat(1), & ! intent(out): [dp] above canopy aerodynamic resistance (s m-1) + 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 => mvar_data%var(iLookMVAR%mLayerRootDensity)%dat, & ! intent(in): [dp] root density in each layer (-) - scalarAquiferRootFrac => mvar_data%var(iLookMVAR%scalarAquiferRootFrac)%dat(1), & ! intent(in): [dp] fraction of roots below the lowest soil layer (-) - scalarTranspireLim => mvar_data%var(iLookMVAR%scalarTranspireLim)%dat(1), & ! intent(inout): [dp] weighted average of the transpiration limiting factor (-) - mLayerTranspireLim => mvar_data%var(iLookMVAR%mLayerTranspireLim)%dat, & ! intent(inout): [dp] transpiration limiting factor in each layer (-) - scalarTranspireLimAqfr => mvar_data%var(iLookMVAR%scalarTranspireLimAqfr)%dat(1), & ! intent(inout): [dp] transpiration limiting factor for the aquifer (-) - scalarSoilRelHumidity => mvar_data%var(iLookMVAR%scalarSoilRelHumidity)%dat(1), & ! intent(inout): [dp] relative humidity in the soil pores [0-1] - scalarSoilResistance => mvar_data%var(iLookMVAR%scalarSoilResistance)%dat(1), & ! intent(inout): [dp] resistance from the soil (s m-1) + 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 => mvar_data%var(iLookMVAR%scalarStomResistSunlit)%dat(1), & ! intent(inout): [dp] stomatal resistance for sunlit leaves (s m-1) - scalarStomResistShaded => mvar_data%var(iLookMVAR%scalarStomResistShaded)%dat(1), & ! intent(inout): [dp] stomatal resistance for shaded leaves (s m-1) - scalarPhotosynthesisSunlit => mvar_data%var(iLookMVAR%scalarPhotosynthesisSunlit)%dat(1), & ! intent(inout): [dp] sunlit photosynthesis (umolco2 m-2 s-1) - scalarPhotosynthesisShaded => mvar_data%var(iLookMVAR%scalarPhotosynthesisShaded)%dat(1), & ! intent(inout): [dp] shaded photosynthesis (umolco2 m-2 s-1) + 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 => mvar_data%var(iLookMVAR%scalarLatHeatSubVapCanopy)%dat(1), & ! intent(inout): [dp] latent heat of sublimation/vaporization for the vegetation canopy (J kg-1) - scalarLatHeatSubVapGround => mvar_data%var(iLookMVAR%scalarLatHeatSubVapGround)%dat(1), & ! intent(inout): [dp] latent heat of sublimation/vaporization for the ground surface (J kg-1) - scalarSatVP_canopyTemp => mvar_data%var(iLookMVAR%scalarSatVP_CanopyTemp)%dat(1), & ! intent(out): [dp] saturation vapor pressure at the temperature of the vegetation canopy (Pa) - scalarSatVP_groundTemp => mvar_data%var(iLookMVAR%scalarSatVP_GroundTemp)%dat(1), & ! intent(out): [dp] saturation vapor pressure at the temperature of the ground surface (Pa) - scalarSenHeatTotal => mvar_data%var(iLookMVAR%scalarSenHeatTotal)%dat(1), & ! intent(out): [dp] sensible heat from the canopy air space to the atmosphere (W m-2) - scalarSenHeatCanopy => mvar_data%var(iLookMVAR%scalarSenHeatCanopy)%dat(1), & ! intent(out): [dp] sensible heat flux from the canopy to the canopy air space (W m-2) - scalarSenHeatGround => mvar_data%var(iLookMVAR%scalarSenHeatGround)%dat(1), & ! intent(out): [dp] sensible heat flux from ground surface below vegetation (W m-2) - scalarLatHeatTotal => mvar_data%var(iLookMVAR%scalarLatHeatTotal)%dat(1), & ! intent(out): [dp] latent heat from the canopy air space to the atmosphere (W m-2) - scalarLatHeatCanopyEvap => mvar_data%var(iLookMVAR%scalarLatHeatCanopyEvap)%dat(1), & ! intent(out): [dp] latent heat flux for evaporation from the canopy to the canopy air space (W m-2) - scalarLatHeatCanopyTrans => mvar_data%var(iLookMVAR%scalarLatHeatCanopyTrans)%dat(1), & ! intent(out): [dp] latent heat flux for transpiration from the canopy to the canopy air space (W m-2) - scalarLatHeatGround => mvar_data%var(iLookMVAR%scalarLatHeatGround)%dat(1), & ! intent(out): [dp] latent heat flux from ground surface below vegetation (W m-2) + 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 => mvar_data%var(iLookMVAR%scalarCanopyAdvectiveHeatFlux)%dat(1), & ! intent(out): [dp] heat advected to the canopy surface with rain + snow (W m-2) - scalarGroundAdvectiveHeatFlux => mvar_data%var(iLookMVAR%scalarGroundAdvectiveHeatFlux)%dat(1), & ! intent(out): [dp] heat advected to the ground surface with throughfall (W m-2) + 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 => mvar_data%var(iLookMVAR%scalarCanopySublimation)%dat(1), & ! intent(out): [dp] canopy sublimation/frost (kg m-2 s-1) - scalarSnowSublimation => mvar_data%var(iLookMVAR%scalarSnowSublimation)%dat(1), & ! intent(out): [dp] snow sublimation/frost -- below canopy or non-vegetated (kg m-2 s-1) + 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 => mvar_data%var(iLookMVAR%scalarVP_CanopyAir)%dat(1), & ! intent(inout): [dp] vapor pressure of the canopy air space (Pa) - scalarCanopyStabilityCorrection => mvar_data%var(iLookMVAR%scalarCanopyStabilityCorrection)%dat(1),& ! intent(inout): [dp] stability correction for the canopy (-) - scalarGroundStabilityCorrection => mvar_data%var(iLookMVAR%scalarGroundStabilityCorrection)%dat(1),& ! intent(inout): [dp] stability correction for the ground surface (-) + 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 => mvar_data%var(iLookMVAR%scalarCanopyTranspiration)%dat(1), & ! intent(out): [dp] canopy transpiration (kg m-2 s-1) - scalarCanopyEvaporation => mvar_data%var(iLookMVAR%scalarCanopyEvaporation)%dat(1), & ! intent(out): [dp] canopy evaporation/condensation (kg m-2 s-1) - scalarGroundEvaporation => mvar_data%var(iLookMVAR%scalarGroundEvaporation)%dat(1) & ! intent(out): [dp] ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) + 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) ) ! --------------------------------------------------------------------------------------- ! initialize error control err=0; message="vegNrgFlux/" + ! set wind measurement height at distance above canopy + uHeight = mHeight + heightCanopyTop + ! initialize printflag printflag = .false. @@ -572,19 +632,29 @@ subroutine vegNrgFlux(& dCanopyNetFlux_dGroundTemp = 0._dp ! derivative in net canopy flux w.r.t. ground temperature (W m-2 K-1) dGroundNetFlux_dCanairTemp = 0._dp ! derivative in net ground flux w.r.t. canopy air temperature (W m-2 K-1) dGroundNetFlux_dCanopyTemp = 0._dp ! 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._dp ! derivative in canopy evaporation w.r.t. canopy liquid water content (s-1) + dCanopyEvaporation_dTCanair= 0._dp ! derivative in canopy evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + dCanopyEvaporation_dTCanopy= 0._dp ! derivative in canopy evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + dCanopyEvaporation_dTGround= 0._dp ! 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._dp ! derivative in ground evaporation w.r.t. canopy liquid water content (s-1) + dGroundEvaporation_dTCanair= 0._dp ! derivative in ground evaporation w.r.t. canopy air temperature (kg m-2 s-1 K-1) + dGroundEvaporation_dTCanopy= 0._dp ! derivative in ground evaporation w.r.t. canopy temperature (kg m-2 s-1 K-1) + dGroundEvaporation_dTGround= 0._dp ! 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 = -mvar_data%var(iLookMVAR%iLayerThermalC)%dat(0)*(groundTempTrial - upperBoundTemp)/(mvar_data%var(iLookMVAR%mLayerDepth)%dat(1)*0.5_dp) + groundNetFlux = -diag_data%var(iLookDIAG%iLayerThermalC)%dat(0)*(groundTempTrial - upperBoundTemp)/(prog_data%var(iLookPROG%mLayerDepth)%dat(1)*0.5_dp) ! compute derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) - dGroundNetFlux_dGroundTemp = -mvar_data%var(iLookMVAR%iLayerThermalC)%dat(0)/(mvar_data%var(iLookMVAR%mLayerDepth)%dat(1)*0.5_dp) + dGroundNetFlux_dGroundTemp = -diag_data%var(iLookDIAG%iLayerThermalC)%dat(0)/(prog_data%var(iLookPROG%mLayerDepth)%dat(1)*0.5_dp) elseif(model_decisions(iLookDECISIONS%bcUpprTdyn)%iDecision == zeroFlux)then groundNetFlux = 0._dp dGroundNetFlux_dGroundTemp = 0._dp else err=20; message=trim(message)//'unable to identify upper boundary condition for thermodynamics: expect the case to be prescribedTemp or zeroFlux'; return - endif + end if ! ***** ! (2) NEUMANN BOUNDARY CONDITION... @@ -619,8 +689,8 @@ subroutine vegNrgFlux(& ! NOTE: this is needed for the stomatal resistance calculations if(scalarVP_CanopyAir < 0._dp)then scalarVP_CanopyAir = scalarVPair - 1._dp ! "small" offset used to assist in checking initial derivative calculations - endif - endif + 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 @@ -628,15 +698,15 @@ subroutine vegNrgFlux(& 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; endif + 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._dp ! 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._dp - endif ! (if there is snow on the ground) - endif ! (if the first flux call) + 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) @@ -665,7 +735,7 @@ subroutine vegNrgFlux(& case default err=20; message=trim(message)//'unable to identify option for canopy emissivity'; return end select - endif + end if ! ensure canopy longwave fluxes are zero when not computing canopy fluxes if(.not.computeVegFlux) scalarCanopyEmissivity=0._dp @@ -683,7 +753,7 @@ subroutine vegNrgFlux(& fracLiquidCanopy = canopyLiqTrial / (canopyLiqTrial + canopyIceTrial) else fracLiquidCanopy = 0._dp - endif + end if ! get wetted fraction and derivatives call wettedFrac(& @@ -697,19 +767,21 @@ subroutine vegNrgFlux(& 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; endif + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if else scalarCanopyWetFraction = 0._dp ! canopy wetted fraction (-) dCanopyWetFraction_dWat = 0._dp ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) dCanopyWetFraction_dT = 0._dp ! derivative in wetted fraction w.r.t. canopy temperature (K-1) - endif - !print*, 'scalarCanopyWetFraction = ', scalarCanopyWetFraction + 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 @@ -737,7 +809,7 @@ subroutine vegNrgFlux(& 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) + uHeight, & ! 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 @@ -782,7 +854,7 @@ subroutine vegNrgFlux(& 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; endif + 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) @@ -812,8 +884,8 @@ subroutine vegNrgFlux(& 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 layer (m) - mLayerVolFracLiq(1:nSoil), & ! intent(in): volumetric fraction of liquid water in each layer (-) + 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 (-) @@ -829,63 +901,31 @@ subroutine vegNrgFlux(& 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; endif + 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 - select case(ix_stomResist) - - case(simpleResistance) - ! check that we don't divide by zero -- should be set to minimum of tiny in runroutine soilResist - if(scalarTranspireLim < tiny(plantWiltPsi))then; err=20; message=trim(message)//'soil moisture stress factor is < tiny -- this will cause problems'; return; endif - ! compute stomatal resistance (assume equal for sunlit and shaded leaves) - scalarStomResistSunlit = minStomatalResistance/scalarTranspireLim - scalarStomResistShaded = scalarStomResistSunlit - ! set photosynthesis to missing (not computed) - scalarPhotosynthesisSunlit = missingValue - scalarPhotosynthesisShaded = missingValue - - ! compute stomatal resistance (wrapper around the Noah-MP routines) - ! NOTE: canopy air vapor pressure is from the previous time step - case(BallBerry,Jarvis) - call stomResist(& - ! input (model decisions) - 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) - scalarO2air, & ! intent(in): atmospheric o2 concentration (Pa) - scalarCO2air, & ! intent(in): atmospheric co2 concentration (Pa) - scalarCanopySunlitPAR, & ! intent(in): average absorbed par for sunlit leaves (w m-2) - scalarCanopyShadedPAR, & ! intent(in): average absorbed par for shaded leaves (w m-2) - ! input (state and diagnostic variables) - scalarGrowingSeasonIndex, & ! intent(in): growing season index (0=off, 1=on) - scalarFoliageNitrogenFactor, & ! intent(in): foliage nitrogen concentration (1=saturated) - scalarTranspireLim, & ! intent(in): weighted average of the soil moiture factor controlling stomatal resistance (-) - scalarLeafResistance, & ! intent(in): leaf boundary layer resistance (s m-1) - 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) - ! output - scalarStomResistSunlit, & ! intent(out): stomatal resistance for sunlit leaves (s m-1) - scalarStomResistShaded, & ! intent(out): stomatal resistance for shaded leaves (s m-1) - scalarPhotosynthesisSunlit, & ! intent(out): sunlit photosynthesis (umolco2 m-2 s-1) - scalarPhotosynthesisShaded, & ! intent(out): shaded photosynthesis (umolco2 m-2 s-1) - err,cmessage ) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - - ! error check - case default; err=20; message=trim(message)//'unable to identify option for stomatal resistance'; return - - endselect ! (identifying option for stomatal resistance) - - endif ! (if the first flux call in a given sub-step) + 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) ! ******************************************************************************************************************************************************************* @@ -930,7 +970,7 @@ subroutine vegNrgFlux(& 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; endif + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if !print*, 'dLWNetCanopy_dTGround = ', dLWNetCanopy_dTGround @@ -945,7 +985,7 @@ subroutine vegNrgFlux(& nFlux=5 ! compute the derivatives using one-sided finite differences else nFlux=1 ! compute analytical derivatives - endif + 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) @@ -1005,16 +1045,18 @@ subroutine vegNrgFlux(& 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; endif + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if else canopyWetFraction = 0._dp - endif + end if !print*, 'wetted fraction derivative = ', (canopyWetFraction - scalarCanopyWetFraction)/dx !pause @@ -1048,7 +1090,7 @@ subroutine vegNrgFlux(& 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) + uHeight, & ! 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) @@ -1093,7 +1135,7 @@ subroutine vegNrgFlux(& 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; endif + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! assign scalar resistances for un-perturbed cases @@ -1102,7 +1144,7 @@ subroutine vegNrgFlux(& trialGroundResistance = scalarGroundResistance trialCanopyResistance = scalarCanopyResistance - endif ! (re-computing resistances for perturbed cases) + end if ! (re-computing resistances for perturbed cases) !print*, 'trialLeafResistance = ', trialLeafResistance !print*, 'trialGroundResistance = ', trialGroundResistance !print*, 'trialCanopyResistance = ', trialCanopyResistance @@ -1111,7 +1153,7 @@ subroutine vegNrgFlux(& ! 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(1)/(theta_sat - theta_res) + soilEvapFactor = mLayerVolFracLiq(nSnow+1)/(theta_sat - theta_res) ! (resistance from the soil [s m-1]) scalarSoilResistance = scalarGroundSnowFraction*1._dp + (1._dp - scalarGroundSnowFraction)*EXP(8.25_dp - 4.225_dp*soilEvapFactor) ! Sellers (1992) !scalarSoilResistance = scalarGroundSnowFraction*0._dp + (1._dp - scalarGroundSnowFraction)*exp(8.25_dp - 6.0_dp*soilEvapFactor) ! Niu adjustment to decrease resitance for wet soil @@ -1120,10 +1162,10 @@ subroutine vegNrgFlux(& soilRelHumidity_noSnow = exp( (mLayerMatricHead(1)*gravity) / (groundTemp*R_wv) ) else soilRelHumidity_noSnow = 0._dp - endif ! (if matric head is very low) + end if ! (if matric head is very low) scalarSoilRelHumidity = scalarGroundSnowFraction*1._dp + (1._dp - scalarGroundSnowFraction)*soilRelHumidity_noSnow !print*, 'mLayerMatricHead(1), scalarSoilRelHumidity = ', mLayerMatricHead(1), scalarSoilRelHumidity - endif ! (if the first flux call) + end if ! (if the first flux call) ! compute turbulent heat fluxes call turbFluxes(& @@ -1200,23 +1242,28 @@ subroutine vegNrgFlux(& 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 + ! 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; endif + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if - !print*, 'scalarSenHeatTotal = ', scalarSenHeatTotal - !print*, 'scalarSenHeatCanopy = ', scalarSenHeatCanopy - !print*, 'scalarLatHeatCanopyEvap = ', scalarLatHeatCanopyEvap - !print*, 'scalarLatHeatCanopyTrans = ', scalarLatHeatCanopyTrans + !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 @@ -1260,7 +1307,7 @@ subroutine vegNrgFlux(& 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) - endif ! (if numerical) + end if ! (if numerical) end do ! (looping through different flux perturbations) @@ -1292,7 +1339,7 @@ subroutine vegNrgFlux(& 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) - endif + end if !if(heightCanopyBottom < scalarSnowDepth+z0Ground) pause 'bottom of the canopy is covered' ! test @@ -1343,7 +1390,7 @@ subroutine vegNrgFlux(& scalarCanopyTranspiration = 0._dp else scalarCanopyTranspiration = scalarLatHeatCanopyTrans/LH_vap ! transpiration is always vapor - endif + end if ! (canopy transpiration/evaporation) else ! evaporation scalarCanopyEvaporation = scalarLatHeatCanopyEvap/LH_vap @@ -1353,22 +1400,23 @@ subroutine vegNrgFlux(& scalarCanopyTranspiration = 0._dp else scalarCanopyTranspiration = scalarLatHeatCanopyTrans/LH_vap - endif - endif + 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; endif + 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._dp ! 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; endif + 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._dp ! no sublimation from snow if no snow layers have formed - endif + end if !print*, 'scalarSnowSublimation, scalarLatHeatGround = ', scalarSnowSublimation, scalarLatHeatGround + !print*, 'canopyWetFraction, scalarCanopyEvaporation = ', canopyWetFraction, scalarCanopyEvaporation ! ******************************************************************************************************************************************************************* ! ******************************************************************************************************************************************************************* @@ -1380,8 +1428,8 @@ subroutine vegNrgFlux(& canairNetFlux = turbFluxCanair canopyNetFlux = scalarCanopyAbsorbedSolar + scalarLWNetCanopy + turbFluxCanopy + scalarCanopyAdvectiveHeatFlux groundNetFlux = scalarGroundAbsorbedSolar + scalarLWNetGround + turbFluxGround + scalarGroundAdvectiveHeatFlux - !write(*,'(a,1x,10(e22.16,1x))') 'canopyNetFlux, groundNetFlux, scalarLWNetCanopy, turbFluxCanopy, turbFluxGround, scalarLWNetGround = ', & - ! canopyNetFlux, groundNetFlux, scalarLWNetCanopy, turbFluxCanopy, turbFluxGround, scalarLWNetGround + !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 @@ -1411,7 +1459,13 @@ subroutine vegNrgFlux(& dCanopyEvaporation_dTCanair = 0._dp ! (kg m-2 s-1 K-1) dCanopyEvaporation_dTCanopy = 0._dp ! (kg m-2 s-1 K-1) dCanopyEvaporation_dTGround = 0._dp ! (kg m-2 s-1 K-1) - endif + 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) @@ -1458,6 +1512,8 @@ subroutine wettedFrac(& 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) @@ -1474,6 +1530,8 @@ subroutine wettedFrac(& real(dp),intent(in) :: canopyIce ! canopy ice (kg m-2) real(dp),intent(in) :: canopyLiqMax ! maximum canopy liquid water (kg m-2) real(dp),intent(in) :: canopyIceMax ! maximum canopy ice content (kg m-2) + real(dp),intent(in) :: canopyWettingFactor ! maximum wetted fraction of the canopy (-) + real(dp),intent(in) :: canopyWettingExp ! exponent in canopy wetting function (-) ! output real(dp),intent(out) :: canopyWetFraction ! canopy wetted fraction (-) real(dp),intent(out) :: dCanopyWetFraction_dWat ! derivative in wetted fraction w.r.t. canopy total water (kg-1 m2) @@ -1482,11 +1540,8 @@ subroutine wettedFrac(& integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! local variables - logical(lgt),parameter :: noDerivs=.false. ! flag to denote that derivatives are not required logical(lgt),parameter :: smoothing=.true. ! flag to denote that smoothing is required - logical(lgt),parameter :: noSmoothing=.false. ! flag to denote that no smoothing is required real(dp) :: canopyWetFractionPert ! canopy wetted fraction after state perturbations (-) - real(dp),parameter :: maxScaleFactor=1._dp ! temporary fix: since canopyLiqMax is not really max (it is the point when drainage begins), add scale factor for the wetted fraction (-) real(dp) :: canopyWetFractionDeriv ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) ! ----------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control @@ -1495,28 +1550,28 @@ subroutine 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*maxScaleFactor,canopyWetFraction,canopyWetFractionDeriv) + 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*maxScaleFactor,canopyWetFractionPert,canopyWetFractionDeriv) + call wetFraction((deriv .and. .not.derNum),smoothing,canopyIce+dx,canopyIceMax,canopyWettingFactor,canopyWettingExp,canopyWetFractionPert,canopyWetFractionDeriv) canopyWetFractionDeriv = (canopyWetFractionPert - canopyWetFraction)/dx - endif + end if ! scale derivative by the fraction of water ! NOTE: dIce/dWat = (1._dp - fracLiq), hence dWet/dWat = dIce/dWat . dWet/dLiq dCanopyWetFraction_dWat = canopyWetFractionDeriv*(1._dp - fracLiq) dCanopyWetFraction_dT = -canopyWetFractionDeriv*dLiq_dT ! NOTE: dIce/dT = -dLiq/dT return - endif + end if ! compute fraction of liquid water on the canopy ! NOTE: if(.not.deriv) canopyWetFractionDeriv = 0._dp - call wetFraction((deriv .and. .not.derNum),smoothing,canopyLiq,canopyLiqMax*maxScaleFactor,canopyWetFraction,canopyWetFractionDeriv) + 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*maxScaleFactor,canopyWetFractionPert,canopyWetFractionDeriv) + call wetFraction((deriv .and. .not.derNum),smoothing,canopyLiq+dx,canopyLiqMax,canopyWettingFactor,canopyWettingExp,canopyWetFractionPert,canopyWetFractionDeriv) canopyWetFractionDeriv = (canopyWetFractionPert - canopyWetFraction)/dx - endif + end if ! scale derivative by the fraction of water ! NOTE: dLiq/dWat = fracLiq, hence dWet/dWat = dLiq/dWat . dWet/dLiq @@ -1533,18 +1588,20 @@ end subroutine wettedFrac ! ******************************************************************************************************* ! private subroutine wetFraction: compute fraction of canopy covered with liquid water ! ******************************************************************************************************* - subroutine wetFraction(derDesire,smoothing,canopyLiq,canopyMax,canopyWetFraction,canopyWetFractionDeriv) + 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(dp),intent(in) :: canopyLiq ! liquid water content (kg m-2) real(dp),intent(in) :: canopyMax ! liquid water content (kg m-2) + real(dp),intent(in) :: canopyWettingFactor ! maximum wetted fraction of the canopy (-) + real(dp),intent(in) :: canopyWettingExp ! exponent in canopy wetting function (-) + real(dp),intent(out) :: canopyWetFraction ! canopy wetted fraction (-) real(dp),intent(out) :: canopyWetFractionDeriv ! derivative in wetted fraction w.r.t. canopy liquid water (kg-1 m2) ! local variables real(dp) :: relativeCanopyWater ! water stored on vegetation canopy, expressed as a fraction of maximum storage (-) - real(dp),parameter :: wetExp=0.666666667_dp ! exponent in wetted area function real(dp) :: rawCanopyWetFraction ! initial value of the canopy wet fraction (before smoothing) real(dp) :: rawWetFractionDeriv ! derivative in canopy wet fraction w.r.t. storage (kg-1 m2) real(dp) :: smoothFunc ! smoothing function used to improve numerical stability at times with limited water storage (-) @@ -1554,23 +1611,23 @@ subroutine wetFraction(derDesire,smoothing,canopyLiq,canopyMax,canopyWetFraction ! compute relative canopy water relativeCanopyWater = canopyLiq/canopyMax - !write(*,'(a,1x,3(f20.10,1x))') 'relativeCanopyWater, canopyLiq, canopyMax = ', 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._dp)then - rawCanopyWetFraction = relativeCanopyWater**wetExp + rawCanopyWetFraction = canopyWettingFactor*(relativeCanopyWater**canopyWettingExp) if(derDesire .and. relativeCanopyWater>verySmall)then - rawWetFractionDeriv = (wetExp/canopyMax)*relativeCanopyWater**(wetExp - 1._dp) + rawWetFractionDeriv = (canopyWettingFactor*canopyWettingExp/canopyMax)*relativeCanopyWater**(canopyWettingExp - 1._dp) else rawWetFractionDeriv = 0._dp - endif + end if - ! - canopy is 100% wet + ! - canopy is at capacity (canopyWettingFactor) else - rawCanopyWetFraction = 1._dp + rawCanopyWetFraction = canopyWettingFactor rawWetFractionDeriv = 0._dp - endif + end if ! smooth canopy wetted fraction if(smoothing)then @@ -1579,14 +1636,14 @@ subroutine wetFraction(derDesire,smoothing,canopyLiq,canopyMax,canopyWetFraction else canopyWetFraction = rawCanopyWetFraction canopyWetFractionDeriv = rawWetFractionDeriv - endif + 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._dp - endif + end if end subroutine wetFraction @@ -1619,15 +1676,15 @@ subroutine logisticSmoother(derDesire,canopyLiq,smoothFunc,smoothFuncDeriv) smoothFuncDeriv = expX / (smoothScale * (1._dp + expX)**2._dp) ! (derivative in the smoothing function) else smoothFuncDeriv = 0._dp - endif + end if ! outside limits: special case of smooth exponents else if(xArg < 0._dp)then; smoothFunc = 0._dp ! xArg < -xLimit else; smoothFunc = 1._dp ! xArg > xLimit - endif + end if smoothFuncDeriv = 0._dp - endif ! check for huge exponents + end if ! check for huge exponents end subroutine logisticSmoother ! -------------------------------------------------------------------------------------------------------------- @@ -1734,7 +1791,7 @@ subroutine longwaveBal(& nFlux=3 ! compute the derivatives using one-sided finite differences else nFlux=1 ! compute analytical derivatives - endif + 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) @@ -1779,7 +1836,7 @@ subroutine longwaveBal(& LWRadCanopy = emc*sb*TCan**4._dp ! longwave radiation emitted from the canopy (W m-2) else LWRadCanopy = 0._dp - endif + end if LWRadGround = emg*sb*TGnd**4._dp ! longwave radiation emitted at the ground surface (W m-2) ! compute fluxes originating from the atmosphere @@ -1830,7 +1887,7 @@ subroutine longwaveBal(& print*, 'LWNetUbound = ', LWNetUbound message=trim(message)//'flux imbalance' err=20; return - endif + end if ! -------------------------------------------------------------------------------------- ! save perturbed fluxes to calculate numerical derivatives (one-sided finite difference) @@ -1846,7 +1903,7 @@ subroutine longwaveBal(& LWNetGround_dStateGround = LWNetGround case default; err=10; message=trim(message)//"unknown perturbation"; return end select ! (type of perturbation) - endif ! (if numerical) + end if ! (if numerical) end do ! looping through different perturbations @@ -2043,7 +2100,7 @@ subroutine 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 - endif + end if ! ----------------------------------------------------------------------------------------------------------------------------------------- ! * compute vegetation poperties (could be done at the same time as phenology.. does not have to be in the flux routine!) @@ -2058,10 +2115,10 @@ subroutine aeroResist(& ! (compute zero-plane displacement) funcLAI = sqrt(c_d1*exposedVAI) fracCanopyHeight = -(1._dp - exp(-funcLAI))/funcLAI + 1._dp - zeroPlaneDisplacement = fracCanopyHeight*heightCanopyTop + zeroPlaneDisplacement = fracCanopyHeight*(heightCanopyTop-heightCanopyBottom)+heightCanopyBottom ! (coupute roughness length of the veg canopy) approxDragCoef = min( sqrt(C_s + C_r*exposedVAI/2._dp), approxDragCoef_max) - z0Canopy = (1._dp - fracCanopyHeight) * exp(-vkc*approxDragCoef - psi_h) * heightCanopyTop + z0Canopy = (1._dp - fracCanopyHeight) * exp(-vkc*approxDragCoef - psi_h) * (heightCanopyTop-heightCanopyBottom) ! Choudhury and Monteith (QJRMS 1998) "A four layer model for the heat budget..." case(CM_QJRMS1998) @@ -2071,7 +2128,7 @@ subroutine aeroResist(& z0Canopy = z0Ground + 0.3_dp*heightCanopyTop*funcLAI**0.5_dp else z0Canopy = 0.3_dp*heightCanopyTop*(1._dp - zeroPlaneDisplacement/heightCanopyTop) - endif + end if ! constant parameters dependent on the vegetation type case(vegTypeTable) @@ -2088,11 +2145,11 @@ subroutine aeroResist(& if(zeroPlaneDisplacement < snowDepth) zeroPlaneDisplacement = snowDepth ! check that everything is consistent - if(zeroPlaneDisplacement < heightCanopyBottom)then; err=20; message=trim(message)//'zero plane displacement is below the canopy bottom'; return; endif - if(mHeight < zeroPlaneDisplacement)then; err=20; message=trim(message)//'measurement height is below the displacement height'; return; endif - if(mHeight < z0Canopy)then; err=20; message=trim(message)//'measurement height is below the roughness length'; return; endif + if(zeroPlaneDisplacement < heightCanopyBottom)then; err=20; message=trim(message)//'zero plane displacement is below the canopy bottom'; return; end if + 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 - endif ! if there is a canopy + end if ! if there is a canopy ! ----------------------------------------------------------------------------------------------------------------------------------------- ! ----------------------------------------------------------------------------------------------------------------------------------------- @@ -2122,7 +2179,7 @@ subroutine aeroResist(& 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; endif + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! compute turbulent exchange coefficient (-) canopyExNeut = (vkc**2._dp) / ( log((mHeight - zeroPlaneDisplacement)/z0Canopy))**2._dp ! coefficient under conditions of neutral stability @@ -2133,7 +2190,7 @@ subroutine aeroResist(& ! compute the above-canopy resistance (s m-1) canopyResistance = 1._dp/(sfc2AtmExchangeCoeff_canopy*windspd) - if(canopyResistance < 0._dp)then; err=20; message=trim(message)//'canopy resistance < 0'; return; endif + if(canopyResistance < 0._dp)then; err=20; message=trim(message)//'canopy resistance < 0'; return; end if !write(*,'(a,10(f20.10,1x))') 'in aeroResist: windspd, canairTemp, canopyExNeut, canopyStabilityCorrection, canopyResistance = ', & ! windspd, canairTemp, canopyExNeut, canopyStabilityCorrection, canopyResistance @@ -2164,14 +2221,15 @@ subroutine aeroResist(& print*, 'zeroPlaneDisplacement = ', zeroPlaneDisplacement message=trim(message)//'reference height > z0Canopy+zeroPlaneDisplacement' err=20; return - endif + end if ! compute the leaf boundary layer resistance (s m-1) + singleLeafConductance = leafExchangeCoeff*sqrt(windspdCanopyTop/leafDimension) leaf2CanopyScaleFactor = (2._dp/windReductionFactor) * (1._dp - exp(-windReductionFactor/2._dp)) ! factor to scale from the leaf to the canopy canopyLeafConductance = singleLeafConductance*leaf2CanopyScaleFactor leafResistance = 1._dp/(canopyLeafConductance) - if(leafResistance < 0._dp)then; err=20; message=trim(message)//'leaf resistance < 0'; return; endif + if(leafResistance < 0._dp)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 @@ -2193,7 +2251,7 @@ subroutine aeroResist(& else ! snow is below the bottom of the canopy groundResistanceNeutral = ( heightCanopyTop*exp(windReductionFactor) / (windReductionFactor*eddyDiffusCanopyTop) ) * (tmp1 - tmp2) & ! s m-1 + (1._dp/(max(0.1_dp,windspdCanopyBottom)*vkc**2._dp))*(log((referenceHeight - snowDepth)/z0Ground))**2._dp - endif + end if ! check that we identified the option case default err=20; message=trim(message)//'cannot identify option for canopy wind profile'; return @@ -2220,11 +2278,11 @@ subroutine aeroResist(& 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; endif + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! compute the ground resistance groundResistance = groundResistanceNeutral / groundStabilityCorrection - if(groundResistance < 0._dp)then; err=20; message=trim(message)//'ground resistance < 0 [vegetation is present]'; return; endif + if(groundResistance < 0._dp)then; err=20; message=trim(message)//'ground resistance < 0 [vegetation is present]'; return; end if ! ----------------------------------------------------------------------------------------------------------------------------------------- ! ----------------------------------------------------------------------------------------------------------------------------------------- @@ -2236,7 +2294,7 @@ subroutine aeroResist(& leafResistance = 1.e12_dp ! 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; endif + 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._dp) / ( log((mHeight - snowDepth)/z0Ground)**2._dp) ! turbulent transfer coefficient under conditions of neutral stability (-) @@ -2253,7 +2311,7 @@ subroutine aeroResist(& print*, 'heightAboveGround = ', heightAboveGround message=trim(message)//'height above ground < roughness length [likely due to snow accumulation]' err=20; return - endif + end if ! compute ground stability correction call aStability(& @@ -2276,11 +2334,11 @@ subroutine aeroResist(& 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; endif + 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._dp)then; err=20; message=trim(message)//'ground resistance < 0 [no vegetation]'; return; endif + if(groundResistance < 0._dp)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) @@ -2293,7 +2351,7 @@ subroutine aeroResist(& 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) - endif ! (if no canopy) + end if ! (if no canopy) ! ----------------------------------------------------------------------------------------------------------------------------------------- ! ----------------------------------------------------------------------------------------------------------------------------------------- @@ -2334,14 +2392,14 @@ subroutine aeroResist(& ! compute derivatives for ground resistance dGroundResistance_dTGround = -dGroundStabilityCorrection_dSfcTemp/(windspd*groundExNeut*groundStabilityCorrection**2._dp) - endif ! (switch between vegetated and non-vegetated surfaces) + end if ! (switch between vegetated and non-vegetated surfaces) ! * analytical derivatives not desired else dGroundResistance_dTGround = missingValue dGroundResistance_dTCanopy = missingValue dCanopyResistance_dTCanopy = missingValue - endif + end if ! test !print*, 'dGroundResistance_dTGround = ', dGroundResistance_dTGround @@ -2412,7 +2470,7 @@ subroutine soilResist(& ! ** compute the factor limiting transpiration for each soil layer (-) wAvgTranspireLimitFac = 0._dp ! (initialize the weighted average) - do iLayer=1,nSoil + do iLayer=1,size(mLayerMatricHead) ! compute the soil stress function select case(ixSoilResist) case(NoahType) ! thresholded linear function of volumetric liquid water content @@ -2422,13 +2480,13 @@ subroutine soilResist(& gx = 1._dp - mLayerMatricHead(iLayer)/plantWiltPsi else gx = 0._dp - endif + end if case(SiB_Type) ! exponential of the log of matric head if(mLayerMatricHead(iLayer) < 0._dp)then ! (unsaturated) gx = 1._dp - exp( -soilStressParam * ( log(plantWiltPsi/mLayerMatricHead(iLayer)) ) ) else ! (saturated) gx = 1._dp - endif + end if case default ! check identified the option err=20; message=trim(message)//'cannot identify option for soil resistance'; return end select @@ -2439,172 +2497,23 @@ subroutine soilResist(& end do ! (looping through soil layers) ! ** compute the factor limiting evaporation in the aquifer - if(scalarAquiferRootFrac > 0._dp)then + 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 - endif + end if ! compute the factor limiting evaporation for the aquifer aquiferTranspireLimitFac = min(scalarAquiferStorage/critAquiferTranspire, 1._dp) else ! (if there are roots in the aquifer) aquiferTranspireLimitFac = 0._dp - endif + end if ! compute the weighted average (weighted by root density) wAvgTranspireLimitFac = wAvgTranspireLimitFac + aquiferTranspireLimitFac*scalarAquiferRootFrac end subroutine soilResist - ! ******************************************************************************************************* - ! private subroutine stomResist: compute stomatal resistance - ! ******************************************************************************************************* - subroutine stomResist(& - ! input (model decisions) - 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) - scalarO2air, & ! intent(in): atmospheric o2 concentration (Pa) - scalarCO2air, & ! intent(in): atmospheric co2 concentration (Pa) - scalarCanopySunlitPAR, & ! intent(in): average absorbed par for sunlit leaves (w m-2) - scalarCanopyShadedPAR, & ! intent(in): average absorbed par for shaded leaves (w m-2) - ! input (state and diagnostic variables) - scalarGrowingSeasonIndex, & ! intent(in): growing season index (0=off, 1=on) - scalarFoliageNitrogenFactor, & ! intent(in): foliage nitrogen concentration (1=saturated) - scalarTranspireLim, & ! intent(in): weighted average of the soil moiture factor controlling stomatal resistance (-) - scalarLeafResistance, & ! intent(in): leaf boundary layer resistance (s m-1) - 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) - ! output - scalarStomResistSunlit, & ! intent(out): stomatal resistance for sunlit leaves (s m-1) - scalarStomResistShaded, & ! intent(out): stomatal resistance for shaded leaves (s m-1) - scalarPhotosynthesisSunlit, & ! intent(out): sunlit photosynthesis (umolco2 m-2 s-1) - scalarPhotosynthesisShaded, & ! intent(out): shaded photosynthesis (umolco2 m-2 s-1) - err,message ) ! intent(out): error control - ! ----------------------------------------------------------------------------------------------------------------------------------------- - ! Modified from Noah-MP - ! Compute stomatal resistance and photosynthesis using either - ! 1) Ball-Berry - ! 2) Jarvis - ! See Niu et al. JGR 2011 for more details - USE mDecisions_module, only: BallBerry,Jarvis ! options for the choice of function for stomatal resistance - USE NOAHMP_ROUTINES,only:stomata ! compute canopy resistance based on Ball-Berry - USE NOAHMP_ROUTINES,only:canres ! compute canopy resistance based Jarvis - implicit none - ! input (model decisions) - 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(dp),intent(in) :: airtemp ! measured air temperature at some height above the surface (K) - real(dp),intent(in) :: airpres ! measured air pressure at some height above the surface (Pa) - real(dp),intent(in) :: scalarO2air ! atmospheric o2 concentration (Pa) - real(dp),intent(in) :: scalarCO2air ! atmospheric co2 concentration (Pa) - real(dp),intent(in),target :: scalarCanopySunlitPAR ! average absorbed par for sunlit leaves (w m-2) - real(dp),intent(in),target :: scalarCanopyShadedPAR ! average absorbed par for shaded leaves (w m-2) - ! input (state and diagnostic variables) - real(dp),intent(in) :: scalarGrowingSeasonIndex ! growing season index (0=off, 1=on) - real(dp),intent(in) :: scalarFoliageNitrogenFactor ! foliage nitrogen concentration (1=saturated) - real(dp),intent(in) :: scalarTranspireLim ! weighted average of the soil moiture factor controlling stomatal resistance (-) - real(dp),intent(in) :: scalarLeafResistance ! leaf boundary layer resistance (s m-1) - real(dp),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) - real(dp),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) - real(dp),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) - ! output - real(dp),intent(out) :: scalarStomResistSunlit ! stomatal resistance for sunlit leaves (s m-1) - real(dp),intent(out) :: scalarStomResistShaded ! stomatal resistance for shaded leaves (s m-1) - real(dp),intent(out) :: scalarPhotosynthesisSunlit ! sunlit photosynthesis (umolco2 m-2 s-1) - real(dp),intent(out) :: scalarPhotosynthesisShaded ! sunlit photosynthesis (umolco2 m-2 s-1) - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! local variables - integer(i4b),parameter :: ixSunlit=1 ! named variable for sunlit leaves - integer(i4b),parameter :: ixShaded=2 ! named variable for shaded leaves - integer(i4b) :: iSunShade ! index for sunlit/shaded leaves - real(dp),pointer :: PAR ! average absorbed PAR for sunlit/shaded leaves (w m-2) - real(dp) :: scalarStomResist ! stomatal resistance for sunlit/shaded leaves (s m-1) - real(dp) :: scalarPhotosynthesis ! photosynthesis for sunlit/shaded leaves (umolco2 m-2 s-1) - ! initialize error control - err=0; message='stomResist/' - - ! loop through sunlit and shaded leaves - do iSunShade=1,2 - - ! get appropriate value for PAR - select case(iSunShade) - case(ixSunlit); PAR => scalarCanopySunlitPAR ! average absorbed par for sunlit leaves (w m-2) - case(ixShaded); PAR => scalarCanopyShadedPAR ! average absorbed par for shaded leaves (w m-2) - case default; err=20; message=trim(message)//'unable to identify case for sunlit/shaded leaves'; return - end select - - ! identify option for stomatal resistance - select case(ixStomResist) - - ! Ball-Berry - case(BallBerry) - call stomata(& - ! input - vegTypeIndex, & ! intent(in): vegetation type index - 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) - airtemp, & ! intent(in): air temperature at some height above the surface (K) - airpres, & ! intent(in): air pressure at some height above the surface (Pa) - scalarO2air, & ! intent(in): atmospheric o2 concentration (Pa) - scalarCO2air, & ! intent(in): atmospheric co2 concentration (Pa) - scalarGrowingSeasonIndex, & ! intent(in): growing season index (0=off, 1=on) - scalarTranspireLim, & ! intent(in): weighted average of the soil moiture factor controlling stomatal resistance (-) - scalarLeafResistance, & ! intent(in): leaf boundary layer resistance (s m-1) - ! output - scalarStomResist, & ! intent(out): stomatal resistance (s m-1) - scalarPhotosynthesis ) ! intent(out): photosynthesis (umolco2 m-2 s-1) - - ! Jarvis - case(Jarvis) - call canres(& - ! input - PAR, & ! intent(in): average absorbed par (w m-2) - scalarVegetationTemp, & ! intent(in): vegetation temperature (K) - scalarTranspireLim, & ! intent(in): weighted average of the soil moiture factor controlling stomatal resistance (-) - scalarVP_CanopyAir, & ! intent(in): canopy air vapor pressure (Pa) - 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 - - ! check identified an option - case default; err=20; message=trim(message)//'unable to identify case for stomatal resistance'; return - - end select ! (selecting option for stomatal resistance) - - ! assign output variables - select case(iSunShade) - case(ixSunlit) - scalarStomResistSunlit = scalarStomResist - scalarPhotosynthesisSunlit = scalarPhotosynthesis - case(ixShaded) - scalarStomResistShaded = scalarStomResist - scalarPhotosynthesisShaded = scalarPhotosynthesis - case default; err=20; message=trim(message)//'unable to identify case for sunlit/shaded leaves'; return - end select - - end do ! (looping through sunlit and shaded leaves) - - end subroutine stomResist - - ! ******************************************************************************** ! private subroutine turbFluxes: compute turbulent heat fluxes ! ******************************************************************************** @@ -2682,11 +2591,16 @@ subroutine turbFluxes(& 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 + ! 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) @@ -2769,11 +2683,16 @@ subroutine turbFluxes(& real(dp),intent(out) :: dTurbFluxGround_dTCanair ! derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) real(dp),intent(out) :: dTurbFluxGround_dTCanopy ! derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) real(dp),intent(out) :: dTurbFluxGround_dTGround ! derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) - ! output: liquid flux derivatives + ! output: liquid flux derivatives (canopy evap) real(dp),intent(out) :: dLatHeatCanopyEvap_dCanLiq ! derivative in latent heat of canopy evaporation w.r.t. canopy liquid water content (W kg-1) real(dp),intent(out) :: dLatHeatCanopyEvap_dTCanair ! derivative in latent heat of canopy evaporation w.r.t. canopy air temperature (W m-2 K-1) real(dp),intent(out) :: dLatHeatCanopyEvap_dTCanopy ! derivative in latent heat of canopy evaporation w.r.t. canopy temperature (W m-2 K-1) real(dp),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(dp),intent(out) :: dLatHeatGroundEvap_dCanLiq ! derivative in latent heat of ground evaporation w.r.t. canopy liquid water content (J kg-1 s-1) + real(dp),intent(out) :: dLatHeatGroundEvap_dTCanair ! derivative in latent heat of ground evaporation w.r.t. canopy air temperature (W m-2 K-1) + real(dp),intent(out) :: dLatHeatGroundEvap_dTCanopy ! derivative in latent heat of ground evaporation w.r.t. canopy temperature (W m-2 K-1) + real(dp),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(dp),intent(out) :: dTurbFluxCanair_dCanLiq ! derivative in net canopy air space fluxes w.r.t. canopy liquid water content (J kg-1 s-1) real(dp),intent(out) :: dTurbFluxCanopy_dCanLiq ! derivative in net canopy turbulent fluxes w.r.t. canopy liquid water content (J kg-1 s-1) @@ -2785,7 +2704,6 @@ subroutine turbFluxes(& ! local variables -- general real(dp) :: fpart1,fpart2 ! different parts of a function real(dp) :: dPart0,dpart1,dpart2 ! derivatives for different parts of a function - real(dp),parameter :: evapSmooth=1._dp ! smoothing parameter for latent heat (W m-2) ! local variables -- "constants" real(dp) :: volHeatCapacityAir ! volumetric heat capacity of air (J m-3) real(dp) :: latentHeatConstant ! latent heat constant (kg m-3 K-1) @@ -2823,9 +2741,6 @@ subroutine turbFluxes(& real(dp) :: dLatHeatCanopyTrans_dTCanair ! derivative in the canopy transpiration flux w.r.t. canopy air temperature real(dp) :: dLatHeatCanopyTrans_dTCanopy ! derivative in the canopy transpiration flux w.r.t. canopy temperature real(dp) :: dLatHeatCanopyTrans_dTGround ! derivative in the canopy transpiration flux w.r.t. ground temperature - real(dp) :: dLatHeatGround_dTCanair ! derivative in the ground latent heat flux w.r.t. canopy air temperature - real(dp) :: dLatHeatGround_dTCanopy ! derivative in the ground latent heat flux w.r.t. canopy temperature - real(dp) :: dLatHeatGround_dTGround ! derivative in the ground latent heat flux w.r.t. ground temperature ! local variables -- wetted fraction derivatives real(dp) :: dLatHeatCanopyEvap_dWetFrac ! derivative in the latent heat of canopy evaporation w.r.t. canopy wet fraction (W m-2) real(dp) :: dLatHeatCanopyTrans_dWetFrac ! derivative in the latent heat of canopy transpiration w.r.t. canopy wet fraction (W m-2) @@ -2850,7 +2765,7 @@ subroutine turbFluxes(& else leafConductance = 0._dp canopyConductance = 0._dp - endif + end if groundConductanceSH = 1._dp/groundResistance ! compute total conductance for sensible heat @@ -2860,12 +2775,12 @@ subroutine turbFluxes(& if(computeVegFlux)then evapConductance = canopyWetFraction*leafConductance transConductance = (1._dp - canopyWetFraction) * leafConductanceTr - !write(*,'(a,10(f20.10,1x))') 'canopySunlitLAI, canopyShadedLAI, stomResistSunlit, stomResistShaded, leafResistance, canopyWetFraction = ', & - ! canopySunlitLAI, canopyShadedLAI, stomResistSunlit, stomResistShaded, leafResistance, canopyWetFraction + !write(*,'(a,10(f14.8,1x))') 'canopySunlitLAI, canopyShadedLAI, stomResistSunlit, stomResistShaded, leafResistance, canopyWetFraction = ', & + ! canopySunlitLAI, canopyShadedLAI, stomResistSunlit, stomResistShaded, leafResistance, canopyWetFraction else evapConductance = 0._dp transConductance = 0._dp - endif + end if groundConductanceLH = 1._dp/(groundResistance + soilResistance) ! NOTE: soilResistance accounts for fractional snow, and =0 when snow cover is 100% totalConductanceLH = evapConductance + transConductance + groundConductanceLH + canopyConductance @@ -2890,7 +2805,7 @@ subroutine turbFluxes(& dGroundCondSH_dCanairTemp = 0._dp ! derivative in ground conductance w.r.t. canopy air temperature dGroundCondSH_dCanopyTemp = 0._dp ! derivative in ground conductance w.r.t. canopy temperature dGroundCondSH_dGroundTemp = -dGroundResistance_dTGround/groundResistance**2._dp ! derivative in ground conductance w.r.t. ground temperature - endif + end if ! compute derivatives in individual conductances for latent heat w.r.t. canopy temperature (m s-1 K-1) if(computeVegFlux)then @@ -2901,9 +2816,9 @@ subroutine turbFluxes(& dGroundCondLH_dCanairTemp = 0._dp ! derivative in ground conductance w.r.t. canopy air temperature dGroundCondLH_dCanopyTemp = 0._dp ! derivative in ground conductance w.r.t. canopy temperature dGroundCondLH_dGroundTemp = -dGroundResistance_dTGround/(groundResistance+soilResistance)**2._dp ! derivative in ground conductance w.r.t. ground temperature - endif + end if - endif ! (if computing analytical derivatives) + end if ! (if computing analytical derivatives) ! ***** ! * compute sensible and latent heat fluxes, and derivatives... @@ -2929,6 +2844,7 @@ subroutine turbFluxes(& 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 @@ -2936,7 +2852,7 @@ subroutine turbFluxes(& ! maxFlux = -canopyIce*LH_sub/dt ! W m-2 !else ! (evaporation) ! maxFlux = -canopyLiquid*LH_vap/dt ! W m-2 - !endif + !end if ! NOTE: fluxes are positive downwards !if(latHeatCanopyEvap < maxFlux) latHeatCanopyEvap = maxFlux !write(*,'(a,10(f20.10,1x))') 'maxFlux, latHeatCanopyEvap = ', maxFlux, latHeatCanopyEvap @@ -2946,7 +2862,7 @@ subroutine turbFluxes(& senHeatCanopy = 0._dp latHeatCanopyEvap = 0._dp latHeatCanopyTrans = 0._dp - endif + end if ! compute sensible and latent heat fluxes from the ground to the canopy air space (W m-2) if(computeVegFlux)then @@ -2956,7 +2872,7 @@ subroutine turbFluxes(& senHeatGround = -volHeatCapacityAir*groundConductanceSH*(groundTemp - airtemp) ! (positive downwards) latHeatGround = -latHeatSubVapGround*latentHeatConstant*groundConductanceLH*(satVP_GroundTemp*soilRelHumidity - VPair) ! (positive downwards) senHeatTotal = senHeatGround - endif + end if !write(*,'(a,10(f25.15,1x))') 'latHeatGround = ', latHeatGround ! compute latent heat flux from the canopy air space to the atmosphere @@ -3039,11 +2955,11 @@ subroutine turbFluxes(& ! 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 - dLatHeatGround_dTCanair = -latHeatSubVapGround*latentHeatConstant*dGroundCondLH_dCanairTemp*fPart2 - dVPCanopyAir_dTCanair*fPart1 - dLatHeatGround_dTCanopy = -latHeatSubVapGround*latentHeatConstant*dGroundCondLH_dCanopyTemp*fPart2 - dVPCanopyAir_dTCanopy*fPart1 - dLatHeatGround_dTGround = -latHeatSubVapGround*latentHeatConstant*dGroundCondLH_dGroundTemp*fPart2 + (dSVPGround_dGroundTemp*soilRelHumidity - dVPCanopyAir_dTGround)*fPart1 - !write(*,'(a,3(f20.8,1x))') 'dLatHeatGround_dTCanair, dLatHeatGround_dTCanopy, dLatHeatGround_dTGround = ', & - ! dLatHeatGround_dTCanair, dLatHeatGround_dTCanopy, dLatHeatGround_dTGround + 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 @@ -3083,22 +2999,22 @@ subroutine turbFluxes(& dVPCanopyAir_dCanLiq = 0._dp ! set derivatives for ground fluxes w.r.t canopy temperature to zero (no canopy, so fluxes are undefined) - dSenHeatGround_dTCanair = 0._dp - dSenHeatGround_dTCanopy = 0._dp - dLatHeatGround_dTCanair = 0._dp - dLatHeatGround_dTCanopy = 0._dp + dSenHeatGround_dTCanair = 0._dp + dSenHeatGround_dTCanopy = 0._dp + dLatHeatGroundEvap_dTCanair = 0._dp + dLatHeatGroundEvap_dTCanopy = 0._dp ! 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) - dLatHeatGround_dTGround = (-latHeatSubVapGround*latentHeatConstant*dGroundCondLH_dGroundTemp)*(satVP_GroundTemp*soilRelHumidity - VPair) + & ! d(ground latent heat flux)/d(ground temp) - (-latHeatSubVapGround*latentHeatConstant*groundConductanceLH)*dSVPGround_dGroundTemp*soilRelHumidity + 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 - endif ! (if canopy is defined) + end if ! (if canopy is defined) - endif ! (if computing analytical derivatives) + end if ! (if computing analytical derivatives) ! ***** @@ -3109,6 +3025,7 @@ subroutine turbFluxes(& 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 derivatives if(ixDerivMethod == analytical)then @@ -3119,15 +3036,16 @@ subroutine turbFluxes(& dTurbFluxCanopy_dTCanair = dSenHeatCanopy_dTCanair + dLatHeatCanopyEvap_dTCanair + dLatHeatCanopyTrans_dTCanair ! derivative in net canopy turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) dTurbFluxCanopy_dTCanopy = dSenHeatCanopy_dTCanopy + dLatHeatCanopyEvap_dTCanopy + dLatHeatCanopyTrans_dTCanopy ! derivative in net canopy turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) dTurbFluxCanopy_dTGround = dSenHeatCanopy_dTGround + dLatHeatCanopyEvap_dTGround + dLatHeatCanopyTrans_dTGround ! derivative in net canopy turbulent fluxes w.r.t. ground temperature (W m-2 K-1) - dTurbFluxGround_dTCanair = dSenHeatGround_dTCanair + dLatHeatGround_dTCanair ! derivative in net ground turbulent fluxes w.r.t. canopy air temperature (W m-2 K-1) - dTurbFluxGround_dTCanopy = dSenHeatGround_dTCanopy + dLatHeatGround_dTCanopy ! derivative in net ground turbulent fluxes w.r.t. canopy temperature (W m-2 K-1) - dTurbFluxGround_dTGround = dSenHeatGround_dTGround + dLatHeatGround_dTGround ! derivative in net ground turbulent fluxes w.r.t. ground temperature (W m-2 K-1) + 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._dp ! 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 = latHeatSubVapGround*latentHeatConstant*groundConductanceLH*dVPCanopyAir_dCanLiq ! derivative in net ground 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._dp @@ -3141,11 +3059,12 @@ subroutine turbFluxes(& dTurbFluxGround_dTGround = 0._dp ! (liquid water derivatives) dLatHeatCanopyEvap_dCanLiq = 0._dp + dLatHeatGroundEvap_dCanLiq = 0._dp ! (cross deriavtives) dTurbFluxCanair_dCanLiq = 0._dp dTurbFluxCanopy_dCanLiq = 0._dp dTurbFluxGround_dCanLiq = 0._dp - endif + end if end subroutine turbFluxes @@ -3221,7 +3140,7 @@ subroutine aStability(& dStabilityCorrection_dRich = 1._dp dStabilityCorrection_dAirTemp = 1._dp dStabilityCorrection_dSfcTemp = 1._dp - endif + end if ! ***** process unstable cases if(RiBulk<0._dp)then @@ -3232,9 +3151,9 @@ subroutine aStability(& dStabilityCorrection_dRich = (-16._dp) * 0.5_dp*(1._dp - 16._dp*RiBulk)**(-0.5_dp) dStabilityCorrection_dAirTemp = dRiBulk_dAirTemp * dStabilityCorrection_dRich dStabilityCorrection_dSfcTemp = dRiBulk_dSfcTemp * dStabilityCorrection_dRich - endif + end if return - endif + end if ! ***** process stable cases select case(ixStability) @@ -3248,7 +3167,7 @@ subroutine aStability(& if(computeDerivative)then if(RiBulk < critRichNumber) dStabilityCorrection_dRich = (-5._dp) * 2._dp*(1._dp - 5._dp*RiBulk) if(RiBulk >= critRichNumber) dStabilityCorrection_dRich = 0._dp - endif + end if ! (Louis 1979) case(louisInversePower) @@ -3260,7 +3179,7 @@ subroutine aStability(& ! compute derivative in surface-atmosphere exchange coefficient w.r.t. temperature (K-1) if(computeDerivative)then dStabilityCorrection_dRich = bprime * (-2._dp)*(1._dp + bprime*RiBulk)**(-3._dp) - endif + end if ! (Mahrt 1987) case(mahrtExponential) @@ -3270,20 +3189,20 @@ subroutine aStability(& ! compute derivative in surface-atmosphere exchange coefficient w.r.t. temperature (K-1) if(computeDerivative)then dStabilityCorrection_dRich = (-Mahrt87_eScale) * exp(-Mahrt87_eScale * RiBulk) - endif + end if ! (return error if the stability correction method is not found) case default err=10; message=trim(message)//"optionNotFound[stability correction]"; return - endselect + 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 - endif + end if end subroutine aStability @@ -3335,7 +3254,7 @@ subroutine bulkRichardson(& else dRiBulk_dAirTemp = 1._dp dRiBulk_dSfcTemp = 1._dp - endif + end if end subroutine bulkRichardson diff --git a/build/source/engine/vegPhenlgy.f90 b/build/source/engine/vegPhenlgy.f90 old mode 100644 new mode 100755 index f27c12456..e7cd7b458 --- a/build/source/engine/vegPhenlgy.f90 +++ b/build/source/engine/vegPhenlgy.f90 @@ -33,8 +33,6 @@ module vegPhenlgy_module UEB_2stream, & ! UEB 2-stream model (Mahat and Tarboton, WRR 2011) NL_scatter, & ! Simplified method Nijssen and Lettenmaier (JGR 1999) BeersLaw ! Beer's Law (as implemented in VIC) -! named variables for snow and soil -USE data_struc,only:ix_soil,ix_snow implicit none private public::vegPhenlgy @@ -53,7 +51,8 @@ subroutine vegPhenlgy(& type_data, & ! intent(in): type of vegetation and soil attr_data, & ! intent(in): spatial attributes mpar_data, & ! intent(in): model parameters - mvar_data, & ! intent(inout): model variables for a local HRU + prog_data, & ! intent(in): 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) @@ -61,28 +60,29 @@ subroutine vegPhenlgy(& err,message) ! intent(out): error control ! ------------------------------------------------------------------------------------------------- ! provide access to the derived types to define the data structures - USE data_struc,only:& + USE data_types,only:& var_i, & ! data vector (i4b) var_d, & ! data vector (dp) var_dlength, & ! data vector with variable length dimension (dp) model_options ! defines the model decisions ! provide access to named variables defining elements in the data structures - USE var_lookup,only:iLookTIME,iLookTYPE,iLookATTR,iLookFORCE,iLookPARAM,iLookMVAR,iLookBVAR,iLookINDEX ! named variables for structure elements - USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure + USE var_lookup,only:iLookTYPE,iLookATTR,iLookPARAM,iLookDIAG,iLookPROG ! named variables for structure elements + USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure ! modules USE NOAHMP_ROUTINES,only:phenology ! determine vegetation phenology ! common variables - USE data_struc,only:urbanVegCategory ! vegetation category for urban areas - USE data_struc,only:fracJulday ! fractional julian days since the start of year - USE data_struc,only:yearLength ! number of days in the current year + 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 implicit none ! ------------------------------------------------------------------------------------------------- ! input/output 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) :: mpar_data ! model parameters - type(var_dlength),intent(inout) :: mvar_data ! model variables for a local HRU + 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 logical(lgt),intent(out) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) real(dp),intent(out) :: canopyDepth ! canopy depth (m) @@ -107,21 +107,23 @@ subroutine vegPhenlgy(& 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) + ! diagnostic variables and parameters (input) - scalarSnowDepth => mvar_data%var(iLookMVAR%scalarSnowDepth)%dat(1), & ! intent(in): [dp] snow depth on the ground surface (m) - scalarCanopyTemp => mvar_data%var(iLookMVAR%scalarCanopyTemp)%dat(1), & ! intent(in): [dp] temperature of the vegetation canopy at the start of the sub-step (K) - scalarRootZoneTemp => mvar_data%var(iLookMVAR%scalarRootZoneTemp)%dat(1), & ! intent(in): [dp] root zone temperature (K) - heightCanopyTop => mpar_data%var(iLookPARAM%heightCanopyTop), & ! intent(in): [dp] height of the top of the canopy layer (m) - heightCanopyBottom => mpar_data%var(iLookPARAM%heightCanopyBottom), & ! intent(in): [dp] height of the bottom of the canopy layer (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) + scalarRootZoneTemp => diag_data%var(iLookDIAG%scalarRootZoneTemp)%dat(1), & ! intent(in): [dp] root zone temperature (K) ! diagnostic variables and parameters (input/output) - scalarLAI => mvar_data%var(iLookMVAR%scalarLAI)%dat(1), & ! intent(inout): [dp] one-sided leaf area index (m2 m-2) - scalarSAI => mvar_data%var(iLookMVAR%scalarSAI)%dat(1), & ! intent(inout): [dp] one-sided stem area index (m2 m-2) + 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 => mvar_data%var(iLookMVAR%scalarExposedLAI)%dat(1), & ! intent(out): [dp] exposed leaf area index after burial by snow (m2 m-2) - scalarExposedSAI => mvar_data%var(iLookMVAR%scalarExposedSAI)%dat(1), & ! intent(out): [dp] exposed stem area index after burial by snow (m2 m-2) - scalarGrowingSeasonIndex => mvar_data%var(iLookMVAR%scalarGrowingSeasonIndex)%dat(1) & ! intent(out): [dp] growing season index (0=off, 1=on) + 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) ) ! associate variables in data structure ! ---------------------------------------------------------------------------------------------------------------------------------- @@ -173,7 +175,7 @@ subroutine vegPhenlgy(& ! determine if need to include vegetation in the energy flux routines computeVegFlux = (exposedVAI > 0.05_dp .and. heightAboveSnow > 0.05_dp) - endif ! (check if the snow-soil column is isolated) + end if ! (check if the snow-soil column is isolated) ! end association to variables in the data structure end associate diff --git a/build/source/engine/vegSWavRad.f90 b/build/source/engine/vegSWavRad.f90 old mode 100644 new mode 100755 index 172613d4e..eac518e75 --- a/build/source/engine/vegSWavRad.f90 +++ b/build/source/engine/vegSWavRad.f90 @@ -21,13 +21,6 @@ module vegSWavRad_module ! Numerical recipes data types USE nrtype -! named variables for snow and soil -USE data_struc,only:ix_soil,ix_snow -! access the number of snow and soil layers -USE data_struc,only:& - nSnow, & ! number of snow layers - nSoil, & ! number of soil layers - nLayers ! total number of layers ! look-up values for the choice of canopy shortwave radiation method USE mDecisions_module,only: & noah_mp, & ! full Noah-MP implementation (including albedo) @@ -55,8 +48,6 @@ module vegSWavRad_module real(dp),parameter :: verySmall=1.e-6_dp ! used as an additive constant to check if substantial difference among real numbers real(dp),parameter :: mpe=1.e-6_dp ! prevents overflow error if division by zero real(dp),parameter :: dx=1.e-6_dp ! finite difference increment -! control -logical(lgt) :: printflag ! flag to turn on printing contains @@ -64,182 +55,96 @@ module vegSWavRad_module ! public subroutine vegSWavRad: muster program to compute sw radiation in vegetation ! ************************************************************************************************ subroutine vegSWavRad(& - dt, & ! intent(in): time step (s) -- only used in Noah-MP radiation, to compute albedo - computeVegFlux, & ! intent(in): logical flag to compute vegetation fluxes (.false. if veg buried by snow) + dt, & ! 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): classification of veg, soil etc. for a local HRU + 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,message) ! intent(out): error control ! model decisions - USE data_struc,only:model_decisions ! model decision structure + USE globalData,only:model_decisions ! model decision structure USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure - ! model variables, parameters, etc. - USE data_struc,only:type_data,mvar_data,indx_data ! data structures - USE var_lookup,only:iLookTIME,iLookTYPE,iLookATTR,iLookFORCE,iLookPARAM,iLookMVAR,iLookBVAR,iLookINDEX ! named variables for structure elements - implicit none - ! dummy variables - real(dp),intent(in) :: dt ! time step (s) -- only used in Noah-MP radiation, to compute albedo - logical(lgt),intent(in) :: computeVegFlux ! logical flag to compute vegetation fluxes (.false. if veg buried by snow) - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! local variables - character(LEN=256) :: cmessage ! error message of downwind routine - ! initialize error control - err=0; message='vegSWavRad/' - - call vegSWavRad_muster(& - ! input: model control - dt, & ! intent(in): model time step - computeVegFlux, & ! intent(in): logical flag to compute vegetation fluxes (.false. if veg buried by snow) - type_data%var(iLookTYPE%vegTypeIndex), & ! intent(in): vegetation type index - type_data%var(iLookTYPE%soilTypeIndex), & ! intent(in): soil type index - model_decisions(iLookDECISIONS%canopySrad)%iDecision, & ! intent(in): index defining method for canopy shortwave radiation - ! input: forcing at the upper boundary - mvar_data%var(iLookMVAR%scalarSnowfall)%dat(1), & ! intent(in): computed snowfall rate (kg m-2 s-1) - mvar_data%var(iLookMVAR%scalarCosZenith)%dat(1), & ! intent(in): cosine of the solar zenith angle (0-1) - mvar_data%var(iLookMVAR%spectralIncomingDirect)%dat(1:nBands), & ! intent(in): incoming direct solar radiation in each wave band (w m-2) - mvar_data%var(iLookMVAR%spectralIncomingDiffuse)%dat(1:nBands), & ! intent(in): incoming diffuse solar radiation in each wave band (w m-2) - ! input: surface characteristix - mvar_data%var(iLookMVAR%scalarSWE)%dat(1), & ! intent(in): snow water equivalent on the ground (kg m-2) - mvar_data%var(iLookMVAR%scalarSnowDepth)%dat(1), & ! intent(in): snow depth on the ground surface (m) - mvar_data%var(iLookMVAR%mLayerVolFracLiq)%dat(nSnow+1:nLayers), & ! intent(in): volumetric fraction of liquid water in each soil layer (-) - mvar_data%var(iLookMVAR%spectralSnowAlbedoDirect)%dat(1:nBands), & ! intent(in): direct albedo of snow in each spectral band (-) - mvar_data%var(iLookMVAR%spectralSnowAlbedoDiffuse)%dat(1:nBands), & ! intent(in): diffuse albedo of snow in each spectral band (-) - mvar_data%var(iLookMVAR%scalarSnowAlbedo)%dat(1), & ! intent(inout): snow albedo (-) - mvar_data%var(iLookMVAR%scalarSnowAge)%dat(1), & ! intent(inout): non-dimensional snow age (-) - ! input: vegetation characteristix - mvar_data%var(iLookMVAR%scalarExposedLAI)%dat(1), & ! intent(in): exposed leaf area index after burial by snow (m2 m-2) - mvar_data%var(iLookMVAR%scalarExposedSAI)%dat(1), & ! intent(in): exposed stem area index after burial by snow (m2 m-2) - mvar_data%var(iLookMVAR%scalarCanopyWetFraction)%dat(1), & ! intent(in): canopy wetted fraction (-) - ! input: ground and canopy temperature - mvar_data%var(iLookMVAR%mLayerTemp)%dat(1), & ! intent(in): ground temperature (K) - mvar_data%var(iLookMVAR%scalarCanopyTemp)%dat(1), & ! intent(in): vegetation temperature (K) - ! output: canopy sw radiation fluxes - mvar_data%var(iLookMVAR%scalarCanopySunlitFraction)%dat(1), & ! intent(out): sunlit fraction of canopy (-) - mvar_data%var(iLookMVAR%scalarCanopySunlitLAI)%dat(1), & ! intent(out): sunlit leaf area (-) - mvar_data%var(iLookMVAR%scalarCanopyShadedLAI)%dat(1), & ! intent(out): shaded leaf area (-) - mvar_data%var(iLookMVAR%scalarCanopySunlitPAR)%dat(1), & ! intent(out): average absorbed par for sunlit leaves (w m-2) - mvar_data%var(iLookMVAR%scalarCanopyShadedPAR)%dat(1), & ! intent(out): average absorbed par for shaded leaves (w m-2) - mvar_data%var(iLookMVAR%spectralBelowCanopyDirect)%dat, & ! intent(out): downward direct flux below veg layer for each spectral band W m-2) - mvar_data%var(iLookMVAR%spectralBelowCanopyDiffuse)%dat, & ! intent(out): downward diffuse flux below veg layer for each spectral band (W m-2) - mvar_data%var(iLookMVAR%scalarBelowCanopySolar)%dat(1), & ! intent(out): solar radiation transmitted below the canopy (W m-2) - mvar_data%var(iLookMVAR%spectralAlbGndDirect)%dat, & ! intent(out): direct albedo of underlying surface (1:nBands) (-) - mvar_data%var(iLookMVAR%spectralAlbGndDiffuse)%dat, & ! intent(out): diffuse albedo of underlying surface (1:nBands) (-) - mvar_data%var(iLookMVAR%scalarGroundAlbedo)%dat(1), & ! intent(out): albedo of the ground surface (-) - mvar_data%var(iLookMVAR%scalarCanopyAbsorbedSolar)%dat(1), & ! intent(out): solar radiation absorbed by canopy (W m-2) - mvar_data%var(iLookMVAR%scalarGroundAbsorbedSolar)%dat(1), & ! intent(out): solar radiation absorbed by ground (W m-2) - ! output: error control - err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - - - end subroutine vegSWavRad - - - ! ************************************************************************************************ - ! private subroutine vegSWavRad_muster: wrapper for the sw radiation routines - ! ************************************************************************************************ - subroutine vegSWavRad_muster(& - ! input: control - dt, & ! intent(in): time step (s) -- only used in Noah-MP radiation, to compute albedo - computeVegFlux, & ! intent(in): logical flag to compute vegetation fluxes (.false. if veg buried by snow) - vegTypeIndex, & ! intent(in): vegetation type index - soilTypeIndex, & ! intent(in): soil type index - ix_canopySrad, & ! intent(in): index defining method for canopy shortwave radiation - ! input: forcing at the upper boundary - scalarSnowfall, & ! intent(in): computed snowfall rate (kg m-2 s-1) - scalarCosZenith, & ! intent(in): cosine of the solar zenith angle (0-1) - spectralIncomingDirect, & ! intent(in): incoming direct solar radiation in each wave band (w m-2) - spectralIncomingDiffuse, & ! intent(in): incoming diffuse solar radiation in each wave band (w m-2) - ! input: surface characteristix - scalarSWE, & ! intent(in): snow water equivalent on the ground (kg m-2) - scalarSnowDepth, & ! intent(in): snow depth on the ground surface (m) - mLayerVolFracLiq, & ! intent(in): volumetric fraction of liquid water in each soil layer (-) - spectralSnowAlbedoDirect, & ! intent(in): direct albedo of snow in each spectral band (-) - spectralSnowAlbedoDiffuse, & ! intent(in): diffuse albedo of snow in each spectral band (-) - scalarSnowAlbedo, & ! intent(inout): snow albedo (-) - scalarSnowAge, & ! intent(inout): non-dimensional snow age (-) - ! input: vegetation characteristix - 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) - scalarCanopyWetFraction, & ! intent(in): canopy wetted fraction (-) - ! input: ground and canopy temperature - scalarGroundTemp, & ! intent(in): ground temperature (K) - scalarCanopyTemp, & ! intent(in): canopy temperature (K) - ! output: canopy sw radiation fluxes - 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) - 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): 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) (-) - scalarGroundAlbedo, & ! intent(out): albedo of the ground surface (-) - scalarCanopyAbsorbedSolar, & ! intent(out): solar radiation absorbed by canopy (W m-2) - scalarGroundAbsorbedSolar, & ! intent(out): solar radiation absorbed by ground (W m-2) - ! output: error control - err,message) ! intent(out): error control - ! -------------------------------------------------------------------------------------------------------------------------------------- + ! named variables for structure elements + USE var_lookup,only:iLookTYPE,iLookPROG,iLookDIAG,iLookFLUX + ! data types + USE data_types,only:var_i ! x%var(:) (i4b) + USE data_types,only:var_dlength ! x%var(:)%dat (dp) + ! external routines USE NOAHMP_ROUTINES,only:radiation ! subroutine to calculate albedo and shortwave radiaiton in the canopy implicit none - ! input: control - real(dp),intent(in) :: dt ! time step (seconds) + ! dummy variables + real(dp),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) - integer(i4b),intent(in) :: vegTypeIndex ! vegetation type index - integer(i4b),intent(in) :: soilTypeIndex ! soil type index - integer(i4b),intent(in) :: ix_canopySrad ! index defining method for canopy shortwave radiation - ! input: forcing at the upper boundary - real(dp),intent(in) :: scalarSnowfall ! computed snowfall rate (kg m-2 s-1) - real(dp),intent(in) :: scalarCosZenith ! cosine of the solar zenith angle (0-1) - real(dp),intent(in) :: spectralIncomingDirect(:) ! incoming direct solar radiation in each wave band (w m-2) - real(dp),intent(in) :: spectralIncomingDiffuse(:) ! incoming diffuse solar radiation in each wave band (w m-2) - ! input: surface characteristix - real(dp),intent(in) :: scalarSWE ! snow water equivalent on the ground (kg m-2) - real(dp),intent(in) :: scalarSnowDepth ! snow depth on the ground surface (m) - real(dp),intent(in) :: mLayerVolFracLiq(:) ! volumetric fraction of liquid water in each soil layer (-) - real(dp),intent(in) :: spectralSnowAlbedoDirect(:) ! direct albedo of snow in each spectral band (-) - real(dp),intent(in) :: spectralSnowAlbedoDiffuse(:) ! diffuse albedo of snow in each spectral band (-) - real(dp),intent(inout) :: scalarSnowAlbedo ! snow albedo (-) - real(dp),intent(inout) :: scalarSnowAge ! non-dimensional snow age (-) - ! input: vegetation characteristix - real(dp),intent(in) :: scalarExposedLAI ! exposed leaf area index after burial by snow (m2 m-2) - real(dp),intent(in) :: scalarExposedSAI ! exposed stem area index after burial by snow (m2 m-2) - real(dp),intent(in) :: scalarCanopyWetFraction ! canopy wetted fraction (-) - ! input: ground and canopy temperature - real(dp),intent(in) :: scalarGroundTemp ! ground temperature (K) - real(dp),intent(in) :: scalarCanopyTemp ! canopy temperature (K) - ! output: canopy sw radiation fluxes - real(dp),intent(out) :: scalarCanopySunlitFraction ! sunlit fraction of canopy (-) - real(dp),intent(out) :: scalarCanopySunlitLAI ! sunlit leaf area (-) - real(dp),intent(out) :: scalarCanopyShadedLAI ! shaded leaf area (-) - real(dp),intent(out) :: scalarCanopySunlitPAR ! average absorbed par for sunlit leaves (w m-2) - real(dp),intent(out) :: scalarCanopyShadedPAR ! average absorbed par for shaded leaves (w m-2) - real(dp),intent(out) :: spectralBelowCanopyDirect(:) ! downward direct flux below veg layer for each spectral band W m-2) - real(dp),intent(out) :: spectralBelowCanopyDiffuse(:) ! downward diffuse flux below veg layer for each spectral band (W m-2) - real(dp),intent(out) :: scalarBelowCanopySolar ! solar radiation transmitted below the canopy (W m-2) - real(dp),intent(out) :: spectralAlbGndDirect(:) ! direct albedo of underlying surface (1:nBands) (-) - real(dp),intent(out) :: spectralAlbGndDiffuse(:) ! diffuse albedo of underlying surface (1:nBands) (-) - real(dp),intent(out) :: scalarGroundAlbedo ! albedo of the ground surface (-) - real(dp),intent(out) :: scalarCanopyAbsorbedSolar ! solar radiation absorbed by canopy (W m-2) - real(dp),intent(out) :: scalarGroundAbsorbedSolar ! solar radiation absorbed by ground (W m-2) - ! output: error control + 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 - real(dp) :: snowmassPlusNewsnow ! sum of snow mass and new snowfall (kg m-2 [mm]) - real(dp) :: scalarGroundSnowFraction ! snow cover fraction on the ground surface (-) - real(dp),parameter :: scalarVegFraction=1._dp ! vegetation fraction (=1 forces no canopy gaps and open areas in radiation routine) - real(dp) :: scalarTotalReflectedSolar ! total reflected solar radiation (W m-2) - real(dp) :: scalarTotalAbsorbedSolar ! total absorbed solar radiation (W m-2) - real(dp) :: scalarCanopyReflectedSolar ! solar radiation reflected from the canopy (W m-2) - real(dp) :: scalarGroundReflectedSolar ! solar radiation reflected from the ground (W m-2) - real(dp) :: scalarBetweenCanopyGapFraction ! between canopy gap fraction for beam (-) - real(dp) :: scalarWithinCanopyGapFraction ! within canopy gap fraction for beam (-) + character(LEN=256) :: cmessage ! error message of downwind routine + real(dp) :: snowmassPlusNewsnow ! sum of snow mass and new snowfall (kg m-2 [mm]) + real(dp) :: scalarGroundSnowFraction ! snow cover fraction on the ground surface (-) + real(dp),parameter :: scalarVegFraction=1._dp ! vegetation fraction (=1 forces no canopy gaps and open areas in radiation routine) + real(dp) :: scalarTotalReflectedSolar ! total reflected solar radiation (W m-2) + real(dp) :: scalarTotalAbsorbedSolar ! total absorbed solar radiation (W m-2) + real(dp) :: scalarCanopyReflectedSolar ! solar radiation reflected from the canopy (W m-2) + real(dp) :: scalarGroundReflectedSolar ! solar radiation reflected from the ground (W m-2) + real(dp) :: scalarBetweenCanopyGapFraction ! between canopy gap fraction for beam (-) + real(dp) :: scalarWithinCanopyGapFraction ! within canopy gap fraction for beam (-) ! ---------------------------------------------------------------------------------------------------------------------------------- + ! 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 + ! 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) + ! 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 (-) + ! 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) + ! 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 (-) + ! 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 (-) + ! 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 (-) + ! 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) + ) ! associating local variables with the information in the data structures + ! ------------------------------------------------------------------------------------------------------------------------- ! initialize error control - err=0; message='vegSWavRad_muster/' + err=0; message='vegSWavRad/' ! * preliminaries... ! ------------------ @@ -252,7 +157,7 @@ subroutine vegSWavRad_muster(& scalarGroundSnowFraction = 1._dp else scalarGroundSnowFraction = 0._dp - endif ! (if there is snow on the ground) + end if ! (if there is snow on the ground) ! * compute radiation fluxes... ! ----------------------------- @@ -307,7 +212,7 @@ subroutine vegSWavRad_muster(& call canopy_SW(& ! input: model control vegTypeIndex, & ! intent(in): index of vegetation type - soilTypeIndex, & ! intent(in): index of soil type + isc, & ! intent(in): index of soil type computeVegFlux, & ! intent(in): logical flag to compute vegetation fluxes (.false. if veg buried by snow) ix_canopySrad, & ! intent(in): index of method used for transmission of shortwave rad through the canopy ! input: model variables @@ -338,14 +243,16 @@ subroutine vegSWavRad_muster(& scalarCanopySunlitPAR, & ! intent(out): average absorbed par for sunlit leaves (w m-2) scalarCanopyShadedPAR, & ! intent(out): average absorbed par for shaded leaves (w m-2) err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if case default; err=20; message=trim(message)//'unable to identify option for canopy sw radiation'; return end select ! (option for canopy sw radiation) + ! end association between local variables and the information in the data structures + end associate - end subroutine vegSWavRad_muster + end subroutine vegSWavRad @@ -355,7 +262,7 @@ end subroutine vegSWavRad_muster subroutine canopy_SW(& ! input: model control vegTypeIndex, & ! intent(in): index of vegetation type - soilTypeIndex, & ! intent(in): index of soil type + isc, & ! intent(in): index of soil color computeVegFlux, & ! intent(in): logical flag to compute vegetation fluxes (.false. if veg buried by snow) ix_canopySrad, & ! intent(in): index of method used for transmission of shortwave rad through the canopy ! input: model variables @@ -395,7 +302,7 @@ subroutine canopy_SW(& 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) :: soilTypeIndex ! soil 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(dp),intent(in) :: scalarCosZenith ! cosine of the solar zenith angle (0-1) @@ -502,8 +409,6 @@ subroutine canopy_SW(& real(dp) :: fractionLAI ! fraction of vegetation that is leaves real(dp) :: visibleAbsDirect ! direct-beam radiation absorbed in the visible part of the spectrum (W m-2) real(dp) :: visibleAbsDiffuse ! diffuse radiation absorbed in the visible part of the spectrum (W m-2) - - ! ----------------------------------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control err=0; message='canopy_SW/' @@ -511,7 +416,7 @@ subroutine canopy_SW(& ! compute the albedo of the ground surface call gndAlbedo(& ! input - soilTypeIndex, & ! intent(in): index of soil type + isc, & ! intent(in): index of soil color scalarGroundSnowFraction, & ! intent(in): fraction of ground that is snow covered (-) scalarVolFracLiqUpper, & ! intent(in): volumetric liquid water content in upper-most soil layer (-) spectralSnowAlbedoDirect, & ! intent(in): direct albedo of snow in each spectral band (-) @@ -520,7 +425,7 @@ subroutine canopy_SW(& spectralAlbGndDirect, & ! intent(out): direct albedo of underlying surface (-) spectralAlbGndDiffuse, & ! intent(out): diffuse albedo of underlying surface (-) err,cmessage) ! intent(out): error control - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! initialize accumulated fluxes scalarBelowCanopySolar = 0._dp ! radiation transmitted below the canopy (W m-2) @@ -544,7 +449,7 @@ subroutine canopy_SW(& else spectralBelowCanopyDirect(iBand) = 0._dp spectralBelowCanopyDiffuse(iBand) = 0._dp - endif + end if ! (accumulate radiation transmitted below the canopy) scalarBelowCanopySolar = scalarBelowCanopySolar + & ! contribution from all previous wave bands spectralBelowCanopyDirect(iBand) + spectralBelowCanopyDiffuse(iBand) ! contribution from current wave band @@ -554,11 +459,11 @@ subroutine canopy_SW(& spectralBelowCanopyDiffuse(iBand)*(1._dp - spectralAlbGndDiffuse(iBand)) ! diffuse radiation from current wave band end do ! looping through wave bands return - endif + end if ! compute exposed leaf and stem area index scalarExposedVAI = scalarExposedLAI + scalarExposedSAI - if(scalarExposedVAI < epsilon(scalarExposedVAI))then; err=20; message=trim(message)//'very small exposed vegetation area (covered with snow?)'; return; endif + if(scalarExposedVAI < epsilon(scalarExposedVAI))then; err=20; message=trim(message)//'very small exposed vegetation area (covered with snow?)'; return; end if ! ============================================================================================================================================================ ! ============================================================================================================================================================ @@ -596,7 +501,7 @@ subroutine canopy_SW(& print*, 'Fdirect = ', Fdirect message=trim(message)//'BeersLaw: Fdirect is less than zero or greater than one' err=20; return - endif + end if ! compute ground albedo (-) scalarGroundAlbedo = Fdirect*groundAlbedoDirect + (1._dp - Fdirect)*groundAlbedoDiffuse @@ -605,7 +510,7 @@ subroutine canopy_SW(& print*, 'groundAlbedoDiffuse = ', groundAlbedoDiffuse message=trim(message)//'BeersLaw: albedo is less than zero or greater than one' err=20; return - endif + end if ! compute below-canopy radiation (W m-2) spectralBelowCanopyDirect(iBand) = spectralIncomingDirect(iBand)*tauTotal ! direct radiation from current wave band @@ -630,7 +535,7 @@ subroutine canopy_SW(& print*, 'scalarGroundAlbedo = ', scalarGroundAlbedo message=trim(message)//'BeersLaw: problem with the canopy radiation balance' err=20; return - endif + end if ! compute solar radiation lost to space in given wave band (W m-2) spectralTotalReflectedDirect(iBand) = spectralIncomingDirect(iBand) - spectralGroundAbsorbedDirect(iBand) - spectralCanopyAbsorbedDirect(iBand) @@ -646,13 +551,13 @@ subroutine canopy_SW(& print*, 'spectralCanopyAbsorbedSolar(iBand) = ', spectralCanopyAbsorbedSolar(iBand) message=trim(message)//'BeersLaw: reflected radiation is less than zero' err=20; return - endif + end if ! save canopy radiation absorbed in visible wavelengths if(iBand == ixVisible)then visibleAbsDirect = spectralCanopyAbsorbedDirect(ixVisible) visibleAbsDiffuse = spectralCanopyAbsorbedDiffuse(ixVisible) - endif + end if ! accumulate fluxes scalarBelowCanopySolar = scalarBelowCanopySolar + spectralBelowCanopySolar(iBand) @@ -696,7 +601,7 @@ subroutine canopy_SW(& print*, 'Fdirect = ', Fdirect message=trim(message)//'NL_scatter: Fdirect is less than zero or greater than one' err=20; return - endif + end if ! compute ground albedo (-) scalarGroundAlbedo = Fdirect*groundAlbedoDirect + (1._dp - Fdirect)*groundAlbedoDiffuse @@ -705,7 +610,7 @@ subroutine canopy_SW(& print*, 'groundAlbedoDiffuse = ', groundAlbedoDiffuse message=trim(message)//'NL_scatter: albedo is less than zero or greater than one' err=20; return - endif + end if ! compute initial transmission in the absence of scattering and multiple reflections (-) tauInitial = Fdirect*tauFinite + (1._dp - Fdirect)*taudFinite @@ -740,13 +645,13 @@ subroutine canopy_SW(& if(spectralTotalReflectedDirect(iBand) < 0._dp .or. spectralTotalReflectedDiffuse(iBand) < 0._dp)then message=trim(message)//'NL-scatter: reflected radiation is less than zero' err=20; return - endif + end if ! save canopy radiation absorbed in visible wavelengths if(iBand == ixVisible)then visibleAbsDirect = spectralCanopyAbsorbedDirect(ixVisible) visibleAbsDiffuse = spectralCanopyAbsorbedDiffuse(ixVisible) - endif + end if ! accumulate fluxes scalarBelowCanopySolar = scalarBelowCanopySolar + spectralBelowCanopySolar(iBand) @@ -831,13 +736,13 @@ subroutine canopy_SW(& if(spectralTotalReflectedDirect(iBand) < 0._dp .or. spectralTotalReflectedDiffuse(iBand) < 0._dp)then message=trim(message)//'UEB_2stream: reflected radiation is less than zero' err=20; return - endif + end if ! save canopy radiation absorbed in visible wavelengths if(iBand == ixVisible)then visibleAbsDirect = spectralCanopyAbsorbedDirect(ixVisible) visibleAbsDiffuse = spectralCanopyAbsorbedDiffuse(ixVisible) - endif + end if ! accumulate fluxes scalarBelowCanopySolar = scalarBelowCanopySolar + spectralBelowCanopySolar(iBand) @@ -948,7 +853,7 @@ subroutine canopy_SW(& if(iBand == ixVisible)then visibleAbsDirect = spectralIncomingDirect(ixVisible)*spectralCanopyAbsorbedDirect(ixVisible) visibleAbsDiffuse = spectralIncomingDiffuse(ixVisible)*spectralCanopyAbsorbedDiffuse(ixVisible) - endif + end if end do ! (looping through wave bands) @@ -981,7 +886,7 @@ subroutine canopy_SW(& else scalarCanopySunlitPAR = 0._dp scalarCanopyShadedPAR = (visibleAbsDirect + visibleAbsDiffuse) * fractionLAI / max(scalarCanopyShadedLAI, mpe) - endif + end if !print*, 'scalarCanopySunlitLAI, fractionLAI, visibleAbsDirect, visibleAbsDiffuse, scalarCanopySunlitPAR = ', & ! scalarCanopySunlitLAI, fractionLAI, visibleAbsDirect, visibleAbsDiffuse, scalarCanopySunlitPAR @@ -995,7 +900,7 @@ end subroutine canopy_SW ! ************************************************************************************************************************************* subroutine gndAlbedo(& ! input - soilTypeIndex, & ! intent(in): index of soil type + isc, & ! intent(in): index of soil color scalarGroundSnowFraction, & ! intent(in): fraction of ground that is snow covered (-) scalarVolFracLiqUpper, & ! intent(in): volumetric liquid water content in upper-most soil layer (-) spectralSnowAlbedoDirect, & ! intent(in): direct albedo of snow in each spectral band (-) @@ -1009,7 +914,7 @@ 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) :: soilTypeIndex ! index of soil type + integer(i4b),intent(in) :: isc ! index of soil color real(dp),intent(in) :: scalarGroundSnowFraction ! fraction of ground that is snow covered (-) real(dp),intent(in) :: scalarVolFracLiqUpper ! volumetric liquid water content in upper-most soil layer (-) real(dp),intent(in) :: spectralSnowAlbedoDirect(:) ! direct albedo of snow in each spectral band (-) @@ -1029,7 +934,7 @@ subroutine gndAlbedo(& ! compute soil albedo do iBand=1,nBands ! loop through spectral bands xInc = max(0.11_dp - 0.40_dp*scalarVolFracLiqUpper, 0._dp) - spectralSoilAlbedo(iBand) = min(ALBSAT(soilTypeIndex,iBand)+xInc,ALBDRY(soilTypeIndex,iBand)) + 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) diff --git a/build/source/engine/volicePack.f90 b/build/source/engine/volicePack.f90 old mode 100644 new mode 100755 index 23317c825..feb8691bb --- a/build/source/engine/volicePack.f90 +++ b/build/source/engine/volicePack.f90 @@ -21,8 +21,6 @@ module volicePack_module ! numerical recipes data types USE nrtype -! named variables for snow and soil -USE data_struc,only:ix_soil,ix_snow ! physical constants USE multiconst,only:& Tfreeze, & ! freezing point (K) @@ -45,38 +43,45 @@ module volicePack_module ! ************************************************************************************************ subroutine volicePack(& ! input/output: model data structures + tooMuchMelt, & ! 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 - mvar_data, & ! intent(inout): model variables for a local HRU - ! output: error control + 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,message) ! intent(out): error control ! ------------------------------------------------------------------------------------------------ ! provide access to the derived types to define the data structures - USE data_struc,only:& + USE data_types,only:& 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 - ! provide access to named variables defining elements in the data structures - USE var_lookup,only:iLookTIME,iLookTYPE,iLookATTR,iLookFORCE,iLookPARAM,iLookMVAR,iLookBVAR,iLookINDEX ! named variables for structure elements - USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure ! external subroutine USE layerMerge_module,only:layerMerge ! merge snow layers if they are too thin USE layerDivide_module,only:layerDivide ! sub-divide layers if they are too thick implicit none ! ------------------------------------------------------------------------------------------------ ! input/output: model data structures + logical(lgt),intent(in) :: tooMuchMelt ! flag to denote that ice is insufficient to support melt type(model_options),intent(in) :: model_decisions(:) ! model decisions - type(var_d),intent(in) :: mpar_data ! model parameters + type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_ilength),intent(inout) :: indx_data ! type of each layer - type(var_dlength),intent(inout) :: mvar_data ! model variables for a local HRU - ! output: error control + 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 + ! output + logical(lgt),intent(out) :: modifiedLayers ! flag to denote that we modified the layers 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) :: mergedLayers ! flag to denote that layers were merged + logical(lgt) :: divideLayer ! flag to denote that a layer was divided ! initialize error control err=0; message='volicePack/' @@ -86,21 +91,31 @@ subroutine volicePack(& model_decisions, & ! intent(in): model decisions mpar_data, & ! intent(in): model parameters indx_data, & ! intent(inout): type of each layer - mvar_data, & ! intent(inout): model variables for a local HRU - ! output: error control + 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; endif + if(err/=0)then; err=65; message=trim(message)//trim(cmessage); return; end if ! merge snow layers if they are too thin call layerMerge(& ! input/output: model data structures + tooMuchMelt, & ! 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 - mvar_data, & ! intent(inout): model variables for a local HRU - ! output: error control + 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 + mergedLayers, & ! 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; endif + if(err/=0)then; err=65; message=trim(message)//trim(cmessage); return; end if + + ! flag if layers were modified + modifiedLayers = (mergedLayers .or. divideLayer) end subroutine volicePack @@ -215,9 +230,9 @@ subroutine newsnwfall(& write(*,'(a,1x,f20.10)') 'SWE mass balance = ', xMassBalance message=trim(message)//'mass balance problem' err=20; return - endif + end if - endif ! if snow layers already exist + end if ! if snow layers already exist end subroutine newsnwfall diff --git a/build/source/hookup/summaFileManager.f90 b/build/source/hookup/summaFileManager.f90 old mode 100644 new mode 100755 index 8e27653c9..cd410b98f --- a/build/source/hookup/summaFileManager.f90 +++ b/build/source/hookup/summaFileManager.f90 @@ -38,7 +38,7 @@ MODULE summafilemanager CHARACTER(LEN=summaPathLen) :: META_TYPE ='summa_zCatergoryMeta.txt' ! metadata for local classification of veg, soil, etc. CHARACTER(LEN=summaPathLen) :: META_FORCE ='summa_zForceMeta.txt' ! metadata for model forcing variables CHARACTER(LEN=summaPathLen) :: META_LOCALPARAM ='summa_zLocalParamMeta.txt' ! metadata for model parameters -CHARACTER(LEN=summaPathLen) :: META_LOCALMVAR ='summa_zLocalModelVarMeta.txt' ! metadata for model variables +CHARACTER(LEN=summaPathLen) :: OUTPUT_CONTROL ='summa_zLocalModelVarMeta.txt' ! metadata for model variables CHARACTER(LEN=summaPathLen) :: META_LOCALINDEX ='summa_zLocalModelIndexMeta.txt' ! metadata for model indices CHARACTER(LEN=summaPathLen) :: META_BASINPARAM ='summa_zBasinParamMeta.txt' ! metadata for model parameters CHARACTER(LEN=summaPathLen) :: META_BASINMVAR ='summa_zBasinModelVarMeta.txt' ! metadata for model variables @@ -70,7 +70,7 @@ subroutine summa_SetDirsUndPhiles(summaFileManagerIn,err,message) character(*),intent(out)::message ! locals logical(lgt)::xist -integer(i4b),parameter::unt=99 !DK: need to either define units globally, or use getSpareUnit +integer(i4b),parameter::fileUnit=99 !DK: need to either define units globally, or use getSpareUnit character(*),parameter::summaFileManagerHeader="SUMMA_FILE_MANAGER_V1.0" character(LEN=100)::temp integer(i4b)::ierr ! temporary error code @@ -86,49 +86,48 @@ subroutine summa_SetDirsUndPhiles(summaFileManagerIn,err,message) message=trim(message)//"FileNotFound['"//trim(summaFileManagerIn)//"']"& //'/ProceedingWithDefaults' err=-10; return -endif +end if ! open file manager file -open(unt,file=summaFileManagerIn,status="old",action="read",iostat=err) +open(fileUnit,file=summaFileManagerIn,status="old",action="read",iostat=err) if(err/=0)then message=trim(message)//"fileManagerOpenError['"//trim(summaFileManagerIn)//"']" err=10; return -endif +end if ! check the header matches the code -read(unt,*)temp +read(fileUnit,*)temp if(trim(temp)/=summaFileManagerHeader)then message=trim(message)//"unknownHeader&[file='"//trim(summaFileManagerIn)//"']&& &[header="//trim(temp)//"]" err=20; return -endif +end if ! read information from file -ierr=0 ! initialize errors -read(unt,'(a)')temp -read(unt,'(a)')temp -read(unt,*)SETNGS_PATH ; call checkLineRead(SETNGS_PATH, err,message); if(err/=0)return -read(unt,*)INPUT_PATH ; call checkLineRead(INPUT_PATH, err,message); if(err/=0)return -read(unt,*)OUTPUT_PATH ; call checkLineRead(OUTPUT_PATH, err,message); if(err/=0)return -read(unt,'(a)')temp -read(unt,*)M_DECISIONS ; call checkLineRead(M_DECISIONS, err,message); if(err/=0)return -read(unt,*)META_TIME ; call checkLineRead(META_TIME, err,message); if(err/=0)return -read(unt,*)META_ATTR ; call checkLineRead(META_ATTR, err,message); if(err/=0)return -read(unt,*)META_TYPE ; call checkLineRead(META_TYPE, err,message); if(err/=0)return -read(unt,*)META_FORCE ; call checkLineRead(META_FORCE, err,message); if(err/=0)return -read(unt,*)META_LOCALPARAM ; call checkLineRead(META_LOCALPARAM, err,message); if(err/=0)return -read(unt,*)META_LOCALMVAR ; call checkLineRead(META_LOCALMVAR, err,message); if(err/=0)return -read(unt,*)META_LOCALINDEX ; call checkLineRead(META_LOCALINDEX, err,message); if(err/=0)return -read(unt,*)META_BASINPARAM ; call checkLineRead(META_BASINPARAM, err,message); if(err/=0)return -read(unt,*)META_BASINMVAR ; call checkLineRead(META_BASINMVAR, err,message); if(err/=0)return -read(unt,*)LOCAL_ATTRIBUTES; call checkLineRead(LOCAL_ATTRIBUTES, err,message); if(err/=0)return -read(unt,*)LOCALPARAM_INFO ; call checkLineRead(LOCALPARAM_INFO, err,message); if(err/=0)return -read(unt,*)BASINPARAM_INFO ; call checkLineRead(BASINPARAM_INFO, err,message); if(err/=0)return -read(unt,*)FORCING_FILELIST; call checkLineRead(FORCING_FILELIST, err,message); if(err/=0)return -read(unt,*)MODEL_INITCOND ; call checkLineRead(MODEL_INITCOND, err,message); if(err/=0)return -read(unt,*)PARAMETER_TRIAL ; call checkLineRead(PARAMETER_TRIAL, err,message); if(err/=0)return -read(unt,*)OUTPUT_PREFIX ; call checkLineRead(OUTPUT_PREFIX, err,message); if(err/=0)return -close(unt) +ierr=0 ! initialize errors + +call readLine(fileUnit,SETNGS_PATH, err,message); if(err/=0)return +call readLine(fileUnit,INPUT_PATH, err,message); if(err/=0)return +call readLine(fileUnit,OUTPUT_PATH, err,message); if(err/=0)return + +call readLine(fileUnit,M_DECISIONS, err,message); if(err/=0)return +call readLine(fileUnit,META_TIME, err,message); if(err/=0)return +call readLine(fileUnit,META_ATTR, err,message); if(err/=0)return +call readLine(fileUnit,META_TYPE, err,message); if(err/=0)return +call readLine(fileUnit,META_FORCE, err,message); if(err/=0)return +call readLine(fileUnit,META_LOCALPARAM, err,message); if(err/=0)return +call readLine(fileUnit,OUTPUT_CONTROL, err,message); if(err/=0)return +call readLine(fileUnit,META_LOCALINDEX, err,message); if(err/=0)return +call readLine(fileUnit,META_BASINPARAM, err,message); if(err/=0)return +call readLine(fileUnit,META_BASINMVAR, err,message); if(err/=0)return +call readLine(fileUnit,LOCAL_ATTRIBUTES,err,message); if(err/=0)return +call readLine(fileUnit,LOCALPARAM_INFO, err,message); if(err/=0)return +call readLine(fileUnit,BASINPARAM_INFO, err,message); if(err/=0)return +call readLine(fileUnit,FORCING_FILELIST,err,message); if(err/=0)return +call readLine(fileUnit,MODEL_INITCOND, err,message); if(err/=0)return +call readLine(fileUnit,PARAMETER_TRIAL, err,message); if(err/=0)return +call readLine(fileUnit,OUTPUT_PREFIX, err,message); if(err/=0)return +close(fileUnit) ! check that the output directory exists and write the date and time to a log file open(runinfo_fileunit,file=trim(OUTPUT_PATH)//"runinfo.txt",iostat=err) -if(err/=0)then; err=10; message=trim(message)//"cannot write to directory '"//trim(OUTPUT_PATH)//"'"; return; endif +if(err/=0)then; err=10; message=trim(message)//"cannot write to directory '"//trim(OUTPUT_PATH)//"'"; return; end if call date_and_time(cdate,ctime) write(runinfo_fileunit,*) 'ccyy='//cdate(1:4)//' - mm='//cdate(5:6)//' - dd='//cdate(7:8), & ' - hh='//ctime(1:2)//' - mi='//ctime(3:4)//' - ss='//ctime(5:10) @@ -136,19 +135,27 @@ subroutine summa_SetDirsUndPhiles(summaFileManagerIn,err,message) ! End procedure here end subroutine summa_SetDirsUndPhiles - ! ************************************************************************************************* -! public subroutine checkLineRead: check if there is a space in the character string +! public subroutine readLine: read the first string to a string variable ! ************************************************************************************************* -subroutine checkLineRead(stringInput,err,message) +subroutine readLine(fileUnit,inputString,err,message) implicit none -character(*),intent(in) :: stringInput +integer(i4b),intent(in) :: fileUnit +character(*),intent(inout):: inputString integer(i4b),intent(inout):: err character(*),intent(inout):: message -if(index(trim(stringInput),' ')/=0) then - err=30; message="f-summaSetDirsUndPhiles/spaceInString[string="//trim(stringInput)//"]" -endif -end subroutine checkLineRead +do + ! read line that is not comment + read(fileUnit,*) inputString + if (inputString(1:1) /= '!') exit +end do + +! check if there is a space in the character string +if(index(trim(inputString),' ')/=0) then + err=30; message="f-summaSetDirsUndPhiles/spaceInString[string="//trim(inputString)//"]" + return +endif +end subroutine readLine END MODULE summafilemanager diff --git a/build/source/lapack/Makefile b/build/source/lapack/Makefile old mode 100644 new mode 100755 diff --git a/build/source/lapack/README b/build/source/lapack/README old mode 100644 new mode 100755 diff --git a/build/source/lapack/luSolv_numrec.f90 b/build/source/lapack/luSolv_numrec.f90 old mode 100644 new mode 100755 index 592e8e934..32337fe2b --- a/build/source/lapack/luSolv_numrec.f90 +++ b/build/source/lapack/luSolv_numrec.f90 @@ -47,13 +47,13 @@ SUBROUTINE ludcmp(a,indx,d,err,message) if(size(a,1) /= n .or. size(a,2) /= n)then message=trim(message)//'mismatch in size of matrices' err=20; return - endif + end if d=1.0_dp vv=maxval(abs(a),dim=2) if (any(vv == 0.0))then message=trim(message)//'singular matrix' err=20; return - endif + end if vv=1.0_dp/vv do j=1,n imax=(j-1)+imaxloc(vv(j:n)*abs(a(j:n,j))) @@ -90,7 +90,7 @@ SUBROUTINE lubksb(a,indx,b,err,message) if(size(a,1) /= n .or. size(a,2) /= n)then message=trim(message)//'mismatch in size of matrices' err=20; return - endif + end if ii=0 do i=1,n ll=indx(i) diff --git a/build/source/lapack/test_lusolve.f90 b/build/source/lapack/test_lusolve.f90 old mode 100644 new mode 100755 index a20979068..7c89142f6 --- a/build/source/lapack/test_lusolve.f90 +++ b/build/source/lapack/test_lusolve.f90 @@ -47,11 +47,11 @@ program test_lusolve ! decompose the matrix call ludcmp(a,indx,d,err,cmessage) -if(err/=0)then; print*, trim(cmessage); stop; endif +if(err/=0)then; print*, trim(cmessage); stop; end if ! solve the equations call lubksb(a,indx,b,err,cmessage) -if(err/=0)then; print*, trim(cmessage); stop; endif +if(err/=0)then; print*, trim(cmessage); stop; end if write(*,'(a,1x,3(f9.3,1x),a)') 'numrec: b = ', b, '; should be (1,2,-1)' ! set a and b (overwritten in lapack) diff --git a/build/source/netcdf/def_output.f90 b/build/source/netcdf/def_output.f90 old mode 100644 new mode 100755 index 63011a35e..1765d6111 --- a/build/source/netcdf/def_output.f90 +++ b/build/source/netcdf/def_output.f90 @@ -19,166 +19,140 @@ ! along with this program. If not, see . module def_output_module -USE nrtype USE netcdf +USE netcdf_util_module,only:netcdf_err ! netcdf error handling function +USE nrtype, integerMissing=>nr_integerMissing ! top-level data types +USE f2008funcs_module,only:cloneStruc ! used to "clone" data structures -- temporary replacement of the intrinsic allocate(a, source=b) implicit none private public :: def_output + ! define dimension names -character(len=32),parameter :: hru_DimName='hru' ! dimension name for the HRUs -character(len=32),parameter :: scalar_DimName='scalar' ! dimension name for scalar variables -character(len=32),parameter :: wLength_dimName='spectral_bands' ! dimension name for the number of spectral bands -character(len=32),parameter :: timestep_DimName='time' ! dimension name for the time step -character(len=32),parameter :: routing_DimName='timeDelayRouting' ! dimension name for thetime delay routing vectors -character(len=32),parameter :: midSnowAndTime_DimName='midSnowAndTime' ! dimension name for midSnow-time -character(len=32),parameter :: midSoilAndTime_DimName='midSoilAndTime' ! dimension name for midSoil-time -character(len=32),parameter :: midTotoAndTime_DimName='midTotoAndTime' ! dimension name for midToto-time -character(len=32),parameter :: ifcSnowAndTime_DimName='ifcSnowAndTime' ! dimension name for ifcSnow-time -character(len=32),parameter :: ifcSoilAndTime_DimName='ifcSoilAndTime' ! dimension name for ifcSoil-time -character(len=32),parameter :: ifcTotoAndTime_DimName='ifcTotoAndTime' ! dimension name for ifcToto-time -contains +character(len=32),parameter :: hru_DimName = 'hru' ! dimension name for the HRUs +character(len=32),parameter :: depth_DimName = 'depth' ! dimension name for soil depth +character(len=32),parameter :: scalar_DimName = 'scalar' ! dimension name for scalar variables +character(len=32),parameter :: wLength_dimName = 'spectral_bands' ! dimension name for the number of spectral bands +character(len=32),parameter :: timestep_DimName = 'time' ! dimension name for the time step +character(len=32),parameter :: routing_DimName = 'timeDelayRouting' ! dimension name for thetime delay routing vectors +character(len=32),parameter :: midSnowAndTime_DimName = 'midSnowAndTime' ! dimension name for midSnow-time +character(len=32),parameter :: midSoilAndTime_DimName = 'midSoilAndTime' ! dimension name for midSoil-time +character(len=32),parameter :: midTotoAndTime_DimName = 'midTotoAndTime' ! dimension name for midToto-time +character(len=32),parameter :: ifcSnowAndTime_DimName = 'ifcSnowAndTime' ! dimension name for ifcSnow-time +character(len=32),parameter :: ifcSoilAndTime_DimName = 'ifcSoilAndTime' ! dimension name for ifcSoil-time +character(len=32),parameter :: ifcTotoAndTime_DimName = 'ifcTotoAndTime' ! dimension name for ifcToto-time + +! define the dimension IDs +integer(i4b) :: hru_DimID ! dimension name for the HRUs +integer(i4b) :: depth_DimID ! dimension name for the soil depth +integer(i4b) :: scalar_DimID ! dimension name for scalar variables +integer(i4b) :: wLength_dimID ! dimension name for the number of spectral bands +integer(i4b) :: timestep_DimID ! dimension name for the time step +integer(i4b) :: routing_DimID ! dimension name for thetime delay routing vectors +integer(i4b) :: midSnowAndTime_DimID ! dimension name for midSnow-time +integer(i4b) :: midSoilAndTime_DimID ! dimension name for midSoil-time +integer(i4b) :: midTotoAndTime_DimID ! dimension name for midToto-time +integer(i4b) :: ifcSnowAndTime_DimID ! dimension name for ifcSnow-time +integer(i4b) :: ifcSoilAndTime_DimID ! dimension name for ifcSoil-time +integer(i4b) :: ifcTotoAndTime_DimID ! dimension name for ifcToto-time +! define named variables to specify dimensions +integer(i4b),parameter :: needHRU=1,noHRU=2 ! define if there is an HRU dimension +integer(i4b),parameter :: needTime=1,noTime=2 ! define if there is a time dimension + +contains ! ********************************************************************************************************** ! public subroutine def_output: define model output file ! ********************************************************************************************************** - subroutine def_output(nHRU,infile,err,message) - USE data_struc,only:forc_meta,attr_meta,type_meta ! metadata structures - USE data_struc,only:mpar_meta,mvar_meta,indx_meta ! metadata structures - USE data_struc,only:bpar_meta,bvar_meta ! metadata structures - USE data_struc,only:model_decisions - USE multiconst,only:integerMissing + subroutine def_output(nHRU,nSoil,infile,err,message) + USE globalData,only:structInfo ! information on the data structures + USE globalData,only:forc_meta,attr_meta,type_meta ! metaData structures + 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,time_meta ! metaData structures + USE globalData,only:model_decisions ! model decisions + USE globalData,only:ncid + USE globalData,only:nFreq,outFreq ! output frequencies ! declare dummy variables - integer(i4b), intent(in) :: nHRU ! number of HRUs - character(*), intent(in) :: infile ! file suffix - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + integer(i4b),intent(in) :: nHRU ! number of HRUs + integer(i4b),intent(in) :: nSoil ! number of soil layers in the first HRU (used to define fixed length dimensions) + character(*),intent(in) :: infile ! file suffix + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message ! local variables - integer(i4b) :: ivar ! loop through model variables - character(len=256) :: cmessage ! temporary error message + integer(i4b) :: ivar ! loop through model decisions + integer(i4b) :: iFreq ! loop through output frequencies + integer(i4b) :: iStruct ! loop through structure types + integer(i4b),parameter :: modelTime=1 ! model timestep output frequency + character(len=5) :: fstring ! string to hold model output freuqnecy + character(len=1000) :: fname ! temporary filename + character(len=256) :: cmessage ! temporary error message + ! initialize errors err=0; message="def_output/" - ! ********************************************************************************************************** - ! ***** create initial file - ! ********************************************************************************************************** - call ini_create(nHRU,trim(infile),err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - ! ********************************************************************************************************** - ! ***** define model decisions - ! ********************************************************************************************************** - do ivar=1,size(model_decisions) - if(model_decisions(ivar)%iDecision /= integerMissing)then - call put_attrib(trim(infile),model_decisions(ivar)%cOption,model_decisions(ivar)%cDecision,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - endif - end do - ! ********************************************************************************************************** - ! ***** define model forcing data - ! ********************************************************************************************************** - do ivar=1,size(forc_meta) - if(.not.forc_meta(ivar)%v_write) cycle - if(forc_meta(ivar)%varname == 'time')then - call def_variab(trim(infile),(/Timestep_DimName/),forc_meta(ivar),nf90_double,err,cmessage) - else - call def_variab(trim(infile),(/hru_DimName,Timestep_DimName/),forc_meta(ivar),nf90_double,err,cmessage) - endif - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - end do ! looping through forcing variables - ! ********************************************************************************************************** - ! ***** define local attributes - ! ********************************************************************************************************** - do ivar=1,size(attr_meta) - if (.not.attr_meta(ivar)%v_write) cycle - call def_variab(trim(infile),(/hru_DimName/),attr_meta(ivar),nf90_double,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - end do ! looping through local attributes - ! ********************************************************************************************************** - ! ***** define local classification of veg, soil, etc. - ! ********************************************************************************************************** - do ivar=1,size(type_meta) - if (.not.type_meta(ivar)%v_write) cycle - call def_variab(trim(infile),(/hru_DimName/),type_meta(ivar),nf90_int,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - end do ! looping through local classification of veg, soil, etc. - ! ********************************************************************************************************** - ! ***** define local column model parameters - ! ********************************************************************************************************** - do ivar=1,size(mpar_meta) - if (.not.mpar_meta(ivar)%v_write) cycle - call def_variab(trim(infile),(/hru_DimName/),mpar_meta(ivar),nf90_double,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - end do ! looping through model parameters - ! ********************************************************************************************************** - ! ***** define basin-average model parameters - ! ********************************************************************************************************** - do ivar=1,size(bpar_meta) - if (.not.bpar_meta(ivar)%v_write) cycle - call def_variab(trim(infile),(/scalar_DimName/),bpar_meta(ivar),nf90_double,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - end do ! looping through model parameters - ! ********************************************************************************************************** - ! ***** define local column model variables -- dimensions depend on the variable type - ! ********************************************************************************************************** - do ivar=1,size(mvar_meta) - if (.not.mvar_meta(ivar)%v_write) cycle - select case(trim(mvar_meta(ivar)%vartype)) - case('scalarv'); call def_variab(trim(infile),(/hru_DimName,Timestep_DimName/),mvar_meta(ivar),nf90_double,err,cmessage) - case('wLength'); call def_variab(trim(infile),(/hru_DimName,wLength_DimName,Timestep_DimName/),mvar_meta(ivar),nf90_double,err,cmessage) - case('midSnow'); call def_variab(trim(infile),(/hru_DimName,midSnowAndTime_DimName/),mvar_meta(ivar),nf90_double,err,cmessage) - case('midSoil'); call def_variab(trim(infile),(/hru_DimName,midSoilAndTime_DimName/),mvar_meta(ivar),nf90_double,err,cmessage) - case('midToto'); call def_variab(trim(infile),(/hru_DimName,midTotoAndTime_DimName/),mvar_meta(ivar),nf90_double,err,cmessage) - case('ifcSnow'); call def_variab(trim(infile),(/hru_DimName,ifcSnowAndTime_DimName/),mvar_meta(ivar),nf90_double,err,cmessage) - case('ifcSoil'); call def_variab(trim(infile),(/hru_DimName,ifcSoilAndTime_DimName/),mvar_meta(ivar),nf90_double,err,cmessage) - case('ifcToto'); call def_variab(trim(infile),(/hru_DimName,ifcTotoAndTime_DimName/),mvar_meta(ivar),nf90_double,err,cmessage) - case default; err=35; message=trim(message)//"varTypeNotFound"; return - endselect - ! check variable definition was OK - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - end do ! loop through model variables - ! ********************************************************************************************************** - ! ***** define local column model indices -- dimensions depend on the variable type - ! ********************************************************************************************************** - do ivar=1,size(indx_meta) - if (.not.indx_meta(ivar)%v_write) cycle - select case(trim(indx_meta(ivar)%vartype)) - case('scalarv'); call def_variab(trim(infile),(/hru_DimName,Timestep_DimName/),indx_meta(ivar),nf90_int,err,cmessage) - case('midToto'); call def_variab(trim(infile),(/hru_DimName,midTotoAndTime_DimName/),indx_meta(ivar),nf90_int,err,cmessage) - case default; err=35; message=trim(message)//"varTypeNotFound"; return - endselect - ! check variable definition was OK - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - end do ! loop through model variable - ! ********************************************************************************************************** - ! ***** define local column model variables -- dimensions depend on the variable type - ! ********************************************************************************************************** - do ivar=1,size(bvar_meta) - if (.not.bvar_meta(ivar)%v_write) cycle - select case(trim(bvar_meta(ivar)%vartype)) - case('scalarv'); call def_variab(trim(infile),(/Timestep_DimName/),bvar_meta(ivar),nf90_double,err,cmessage) - case('routing'); call def_variab(trim(infile),(/routing_DimName/), bvar_meta(ivar),nf90_double,err,cmessage) - case default; err=35; message=trim(message)//"varTypeNotFound"; return - endselect - ! check variable definition was OK - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - end do ! loop through model variables - end subroutine def_output + ! create initial file + ! each file will have a master name with a frequency appended at the end: + ! e.g., xxxxxxxxx_1.nc (for output at every model timestep) + ! e.g., xxxxxxxxx_24.nc (for daily output with hourly model timestep) + do iFreq = 1,nFreq + + ! create file + write(fstring,'(i5)') outFreq(iFreq) + fstring = adjustl(fstring) + fname = trim(infile)//'_'//trim(fstring)//'.nc' + call ini_create(nHRU,nSoil,trim(fname),ncid(iFreq),err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + print "(A,A)",'Created output file:',trim(fname) + + ! define model decisions + do iVar = 1,size(model_decisions) + if(model_decisions(iVar)%iDecision.ne.integerMissing)then + call put_attrib(ncid(modelTime),model_decisions(iVar)%cOption,model_decisions(iVar)%cDecision,err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + end if + end do + + ! ensure that all time variables are written to all files + time_meta(:)%outFreq = iFreq + ! 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, nf90_double,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, nf90_double,err,cmessage) ! model parameters + case('bpar' ); call def_variab(ncid(iFreq),iFreq, noHRU, noTime,bpar_meta, nf90_double,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,nf90_double,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, nf90_double,err,cmessage) ! model forcing data + case('prog' ); call def_variab(ncid(iFreq),iFreq,needHRU,needTime,prog_meta, nf90_double,err,cmessage) ! model prognostics + case('diag' ); call def_variab(ncid(iFreq),iFreq,needHRU,needTime,diag_meta, nf90_double,err,cmessage) ! model diagnostic variables + case('flux' ); call def_variab(ncid(iFreq),iFreq,needHRU,needTime,flux_meta, nf90_double,err,cmessage) ! model fluxes + case('bvar' ); call def_variab(ncid(iFreq),iFreq, noHRU,needTime,bvar_meta, nf90_double,err,cmessage) ! basin-average variables + 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 + end do ! iStruct + + ! write HRU dimension for each output file + call write_hru_dim(ncid(iFreq), err, cmessage); if(err/=0) then; message=trim(message)//trim(cmessage); return; end if + end do ! iFreq + + end subroutine def_output ! ********************************************************************************************************** ! private subroutine ini_create: initial create ! ********************************************************************************************************** - subroutine ini_create(nHRU,infile,err,message) + subroutine ini_create(nHRU,nSoil,infile,ncid,err,message) ! variables to define number of steps per file (total number of time steps, step length, etc.) USE multiconst,only:secprday ! number of seconds per day - USE data_struc,only:data_step ! time step of model forcing data (s) - USE data_struc,only:numtim ! number of time steps - ! model model index structures - USE data_struc,only:indx_data ! data structures - USE data_struc,only:ix_soil ! named variable to identify a soil layer - USE var_lookup,only:iLookINDEX ! named variables for structure elements + USE globalData,only:data_step ! time step of model forcing data (s) + USE globalData,only:numtim ! number of time steps ! model decisions - USE data_struc,only:model_decisions ! model decision structure + USE globalData,only:model_decisions ! model decision structure USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure USE mDecisions_module,only:& sameRulesAllLayers, & ! SNTHERM option: same combination/sub-dividion rules applied to all layers @@ -186,25 +160,23 @@ subroutine ini_create(nHRU,infile,err,message) implicit none ! declare dummy variables integer(i4b),intent(in) :: nHRU ! number of HRUs + integer(i4b),intent(in) :: nSoil ! number of soil layers in the first HRU (used to define fixed length dimensions) character(*),intent(in) :: infile ! filename + integer(i4b),intent(out) :: ncid ! netcdf file id integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! define local variables - integer(i4b) :: ncid ! NetCDF file ID - integer(i4b) :: dimID integer(i4b) :: maxRouting=1000 ! maximum length of routing vector integer(i4b),parameter :: maxSpectral=2 ! maximum number of spectral bands integer(i4b),parameter :: scalarLength=1 ! length of scalar variable integer(i4b) :: meanSnowLayersPerStep ! mean number of snow layers per time step integer(i4b) :: maxStepsPerFile ! maximum number of time steps to be stored in each file integer(i4b) :: maxLength ! maximum length of the variable vector - integer(i4b) :: nSoil ! number of soil layers ! initialize error control err=0;message="f-iniCreate/" - ! define number of soil layers - nSoil = count(indx_data%var(iLookINDEX%layerType)%dat == ix_soil) ! number of soil layers ! identify length of the variable vector - maxStepsPerFile = min(numtim, nint(366._dp * secprday/data_step) ) + maxStepsPerFile = min(numtim,nint(366._dp * secprday/data_step)) + if(maxStepsPerFile < numtim) maxStepsPerFile=numtim select case(model_decisions(iLookDECISIONS%snowLayers)%iDecision) case(sameRulesAllLayers); meanSnowLayersPerStep = 100 case(rulesDependLayerIndex); meanSnowLayersPerStep = 5 @@ -212,67 +184,44 @@ subroutine ini_create(nHRU,infile,err,message) end select ! (option to combine/sub-divide snow layers) maxLength = maxStepsPerFile*(nSoil+1 + meanSnowLayersPerStep) print*, 'maxStepsPerFile, maxLength = ', maxStepsPerFile, maxLength + ! create output file err = nf90_create(trim(infile),nf90_classic_model,ncid) message='iCreate[create]'; call netcdf_err(err,message); if (err/=0) return - ! create time dimension (unlimited) - err = nf90_def_dim(ncid, trim(timestep_DimName), nf90_unlimited, dimId) - message='iCreate[time]'; call netcdf_err(err,message); if (err/=0) return - ! create scalar dimension - err = nf90_def_dim(ncid, trim(scalar_DimName), scalarLength, dimId) - message='iCreate[scalar]'; call netcdf_err(err,message); if (err/=0) return - ! create HRU dimension - err = nf90_def_dim(ncid, trim(hru_DimName), nHRU, dimId) - message='iCreate[HRU]'; call netcdf_err(err,message); if (err/=0) return - ! create spectral band dimension - err = nf90_def_dim(ncid, trim(wLength_DimName), maxSpectral, dimId) - message='iCreate[spectral]'; call netcdf_err(err,message); if (err/=0) return - ! create dimension for the time-delay routing variables - err = nf90_def_dim(ncid, trim(routing_DimName), maxRouting, dimId) - message='iCreate[routing]'; call netcdf_err(err,message); if (err/=0) return - ! create dimension for midSnow+time - err = nf90_def_dim(ncid, trim(midSnowAndTime_DimName), maxLength, dimId) - message='iCreate[midSnow]'; call netcdf_err(err,message); if (err/=0) return - ! create dimension for midSoil+time - err = nf90_def_dim(ncid, trim(midSoilAndTime_DimName), maxLength, dimId) - message='iCreate[midSoil]'; call netcdf_err(err,message); if (err/=0) return - ! create dimension for midToto+time - err = nf90_def_dim(ncid, trim(midTotoAndTime_DimName), maxLength, dimId) - message='iCreate[minToto]'; call netcdf_err(err,message); if (err/=0) return - ! create dimension for ifcSnow+time - err = nf90_def_dim(ncid, trim(ifcSnowAndTime_DimName), maxLength, dimId) - message='iCreate[ifcSnow]'; call netcdf_err(err,message); if (err/=0) return - ! create dimension for ifcSoil+time - err = nf90_def_dim(ncid, trim(ifcSoilAndTime_DimName), maxLength, dimId) - message='iCreate[ifcSoil]'; call netcdf_err(err,message); if (err/=0) return - ! create dimension for ifcToto+time - err = nf90_def_dim(ncid, trim(ifcTotoAndTime_DimName), maxLength, dimId) - message='iCreate[ifcToto]'; call netcdf_err(err,message); if (err/=0) return - ! close NetCDF file - err = nf90_enddef(ncid); call netcdf_err(err,message); if (err/=0) return - err = nf90_close(ncid); call netcdf_err(err,message); if (err/=0) return - end subroutine ini_create + ! create dimensions + 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 + err = nf90_def_dim(ncid, trim( wLength_DimName), maxSpectral, wLength_DimID); message='iCreate[spectral]'; call netcdf_err(err,message); if (err/=0) return + err = nf90_def_dim(ncid, trim( routing_DimName), maxRouting, routing_DimID); message='iCreate[routing]'; call netcdf_err(err,message); if (err/=0) return + err = nf90_def_dim(ncid, trim(midSnowAndTime_DimName), maxLength, midSnowAndTime_DimID); message='iCreate[midSnow]'; call netcdf_err(err,message); if (err/=0) return + err = nf90_def_dim(ncid, trim(midSoilAndTime_DimName), maxLength, midSoilAndTime_DimID); message='iCreate[midSoil]'; call netcdf_err(err,message); if (err/=0) return + err = nf90_def_dim(ncid, trim(midTotoAndTime_DimName), maxLength, midTotoAndTime_DimID); message='iCreate[midToto]'; call netcdf_err(err,message); if (err/=0) return + err = nf90_def_dim(ncid, trim(ifcSnowAndTime_DimName), maxLength, ifcSnowAndTime_DimID); message='iCreate[ifcSnow]'; call netcdf_err(err,message); if (err/=0) return + err = nf90_def_dim(ncid, trim(ifcSoilAndTime_DimName), maxLength, ifcSoilAndTime_DimID); message='iCreate[ifcSoil]'; call netcdf_err(err,message); if (err/=0) return + err = nf90_def_dim(ncid, trim(ifcTotoAndTime_DimName), maxLength, ifcTotoAndTime_DimID); message='iCreate[ifcToto]'; call netcdf_err(err,message); if (err/=0) return + + ! Leave define mode of NetCDF files + err = nf90_enddef(ncid); message='nf90_enddef'; call netcdf_err(err,message); if (err/=0) return + + end subroutine ini_create ! ********************************************************************************************************** ! private subroutine put_attrib: put global attributes as character string ! ********************************************************************************************************** - subroutine put_attrib(infile,attname,attvalue,err,message) - USE data_struc,only:var_info ! derived type for metadata + subroutine put_attrib(ncid,attname,attvalue,err,message) + USE data_types,only:var_info ! derived type for metaData implicit none ! declare dummy variables - character(*), intent(in) :: infile ! filename + integer(i4b), intent(in) :: ncid ! netcdf file ID character(*), intent(in) :: attname ! attribute name character(*), intent(in) :: attvalue ! attribute vaue integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message - ! local variables - integer(i4b) :: ncid ! NetCDF file ID ! initialize error control - err=0;message="f-defAttrib/"//trim(attname)//"/"//trim(attvalue)//"/" - ! open NetCDF file - err = nf90_open(infile,nf90_write,ncid) - call netcdf_err(err,message); if (err/=0) return + err=0;message="put_attrib/"//trim(attname)//"/"//trim(attvalue)//"/" ! allow re-definition of variables err = nf90_redef(ncid); call netcdf_err(err,message); if (err/=0) return ! put the attribute @@ -280,73 +229,183 @@ subroutine put_attrib(infile,attname,attvalue,err,message) call netcdf_err(err,message); if (err/=0) return ! close output file err = nf90_enddef(ncid); call netcdf_err(err,message); if (err/=0) return - err = nf90_close(ncid); call netcdf_err(err,message); if (err/=0) return end subroutine put_attrib - ! ********************************************************************************************************** ! private subroutine def_variab: define variables ! ********************************************************************************************************** - subroutine def_variab(infile,dimNames,metadata,ivtype,err,message) - USE data_struc,only:var_info ! derived type for metadata + subroutine def_variab(ncid,iFreq,hruDesire,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:maxVarStat ! # of available stats + 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 implicit none - ! declare dummy variables - character(*), intent(in) :: infile ! filename - character(*), intent(in) :: dimNames(:) ! dimension namess - type(var_info),intent(in) :: metadata ! metadata structure for a given variable - integer(i4b),intent(in) :: ivtype ! variable type - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! local variables - integer(i4b) :: id ! loop through dimensions - integer(i4b) :: dimIDs(size(dimNames)) - integer(i4b) :: ncid ! NetCDF file ID - integer(i4b) :: iVarId ! variable ID + ! input + integer(i4b) ,intent(in) :: ncid ! netcdf file id + integer(i4b) ,intent(in) :: iFreq ! frequency of current file + integer(i4b) ,intent(in) :: hruDesire ! variable to define if we desire the HRU dimension + integer(i4b) ,intent(in) :: timeDesire ! variable to define if we desire the time dimension + type(var_info),intent(inout) :: metaData(:) ! metaData structure for a given variable + integer(i4b) ,intent(in) :: ivtype ! variable type + ! output + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! local + integer(i4b) :: iVar ! variable index + integer(i4b) :: iStat ! stat index + integer(i4b),allocatable :: dimensionIDs(:) ! vector of dimension IDs + integer(i4b) :: iVarId ! variable ID +! integer :: index ! intrinsic function to find substring index + integer(i4b) :: timePosition ! extrinsic variable to hold substring index + character(LEN=256) :: cmessage ! error message of downwind routine + character(LEN=256) :: catName ! full variable name ! initialize error control - err=0;message="f-defVariab/"//trim(metadata%varname)//"/" + err=0; message='def_variab/' - ! open NetCDF file - err = nf90_open(infile,nf90_write,ncid) - call netcdf_err(err,message); if (err/=0) return ! allow re-definition of variables err = nf90_redef(ncid); call netcdf_err(err,message); if (err/=0) return - ! define dimension IDs - do id=1,size(dimNames) - err=nf90_inq_dimid(ncid,trim(dimNames(id)),dimIDs(id)); call netcdf_err(err,message); if (err/=0) return - end do + ! loop through metaData + do iVar = 1,size(metaData) - ! define variable - err = nf90_def_var(ncid,trim(metadata%varname),ivtype,dimIds,iVarId) - call netcdf_err(err,message); if (err/=0) return - ! add parameter description - err = nf90_put_att(ncid,iVarId,'long_name',trim(metadata%vardesc)) - call netcdf_err(err,message); if (err/=0) return - ! add parameter units - err = nf90_put_att(ncid,iVarId,'units',trim(metadata%varunit)) - call netcdf_err(err,message); if (err/=0) return + ! check that the variable is desired + if (metaData(iVar)%varType==iLookvarType%unknown) cycle + if ((iFreq.ne.metaData(iVar)%outFreq).and.(metaData(iVar)%varName.ne.'time')) cycle + + ! special case of the time variable + if(metaData(iVar)%varName == 'time')then + call cloneStruc(dimensionIDs, lowerBound=1, source=(/Timestep_DimID/),err=err,message=cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage)//' [variable '//trim(metaData(iVar)%varName)//']'; return; end if + + ! standard case + else + select case(metaData(iVar)%varType) + ! (scalar variable -- many different types) + case(iLookvarType%scalarv) + if(hruDesire==needHRU .and. timeDesire==needTime) call cloneStruc(dimensionIDs, lowerBound=1, source=(/ hru_DimID,Timestep_DimID/), err=err, message=cmessage) + if(hruDesire==needHRU .and. timeDesire== noTime) call cloneStruc(dimensionIDs, lowerBound=1, source=(/ hru_DimID/) , err=err, message=cmessage) + if(hruDesire== noHRU .and. timeDesire==needTime) call cloneStruc(dimensionIDs, lowerBound=1, source=(/Timestep_DimID/) , err=err, message=cmessage) + if(hruDesire== noHRU .and. timeDesire== noTime) call cloneStruc(dimensionIDs, lowerBound=1, source=(/ scalar_DimID/) , err=err, message=cmessage) + ! (other variables) + case(iLookvarType%wLength); call cloneStruc(dimensionIDs, lowerBound=1, source=(/hru_DimID, wLength_DimID, Timestep_DimID/), err=err, message=cmessage) + case(iLookvarType%midSnow); call cloneStruc(dimensionIDs, lowerBound=1, source=(/hru_DimID, midSnowAndTime_DimID /), err=err, message=cmessage) + case(iLookvarType%midSoil); call cloneStruc(dimensionIDs, lowerBound=1, source=(/hru_DimID, midSoilAndTime_DimID /), err=err, message=cmessage) + case(iLookvarType%midToto); call cloneStruc(dimensionIDs, lowerBound=1, source=(/hru_DimID, midTotoAndTime_DimID /), err=err, message=cmessage) + case(iLookvarType%ifcSnow); call cloneStruc(dimensionIDs, lowerBound=1, source=(/hru_DimID, ifcSnowAndTime_DimID /), err=err, message=cmessage) + case(iLookvarType%ifcSoil); call cloneStruc(dimensionIDs, lowerBound=1, source=(/hru_DimID, ifcSoilAndTime_DimID /), err=err, message=cmessage) + case(iLookvarType%ifcToto); call cloneStruc(dimensionIDs, lowerBound=1, source=(/hru_DimID, ifcTotoAndTime_DimID /), err=err, message=cmessage) + case(iLookvarType%parSoil); call cloneStruc(dimensionIDs, lowerBound=1, source=(/hru_DimID, depth_DimID /), err=err, message=cmessage) + case(iLookvarType%routing); call cloneStruc(dimensionIDs, lowerBound=1, source=(/routing_DimID /), err=err, message=cmessage) + end select + ! check errors + if(err/=0)then + message=trim(message)//trim(cmessage)//' [variable '//trim(metaData(iVar)%varName)//']' + return + end if + end if ! check if we are processing the time variable + + ! check that we got the shape + if(.not.allocated(dimensionIDs))then + message=trim(message)//'problem defining dimensions for variable '//trim(metaData(iVar)%varName) + err=20; return + end if + + ! loop through statistics + do iStat = 1,maxvarStat + + ! if requested + if ((.not.metaData(iVar)%statFlag(iStat)).and.(metaData(iVar)%varName.ne.'time')) cycle + if ((metaData(iVar)%varName=='time').and.(iStat.ne.iLookStat%inst)) cycle + + ! create full variable name + catName = trim(metaData(iVar)%varName) + if (iStat.ne.iLookStat%inst) catName = trim(metaData(iVar)%varName)//'_'//trim(get_statName(iStat)) + + ! define variable + err = nf90_def_var(ncid,trim(catName),ivtype,dimensionIDs,iVarId) + call netcdf_err(err,message); if (err/=0) return + + ! add parameter description + catName = trim(metaData(iVar)%vardesc)//' ('//trim(get_statName(iStat)) + catName = trim(catName)//')' + err = nf90_put_att(ncid,iVarId,'long_name',trim(catName)) + call netcdf_err(err,message); if (err/=0) return + + ! add parameter units + catName = trim(metaData(iVar)%varunit) + if (iStat==iLookStat%totl) then + ! make sure that the units of this varaible allow for integration + if ((index(catName,'s-1')<=0).and.(index(catName,'s-2')<=0).and.(index(catName,'W m-2')<=0)) then + err=20 + message=trim(message)//'trying to integrate a non-time variable: '//trim(metaData(iVar)%varName)//' - units: '//trim(catName) + return + endif + ! change to integrated units + if (index(catName,'s-1')>0) then + timePosition = index(catName,'s-1') + catName(timePosition:(timePosition+3)) = ' ' + elseif (index(catName,'s-2')>0) then + timePosition = index(catName,'s-2') + catName(timePosition:(timePosition+3)) = 's-1' + elseif (index(catName,'W m-2')>0) then + timePosition = index(catName,'W') + catName(timePosition:(timePosition+1)) = 'J' + end if + end if + err = nf90_put_att(ncid,iVarId,'units',trim(catName)) + call netcdf_err(err,message); if (err/=0) return + + ! add file info to metadata structure + metaData(iVar)%ncVarID(iStat) = iVarID + + end do ! looping through statistics + end do ! looping through variables + ! close output file err = nf90_enddef(ncid); call netcdf_err(err,message); if (err/=0) return - err = nf90_close(ncid); call netcdf_err(err,message); if (err/=0) return - end subroutine def_variab + end subroutine def_variab ! ********************************************************************************************************** - ! private subroutine netcdf_err: error control + ! internal subroutine write_hru_dim: write HRU dimension ! ********************************************************************************************************** - subroutine netcdf_err(err,message) - ! used to handle errors for NetCDF calls - implicit none - ! declare dummies - integer(i4b), intent(inout) :: err - character(*), intent(inout) :: message - ! start procedure here - if (err/=nf90_noerr) then - message=trim(message)//"["//trim(nf90_strerror(err))//"]" - err=200 - endif - end subroutine netcdf_err - - + subroutine write_hru_dim(ncid, err, message) + use globalData,only:gru_struc ! gru-hru mapping structures + ! input + integer(i4b) ,intent(in) :: ncid ! netcdf file id + ! output + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! define local variables + integer(i4b) :: iHRU ! local HRU index + integer(i4b) :: iGRU ! GRU index + integer(i4b) :: hruVarID ! HRU varID in netcdf + + ! initialize error control + err=0; message='write_hru_dim/' + + ! allow re-definition of variables + 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_int, hru_DimID, hruVarID); 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', 'hru index 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 + + ! Leave define mode of NetCDF files + err = nf90_enddef(ncid); message=trim(message)//'nf90_enddef'; call netcdf_err(err,message); if (err/=nf90_NoErr) return + + ! write the HRU dimension to record position in the input netcdf file for concatenation of outputs of a parallelized run. + do iGRU = 1, size(gru_struc) + do iHRU = 1, gru_struc(iGRU)%hruCount + 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 + end do + end do + + end subroutine + end module def_output_module diff --git a/build/source/netcdf/modelwrite.f90 b/build/source/netcdf/modelwrite.f90 old mode 100644 new mode 100755 index 40b2d623d..da2f01ff0 --- a/build/source/netcdf/modelwrite.f90 +++ b/build/source/netcdf/modelwrite.f90 @@ -19,368 +19,568 @@ ! along with this program. If not, see . module modelwrite_module -USE nrtype USE netcdf +USE netcdf_util_module,only:netcdf_err ! netcdf error handling function +USE nrtype, integerMissing=>nr_integerMissing ! top-level data types implicit none private -public::writeForce -public::writeAttrb -public::writeParam -public::writeModel +public::writeParm +public::writeData public::writeBasin +public::writeTime +public::writeRestart ! define dimension lengths integer(i4b),parameter :: maxSpectral=2 ! maximum number of spectral bands contains - ! ********************************************************************************************************** - ! public subroutine writeAttrb: write local attributes + ! public subroutine writeParm: write model parameters ! ********************************************************************************************************** - subroutine writeAttrb(fileout,iHRU,err,message) - USE data_struc,only:attr_data,attr_meta ! local attributes - USE data_struc,only:type_data,type_meta ! local classification of veg, soil, etc. + subroutine writeParm(iHRU,struct,meta,err,message) + USE globalData,only:ncid ! netcdf file ids + USE globalData,only:integerMissing ! missing value + USE data_types,only:var_info ! metadata info + USE data_types,only:var_i,var_d,var_dlength ! derived data types + USE var_lookup,only:iLookStat ! to index into write flag implicit none - ! declare dummy variables - character(*), intent(in) :: fileout ! output file - integer(i4b), intent(in) :: iHRU ! hydrologic response unit - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + + ! declare input variables + integer(i4b) ,intent(in) :: iHRU ! hydrologic response unit + class(*) ,intent(in) :: struct ! data structure + type(var_info),intent(in) :: meta(:) ! metadata structure + integer(i4b) ,intent(out) :: err ! error code + character(*) ,intent(out) :: message ! error message ! local variables - integer(i4b) :: ncid ! NetCDF file ID - integer(i4b) :: iVar ! loop through variables - integer(i4b) :: iVarId ! variable ID + integer(i4b) :: iVar ! loop through variables + integer(i4b) ,parameter :: modelTime=1 ! these particular data are only output in the timestep file + ! initialize error control - err=0;message="f-writeAttrb/" + err=0;message="f-writeParm/" - ! open NetCDF file - err = nf90_open(trim(fileout),nf90_write,ncid) - call netcdf_err(err,message); if (err/=0) return + ! loop through local column model parameters + do iVar = 1,size(meta) - ! loop through local attributes - do iVar=1,size(attr_meta) ! check that the variable is desired - if (.not.attr_meta(iVar)%v_write) cycle - ! initialize message - message=trim(message)//trim(attr_meta(iVar)%varname)//'/' - ! get variable ID - err = nf90_inq_varid(ncid,trim(attr_meta(iVar)%varname),iVarId) - call netcdf_err(err,message); if (err/=0) return - ! write data - err = nf90_put_var(ncid,iVarId,(/attr_data%var(iVar)/),start=(/iHRU/),count=(/1/)) - call netcdf_err(err,message); if (err/=0) return - ! re-initialize message - message="f-writeAttrb/" - end do ! looping through local attributes + if (.not.meta(iVar)%statFlag(iLookStat%inst)) cycle - ! loop through local classification of veg, soil, etc. - do iVar=1,size(type_meta) - ! check that the variable is desired - if (.not.type_meta(iVar)%v_write) cycle ! initialize message - message=trim(message)//trim(type_meta(iVar)%varname)//'/' - ! get variable ID - err = nf90_inq_varid(ncid,trim(type_meta(iVar)%varname),iVarId) - call netcdf_err(err,message); if (err/=0) return + message=trim(message)//trim(meta(iVar)%varName)//'/' + ! write data - err = nf90_put_var(ncid,iVarId,(/type_data%var(iVar)/),start=(/iHRU/),count=(/1/)) + if (iHRU.ne.integerMissing) then + select type (struct) + type is (var_i) + err = nf90_put_var(ncid(modelTime),meta(iVar)%ncVarID(iLookStat%inst),(/struct%var(iVar)/),start=(/iHRU/),count=(/1/)) + type is (var_d) + err = nf90_put_var(ncid(modelTime),meta(iVar)%ncVarID(iLookStat%inst),(/struct%var(iVar)/),start=(/iHRU/),count=(/1/)) + type is (var_dlength) + err = nf90_put_var(ncid(modelTime),meta(iVar)%ncVarID(iLookStat%inst),(/struct%var(iVar)%dat/),start=(/iHRU,1/),count=(/1,size(struct%var(iVar)%dat)/)) + class default; err=20; message=trim(message)//'unkonwn variable type (with HRU)'; return + end select + else + select type (struct) + type is (var_d) + err = nf90_put_var(ncid(modelTime),meta(iVar)%ncVarID(iLookStat%inst),(/struct%var(iVar)/),start=(/1/),count=(/1/)) + class default; err=20; message=trim(message)//'unkonwn variable type (no HRU)'; return + end select + end if call netcdf_err(err,message); if (err/=0) return + ! re-initialize message - message="f-writeAttrb/" - end do ! looping through local classification of veg, soil, etc. + message="f-writeParm/" + end do ! looping through local column model parameters - ! close output file - err = nf90_close(ncid); call netcdf_err(err,message); if (err/=0) return - end subroutine writeAttrb + end subroutine writeParm + + ! ************************************************************************************** + ! public subroutine writeData: write model time-dependent data + ! ************************************************************************************** + subroutine writeData(modelTimestep,outputTimestep,meta,stat,dat,map,indx,iHRU,err,message) + USE data_types,only:var_info,dlength,ilength ! type structures for passing + 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 globalData,only:outFreq,nFreq,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 + implicit none + ! declare dummy variables + type(var_info),intent(in) :: meta(:) ! meta data + class(*) ,intent(in) :: stat(:) ! stats data + class(*) ,intent(in) :: dat(:) ! timestep data + type(ilength) ,intent(in) :: indx(:) ! index data + integer(i4b) ,intent(in) :: map(:) ! map into stats child struct + integer(i4b) ,intent(in) :: iHRU ! hydrologic response unit + integer(i4b) ,intent(in) :: modelTimestep ! model time step + integer(i4b) ,intent(in) :: outputTimestep(:) ! output time step + integer(i4b) ,intent(out) :: err ! error code + character(*) ,intent(out) :: message ! error message + ! local variables + integer(i4b) :: iVar ! variable index + integer(i4b) :: iStat ! statistics index + integer(i4b) :: iFreq ! frequency index + integer(i4b) :: ncVarID ! used only for time + integer(i4b) :: nSnow ! number of snow layers + integer(i4b) :: nSoil ! number of soil layers + integer(i4b) :: nLayers ! total number of layers + integer(i4b) :: midSnowStartIndex ! start index of the midSnow vector for a given timestep + integer(i4b) :: midSoilStartIndex ! start index of the midSoil vector for a given timestep + integer(i4b) :: midTotoStartIndex ! start index of the midToto vector for a given timestep + integer(i4b) :: ifcSnowStartIndex ! start index of the ifcSnow vector for a given timestep + integer(i4b) :: ifcSoilStartIndex ! start index of the ifcSoil vector for a given timestep + integer(i4b) :: ifcTotoStartIndex ! start index of the ifcToto vector for a given timestep - ! ********************************************************************************************************** - ! public subroutine writeParam: write model parameters - ! ********************************************************************************************************** - subroutine writeParam(fileout,iHRU,err,message) - USE data_struc,only:mpar_data,mpar_meta ! local-column model parameter structures - USE data_struc,only:bpar_data,bpar_meta ! basin-average model parameter structures + ! initialize error control + err=0;message="writeData/" + + ! model layers + nSoil = indx(iLookIndex%nSoil)%dat(1) + nSnow = indx(iLookIndex%nSnow)%dat(1) + nLayers = indx(iLookIndex%nLayers)%dat(1) + ! model indices + midSnowStartIndex = indx(iLookIndex%midSnowStartIndex)%dat(1) + midSoilStartIndex = indx(iLookIndex%midSoilStartIndex)%dat(1) + midTotoStartIndex = indx(iLookIndex%midTotoStartIndex)%dat(1) + ifcSnowStartIndex = indx(iLookIndex%ifcSnowStartIndex)%dat(1) + ifcSoilStartIndex = indx(iLookIndex%ifcSoilStartIndex)%dat(1) + ifcTotoStartIndex = indx(iLookIndex%ifcTotoStartIndex)%dat(1) + + ! loop through output frequencies + do iFreq = 1,nFreq + + ! check that the timestep is desired + if (mod(modelTimestep,outFreq(iFreq)).ne.0) cycle + + ! loop through model variables + do iVar = 1,size(meta) + + ! handle time first + if (meta(iVar)%varName=='time') then + select type(stat) + type is (dlength) + err = nf90_inq_varid(ncid(iFreq),trim(meta(iVar)%varName),ncVarID) + call netcdf_err(err,message); if (err/=0) return + err = nf90_put_var(ncid(iFreq),ncVarID,(/stat(iVar)%dat(iLookStat%inst)/),start=(/outputTimestep(iFreq)/),count=(/1,1/)) + call netcdf_err(err,message); if (err/=0) return + cycle + class default; err=20; message=trim(message)//'time variable must be of type dlength'; return; + end select + end if + + ! check that the variable is desired + if (meta(iVar)%outFreq.ne.iFreq) cycle + + ! loop through output stats + do iStat = 1,maxVarStat + + ! check that the variable is desired + if ((.not.meta(iVar)%statFlag(iStat)).or.(trim(meta(iVar)%varName)=='unknown')) cycle + + ! stats/data output - select data type + if (meta(iVar)%varType==iLookVarType%scalarv) then + select type(stat) + type is (ilength) + err = nf90_put_var(ncid(iFreq),meta(iVar)%ncVarID(iStat),(/stat(map(iVar))%dat(iStat)/),start=(/iHRU,outputTimestep(iFreq)/),count=(/1,1/)) + type is (dlength) + err = nf90_put_var(ncid(iFreq),meta(iVar)%ncVarID(iStat),(/stat(map(iVar))%dat(iStat)/),start=(/iHRU,outputTimestep(iFreq)/),count=(/1,1/)) + class default; err=20; message=trim(message)//'stats must be scalarv and either ilength of dlength'; return + end select ! stat + + ! non-scalar variables + else + select type (dat) + type is (dlength) + select case (meta(iVar)%varType) + case(iLookVarType%wLength); err = nf90_put_var(ncid(iFreq),meta(iVar)%ncVarID(iStat),(/dat(iVar)%dat/),start=(/iHRU,1,outputTimestep(iFreq)/),count=(/1,maxSpectral,1/)) + case(iLookVarType%midToto); err = nf90_put_var(ncid(iFreq),meta(iVar)%ncVarID(iStat),(/dat(iVar)%dat/),start=(/iHRU,midTotoStartIndex/),count=(/1,nLayers/)) + case(iLookVarType%midSnow); err = nf90_put_var(ncid(iFreq),meta(iVar)%ncVarID(iStat),(/dat(iVar)%dat/),start=(/iHRU,midSnowStartIndex/),count=(/1,nSnow/)) + case(iLookVarType%midSoil); err = nf90_put_var(ncid(iFreq),meta(iVar)%ncVarID(iStat),(/dat(iVar)%dat/),start=(/iHRU,midSoilStartIndex/),count=(/1,nSoil/)) + case(iLookVarType%ifcToto); err = nf90_put_var(ncid(iFreq),meta(iVar)%ncVarID(iStat),(/dat(iVar)%dat/),start=(/iHRU,ifcTotoStartIndex/),count=(/1,nLayers+1/)) + case(iLookVarType%ifcSnow); err = nf90_put_var(ncid(iFreq),meta(iVar)%ncVarID(iStat),(/dat(iVar)%dat/),start=(/iHRU,ifcSnowStartIndex/),count=(/1,nSnow+1/)) + case(iLookVarType%ifcSoil); err = nf90_put_var(ncid(iFreq),meta(iVar)%ncVarID(iStat),(/dat(iVar)%dat/),start=(/iHRU,ifcSoilStartIndex/),count=(/1,nSoil+1/)) + end select ! vartype + type is (ilength) + select case (meta(iVar)%varType) + case(iLookVarType%wLength); err = nf90_put_var(ncid(iFreq),meta(iVar)%ncVarID(iStat),(/dat(iVar)%dat/),start=(/iHRU,1,outputTimestep(iFreq)/),count=(/1,maxSpectral,1/)) + case(iLookVarType%midToto); err = nf90_put_var(ncid(iFreq),meta(iVar)%ncVarID(iStat),(/dat(iVar)%dat/),start=(/iHRU,midTotoStartIndex/),count=(/1,nLayers/)) + case(iLookVarType%midSnow); err = nf90_put_var(ncid(iFreq),meta(iVar)%ncVarID(iStat),(/dat(iVar)%dat/),start=(/iHRU,midSnowStartIndex/),count=(/1,nSnow/)) + case(iLookVarType%midSoil); err = nf90_put_var(ncid(iFreq),meta(iVar)%ncVarID(iStat),(/dat(iVar)%dat/),start=(/iHRU,midSoilStartIndex/),count=(/1,nSoil/)) + case(iLookVarType%ifcToto); err = nf90_put_var(ncid(iFreq),meta(iVar)%ncVarID(iStat),(/dat(iVar)%dat/),start=(/iHRU,ifcTotoStartIndex/),count=(/1,nLayers+1/)) + case(iLookVarType%ifcSnow); err = nf90_put_var(ncid(iFreq),meta(iVar)%ncVarID(iStat),(/dat(iVar)%dat/),start=(/iHRU,ifcSnowStartIndex/),count=(/1,nSnow+1/)) + case(iLookVarType%ifcSoil); err = nf90_put_var(ncid(iFreq),meta(iVar)%ncVarID(iStat),(/dat(iVar)%dat/),start=(/iHRU,ifcSoilStartIndex/),count=(/1,nSoil+1/)) + end select ! vartype + end select ! dat + end if ! sacalarv + + ! process error code + if (err.ne.0) message=trim(message)//trim(meta(iVar)%varName)//'_'//trim(get_statName(iStat)) + call netcdf_err(err,message); if (err/=0) return + + end do ! iStat + end do ! iVar + end do ! iFreq + + end subroutine writeData + + ! ************************************************************************************** + ! public subroutine writeBasin: write basin-average variables + ! ************************************************************************************** + subroutine writeBasin(modelTimestep,outputTimestep,meta,stat,dat,map,err,message) + USE data_types,only:var_info,dlength,ilength ! type structures for passing + USE var_lookup,only:maxVarStat ! index into stats structure + USE var_lookup,only:iLookVarType ! index into type structure + USE globalData,only:outFreq,nFreq,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 implicit none + ! declare dummy variables - character(*), intent(in) :: fileout ! output file - integer(i4b), intent(in) :: iHRU ! hydrologic response unit - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + type(var_info),intent(in) :: meta(:) ! meta data + type(dlength) ,intent(in) :: stat(:) ! stats data + type(dlength) ,intent(in) :: dat(:) ! timestep data + integer(i4b) ,intent(in) :: map(:) ! map into stats child struct + integer(i4b) ,intent(in) :: modelTimestep ! model time step + integer(i4b) ,intent(in) :: outputTimestep(:) ! output time step + integer(i4b) ,intent(out) :: err ! error code + character(*) ,intent(out) :: message ! error message ! local variables - integer(i4b) :: ncid ! NetCDF file ID - integer(i4b) :: ipar ! loop through model parameters - integer(i4b) :: iVarId ! variable ID + integer(i4b) :: iVar ! variable index + integer(i4b) :: iStat ! statistics index + integer(i4b) :: iFreq ! frequency index ! initialize error control - err=0;message="f-writeParam/" + err=0;message="f-writeBasin/" - ! open NetCDF file - err = nf90_open(trim(fileout),nf90_write,ncid) - call netcdf_err(err,message); if (err/=0) return + do iFreq = 1,nFreq + ! check that the timestep is desired + if (mod(modelTimestep,outFreq(iFreq)).ne.0) cycle - ! loop through local column model parameters - do ipar=1,size(mpar_meta) - ! check that the variable is desired - if (.not.mpar_meta(ipar)%v_write) cycle - ! initialize message - message=trim(message)//trim(mpar_meta(ipar)%varname)//'/' - ! get variable ID - err = nf90_inq_varid(ncid,trim(mpar_meta(ipar)%varname),iVarId) - call netcdf_err(err,message); if (err/=0) return - ! write data - err = nf90_put_var(ncid,iVarId,(/mpar_data%var(ipar)/),start=(/iHRU/),count=(/1/)) - call netcdf_err(err,message); if (err/=0) return - ! re-initialize message - message="f-writeParam/" - end do ! looping through local column model parameters + ! loop through model variables + do iVar = 1,size(meta) - ! loop through basin-average model parameters - do ipar=1,size(bpar_meta) - ! check that the variable is desired - if (.not.bpar_meta(ipar)%v_write) cycle - ! initialize message - message=trim(message)//trim(bpar_meta(ipar)%varname)//'/' - ! get variable ID - err = nf90_inq_varid(ncid,trim(bpar_meta(ipar)%varname),iVarId) - call netcdf_err(err,message); if (err/=0) return - ! write data - err = nf90_put_var(ncid,iVarId,(/bpar_data%var(ipar)/),start=(/1/),count=(/1/)) - call netcdf_err(err,message); if (err/=0) return - ! re-initialize message - message="f-writeParam/" - end do ! looping through basin-average model parameters + ! check that the variable is desired + if (meta(iVar)%outFreq.ne.iFreq) cycle - ! close output file - err = nf90_close(ncid); call netcdf_err(err,message); if (err/=0) return - end subroutine writeParam + ! loop through output stats + do iStat = 1,maxVarStat + ! check that the variable is desired + if ((.not.meta(iVar)%statFlag(iStat)).or.(trim(meta(iVar)%varName)=='unknown')) cycle + ! stats/dats output - select data type + select case (meta(iVar)%varType) - ! ********************************************************************************************************** - ! public subroutine writeParam: write model forcing data - ! ********************************************************************************************************** - subroutine writeForce(fileout,iHRU,istep,err,message) - USE data_struc,only:forc_data,forc_meta ! forcing data structures - USE var_lookup,only:iLookFORCE ! identifies element of the forcing structure - implicit none - ! declare dummy variables - character(*), intent(in) :: fileout ! output file - integer(i4b), intent(in) :: iHRU ! hydrologic response unit - integer(i4b), intent(in) :: istep ! model time step - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! pointers to time variables - real(dp),pointer :: dtime ! time since reference time (seconds) - ! local variables - integer(i4b) :: ncid ! NetCDF file ID - integer(i4b) :: iforce ! loop through model forcing variables - integer(i4b) :: iVarId ! variable ID - ! initialize error control - err=0;message="f-writeForce/" + case (iLookVarType%scalarv) + err = nf90_put_var(ncid(iFreq),meta(iVar)%ncVarID(iStat),(/stat(map(iVar))%dat(iStat)/),start=(/outputTimestep(iFreq)/),count=(/1/)) - ! assign pointers - dtime => forc_data%var(iLookFORCE%time) + case (iLookVarType%routing) + if (modelTimestep==1) then + err = nf90_put_var(ncid(iFreq),meta(iVar)%ncVarID(iStat),(/dat(iVar)%dat/),start=(/1/),count=(/1000/)) + end if - ! open NetCDF file - err = nf90_open(trim(fileout),nf90_write,ncid) - call netcdf_err(err,message); if (err/=0) return + case default + err=40; message=trim(message)//"unknownVariableType[name='"//trim(meta(iVar)%varName)//"';type='"//trim(get_varTypeName(meta(iVar)%varType))// "']"; return + end select ! variable type - ! write the time coordinate variable - if(iHRU == 1)then - message=trim(message)//'writeTime/' - !print*, 'iHRU, istep, dtime = ', iHRU, istep, dtime - err = nf90_inq_varid(ncid,'time',iVarId); call netcdf_err(err,message); if (err/=0) return - err = nf90_put_var(ncid,iVarId,(/dtime/),start=(/istep/),count=(/1/)) - call netcdf_err(err,message); if (err/=0) return - message="f-writeForce/" - endif + ! process error code + if (err.ne.0) message=trim(message)//trim(meta(iVar)%varName)//'_'//trim(get_statName (iStat)) + call netcdf_err(err,message); if (err/=0) return - ! loop through model forcing variables - do iforce=1,size(forc_meta) - ! ignore the time variable (used as a coordinate variable above) - if(forc_meta(iforce)%varname == 'time') cycle - ! check that the variable is desired - if (.not.forc_meta(iforce)%v_write) cycle - ! initialize message - message=trim(message)//trim(forc_meta(iforce)%varname)//'/' - ! get variable ID - err = nf90_inq_varid(ncid,trim(forc_meta(iforce)%varname),iVarId) - call netcdf_err(err,message); if (err/=0) return - ! write data - err = nf90_put_var(ncid,iVarId,(/forc_data%var(iforce)/),start=(/iHRU,istep/),count=(/1,1/)) - call netcdf_err(err,message); if (err/=0) return - end do ! looping through forcing data variables + end do ! iStat + end do ! iVar + end do ! iFreq - ! close output file - message="f-writeForce/" - err = nf90_close(ncid); call netcdf_err(err,message); if (err/=0) return - end subroutine writeForce + end subroutine writeBasin - ! ********************************************************************************************************** - ! public subroutine writeModel: write local column model variables - ! ********************************************************************************************************** - subroutine writeModel(fileout,iHRU,istep,err,message) - USE data_struc,only:indx_data,indx_meta ! index data structures - USE data_struc,only:mvar_data,mvar_meta ! model data structures - USE var_lookup,only:iLookINDEX ! identifies element of the index structure + ! ************************************************************************************** + ! public subroutine writeTime: write current time to all files + ! ************************************************************************************** + subroutine writeTime(modelTimestep,outputTimestep,meta,dat,err,message) + USE data_types,only:var_info,dlength,ilength ! type structures for passing + USE globalData,only:outFreq,nFreq,ncid ! output file information + USE var_lookup,only:iLookStat ! index into stat structure implicit none + ! declare dummy variables - character(*), intent(in) :: fileout ! output file - integer(i4b), intent(in) :: iHRU ! hydrologic response unit - integer(i4b), intent(in) :: istep ! model time step - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! declare pointers to the model index variables (used to identify the appropriate write position) - integer(i4b),pointer :: nSnow ! number of snow layers - integer(i4b),pointer :: nSoil ! number of soil layers - integer(i4b),pointer :: nLayers ! total number of layers - integer(i4b),pointer :: midSnowStartIndex ! start index of the midSnow vector for a given timestep - integer(i4b),pointer :: midSoilStartIndex ! start index of the midSoil vector for a given timestep - integer(i4b),pointer :: midTotoStartIndex ! start index of the midToto vector for a given timestep - integer(i4b),pointer :: ifcSnowStartIndex ! start index of the ifcSnow vector for a given timestep - integer(i4b),pointer :: ifcSoilStartIndex ! start index of the ifcSoil vector for a given timestep - integer(i4b),pointer :: ifcTotoStartIndex ! start index of the ifcToto vector for a given timestep + type(var_info),intent(in) :: meta(:) ! meta data + integer ,intent(in) :: dat(:) ! timestep data + integer(i4b) ,intent(in) :: modelTimestep ! model time step + integer(i4b) ,intent(in) :: outputTimestep(:) ! output time step + integer(i4b) ,intent(out) :: err ! error code + character(*) ,intent(out) :: message ! error message ! local variables - integer(i4b) :: ncid ! NetCDF file ID - integer(i4b) :: iindex ! loop through model index variables - integer(i4b) :: imodel ! loop through model variables - integer(i4b) :: iVarId ! variable ID + integer(i4b) :: iVar ! variable index + integer(i4b) :: iFreq ! frequency index + integer(i4b) :: ncVarID ! used only for time ! initialize error control - err=0;message="f-writeModel/" - - ! assign pointers to model layers - nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1) - nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) - nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1) - - ! assign pointers to model indices - midSnowStartIndex => indx_data%var(iLookINDEX%midSnowStartIndex)%dat(1) - midSoilStartIndex => indx_data%var(iLookINDEX%midSoilStartIndex)%dat(1) - midTotoStartIndex => indx_data%var(iLookINDEX%midTotoStartIndex)%dat(1) - ifcSnowStartIndex => indx_data%var(iLookINDEX%ifcSnowStartIndex)%dat(1) - ifcSoilStartIndex => indx_data%var(iLookINDEX%ifcSoilStartIndex)%dat(1) - ifcTotoStartIndex => indx_data%var(iLookINDEX%ifcTotoStartIndex)%dat(1) - - ! open NetCDF file - err = nf90_open(trim(fileout),nf90_write,ncid) - call netcdf_err(err,message); if (err/=0) return - - ! loop through model index variables - ! ---------------------------------- - do iindex=1,size(indx_meta) - ! check that the variable is desired - if (.not.indx_meta(iindex)%v_write) cycle - ! initialize message - message=trim(message)//trim(indx_meta(iindex)%varname)//'/' - ! get variable ID - err = nf90_inq_varid(ncid,trim(indx_meta(iindex)%varname),iVarId) - call netcdf_err(err,message); if (err/=0) return - ! write data - err = nf90_put_var(ncid,iVarId,indx_data%var(iindex)%dat,start=(/iHRU,istep/),count=(/1,1/)) - call netcdf_err(err,message); if (err/=0) return - message="f-writeModel/" - end do - - ! loop through model variables - ! ---------------------------- - do imodel=1,size(mvar_meta) - ! check that the variable is desired - if (.not.mvar_meta(imodel)%v_write) cycle - ! initialize message - message=trim(message)//trim(mvar_meta(imodel)%varname)//'/' - ! get variable ID - err = nf90_inq_varid(ncid,trim(mvar_meta(imodel)%varname),iVarId) - call netcdf_err(err,message); if (err/=0) return - ! write data - select case(trim(mvar_meta(imodel)%vartype)) - case('scalarv'); err = nf90_put_var(ncid,iVarId,mvar_data%var(imodel)%dat,start=(/iHRU,istep/),count=(/1,1/)) - case('wLength'); err = nf90_put_var(ncid,iVarId,mvar_data%var(imodel)%dat,start=(/iHRU,1,istep/),count=(/1,maxSpectral,1/)) - case('midSnow'); err = nf90_put_var(ncid,iVarId,mvar_data%var(imodel)%dat,start=(/iHRU,midSnowStartIndex/),count=(/1,nSnow/)) - case('midSoil'); err = nf90_put_var(ncid,iVarId,mvar_data%var(imodel)%dat,start=(/iHRU,midSoilStartIndex/),count=(/1,nSoil/)) - case('midToto'); err = nf90_put_var(ncid,iVarId,mvar_data%var(imodel)%dat,start=(/iHRU,midTotoStartIndex/),count=(/1,nLayers/)) - case('ifcSnow'); err = nf90_put_var(ncid,iVarId,mvar_data%var(imodel)%dat,start=(/iHRU,ifcSnowStartIndex/),count=(/1,nSnow+1/)) - case('ifcSoil'); err = nf90_put_var(ncid,iVarId,mvar_data%var(imodel)%dat,start=(/iHRU,ifcSoilStartIndex/),count=(/1,nSoil+1/)) - case('ifcToto'); err = nf90_put_var(ncid,iVarId,mvar_data%var(imodel)%dat,start=(/iHRU,ifcTotoStartIndex/),count=(/1,nLayers+1/)) - case default - err=40; message=trim(message)//"unknownVariableType[name='"//trim(mvar_meta(imodel)%varname)//"'; & - &type='"//trim(mvar_meta(imodel)%vartype)//"']"; return - endselect - call netcdf_err(err,message); if (err/=0) return - message="f-writeModel/" - end do ! looping through model variables - - ! close output file - err = nf90_close(ncid); call netcdf_err(err,message); if (err/=0) return - end subroutine writeModel - - - ! ********************************************************************************************************** - ! public subroutine writeBasin: write basin-average variables - ! ********************************************************************************************************** - subroutine writeBasin(fileout,istep,err,message) - USE data_struc,only:bvar_data,bvar_meta ! model data structures - USE var_lookup,only:iLookINDEX ! identifies element of the index structure + err=0;message="f-writeTime/" + + do iFreq = 1,nFreq + ! check that the timestep is desired + if (mod(modelTimestep,outFreq(iFreq)).ne.0) cycle + + ! loop through model variables + do iVar = 1,size(meta) + + ! if variable is desired + if (.not.meta(iVar)%statFlag(iLookStat%inst)) cycle + + ! get variable id in file + err = nf90_inq_varid(ncid(iFreq),trim(meta(iVar)%varName),ncVarID) + if (err/=0) message=trim(message)//trim(meta(iVar)%varName) + call netcdf_err(err,message) + if (err/=0) then; err=20; return; end if + + ! add to file + err = nf90_put_var(ncid(iFreq),ncVarID,(/dat(iVar)/),start=(/outputTimestep(iFreq)/),count=(/1/)) + if (err/=0) message=trim(message)//trim(meta(iVar)%varName) + call netcdf_err(err,message) + if (err/=0) then; err=20; return; end if + + end do ! iVar + end do ! iFreq + + end subroutine writeTime + + ! ********************************************************************************************************* + ! public subroutine printRestartFile: print a re-start file + ! ********************************************************************************************************* + subroutine writeRestart(filename, & ! intent(in): name of restart file + nGRU, & ! intent(in): number of GRUs + nHRU, & ! intent(in): number of HRUs + prog_meta, & ! intent(in): prognostics metadata + prog_data, & ! intent(in): prognostics data + indx_meta, & ! intent(in): index metadata + indx_data, & ! intent(in): index data + err,message) ! intent(out): error control + ! -------------------------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------------------------- + ! access the derived types to define the data structures +! USE data_types,only:hru_d ! length of substep + USE data_types,only:gru_hru_doubleVec ! actual data + USE data_types,only:gru_hru_intVec ! actual data + USE data_types,only:var_info ! metadata + ! access named variables defining elements in the data structures + USE var_lookup,only:iLookINDEX ! named variables for structure elements + USE var_lookup,only:iLookVarType ! named variables for structure elements + ! constants + USE globalData,only:gru_struc ! gru-hru mapping structures + ! external routines + USE netcdf_util_module,only:nc_file_close ! close netcdf file + USE netcdf_util_module,only:nc_file_open ! open netcdf file implicit none - ! declare dummy variables - character(*), intent(in) :: fileout ! output file - integer(i4b), intent(in) :: istep ! model time step - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + ! -------------------------------------------------------------------------------------------------------- + ! input + character(len=256),intent(in) :: filename ! name of the restart file + integer(i4b),intent(in) :: nGRU ! number of GRUs + integer(i4b),intent(in) :: nHRU ! number of HRUs + type(var_info),intent(in) :: prog_meta(:) ! metadata + type(gru_hru_doubleVec),intent(in) :: prog_data ! prognostic vars + type(var_info),intent(in) :: indx_meta(:) ! metadata + type(gru_hru_intVec),intent(in) :: indx_data ! indexing vars + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! -------------------------------------------------------------------------------------------------------- ! local variables - integer(i4b) :: ncid ! NetCDF file ID - integer(i4b) :: imodel ! loop through model variables - integer(i4b) :: iVarId ! variable ID - ! initialize error control - err=0;message="f-writeModel/" - - ! open NetCDF file - err = nf90_open(trim(fileout),nf90_write,ncid) - call netcdf_err(err,message); if (err/=0) return + integer(i4b) :: ncid ! netcdf file id + 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 + integer(i4b) :: maxSoil ! maximum number of soil layers + integer(i4b) :: nLayers ! number of total layers + integer(i4b) :: maxLayers ! maximum number of total layers + integer(i4b),parameter :: nSpectral=2 ! number of spectal bands + integer(i4b),parameter :: nScalar=1 ! size of a scalar + + integer(i4b) :: hruDimID ! variable dimension ID + integer(i4b) :: scalDimID ! variable dimension ID + integer(i4b) :: specDimID ! variable dimension ID + integer(i4b) :: midSnowDimID ! variable dimension ID + integer(i4b) :: midSoilDimID ! variable dimension ID + integer(i4b) :: midTotoDimID ! variable dimension ID + 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 :: scalDimName ='scalarv' ! dimension name for scalar data + character(len=32),parameter :: specDimName ='spectral' ! dimension name for spectral bands + character(len=32),parameter :: midSnowDimName='midSnow' ! dimension name for snow-only layers + 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 :: 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 varaiables + + integer(i4b) :: cHRU ! count of HRUs + integer(i4b) :: iHRU ! index of HRUs + integer(i4b) :: iGRU ! index of GRUs + integer(i4b) :: iVar ! variable index + logical(lgt) :: okLength ! flag to check if the vector length is OK + character(len=256) :: cmessage ! downstream error message + ! -------------------------------------------------------------------------------------------------------- - ! loop through model variables - ! ---------------------------- - do imodel=1,size(bvar_meta) - ! check that the variable is desired - if (.not.bvar_meta(imodel)%v_write) cycle - ! initialize message - message=trim(message)//trim(bvar_meta(imodel)%varname)//'/' - ! get variable ID - err = nf90_inq_varid(ncid,trim(bvar_meta(imodel)%varname),iVarId) - call netcdf_err(err,message); if (err/=0) return - ! write data - select case(trim(bvar_meta(imodel)%vartype)) - case('scalarv'); err = nf90_put_var(ncid,iVarId,bvar_data%var(imodel)%dat,start=(/istep/),count=(/1/)) - case('routing') - if(istep==1)then - err = nf90_put_var(ncid,iVarId,bvar_data%var(imodel)%dat,start=(/1/),count=(/1000/)) - endif - case default - err=40; message=trim(message)//"unknownVariableType[name='"//trim(bvar_meta(imodel)%varname)//"'; & - &type='"//trim(bvar_meta(imodel)%vartype)//"']"; return - endselect - call netcdf_err(err,message); if (err/=0) return - message="f-writeBasin/" - end do ! looping through model variables + ! initialize error control + err=0; message='writeRestart/' - ! close output file - err = nf90_close(ncid); call netcdf_err(err,message); if (err/=0) return - end subroutine writeBasin + ! size of prog vector + allocate(ncVarID(size(prog_meta))) + ! maximum number of soil layers + maxSoil = 0 + do iGRU = 1,nGRU + do iHRU = 1,gru_struc(iGRU)%hruCount + maxSoil = max(maxSoil,gru_struc(iGRU)%hruInfo(iHRU)%nSoil) + end do + end do - ! ********************************************************************************************************** - ! private subroutine netcdf_err: error control - ! ********************************************************************************************************** - subroutine netcdf_err(err,message) - ! used to handle errors for NetCDF calls - implicit none - ! declare dummies - integer(i4b), intent(inout) :: err - character(*), intent(inout) :: message - ! start procedure here - if (err/=nf90_noerr) then - message=trim(message)//"["//trim(nf90_strerror(err))//"]" - err=200 - else - err=0 - endif - end subroutine netcdf_err + ! maximum number of snow layers + maxSnow = 0 + do iGRU = 1,nGRU + do iHRU = 1,gru_struc(iGRU)%hruCount + maxSnow = max(maxSnow,gru_struc(iGRU)%hruInfo(iHRU)%nSnow) + end do + end do + + ! total number of layers + maxLayers = maxSnow+maxSoil + + ! create file + err = nf90_create(trim(filename),nf90_classic_model,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(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 + err = nf90_def_dim(ncid,trim(midSoilDimName),maxSoil ,midSoilDimID); message='iCreate[ifcSoil]' ;call netcdf_err(err,message); if(err/=0)return + err = nf90_def_dim(ncid,trim(midTotoDimName),maxLayers ,midTotoDimID); message='iCreate[midToto]' ;call netcdf_err(err,message); if(err/=0)return + err = nf90_def_dim(ncid,trim(ifcSoilDimName),maxSoil+1 ,ifcSoilDimID); message='iCreate[ifcSoil]' ;call netcdf_err(err,message); if(err/=0)return + err = nf90_def_dim(ncid,trim(ifcTotoDimName),maxLayers+1,ifcTotoDimID); message='iCreate[ifcToto]' ;call netcdf_err(err,message); if(err/=0)return + if (maxSnow>0) err = nf90_def_dim(ncid,trim(midSnowDimName),maxSnow ,midSnowDimID); message='iCreate[ifcSnow]' ;call netcdf_err(err,message); if(err/=0)return + if (maxSnow>0) err = nf90_def_dim(ncid,trim(ifcSnowDimName),maxSnow+1 ,ifcSnowDimID); message='iCreate[ifcSnow]' ;call netcdf_err(err,message); if(err/=0)return + ! re-initialize error control + err=0; message='writeRestart/' + + ! define prognostic variables + do iVar = 1,size(prog_meta) + if (prog_meta(iVar)%varType==iLookvarType%unknown) cycle + + ! define variable + select case(prog_meta(iVar)%varType) + case(iLookvarType%scalarv); err = nf90_def_var(ncid,trim(prog_meta(iVar)%varname),nf90_double,(/hruDimID, scalDimID /),ncVarID(iVar)) + case(iLookvarType%wLength); err = nf90_def_var(ncid,trim(prog_meta(iVar)%varname),nf90_double,(/hruDimID, specDimID /),ncVarID(iVar)) + case(iLookvarType%midSoil); err = nf90_def_var(ncid,trim(prog_meta(iVar)%varname),nf90_double,(/hruDimID,midSoilDimID/),ncVarID(iVar)) + case(iLookvarType%midToto); err = nf90_def_var(ncid,trim(prog_meta(iVar)%varname),nf90_double,(/hruDimID,midTotoDimID/),ncVarID(iVar)) + case(iLookvarType%ifcSoil); err = nf90_def_var(ncid,trim(prog_meta(iVar)%varname),nf90_double,(/hruDimID,ifcSoilDimID/),ncVarID(iVar)) + case(iLookvarType%ifcToto); err = nf90_def_var(ncid,trim(prog_meta(iVar)%varname),nf90_double,(/hruDimID,ifcTotoDimID/),ncVarID(iVar)) + case(iLookvarType%midSnow); if (maxSnow>0) err = nf90_def_var(ncid,trim(prog_meta(iVar)%varname),nf90_double,(/hruDimID,midSnowDimID/),ncVarID(iVar)) + case(iLookvarType%ifcSnow); if (maxSnow>0) err = nf90_def_var(ncid,trim(prog_meta(iVar)%varname),nf90_double,(/hruDimID,ifcSnowDimID/),ncVarID(iVar)) + end select + + ! check errors + if(err/=0)then + message=trim(message)//trim(cmessage)//' [variable '//trim(prog_meta(iVar)%varName)//']' + return + end if + + ! add parameter description + err = nf90_put_att(ncid,ncVarID(iVar),'long_name',trim(prog_meta(iVar)%vardesc)) + call netcdf_err(err,message) + + ! add parameter units + err = nf90_put_att(ncid,ncVarID(iVar),'units',trim(prog_meta(iVar)%varunit)) + call netcdf_err(err,message) + + end do ! iVar + + ! 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) + + ! 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) + + ! end definition phase + err = nf90_enddef(ncid); call netcdf_err(err,message); if (err/=0) return + + ! write variables + do iGRU = 1,nGRU + do iHRU = 1,gru_struc(iGRU)%hruCount + cHRU = gru_struc(iGRU)%hruInfo(iHRU)%hru_ix + do iVar = 1,size(prog_meta) + + ! excape if this variable is not used + if (prog_meta(iVar)%varType==iLookvarType%unknown) cycle + + ! actual number of layers + nSnow = gru_struc(iGRU)%hruInfo(iHRU)%nSnow + nSoil = gru_struc(iGRU)%hruInfo(iHRU)%nSoil + nLayers = nSoil + nSnow + + ! check size + ! NOTE: this may take time that we do not wish to use + okLength=.true. + select case (prog_meta(iVar)%varType) + case(iLookVarType%scalarv); okLength = (size(prog_data%gru(iGRU)%hru(iHRU)%var(iVar)%dat) == nScalar ) + case(iLookVarType%wlength); okLength = (size(prog_data%gru(iGRU)%hru(iHRU)%var(iVar)%dat) == nSpectral) + case(iLookVarType%midSoil); okLength = (size(prog_data%gru(iGRU)%hru(iHRU)%var(iVar)%dat) == nSoil ) + case(iLookVarType%midToto); okLength = (size(prog_data%gru(iGRU)%hru(iHRU)%var(iVar)%dat) == nLayers ) + case(iLookVarType%ifcSoil); okLength = (size(prog_data%gru(iGRU)%hru(iHRU)%var(iVar)%dat) == nSoil+1 ) + case(iLookVarType%ifcToto); okLength = (size(prog_data%gru(iGRU)%hru(iHRU)%var(iVar)%dat) == nLayers+1) + case(iLookVarType%midSnow); if (nSnow>0) okLength = (size(prog_data%gru(iGRU)%hru(iHRU)%var(iVar)%dat) == nSnow ) + case(iLookVarType%ifcSnow); if (nSnow>0) okLength = (size(prog_data%gru(iGRU)%hru(iHRU)%var(iVar)%dat) == nSnow+1 ) + case default; err=20; message=trim(message)//'unknown var type'; return + end select + + ! error check + if(.not.okLength)then + message=trim(message)//'bad vector length for variable '//trim(prog_meta(iVar)%varname) + err=20; return + endif + ! write data + select case (prog_meta(iVar)%varType) + case(iLookVarType%scalarv); err=nf90_put_var(ncid,ncVarID(iVar),(/prog_data%gru(iGRU)%hru(iHRU)%var(iVar)%dat/),start=(/cHRU,1/),count=(/1,nScalar /)) + case(iLookVarType%wlength); err=nf90_put_var(ncid,ncVarID(iVar),(/prog_data%gru(iGRU)%hru(iHRU)%var(iVar)%dat/),start=(/cHRU,1/),count=(/1,nSpectral/)) + case(iLookVarType%midSoil); err=nf90_put_var(ncid,ncVarID(iVar),(/prog_data%gru(iGRU)%hru(iHRU)%var(iVar)%dat/),start=(/cHRU,1/),count=(/1,nSoil /)) + case(iLookVarType%midToto); err=nf90_put_var(ncid,ncVarID(iVar),(/prog_data%gru(iGRU)%hru(iHRU)%var(iVar)%dat/),start=(/cHRU,1/),count=(/1,nLayers /)) + case(iLookVarType%ifcSoil); err=nf90_put_var(ncid,ncVarID(iVar),(/prog_data%gru(iGRU)%hru(iHRU)%var(iVar)%dat/),start=(/cHRU,1/),count=(/1,nSoil+1 /)) + case(iLookVarType%ifcToto); err=nf90_put_var(ncid,ncVarID(iVar),(/prog_data%gru(iGRU)%hru(iHRU)%var(iVar)%dat/),start=(/cHRU,1/),count=(/1,nLayers+1/)) + case(iLookVarType%midSnow); if (nSnow>0) err=nf90_put_var(ncid,ncVarID(iVar),(/prog_data%gru(iGRU)%hru(iHRU)%var(iVar)%dat/),start=(/cHRU,1/),count=(/1,nSnow /)) + case(iLookVarType%ifcSnow); if (nSnow>0) err=nf90_put_var(ncid,ncVarID(iVar),(/prog_data%gru(iGRU)%hru(iHRU)%var(iVar)%dat/),start=(/cHRU,1/),count=(/1,nSnow+1 /)) + case default; err=20; message=trim(message)//'unknown var type'; return + end select + + ! error check + if (err.ne.0) message=trim(message)//'writing variable:'//trim(prog_meta(iVar)%varName) + call netcdf_err(err,message); if (err/=0) return + err=0; message='writeRestart/' + + end do ! iVar + + ! 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/)) + + end do ! iGRU + end do ! iHRU + + ! close file + call nc_file_close(ncid,err,cmessage) + if(err/=0)then;message=trim(message)//trim(cmessage);return;end if + + ! cleanup + deallocate(ncVarID) + + end subroutine writeRestart end module modelwrite_module diff --git a/build/source/netcdf/netcdf_util.f90 b/build/source/netcdf/netcdf_util.f90 new file mode 100755 index 000000000..e39a7e13a --- /dev/null +++ b/build/source/netcdf/netcdf_util.f90 @@ -0,0 +1,102 @@ +! 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 netcdf_util_module +USE nrtype +USE netcdf +implicit none +private +public::nc_file_open +public::nc_file_close +public::netcdf_err +contains + + + ! ********************************************************************************************************* + ! public subroutine file_open: open file + ! ********************************************************************************************************* + subroutine nc_file_open(infile,mode,ncid,err,message) + implicit none + ! declare dummy variables + character(*),intent(in) :: infile ! filename + integer(i4b),intent(in) :: mode ! file open mode + integer(i4b),intent(out) :: ncid ! file unit + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! declare local variables + logical(lgt) :: xist ! .TRUE. if the file exists + + ! initialize errors + err=0; message="netcdf-file_open/" + + ! check if the file exists + inquire(file=trim(infile),exist=xist) ! Check for existence of file + if(.not.xist)then + message=trim(message)//"FileNotFound[file='"//trim(infile)//"']" + err=10; return + end if + + ! open file + err=nf90_open(infile, mode, ncid) + if(err/=nf90_noerr) then + message=trim(message)//"OpenError['"//trim(infile)//"']"//trim(nf90_strerror(err)) + err=20; return + end if + + end subroutine nc_file_open + + ! ********************************************************************************************************** + ! private subroutine put_attrib: put global attributes as character string + ! ********************************************************************************************************** + subroutine nc_file_close(ncid,err,message) + implicit none + + ! declare dummy variables + integer(i4b),intent(in) :: ncid ! file id of netcdf file to close + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! initialize error control + err=0; message = 'nc_file_close/' + + err = nf90_close(ncid); + call netcdf_err(err,message) + + end subroutine nc_file_close + +! *********************************************************************************************** +! check the status of netCDF file operation and return error message +! *********************************************************************************************** + subroutine netcdf_err(err,message) + ! used to handle errors for NetCDF calls + use netcdf + implicit none + ! declare dummies + integer(i4b), intent(inout) :: err + character(*), intent(inout) :: message + ! start procedure here + if (err/=nf90_noerr) then + print*, 'trim(nf90_strerror(err) = ', trim(nf90_strerror(err)) + message=trim(message)//"["//trim(nf90_strerror(err))//"]" + print*, trim(message) + err=200 + end if + end subroutine netcdf_err + +end module netcdf_util_module diff --git a/build/source/netcdf/read_icond.f90 b/build/source/netcdf/read_icond.f90 new file mode 100755 index 000000000..ddd3f123b --- /dev/null +++ b/build/source/netcdf/read_icond.f90 @@ -0,0 +1,296 @@ +! 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 read_icond_module +USE nrtype +USE netcdf +implicit none +private +public::read_icond +public::read_icond_nlayers +contains + + ! ************************************************************************************************ + ! public subroutine read_icond_nlayers: read model initial conditions file for number of snow/soil layers + ! ************************************************************************************************ + subroutine read_icond_nlayers(iconFile,nGRU,indx_meta,err,message) + ! -------------------------------------------------------------------------------------------------------- + ! modules + USE nrtype + USE var_lookup,only:iLookIndex ! variable lookup structure + USE globalData,only:gru_struc ! gru-hru mapping structures + 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 + USE data_types,only:gru_hru_intVec ! actual data + USE data_types,only:var_info ! metadata + implicit none + + ! -------------------------------------------------------------------------------------------------------- + ! variable declarations + ! dummies + character(*) ,intent(in) :: iconFile ! name of input (restart) file + integer(i4b) ,intent(in) :: nGRU ! total # of GRUs in run domain + 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),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 + err=0 + message = 'read_icond_nlayers/' + + ! open netcdf file + call nc_file_open(iconFile,nf90_nowrite,ncid,err,cmessage); + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if + + ! get number of HRUs in file + err = nf90_inq_dimid(ncID,"hru",dimId); if(err/=nf90_noerr)then; message=trim(message)//'problem finding hru dimension/'//trim(nf90_strerror(err)); return; end if + 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 + + ! allocate sotrage for reading from file + allocate(snowData(fileHRU)) + allocate(soilData(fileHRU)) + snowData = 0 + soilData = 0 + + ! get variable ids + 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 data + err = nf90_get_var(ncid,snowid,snowData); call netcdf_err(err,message) + err = nf90_get_var(ncid,soilid,soilData); call netcdf_err(err,message) + + ! assign to index structure - gru by hru + do iGRU = 1,nGRU + do iHRU = 1,gru_struc(iGRU)%hruCount + gru_struc(iGRU)%hruInfo(iHRU)%nSnow = snowData(gru_struc(iGRU)%hruInfo(iHRU)%hru_nc) + gru_struc(iGRU)%hruInfo(iHRU)%nSoil = soilData(gru_struc(iGRU)%hruInfo(iHRU)%hru_nc) + end do + end do + + ! close file + call nc_file_close(ncid,err,cmessage) + if(err/=0)then;message=trim(message)//trim(cmessage);return;end if + + ! cleanup + deallocate(snowData,soilData) + + end subroutine read_icond_nlayers + + + ! ************************************************************************************************ + ! public subroutine read_icond: read model initial conditions + ! ************************************************************************************************ + subroutine read_icond(iconFile, & ! name of initial conditions file + nGRU, & ! number of GRUs + prog_meta, & ! metadata + progData, & ! model prognostic (state) variables + indxData, & ! layer index data + err,message) ! error control + ! -------------------------------------------------------------------------------------------------------- + ! modules + USE nrtype + USE var_lookup,only:iLookVarType ! variable lookup structure + USE var_lookup,only:iLookProg ! variable lookup structure + USE var_lookup,only:iLookIndex ! variable lookup structure + USE globalData,only:gru_struc ! gru-hru mapping structures + USE globaldata,only:iname_soil,iname_snow ! named variables to describe the type of layer + 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 + USE data_types,only:gru_hru_doubleVec ! actual data + USE data_types,only:gru_hru_intVec ! actual data + USE data_types,only:var_info ! metadata + USE get_ixName_module,only:get_varTypeName ! to access type strings for error messages + 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(var_info) ,intent(in) :: prog_meta(:) ! prognostic metadata + type(gru_hru_doubleVec),intent(inout) :: progData ! prognostic vars + type(gru_hru_intVec) ,intent(inout) :: indxData ! layer indexes + 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) :: iVar ! loop index + 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 + real(dp),allocatable :: varData(:,:) ! variable data storage + integer(i4b) :: nSoil, nSnow, nToto ! # layers + integer(i4b),parameter :: nBand=2 ! number of spectral bands + + 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 + + ! -------------------------------------------------------------------------------------------------------- + + ! Start procedure here + err=0; message="read_icond/" + + ! -------------------------------------------------------------------------------------------------------- + ! (1) read the file + ! -------------------------------------------------------------------------------------------------------- + ! open netcdf file + call nc_file_open(iconFile,nf90_nowrite,ncID,err,cmessage) + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if + + ! get number of HRUs in file + err = nf90_inq_dimid(ncID,"hru",dimID); if(err/=nf90_noerr)then; message=trim(message)//'problem finding hru dimension/'//trim(nf90_strerror(err)); return; end if + 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 + do iVar = 1,size(prog_meta) + + ! skip variables that are computed later + if(prog_meta(iVar)%varName=='scalarCanopyWat' .or. & + prog_meta(iVar)%varName=='spectralSnowAlbedoDiffuse' .or. & + prog_meta(iVar)%varName=='scalarSurfaceTemp' .or. & + prog_meta(iVar)%varName=='mLayerVolFracWat' .or. & + 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 + message=trim(message)//': problem with getting variable id, var='//trim(prog_meta(iVar)%varName) + return + endif + + ! get variable dimension IDs + select case (prog_meta(iVar)%varType) + case (iLookVarType%scalarv); err = nf90_inq_dimid(ncID,trim(scalDimName) ,dimID); call netcdf_err(err,message) + case (iLookVarType%midSoil); err = nf90_inq_dimid(ncID,trim(midSoilDimName),dimID); call netcdf_err(err,message) + case (iLookVarType%midToto); err = nf90_inq_dimid(ncID,trim(midTotoDimName),dimID); call netcdf_err(err,message) + case (iLookVarType%ifcToto); err = nf90_inq_dimid(ncID,trim(ifcTotoDimName),dimID); call netcdf_err(err,message) + case default + message=trim(message)//"unexpectedVariableType[name='"//trim(prog_meta(iVar)%varName)//"';type='"//trim(get_varTypeName(prog_meta(iVar)%varType))//"']" + err=20; return + end select + + ! check errors + if(err/=0)then + message=trim(message)//': problem with dimension ids, var='//trim(prog_meta(iVar)%varName) + return + endif + + ! get the dimension length + err = nf90_inquire_dimension(ncID,dimID,dimName,dimLen); call netcdf_err(err,message) + if(err/=0)then; message=trim(message)//': problem getting the dimension length'; return; endif + + ! iniitialize the variable data + allocate(varData(fileHRU,dimLen),stat=err) + if(err/=0)then; message=trim(message)//'problem allocating variable data'; return; endif + + ! get data + err = nf90_get_var(ncID,ncVarID,varData); call netcdf_err(err,message) + if(err/=0)then; message=trim(message)//': problem getting the data'; return; endif + + ! check data are not set to the fill value + if( any( abs(varData - nf90_fill_double) < epsilon(varData) ) )then + message=trim(message)//"data set to the fill value (name='"//trim(prog_meta(iVar)%varName)//"')" + err=20; return + endif + + ! store data in prognostics structure + ! loop through GRUs + do iGRU = 1,nGRU + do iHRU = 1,gru_struc(iGRU)%hruCount + + ! get ther number of layers + nSnow = gru_struc(iGRU)%hruInfo(iHRU)%nSnow + nSoil = gru_struc(iGRU)%hruInfo(iHRU)%nSoil + nToto = nSnow + nSoil + + ! put the data into data structures + select case (prog_meta(iVar)%varType) + case (iLookVarType%scalarv); progData%gru(iGRU)%hru(iHRU)%var(iVar)%dat(1 ) = varData(gru_struc(iGRU)%hruInfo(iHRU)%hru_nc,1 ) + case (iLookVarType%midSoil); progData%gru(iGRU)%hru(iHRU)%var(iVar)%dat(1:nSoil ) = varData(gru_struc(iGRU)%hruInfo(iHRU)%hru_nc,1:nSoil ) + case (iLookVarType%midToto); progData%gru(iGRU)%hru(iHRU)%var(iVar)%dat(1:nToto ) = varData(gru_struc(iGRU)%hruInfo(iHRU)%hru_nc,1:nToto ) + case (iLookVarType%ifcToto); progData%gru(iGRU)%hru(iHRU)%var(iVar)%dat(0:nToto ) = varData(gru_struc(iGRU)%hruInfo(iHRU)%hru_nc,1:nToto+1) + case default + message=trim(message)//"unexpectedVariableType[name='"//trim(prog_meta(iVar)%varName)//"';type='"//trim(get_varTypeName(prog_meta(iVar)%varType))//"']" + err=20; return + end select + + ! 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) + + end do ! iHRU + end do ! iGRU + + ! deallocate storage vector for next variable + deallocate(varData, stat=err) + if(err/=0)then; message=trim(message)//'problem deallocating variable data'; return; endif + + end do ! iVar + + ! -------------------------------------------------------------------------------------------------------- + ! (2) set number of layers + ! -------------------------------------------------------------------------------------------------------- + do iGRU = 1,nGRU + do iHRU = 1,gru_struc(iGRU)%hruCount + + ! save the number of layers + indxData%gru(iGRU)%hru(iHRU)%var(iLookINDEX%nSnow)%dat(1) = gru_struc(iGRU)%hruInfo(iHRU)%nSnow + indxData%gru(iGRU)%hru(iHRU)%var(iLookINDEX%nSoil)%dat(1) = gru_struc(iGRU)%hruInfo(iHRU)%nSoil + indxData%gru(iGRU)%hru(iHRU)%var(iLookINDEX%nLayers)%dat(1) = gru_struc(iGRU)%hruInfo(iHRU)%nSnow + gru_struc(iGRU)%hruInfo(iHRU)%nSoil + + ! initalize the indices for midSnow, midSoil, midToto, and ifcToto + indxData%gru(iGRU)%hru(iHRU)%var(iLookINDEX%midSnowStartIndex)%dat(1) = 1 + indxData%gru(iGRU)%hru(iHRU)%var(iLookINDEX%midSoilStartIndex)%dat(1) = 1 + indxData%gru(iGRU)%hru(iHRU)%var(iLookINDEX%midTotoStartIndex)%dat(1) = 1 + indxData%gru(iGRU)%hru(iHRU)%var(iLookINDEX%ifcSnowStartIndex)%dat(1) = 1 + indxData%gru(iGRU)%hru(iHRU)%var(iLookINDEX%ifcSoilStartIndex)%dat(1) = 1 + indxData%gru(iGRU)%hru(iHRU)%var(iLookINDEX%ifcTotoStartIndex)%dat(1) = 1 + + ! set layer type + indxData%gru(iGRU)%hru(iHRU)%var(iLookINDEX%layerType)%dat(1:gru_struc(iGRU)%hruInfo(iHRU)%nSnow) = iname_snow + indxData%gru(iGRU)%hru(iHRU)%var(iLookINDEX%layerType)%dat((gru_struc(iGRU)%hruInfo(iHRU)%nSnow+1):(gru_struc(iGRU)%hruInfo(iHRU)%nSnow+gru_struc(iGRU)%hruInfo(iHRU)%nSoil)) = iname_soil + + end do + end do + + end subroutine read_icond + +end module read_icond_module diff --git a/build/source/noah-mp/module_model_constants.F b/build/source/noah-mp/module_model_constants.F old mode 100644 new mode 100755 diff --git a/build/source/noah-mp/module_sf_myjsfc.F b/build/source/noah-mp/module_sf_myjsfc.F old mode 100644 new mode 100755 diff --git a/build/source/noah-mp/module_sf_noahlsm.F b/build/source/noah-mp/module_sf_noahlsm.F old mode 100644 new mode 100755 diff --git a/build/source/noah-mp/module_sf_noahmplsm.F b/build/source/noah-mp/module_sf_noahmplsm.F old mode 100644 new mode 100755 index 5ee915f43..1455555ea --- a/build/source/noah-mp/module_sf_noahmplsm.F +++ b/build/source/noah-mp/module_sf_noahmplsm.F @@ -324,6 +324,27 @@ subroutine read_mp_veg_parameters(FILENAME_VEGTABLE,DATASET_IDENTIFIER) LTOVRC, DILEFC, DILEFW, RMF25 , SLA , FRAGR , TMIN , VCMX25, TDLEF , BP, MP, QE25, RMS25, RMR25, ARM, FOLNMX, WDPOOL, WRRAT, MRP, & SAIM, LAIM, SLAREA, EPS + ! MPC change: enable use of alternative veg tables + ! - in this case, tables using attributes from other models used in the PLUMBER experiment + + NAMELIST / noah_mp_plumberCABLE_veg_categories / VEG_DATASET_DESCRIPTION, NVEG + NAMELIST / noah_mp_plumberCABLE_parameters / ISURBAN, ISWATER, ISBARREN, ISSNOW, EBLFOREST, & + CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, RHOL, RHOS, TAUL, TAUS, XL, CWPVT, C3PSN, KC25, AKC, KO25, AKO, AVCMX, AQE, & + LTOVRC, DILEFC, DILEFW, RMF25 , SLA , FRAGR , TMIN , VCMX25, TDLEF , BP, MP, QE25, RMS25, RMR25, ARM, FOLNMX, WDPOOL, WRRAT, MRP, & + SAIM, LAIM, SLAREA, EPS + + NAMELIST / noah_mp_plumberCHTESSEL_veg_categories / VEG_DATASET_DESCRIPTION, NVEG + NAMELIST / noah_mp_plumberCHTESSEL_parameters / ISURBAN, ISWATER, ISBARREN, ISSNOW, EBLFOREST, & + CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, RHOL, RHOS, TAUL, TAUS, XL, CWPVT, C3PSN, KC25, AKC, KO25, AKO, AVCMX, AQE, & + LTOVRC, DILEFC, DILEFW, RMF25 , SLA , FRAGR , TMIN , VCMX25, TDLEF , BP, MP, QE25, RMS25, RMR25, ARM, FOLNMX, WDPOOL, WRRAT, MRP, & + SAIM, LAIM, SLAREA, EPS + + NAMELIST / noah_mp_plumberSUMMA_veg_categories / VEG_DATASET_DESCRIPTION, NVEG + NAMELIST / noah_mp_plumberSUMMA_parameters / ISURBAN, ISWATER, ISBARREN, ISSNOW, EBLFOREST, & + CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, RHOL, RHOS, TAUL, TAUS, XL, CWPVT, C3PSN, KC25, AKC, KO25, AKO, AVCMX, AQE, & + LTOVRC, DILEFC, DILEFW, RMF25 , SLA , FRAGR , TMIN , VCMX25, TDLEF , BP, MP, QE25, RMS25, RMR25, ARM, FOLNMX, WDPOOL, WRRAT, MRP, & + SAIM, LAIM, SLAREA, EPS + ! Initialize our variables to bad values, so that if the namelist read fails, we come to a screeching halt as soon as we try to use anything. CH2OP = -1.E36 DLEAF = -1.E36 @@ -384,6 +405,15 @@ subroutine read_mp_veg_parameters(FILENAME_VEGTABLE,DATASET_IDENTIFIER) else if ( trim(DATASET_IDENTIFIER) == "MODIFIED_IGBP_MODIS_NOAH" ) then read(15,noah_mp_modis_veg_categories) read(15,noah_mp_modis_parameters) + else if ( trim(DATASET_IDENTIFIER) == "plumberCABLE" ) then + read(15,noah_mp_plumberCABLE_veg_categories) + read(15,noah_mp_plumberCABLE_parameters) + else if ( trim(DATASET_IDENTIFIER) == "plumberCHTESSEL" ) then + read(15,noah_mp_plumberCHTESSEL_veg_categories) + read(15,noah_mp_plumberCHTESSEL_parameters) + else if ( trim(DATASET_IDENTIFIER) == "plumberSUMMA" ) then + read(15,noah_mp_plumberSUMMA_veg_categories) + read(15,noah_mp_plumberSUMMA_parameters) else write(*,'("Unrecognized DATASET_IDENTIFIER in subroutine READ_MP_VEG_PARAMETERS")') write(*,'("DATASET_IDENTIFIER = ''", A, "''")') trim(DATASET_IDENTIFIER) @@ -5382,6 +5412,7 @@ SUBROUTINE STOMATA (VEGTYP ,MPE ,APAR ,FOLN ,ILOC , JLOC, & !in CF = SFCPRS/(8.314*SFCTMP)*1.e06 RS = 1./(BP(VEGTYP)*BTRAN) * CF ! MPC change: include BTRAN multiplier PSN = 0. + !write(*,'(a,1x,20(f16.6,1x))') 'TV-TFRZ, RS, CF = ', TV-TFRZ, RS, CF IF (APAR .LE. 0.) RETURN @@ -5389,17 +5420,21 @@ SUBROUTINE STOMATA (VEGTYP ,MPE ,APAR ,FOLN ,ILOC , JLOC, & !in TC = TV-TFRZ PPF = 4.6*APAR J = PPF*QE25(VEGTYP) + !write(*,'(a,1x,10(f20.10,1x))') 'J, APAR, QE25(VEGTYP) = ', J, APAR, QE25(VEGTYP) KC = KC25(VEGTYP) * F1(AKC(VEGTYP),TC) KO = KO25(VEGTYP) * F1(AKO(VEGTYP),TC) AWC = KC * (1.+O2/KO) CP = 0.5*KC/KO*O2*0.21 VCMX = VCMX25(VEGTYP) / F2(TC) * FNF * BTRAN * F1(AVCMX(VEGTYP),TC) - !print*,'BTRAN, VCMX = ', BTRAN, VCMX + !write(*,'(a,1x,20(f14.8,1x))') 'F1, F2, VCMX25(VEGTYP), AVCMX(VEGTYP), TC = ', F1(AVCMX(VEGTYP),TC), F2(TC), VCMX25(VEGTYP), AVCMX(VEGTYP), TC ! first guess ci CI = 0.7*CO2*C3PSN(VEGTYP) + 0.4*CO2*(1.-C3PSN(VEGTYP)) + !write(*,'(a,1x,10(f20.10,1x))') 'KC25(VEGTYP), AKC(VEGTYP), KO25(VEGTYP), AKO(VEGTYP) = ', KC25(VEGTYP), AKC(VEGTYP), KO25(VEGTYP), AKO(VEGTYP) + !write(*,'(a,1x,10(f20.10,1x))') 'CO2, CI, CP, KC, KO = ', CO2, CI, CP, KC, KO + ! rb: s/m -> s m**2 / umol RLB = RB/CF @@ -5408,18 +5443,23 @@ SUBROUTINE STOMATA (VEGTYP ,MPE ,APAR ,FOLN ,ILOC , JLOC, & !in CEA = MAX(0.25*EI*C3PSN(VEGTYP)+0.40*EI*(1.-C3PSN(VEGTYP)), MIN(EA,EI) ) + !print*, '**' + !write(*,'(a,1x,20(f14.8,1x))') 'BTRAN, VCMX, MP(VEGTYP), EA, EI, CEA/EI, O2, CO2, KC, KO, J, TC, RLB, SFCPRS = ', & + ! BTRAN, VCMX, MP(VEGTYP), EA, EI, CEA/EI, O2, CO2, KC, KO, J, TC, RLB, SFCPRS + ! ci iteration !jref: C3PSN is equal to 1 for all veg types. DO ITER = 1, NITER + WJ = MAX(CI-CP,0.)*J/(CI+2.*CP)*C3PSN(VEGTYP) + J*(1.-C3PSN(VEGTYP)) WC = MAX(CI-CP,0.)*VCMX/(CI+AWC)*C3PSN(VEGTYP) + VCMX*(1.-C3PSN(VEGTYP)) WE = 0.5*VCMX*C3PSN(VEGTYP) + 4000.*VCMX*CI/SFCPRS*(1.-C3PSN(VEGTYP)) PSN = MIN(WJ,WC,WE) * IGS - !write(*,'(a,1x,10(e20.10,1x))') 'WJ, WC, WE, PSN, BP(VEGTYP) = ', WJ, WC, WE, PSN, BP(VEGTYP) CS = MAX( CO2-1.37*RLB*SFCPRS*PSN, MPE ) + A = MP(VEGTYP)*PSN*SFCPRS*CEA / (CS*EI) + BTRAN*BP(VEGTYP) ! MPC change: include BTRAN multiplier for 2nd term - B = ( MP(VEGTYP)*PSN*SFCPRS/CS + BTRAN*BP(VEGTYP) ) * RLB - 1. ! MPC change: include BTRAN multiplier for 2nd term om brackets + B = ( MP(VEGTYP)*PSN*SFCPRS/CS + BTRAN*BP(VEGTYP) ) * RLB - 1. ! MPC change: include BTRAN multiplier for 2nd term in brackets C = -RLB IF (B .GE. 0.) THEN Q = -0.5*( B + SQRT(B*B-4.*A*C) ) @@ -5430,12 +5470,17 @@ SUBROUTINE STOMATA (VEGTYP ,MPE ,APAR ,FOLN ,ILOC , JLOC, & !in R2 = C/Q RS = MAX(R1,R2) CI = MAX( CS-PSN*SFCPRS*1.65*RS, 0. ) + + !write(*,'(a,1x10(f14.10,1x))') 'WJ, WC, WE, PSN, CI, CS, RS, TV, VCMX, J = ', & + ! WJ, WC, WE, PSN, CI, CS, RS, TV, VCMX, J + END DO + !pause ! rs, rb: s m**2 / umol -> s/m RS = RS*CF - !print*, 'RS = ', RS + !write(*,'(a,1x,10(f20.10,1x))') 'RS, G, CEA, EA, EI = ', RS, 1./RS, CEA, EA, EI END SUBROUTINE STOMATA ! ================================================================================================== diff --git a/build/source/noah-mp/module_sf_noahutl.F b/build/source/noah-mp/module_sf_noahutl.F old mode 100644 new mode 100755 diff --git a/build/source/noah-mp/module_sf_sfclay.F b/build/source/noah-mp/module_sf_sfclay.F old mode 100644 new mode 100755 diff --git a/ci/summa_install_utils b/ci/summa_install_utils index 12d1a5445..dba6496fb 100644 --- a/ci/summa_install_utils +++ b/ci/summa_install_utils @@ -31,11 +31,11 @@ function install_szip { function install_hdf5 { echo install_hdf5 cd $WORKDIR - wget --no-check-certificate -q http://www.hdfgroup.org/ftp/HDF5/current/src/hdf5-1.8.17.tar.gz - tar -xzf hdf5-1.8.17.tar.gz - cd hdf5-1.8.17 + wget --no-check-certificate -q https://support.hdfgroup.org/ftp/HDF5/current/src/hdf5-1.10.1.tar.gz + tar -xzf hdf5-1.10.1.tar.gz + cd hdf5-1.10.1 ./configure --prefix=$INSTALLDIR &> config.log - make &> make.log + make make install export LIBDIR=${INSTALLDIR}/lib } @@ -78,9 +78,11 @@ function summa_before_install { function summa_install { echo summa_install cd ${TRAVIS_BUILD_DIR} - sed -i "s/FC =.*/FC = gfortran-6/" build/Makefile - sed -i "s|F_MASTER =.*|F_MASTER = ${TRAVIS_BUILD_DIR}|" build/Makefile - sed -i "s|NCDF_PATH =.*|NCDF_PATH = ${INSTALLDIR}|" build/Makefile + export F_MASTER=${TRAVIS_BUILD_DIR} + export FC=gfortran + export FC_EXE=gfortran-6 + export FC_ENV=gfortran-6-travis + export NCDF_PATH=${INSTALLDIR} make -C build/ -f Makefile &> make.log } diff --git a/docs/howto/Model_Output.txt b/docs/howto/Model_Output.txt new file mode 100755 index 000000000..788161f57 --- /dev/null +++ b/docs/howto/Model_Output.txt @@ -0,0 +1,131 @@ +! ------------------------------------------------------------ +! ------------------------------------------------------------ +! File for specifying model outputs +! ------------------------------------------------------------ +! ------------------------------------------------------------ +! Each file line contains the following: +! (1) variable name (see source/dshare/popMetadat.f90 for a list of all possible variables) +! (2) output frequency specified in terms of # timesteps +! (3) flag for output statistics - 1=on,0=off +! +! The format of each file line is: +! (1) | (2) | (3) | (3) | (3) | (3) | (3) | (3) | (3) | +! Bars are used as separators, and there are seven possible output statistics for each time-dependent variable: +! 1. Sum over output period +! 2. Instantaneous value at output timestep +! 3. Mean over output period +! 4. Variance over output period +! 5. Minimum over ouptut period +! 6. Maximum over output period +! 7. Mode over output period +! ------------------------------------------------------------ +! ------------------------------------------------------------ +! +! +! --------- +! time +! --------- +iyyy | 24 +im | 24 +id | 24 +ih | 24 +imin | 24 +! --------- +! type +! --------- +hruIndex | 24 +vegTypeIndex | 24 +soilTypeIndex | 24 +slopeTypeIndex | 24 +downHRUindex | 24 +! --------- +! attributes +! --------- +latitude | 24 +longitude | 24 +elevation | 24 +tan_slope | 24 +contourLength | 24 +HRUarea | 24 +mHeight | 24 +! --------- +! model parameters +! --------- +frac_sand | 24 +frac_silt | 24 +frac_clay | 24 +theta_sat | 24 +theta_res | 24 +! --------- +! basin parameters +! --------- +basin__aquiferHydCond | 24 +basin__aquiferScaleFactor | 24 +basin__aquiferBaseflowExp | 24 +routingGammaShape | 0 +routingGammaScale | 0 +! --------- +! indexes +! --------- +nSnow | 0 +nSoil | 0 +nLayers | 0 +midSnowStartIndex | 0 +midSoilStartIndex | 0 +midTotoStartIndex | 0 +ifcSnowStartIndex | 0 +ifcSoilStartIndex | 0 +ifcTotoStartIndex | 0 +layerType | 0 +! --------- +! forcing +! --------- +pptrate | 24 | 1 | 1 | 1 | 1 | 1 | 1 | 0 +SWRadAtm | 24 | 1 | 1 | 1 | 1 | 1 | 1 | 0 +LWRadAtm | 24 | 1 | 1 | 1 | 1 | 1 | 1 | 0 +airtemp | 24 | 1 | 1 | 1 | 1 | 1 | 1 | 0 +windspd | 24 | 1 | 1 | 1 | 1 | 1 | 1 | 0 +airpres | 24 | 1 | 1 | 1 | 1 | 1 | 1 | 0 +spechum | 24 | 1 | 1 | 1 | 1 | 1 | 1 | 0 +! --------- +! basin vars +! --------- +basin__TotalArea | 24 | 1 | 1 | 1 | 1 | 1 | 1 | 0 +basin__SurfaceRunoff | 24 | 1 | 1 | 1 | 1 | 1 | 1 | 0 +basin__ColumnOutflow | 24 | 1 | 1 | 1 | 1 | 1 | 1 | 0 +basin__AquiferStorage | 24 | 1 | 1 | 1 | 1 | 1 | 1 | 0 +basin__AquiferRecharge | 24 | 1 | 1 | 1 | 1 | 1 | 1 | 0 +basin__AquiferBaseflow | 24 | 1 | 1 | 1 | 1 | 1 | 1 | 0 +basin__AquiferTranspire | 24 | 1 | 1 | 1 | 1 | 1 | 1 | 0 +averageInstantRunoff | 24 | 1 | 1 | 1 | 1 | 1 | 1 | 0 +averageRoutedRunoff | 24 | 1 | 1 | 1 | 1 | 1 | 1 | 0 +! +routingRunoffFuture | 0 +routingFractionFuture | 0 +! --------- +! model variables +! --------- +scalarSWE | 24 | 1 | 1 | 1 | 1 | 1 | 1 | 0 +scalarSurfaceTemp | 24 | 1 | 1 | 1 | 1 | 1 | 1 | 0 +scalarSenHeatTotal | 24 | 1 | 1 | 1 | 1 | 1 | 1 | 0 +scalarLatHeatTotal | 24 | 1 | 1 | 1 | 1 | 1 | 1 | 0 +scalarCanopyTemp | 24 | 1 | 1 | 1 | 1 | 1 | 1 | 0 +scalarCanopyLiq | 24 | 1 | 1 | 1 | 1 | 1 | 1 | 0 +scalarCanopyAbsorbedSolar | 24 | 1 | 1 | 1 | 1 | 1 | 1 | 0 +scalarGroundAbsorbedSolar | 24 | 1 | 1 | 1 | 1 | 1 | 1 | 0 +! +spectralAlbGndDirect | 0 +spectralAlbGndDiffuse | 0 +! +mLayerTemp | 0 +mLayerVolFracIce | 0 +mLayerVolFracLiq | 0 +mLayerMatricHead | 0 +! --------- +! integrated variables +! --------- +!intgLayerVolFracLiq | 0 | 1 | 1 | 1 | 1 | 1 | 1 | 0 +!intgLayerVolFracIce | 0 | 1 | 1 | 1 | 1 | 1 | 1 | 0 +!intgLayerVolFracAir | 0 | 1 | 1 | 1 | 1 | 1 | 1 | 0 +! +! diff --git a/docs/howto/git_howto.md b/docs/howto/git_howto.md old mode 100644 new mode 100755 diff --git a/docs/howto/summa_and_git_howto.md b/docs/howto/summa_and_git_howto.md old mode 100644 new mode 100755 index a40bdc03f..bba0a80bd --- a/docs/howto/summa_and_git_howto.md +++ b/docs/howto/summa_and_git_howto.md @@ -18,7 +18,7 @@ In general, if you plan to apply the model rather than work directly on the sour If you plan on contributing to model development or would like a systematic way to incorporate updates to the SUMMA source code, we encourage you to use Git. The following sections are designed to get you started using Git and working with the SUMMA source code repository. ### Git resources -If you are SUMMA familiar with Git yet, we encourage you to spend a few minutes getting antiquated with the system before you starting working with the SUMMA source code and Git. It's not difficult to use and a few minutes of learning about Git will go along way in helping you manage your code development. +If you are not familiar with Git yet, we encourage you to spend a few minutes getting acquainted with the system before you starting working with the SUMMA source code and Git. It's not difficult to use and a few minutes of learning about Git will go along way in helping you manage your code development. There are a number of good Git learning resources that will provide a basic introduction to the version control system. * http://git-scm.com/about diff --git a/docs/howto/summa_coding_conventions.md b/docs/howto/summa_coding_conventions.md old mode 100644 new mode 100755 diff --git a/docs/howto/summa_configuration.md b/docs/howto/summa_configuration.md old mode 100644 new mode 100755 diff --git a/docs/howto/summa_git_workflow.md b/docs/howto/summa_git_workflow.md old mode 100644 new mode 100755 index 6bc8fca02..d6e7c428b --- a/docs/howto/summa_git_workflow.md +++ b/docs/howto/summa_git_workflow.md @@ -47,7 +47,7 @@ Using Github to host the central or truth repository of our models allows us to 2. Model Admins have full access to specific repositories. They may push, pull, or make administrative changes to those repositories associated with their model. However, they should generally not push to the truth repo directly. Instead, they should fork, clone, edit locally, update their fork and then issue a pull request. This pull request should preferably be reviewed by someone else before it is merged. - 3. Developers have read-only access (pull, clone, fork) to any of the publically listed repositories under the NCAR name. If a developer would like a feature branch merged into the main repository, a pull request must be submitted and a Model Admin may merge it in. + 3. Developers have read-only access (pull, clone, fork) to any of the publicly listed repositories under the UW-hydro name. If a developer would like a feature branch merged into the main repository, a pull request must be submitted and a Model Admin may merge it in. ## Workflow examples @@ -81,7 +81,7 @@ The process would be as follows: git push - * Now make as many changes as you need to, commit them to your local repo and push them to your remote on GitHub. This is just like any other work you would do using Git. Once everything is working and eevrything is sufficiently tested, you will be ready to share your code with others. + * Now make as many changes as you need to, commit them to your local repo and push them to your remote on GitHub. This is just like any other work you would do using Git. Once everything is working and everything is sufficiently tested, you will be ready to share your code with others. * Before you do that, merge any changes that have been made in the develop branch in the main SUMMA repo into the `feature/resistance` branch of your local repo. Assuming you are already on the `feature/resistance` branch: @@ -96,8 +96,3 @@ The process would be as follows: * Issue a pull request. You do that on GitHub. Make sure that you make the pull request with respect to the correct branches. On your end this should be the `feature/resistance` branch and on the other end the `develop` branch. * You changes will be reviewed and merged or more likely there will be some back-and-forth with suggested changes and clarifications. - - - - - diff --git a/docs/howto/summa_mac_os_x.md b/docs/howto/summa_mac_os_x.md old mode 100644 new mode 100755 diff --git a/header.license b/header.license old mode 100644 new mode 100755 diff --git a/readme.md b/readme.md old mode 100644 new mode 100755 index 49a46674a..3da63f167 --- a/readme.md +++ b/readme.md @@ -1,4 +1,4 @@ -[![Build Status](https://travis-ci.org/NCAR/summa.svg)](https://travis-ci.org/NCAR/summa) +[![Build Status](https://travis-ci.org/NCAR/summa.svg?branch=develop)](https://travis-ci.org/NCAR/summa) #SUMMA This is the source code repository for the **Structure for Unifying Multiple Modeling Alternatives** or **SUMMA**. More information about SUMMA, including publications, test data sets, and sample applications can be found on the [SUMMA web site](http://www.ral.ucar.edu/projects/summa) at NCAR. @@ -71,8 +71,13 @@ Once you have all the above, you can compile SUMMA using the following steps: 1. Run `summa.exe`. If all goes well, you should get an error message that looks something like: ``` - 231714.555 - 1st command-line argument missing, expect text string defining the output file suffix + Usage: summa.exe master_file [-s file_suffix] [-g startGRU countGRU] [-c checkHRU] + summa.exe -- summa executable + file_suffix -- text string defining the output file suffix + master_file -- path/name of master file + startGRU -- the index of the first GRU for a parallelization run + countGRU -- the number of GRUs for a parallelization run + checkHRU -- the index of the HRU for a single HRU run ``` If you get this far then SUMMA is installed correctly and functional.