diff --git a/build/CMakeLists.txt b/build/CMakeLists.txt index 36f6940bc..662fe7c3c 100644 --- a/build/CMakeLists.txt +++ b/build/CMakeLists.txt @@ -145,6 +145,7 @@ set(ENGINE_DIR ${F_MASTER}/build/source/engine) set(HOOKUP_DIR ${F_MASTER}/build/source/hookup) set(NETCDF_DIR ${F_MASTER}/build/source/netcdf) set(NOAHMP_DIR ${F_MASTER}/build/source/noah-mp) +set(NUMREC_DIR ${F_MASTER}/build/source/numrec) #========================================================================================= # COMPILE PART 2: Assemble all of the SUMMA sub-routines diff --git a/build/source/CMakeLists.txt b/build/source/CMakeLists.txt index a9f885857..e44734cd9 100644 --- a/build/source/CMakeLists.txt +++ b/build/source/CMakeLists.txt @@ -13,16 +13,16 @@ set(NOAHMP # Free versions of numerical recipes utilities for NOAH-MP modules set(NRUTIL - ${ENGINE_DIR}/f2008funcs.f90 - ${ENGINE_DIR}/nr_utility.f90 - ${ENGINE_DIR}/nrtype.f90 + ${NUMREC_DIR}/f2008funcs.f90 + ${NUMREC_DIR}/nr_utils.f90 + ${NUMREC_DIR}/nr_type.f90 CACHE INTERNAL "NRUTIL") # Free versions of numerical recipes procedures for SUMMA modules set(NRPROC - ${ENGINE_DIR}/expIntegral.f90 - ${ENGINE_DIR}/spline_int.f90 - ${ENGINE_DIR}/hyp_2F1.f90 + ${NUMREC_DIR}/expIntegral.f90 + ${NUMREC_DIR}/spline_int.f90 + ${NUMREC_DIR}/hyp_2F1.f90 CACHE INTERNAL "NRPROC") # Hook-up modules @@ -34,7 +34,7 @@ set(HOOKUP # Data modules set(DATAMS ${DSHARE_DIR}/data_types.f90 - ${DSHARE_DIR}/flxMapping.f90 + ${DSHARE_DIR}/fluxMapping.f90 ${DSHARE_DIR}/get_ixname.f90 ${DSHARE_DIR}/globalData.f90 ${DSHARE_DIR}/multiconst.f90 @@ -75,7 +75,7 @@ set(PRELIM ${ENGINE_DIR}/check_icond.f90 ${ENGINE_DIR}/checkStruc.f90 ${ENGINE_DIR}/childStruc.f90 - ${ENGINE_DIR}/conv_funcs.f90 + ${ENGINE_DIR}/convert_funcs.f90 ${ENGINE_DIR}/ffile_info.f90 ${ENGINE_DIR}/read_pinit.f90 ${ENGINE_DIR}/read_attrb.f90 @@ -89,7 +89,7 @@ set(PRELIM set(MODRUN ${ENGINE_DIR}/canopySnow.f90 ${ENGINE_DIR}/derivforce.f90 - ${ENGINE_DIR}/enthalpyTemp.f90 + ${ENGINE_DIR}/convertEnthalpyTemp.f90 ${ENGINE_DIR}/getVectorz.f90 ${ENGINE_DIR}/indexState.f90 ${ENGINE_DIR}/layerMerge.f90 @@ -97,38 +97,36 @@ set(MODRUN ${ENGINE_DIR}/qTimeDelay.f90 ${ENGINE_DIR}/read_force.f90 ${ENGINE_DIR}/snowAlbedo.f90 - ${ENGINE_DIR}/snwCompact.f90 ${ENGINE_DIR}/tempAdjust.f90 - ${ENGINE_DIR}/updateVars.f90 + ${ENGINE_DIR}/updatDiagn.f90 ${ENGINE_DIR}/var_derive.f90 ${ENGINE_DIR}/volicePack.f90 CACHE INTERNAL "MODRUN") set(MODRUN_SUNDIALS ${ENGINE_DIR}/tol4ida.f90 - ${ENGINE_DIR}/updateVarsWithPrime.f90 + ${ENGINE_DIR}/updatDiagnWithPrime.f90 CACHE INTERNAL "MODRUN_SUNDIALS") # Solver main modules set(SOLVER ${ENGINE_DIR}/bigAquifer.f90 ${ENGINE_DIR}/computFlux.f90 - ${ENGINE_DIR}/computHeatCap.f90 + ${ENGINE_DIR}/heat_Cp_Cm.f90 ${ENGINE_DIR}/computJacob.f90 ${ENGINE_DIR}/computResid.f90 - ${ENGINE_DIR}/computSnowDepth.f90 - ${ENGINE_DIR}/computThermConduct.f90 + ${ENGINE_DIR}/snowDepth.f90 + ${ENGINE_DIR}/thermConductivity.f90 ${ENGINE_DIR}/coupled_em.f90 - ${ENGINE_DIR}/diagn_evar.f90 ${ENGINE_DIR}/eval8summa.f90 ${ENGINE_DIR}/groundwatr.f90 ${ENGINE_DIR}/opSplittin.f90 ${ENGINE_DIR}/run_oneGRU.f90 ${ENGINE_DIR}/run_oneHRU.f90 - ${ENGINE_DIR}/snowLiqFlx.f90 - ${ENGINE_DIR}/soilLiqFlx.f90 - ${ENGINE_DIR}/ssdNrgFlux.f90 + ${ENGINE_DIR}/snowLiqFlux.f90 + ${ENGINE_DIR}/soilLiqFlux.f90 + ${ENGINE_DIR}/snowSoilNrgFlux.f90 ${ENGINE_DIR}/stomResist.f90 - ${ENGINE_DIR}/summaSolve4homegrown.f90 + ${ENGINE_DIR}/summaSolv4homegrown.f90 ${ENGINE_DIR}/systemSolv.f90 ${ENGINE_DIR}/varSubstep.f90 ${ENGINE_DIR}/vegLiqFlux.f90 @@ -140,8 +138,8 @@ set(SOLVER_SUNDIALS ${ENGINE_DIR}/computJacobWithPrime.f90 ${ENGINE_DIR}/computResidWithPrime.f90 ${ENGINE_DIR}/eval8summaWithPrime.f90 - ${ENGINE_DIR}/summaSolve4ida.f90 - ${ENGINE_DIR}/summaSolve4kinsol.f90 + ${ENGINE_DIR}/summaSolv4ida.f90 + ${ENGINE_DIR}/summaSolv4kinsol.f90 CACHE INTERNAL "SOLVER_SUNDIALS") # Driver support modules diff --git a/build/source/driver/summa_alarms.f90 b/build/source/driver/summa_alarms.f90 index 1ee5d1564..eafa44a98 100644 --- a/build/source/driver/summa_alarms.f90 +++ b/build/source/driver/summa_alarms.f90 @@ -21,6 +21,9 @@ module summa_alarms ! used to set alarms to write model output +! named variables for time information +USE globalData, only: numtim ! number of model time steps + ! named variables to define new output files USE globalData, only: noNewFiles ! no new output files USE globalData, only: newFileEveryOct1 ! create a new file on Oct 1 every year (start of the USA water year) @@ -53,19 +56,21 @@ module summa_alarms contains ! used to set alarms to write model output -subroutine summa_setWriteAlarms(oldTime, newTime, endTime, & ! time vectors - newOutputFile, defNewOutputFile, & ! flag to define new output file - ixRestart, printRestart, & ! flag to print the restart file - ixProgress, printProgress, & ! flag to print simulation progress - resetStats, finalizeStats, & ! flags to reset and finalize stats - statCounter, & ! statistics counter - err,message) ! error control +subroutine summa_setWriteAlarms(modelTimeStep, & ! time index + oldTime, newTime, endTime, & ! time vectors + newOutputFile, defNewOutputFile, & ! flag to define new output file + ixRestart, printRestart, & ! flag to print the restart file + ixProgress, printProgress, & ! flag to print simulation progress + resetStats, finalizeStats, & ! flags to reset and finalize stats + statCounter, & ! statistics counter + err,message) ! error control ! --------------------------------------------------------------------------------------- ! data types - USE nrtype ! variable types, etc. + USE nr_type ! variable types, etc. ! --------------------------------------------------------------------------------------- implicit none ! dummy variables: time vectors + integer(i4b),intent(in) :: modelTimeStep ! index of model time step integer(i4b),intent(in) :: oldTime(:) ! time vector from the previous time step integer(i4b),intent(in) :: newTime(:) ! time vector from the current time step integer(i4b),intent(in) :: endTime(:) ! time vector at the end of the simulation @@ -111,6 +116,12 @@ subroutine summa_setWriteAlarms(oldTime, newTime, endTime, & ! time vector end select + ! check that we do not have multiple files for the buffered write + if(defNewOutputFile .and. modelTimeStep>1)then + err=10 + message=trim(message)//'cannot have multiple output files when using the buffered write decision (check the -n option)'; return + endif + ! ***************************************************************************** ! *** define the need to create a restart file ! ***************************************************************************** @@ -145,7 +156,7 @@ subroutine summa_setWriteAlarms(oldTime, newTime, endTime, & ! time vector ! ***************************************************************************** ! reset output counters/flags - do iFreq=1,maxVarFreq ! loop through output frequencies + do iFreq=1,maxvarFreq ! loop through output frequencies ! define the need to finalize statistics ! NOTE: time vector is configured so that ih=0 at the start of the day, hence day in oldTime and timeStruct%var differ @@ -157,6 +168,9 @@ subroutine summa_setWriteAlarms(oldTime, newTime, endTime, & ! time vector case default; err=20; message=trim(message)//'unable to identify output frequency'; return end select + ! force finalize the stats if the last model time step + if(modelTimeStep == numtim) finalizeStats(iFreq)=.true. + ! reset ouput timestep if(resetStats(iFreq)) statCounter(iFreq)=1 @@ -164,4 +178,4 @@ subroutine summa_setWriteAlarms(oldTime, newTime, endTime, & ! time vector end subroutine summa_setWriteAlarms -end module summa_alarms \ No newline at end of file +end module summa_alarms diff --git a/build/source/driver/summa_bmi.f90 b/build/source/driver/summa_bmi.f90 index 7ff2cb7b9..6c31766a9 100644 --- a/build/source/driver/summa_bmi.f90 +++ b/build/source/driver/summa_bmi.f90 @@ -25,7 +25,7 @@ module summabmi ! ***************************************************************************** ! data types USE,intrinsic :: iso_c_binding, only: c_ptr, c_loc, c_f_pointer - USE nrtype ! variable types, etc. + USE nr_type ! variable types, etc. ! NGEN_ACTIVE is to be set when running in the Nextgen framework ! https://github.com/NOAA-OWP/ngen #ifdef NGEN_ACTIVE @@ -66,7 +66,7 @@ module summabmi USE globalData, only: fileout, output_fileSuffix ! output filename and suffix USE globalData, only: outFreq ! output frequency flags USE globalData, only: ncid ! netcdf output file id - USE globalData, only: maxLayers, maxSnowLayers ! maximum number of layers and snow layers + USE globalData, only: maxLayers,maxSnowLayers,maxSoilLayers ! maximum number of layers and snow soil layers USE globalData, only: ixProgress ! define frequency to write progress USE globalData, only: ixRestart ! define frequency to write restart files USE globalData, only: newOutputFile ! define option for new output files @@ -112,7 +112,7 @@ module summabmi character(len=256) :: fileout, output_fileSuffix ! output filename and suffix logical(lgt),dimension(maxvarFreq) :: outFreq ! true if the output frequency is desired integer(i4b),dimension(maxvarFreq) :: ncid ! netcdf output file id - integer(i4b) :: maxLayers, maxSnowLayers ! maximum number of layers and snow layers, could be different for different GRUs + integer(i4b) :: maxLayers,maxSnowLayers,maxSoilLayers ! maximum number of layers and snow soil layers, could be different for different GRUs integer(i4b) :: ixProgress ! define frequency to write progress integer(i4b) :: ixRestart ! define frequency to write restart files integer(i4b) :: newOutputFile ! define option for new output files @@ -317,6 +317,7 @@ function summa_bmi_initialize(this, config_file) result (bmi_status) this%model%output_fileSuffix = output_fileSuffix this%model%maxLayers = maxLayers this%model%maxSnowLayers = maxSnowLayers + this%model%maxSoilLayers = maxSoilLayers this%model%urbanVegCategory = urbanVegCategory this%model%ixProgress = ixProgress this%model%ixRestart = ixRestart @@ -359,6 +360,7 @@ function summa_update(this) result (bmi_status) outFreq = this%model%outFreq maxLayers = this%model%maxLayers maxSnowLayers = this%model%maxSnowLayers + maxSoilLayers = this%model%maxSoilLayers urbanVegCategory = this%model%urbanVegCategory ixProgress = this%model%ixProgress ixRestart = this%model%ixRestart diff --git a/build/source/driver/summa_defineOutput.f90 b/build/source/driver/summa_defineOutput.f90 index 531f6545f..8c680b636 100644 --- a/build/source/driver/summa_defineOutput.f90 +++ b/build/source/driver/summa_defineOutput.f90 @@ -20,10 +20,6 @@ module summa_defineOutput ! used to define model output files -! access missing values -USE globalData,only:integerMissing ! missing integer -USE globalData,only:realMissing ! missing real number - ! named variables to define new output files USE globalData, only: noNewFiles ! no new output files USE globalData, only: newFileEveryOct1 ! create a new file on Oct 1 every year (start of the USA water year) @@ -36,7 +32,6 @@ module summa_defineOutput ! used to define model output file USE globalData,only:bpar_meta ! basin parameter metadata structure ! named variables -USE var_lookup,only:maxvarFreq ! maximum number of output files USE var_lookup,only:iLookTIME ! named variables for time data structure USE var_lookup,only:iLookFREQ ! named variables for the frequency structure @@ -47,16 +42,16 @@ module summa_defineOutput ! used to define model output file contains ! used to define model output files - subroutine summa_defineOutputFiles(modelTimeStep, summa1_struc, err, message) + subroutine summa_defineOutputFiles(modelTimeStep, using_buffer, summa1_struc, err, message) ! --------------------------------------------------------------------------------------- ! * desired modules ! --------------------------------------------------------------------------------------- ! data types - USE nrtype ! variable types, etc. + USE nr_type ! variable types, etc. USE summa_type, only:summa1_type_dec ! master summa data type ! functions and subroutines USE def_output_module,only:def_output ! module to define model output - USE modelwrite_module,only:writeParm ! module to write model parameters + USE modelwrite_module,only:writeParam ! module to write model parameters ! global data structures USE globalData,only:gru_struc ! gru-hru mapping structures USE globalData,only:structInfo ! information on the data structures @@ -71,6 +66,7 @@ subroutine summa_defineOutputFiles(modelTimeStep, summa1_struc, err, message) implicit none ! dummy variables integer(i4b),intent(in) :: modelTimeStep ! time step index + logical(lgt),intent(in) :: using_buffer ! flag for will do buffered write type(summa1_type_dec),intent(inout) :: summa1_struc ! master summa data structure integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -122,28 +118,32 @@ subroutine summa_defineOutputFiles(modelTimeStep, summa1_struc, err, message) ! ***************************************************************************** ! define the file - call def_output(summaVersion,buildTime,gitBranch,gitHash,nGRU,nHRU,gru_struc(1)%hruInfo(1)%nSoil,fileout,err,cmessage) + call def_output(using_buffer,summaVersion,buildTime,gitBranch,gitHash,nGRU,nHRU,fileout,err,cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - ! write parameters for each HRU + ! write parameters with no time dimension do iGRU=1,nGRU - ! write HRU parameters + ! write HRU parameters, all written to timestep frequency file do iHRU=1,gru_struc(iGRU)%hruCount do iStruct=1,size(structInfo) select case(trim(structInfo(iStruct)%structName)) - case('attr'); call writeParm(gru_struc(iGRU)%hruInfo(iHRU)%hru_ix,attrStruct%gru(iGRU)%hru(iHRU),attr_meta,err,cmessage) - case('type'); call writeParm(gru_struc(iGRU)%hruInfo(iHRU)%hru_ix,typeStruct%gru(iGRU)%hru(iHRU),type_meta,err,cmessage) - case('mpar'); call writeParm(gru_struc(iGRU)%hruInfo(iHRU)%hru_ix,mparStruct%gru(iGRU)%hru(iHRU),mpar_meta,err,cmessage) + case('attr'); call writeParam(gru_struc(iGRU)%hruInfo(iHRU)%hru_ix,attrStruct%gru(iGRU)%hru(iHRU),attr_meta,err,cmessage) + case('type'); call writeParam(gru_struc(iGRU)%hruInfo(iHRU)%hru_ix,typeStruct%gru(iGRU)%hru(iHRU),type_meta,err,cmessage) + case('mpar'); call writeParam(gru_struc(iGRU)%hruInfo(iHRU)%hru_ix,mparStruct%gru(iGRU)%hru(iHRU),mpar_meta,err,cmessage) end select if(err/=0)then; message=trim(message)//trim(cmessage)//'['//trim(structInfo(iStruct)%structName)//']'; return; endif end do ! (looping through structures) end do ! (looping through HRUs) - ! write GRU parameters - call writeParm(iGRU,bparStruct%gru(iGRU),bpar_meta,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - + ! write GRU parameters, all written to timestep frequency file + do iStruct=1,size(structInfo) + select case(trim(structInfo(iStruct)%structName)) + case('bpar'); call writeParam(iGRU,bparStruct%gru(iGRU),bpar_meta,err,cmessage) + end select + if(err/=0)then; message=trim(message)//trim(cmessage)//'['//trim(structInfo(iStruct)%structName)//']'; return; endif + end do ! (looping through structures) + end do ! (looping through GRUs) ! end associate statements diff --git a/build/source/driver/summa_driver.f90 b/build/source/driver/summa_driver.f90 index b9ea54eaa..8c7324e9c 100644 --- a/build/source/driver/summa_driver.f90 +++ b/build/source/driver/summa_driver.f90 @@ -23,7 +23,7 @@ program summa_driver ! * module access * ! data types - USE nrtype ! variable types, etc. + USE nr_type ! variable types, etc. USE summa_type, only: summa1_type_dec ! master summa data type ! subroutines and functions: model setup USE summa_init, only: summa_initialize ! used to allocate/initialize summa data structures diff --git a/build/source/driver/summa_driver4bmi.f90 b/build/source/driver/summa_driver4bmi.f90 deleted file mode 100644 index 9154f2154..000000000 --- a/build/source/driver/summa_driver4bmi.f90 +++ /dev/null @@ -1,56 +0,0 @@ -! SUMMA - Structure for Unifying Multiple Modeling Alternatives -! Copyright (C) 2014-2020 NCAR/RAL; University of Saskatchewan; University of Washington -! -! This file is part of SUMMA -! -! For more information see: http://www.ral.ucar.edu/projects/summa -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see . - -program summa_driver4bmi - ! driver program for summa simulations - ! ***************************************************************************** - ! * use desired modules - ! ***************************************************************************** - USE nrtype ! variable types, etc. - ! subroutines and functions: model simulation - USE summa_bmi - ! global data - USE globalData,only:numtim ! number of time steps - - implicit none - - ! ***************************************************************************** - ! * variable definitions - ! ***************************************************************************** - type (summa_bmi) :: model - integer(i4b) :: istat - ! define timing information - integer(i4b) :: modelTimeStep ! index of model time step - - ! ***************************************************************************** - ! * model simulation - ! ***************************************************************************** - ! give this a 0 length argument to use fileManager from summa standard command arguments - istat = model%initialize('') - - ! loop through time where numtim has been already computed as - ! numtim = nint( (dJulianFinsh - dJulianStart)*secprday/data_step ) + 1 - ! SUMMA runs the ending step (so start=end would still run a step) - do modelTimeStep=1,numtim - istat = model%update() - end do ! (looping through time) - istat = model%finalize() - -end program summa_driver4bmi diff --git a/build/source/driver/summa_forcing.f90 b/build/source/driver/summa_forcing.f90 index 79455f302..4720a27bd 100644 --- a/build/source/driver/summa_forcing.f90 +++ b/build/source/driver/summa_forcing.f90 @@ -33,7 +33,7 @@ subroutine summa_readForcing(modelTimeStep, summa1_struc, err, message) ! * desired modules ! --------------------------------------------------------------------------------------- ! data types - USE nrtype ! variable types, etc. + USE nr_type ! variable types, etc. USE summa_type, only:summa1_type_dec ! master summa data type ! subroutines and functions USE read_force_module,only:read_force ! module to read model forcing data @@ -45,6 +45,8 @@ subroutine summa_readForcing(modelTimeStep, summa1_struc, err, message) ! timing variables USE globalData,only:startRead,endRead ! date/time for the start and end of reading forcing data USE globalData,only:elapsedRead ! elapsed time to read forcing data + ! model decisions + USE globalData,only:model_decisions ! model decision structure ! --------------------------------------------------------------------------------------- ! * variables ! --------------------------------------------------------------------------------------- @@ -73,6 +75,7 @@ subroutine summa_readForcing(modelTimeStep, summa1_struc, err, message) call read_force(& ! input modelTimeStep, & ! intent(in): time step index + model_decisions, & ! intent(in): model decisions structure ! 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 diff --git a/build/source/driver/summa_globalData.f90 b/build/source/driver/summa_globalData.f90 index 51857d4d9..913889a3a 100644 --- a/build/source/driver/summa_globalData.f90 +++ b/build/source/driver/summa_globalData.f90 @@ -67,12 +67,12 @@ subroutine summa_defineGlobalData(err, message) ! * desired modules ! --------------------------------------------------------------------------------------- ! data types - USE nrtype ! variable types, etc. + USE nr_type ! variable types, etc. ! subroutines and functions: initial priming USE,intrinsic :: ieee_arithmetic ! IEEE arithmetic (obviously) ! subroutines and functions: define metadata structures USE popMetadat_module,only:popMetadat ! module to populate metadata structures - USE flxMapping_module,only:flxMapping ! module to map fluxes to states + USE fluxMapping_module,only:fluxMapping ! module to map fluxes to states USE checkStruc_module,only:checkStruc ! module to check metadata structures USE childStruc_module,only:childStruc ! module to create a child data structure ! miscellaneous global data @@ -110,7 +110,7 @@ subroutine summa_defineGlobalData(err, message) if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! define mapping between fluxes and states - call flxMapping(err,cmessage) + call fluxMapping(err,cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! check data structures @@ -118,7 +118,7 @@ subroutine summa_defineGlobalData(err, message) if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! define the mask to identify the subset of variables in the "child" data structure (just scalar variables) - flux_mask = (flux_meta(:)%vartype==iLookVarType%scalarv) + flux_mask = (flux_meta(:)%varType==iLookVarType%scalarv) ! create the averageFlux metadata structure call childStruc(flux_meta, flux_mask, averageFlux_meta, childFLUX_MEAN, err, cmessage) @@ -126,12 +126,12 @@ subroutine summa_defineGlobalData(err, message) ! child metadata structures - so that we do not carry full stats structures around everywhere ! only carry stats for variables with output frequency > model time step - statForc_mask = (forc_meta(:)%vartype==iLookVarType%scalarv.and.forc_meta(:)%varDesire) - statProg_mask = (prog_meta(:)%vartype==iLookVarType%scalarv.and.prog_meta(:)%varDesire) - statDiag_mask = (diag_meta(:)%vartype==iLookVarType%scalarv.and.diag_meta(:)%varDesire) - statFlux_mask = (flux_meta(:)%vartype==iLookVarType%scalarv.and.flux_meta(:)%varDesire) - statIndx_mask = (indx_meta(:)%vartype==iLookVarType%scalarv.and.indx_meta(:)%varDesire) - statBvar_mask = (bvar_meta(:)%vartype==iLookVarType%scalarv.and.bvar_meta(:)%varDesire) + statForc_mask = (forc_meta(:)%varType==iLookVarType%scalarv.and.forc_meta(:)%varDesire) + statProg_mask = (prog_meta(:)%varType==iLookVarType%scalarv.and.prog_meta(:)%varDesire) + statDiag_mask = (diag_meta(:)%varType==iLookVarType%scalarv.and.diag_meta(:)%varDesire) + statFlux_mask = (flux_meta(:)%varType==iLookVarType%scalarv.and.flux_meta(:)%varDesire) + statIndx_mask = (indx_meta(:)%varType==iLookVarType%scalarv.and.indx_meta(:)%varDesire) + statBvar_mask = (bvar_meta(:)%varType==iLookVarType%scalarv.and.bvar_meta(:)%varDesire) ! create the stats metadata structures do iStruct=1,size(structInfo) @@ -148,12 +148,12 @@ subroutine summa_defineGlobalData(err, message) 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 + statForc_meta(:)%varType = iLookVarType%outstat + statProg_meta(:)%varType = iLookVarType%outstat + statDiag_meta(:)%varType = iLookVarType%outstat + statFlux_meta(:)%varType = iLookVarType%outstat + statIndx_meta(:)%varType = iLookVarType%outstat + statBvar_meta(:)%varType = iLookVarType%outstat end subroutine summa_defineGlobalData diff --git a/build/source/driver/summa_init.f90 b/build/source/driver/summa_init.f90 index 4706b582e..3607b03ae 100644 --- a/build/source/driver/summa_init.f90 +++ b/build/source/driver/summa_init.f90 @@ -62,11 +62,11 @@ subroutine summa_initialize(summa1_struc, err, message) ! * desired modules ! --------------------------------------------------------------------------------------- ! data types - USE nrtype ! variable types, etc. + USE nr_type ! variable types, etc. USE summa_type, only:summa1_type_dec ! master summa data type ! subroutines and functions: initial priming USE summa_util, only:getCommandArguments ! process command line arguments - USE summaFileManager,only:summa_SetTimesDirsAndFiles ! sets directories and filenames + USE summaFileManager,only:summa_SetTimesDirsAndFiles ! sets directories and filenames USE summa_globalData,only:summa_defineGlobalData ! used to define global summa data structures USE time_utils_module,only:elapsedSec ! calculate the elapsed time ! subroutines and functions: read dimensions (NOTE: NetCDF) @@ -207,7 +207,7 @@ subroutine summa_initialize(summa1_struc, err, message) if(STATE_PATH == '') then restartFile = trim(SETTINGS_PATH)//trim(MODEL_INITCOND) else - restartFile = trim(STATE_PATH)//trim(MODEL_INITCOND) + restartFile = trim(STATE_PATH)//trim(MODEL_INITCOND) endif call read_icond_nlayers(trim(restartFile),nGRU,indx_meta,err,cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return; endif @@ -244,7 +244,7 @@ subroutine summa_initialize(summa1_struc, err, message) case('bpar' ); call allocGlobal(bpar_meta, bparStruct, err, cmessage) ! basin-average parameters case('bvar' ); call allocGlobal(bvar_meta, bvarStruct, err, cmessage) ! basin-average variables case('lookup'); call allocGlobal(lookup_meta, lookupStruct, err, cmessage) ! basin-average variables - case('deriv' ); cycle + case('deriv' ); cycle ! derivatives are not stored in the data structure, but are instead computed on the fly and stored in local variables case default; err=20; message='unable to find structure name: '//trim(structInfo(iStruct)%structName) end select ! check errors diff --git a/build/source/driver/summa_modelRun.f90 b/build/source/driver/summa_modelRun.f90 index cee0e8ff7..47fb1f071 100644 --- a/build/source/driver/summa_modelRun.f90 +++ b/build/source/driver/summa_modelRun.f90 @@ -48,10 +48,10 @@ subroutine summa_runPhysics(modelTimeStep, summa1_struc, err, message) ! * desired modules ! --------------------------------------------------------------------------------------- ! data types - USE nrtype ! variable types, etc. + USE nr_type ! variable types, etc. USE summa_type, only:summa1_type_dec ! master summa data type ! subroutines and functions - USE nr_utility_module,only:indexx ! sort vectors in ascending order + USE nr_utils_module,only:indexx ! sort vectors in ascending order USE vegPhenlgy_module,only:vegPhenlgy ! module to compute vegetation phenology USE run_oneGRU_module,only:run_oneGRU ! module to run for one GRU USE time_utils_module,only:elapsedSec ! calculate the elapsed time diff --git a/build/source/driver/summa_restart.f90 b/build/source/driver/summa_restart.f90 index b5fdd5db9..9d93a58f1 100644 --- a/build/source/driver/summa_restart.f90 +++ b/build/source/driver/summa_restart.f90 @@ -44,7 +44,7 @@ subroutine summa_readRestart(summa1_struc, err, message) ! * desired modules ! --------------------------------------------------------------------------------------- ! data types - USE nrtype ! variable types, etc. + USE nr_type ! variable types, etc. USE summa_type, only:summa1_type_dec ! master summa data type ! functions and subroutines USE time_utils_module,only:elapsedSec ! calculate the elapsed time @@ -71,8 +71,8 @@ subroutine summa_readRestart(summa1_struc, err, message) ! look-up values for the choice of variable in energy equations (BE residual or IDA state variable) USE mDecisions_module,only:& closedForm, & ! use temperature with closed form heat capacity - enthalpyFormLU, & ! use enthalpy with soil temperature-enthalpy lookup tables - enthalpyForm ! use enthalpy with soil temperature-enthalpy analytical solution + enthalpyForm, & ! use enthalpy with soil temperature-enthalpy lookup tables + enthalpyFormAN ! use enthalpy with soil temperature-enthalpy analytical solution ! look-up values for the choice of full or empty aquifer at start USE mDecisions_module,only:& fullStart, & ! start with full aquifer @@ -113,8 +113,7 @@ subroutine summa_readRestart(summa1_struc, err, message) bvarStruct => summa1_struc%bvarStruct , & ! x%gru(:)%var(:)%dat -- basin-average variables ! miscellaneous variables dt_init => summa1_struc%dt_init , & ! used to initialize the length of the sub-step for each HRU - nGRU => summa1_struc%nGRU , & ! number of grouped response units - nHRU => summa1_struc%nHRU & ! number of global hydrologic response units + nGRU => summa1_struc%nGRU & ! number of grouped response units ) ! assignment to variables in the data structures ! --------------------------------------------------------------------------------------- @@ -149,8 +148,8 @@ subroutine summa_readRestart(summa1_struc, err, message) ! check initial conditions checkEnthalpy = .false. use_lookup = .false. - if(ixNrgConserv .ne. closedForm) checkEnthalpy = .true. ! check enthalpy either for mixed form energy equation or enthalpy state variable - if(ixNrgConserv==enthalpyFormLU) use_lookup = .true. ! use lookup tables for soil temperature-enthalpy instead of analytical solution + if(ixNrgConserv/=closedForm) checkEnthalpy = .true. ! check enthalpy either for mixed form energy equation or enthalpy state variable + if(ixNrgConserv==enthalpyForm) use_lookup = .true. ! use lookup tables for soil temperature-enthalpy instead of analytical solution call check_icond(nGRU, & ! intent(in): number of response units progStruct, & ! intent(inout): model prognostic variables diagStruct, & ! intent(inout): model diagnostic variables diff --git a/build/source/driver/summa_setup.f90 b/build/source/driver/summa_setup.f90 index a4d6593cf..e6772263b 100644 --- a/build/source/driver/summa_setup.f90 +++ b/build/source/driver/summa_setup.f90 @@ -45,8 +45,8 @@ module summa_setup ! look-up values for the choice of variable in energy equations (BE residual or IDA state variable) USE mDecisions_module,only:& closedForm, & ! use temperature with closed form heat capacity - enthalpyFormLU,& ! use enthalpy with soil temperature-enthalpy lookup tables - enthalpyForm ! use enthalpy with soil temperature-enthalpy analytical solution + enthalpyForm, & ! use enthalpy with soil temperature-enthalpy lookup tables + enthalpyFormAN ! use enthalpy with soil temperature-enthalpy analytical solution ! named variables to define the decisions for snow layers USE mDecisions_module,only:& @@ -69,10 +69,10 @@ subroutine summa_paramSetup(summa1_struc, err, message) ! --------------------------------------------------------------------------------------- ! * desired modules ! --------------------------------------------------------------------------------------- - USE nrtype ! variable types, etc. + USE nr_type ! variable types, etc. USE summa_type, only:summa1_type_dec ! master summa data type ! subroutines and functions - use time_utils_module,only:elapsedSec ! calculate the elapsed time + USE time_utils_module,only:elapsedSec ! calculate the elapsed time USE mDecisions_module,only:mDecisions ! module to read model decisions USE ffile_info_module,only:ffile_info ! module to read information on forcing datafile USE read_attrb_module,only:read_attrb ! module to read local attributes @@ -80,8 +80,8 @@ subroutine summa_paramSetup(summa1_struc, err, message) USE paramCheck_module,only:paramCheck ! module to check consistency of model parameters USE pOverwrite_module,only:pOverwrite ! module to overwrite default parameter values with info from the Noah tables USE read_param_module,only:read_param ! module to read model parameter sets - USE enthalpyTemp_module,only:T2H_lookup_snWat ! module to calculate a look-up table for the snow temperature-enthalpy conversion - USE enthalpyTemp_module,only:T2L_lookup_soil ! module to calculate a look-up table for the soil temperature-enthalpy conversion + USE convertEnthalpyTemp_module,only:T2H_lookup_snWat ! module to calculate a look-up table for the snow temperature-enthalpy conversion + USE convertEnthalpyTemp_module,only:T2L_lookup_soil ! module to calculate a look-up table for the soil temperature-enthalpy conversion USE var_derive_module,only:fracFuture ! module to calculate the fraction of runoff in future time steps (time delay histogram) USE module_sf_noahmplsm,only:read_mp_veg_parameters ! module to read NOAH vegetation tables ! global data structures @@ -94,9 +94,11 @@ subroutine summa_paramSetup(summa1_struc, err, message) USE globalData,only:startGRU ! index of the starting GRU for parallelization run USE globalData,only:checkHRU ! index of the HRU for a single HRU run USE globalData,only:iRunMode ! define the current running mode - ! output constraints +! output constraints USE globalData,only:maxLayers ! maximum number of layers + USE globalData,only:maxSoilLayers ! maximum number of soil layers USE globalData,only:maxSnowLayers ! maximum number of snow layers + USE globalData,only:maxSoilLayers ! maximum number of soil layers ! timing variables USE globalData,only:startSetup,endSetup ! date/time for the start and end of the parameter setup USE globalData,only:elapsedSetup ! elapsed time for the parameter setup @@ -180,7 +182,7 @@ subroutine summa_paramSetup(summa1_struc, err, message) ! decide if computing soil enthalpy lookup tables and vegetation enthalpy lookup tables needLookup_soil = .false. ! if need enthalpy for either energy backward Euler residual or IDA state variable and not using soil enthalpy hypergeometric function - if(model_decisions(iLookDECISIONS%nrgConserv)%iDecision == enthalpyFormLU) needLookup_soil = .true. + if(model_decisions(iLookDECISIONS%nrgConserv)%iDecision == enthalpyForm) needLookup_soil = .true. ! if using IDA and enthalpy as a state variable, need temperature-enthalpy lookup tables for soil and vegetation ! get the maximum number of snow layers @@ -191,7 +193,14 @@ subroutine summa_paramSetup(summa1_struc, err, message) end select ! (option to combine/sub-divide snow layers) ! get the maximum number of layers - maxLayers = gru_struc(1)%hruInfo(1)%nSoil + maxSnowLayers + maxLayers = 0 + maxSoilLayers = 0 + do iGRU=1,nGRU + do iHRU=1,gru_struc(iGRU)%hruCount + maxSoilLayers = max(maxSoilLayers, gru_struc(iGRU)%hruInfo(iHRU)%nSoil) + maxLayers = max(maxLayers, maxSnowLayers+gru_struc(iGRU)%hruInfo(iHRU)%nSoil) + end do + end do ! ***************************************************************************** ! *** read local attributes for each HRU @@ -212,7 +221,7 @@ subroutine summa_paramSetup(summa1_struc, err, message) select case(model_decisions(iLookDECISIONS%nrgConserv)%iDecision) case(closedForm) ! ida temperature state variable absEnergyFac = 1.e2_rkind ! energy state variable is 2 orders of magnitude larger than mass state variable - case(enthalpyFormLU,enthalpyForm) ! ida enthalpy state variable + case(enthalpyForm, enthalpyFormAN) ! ida enthalpy state variable absEnergyFac = 1.e7_rkind ! energy state variable is 7 orders of magnitude larger than mass state variable case default; err=20; message=trim(message)//'unable to identify option for energy conservation'; return end select ! (option for energy conservation) @@ -271,8 +280,8 @@ subroutine summa_paramSetup(summa1_struc, err, message) ! 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) + 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 @@ -361,10 +370,10 @@ subroutine summa_paramSetup(summa1_struc, err, message) ! identify the total basin area for a GRU (m2) associate(totalArea => bvarStruct%gru(iGRU)%var(iLookBVAR%basin__totalArea)%dat(1) ) - totalArea = 0._rkind - do iHRU=1,gru_struc(iGRU)%hruCount - totalArea = totalArea + attrStruct%gru(iGRU)%hru(iHRU)%var(iLookATTR%HRUarea) - end do + totalArea = 0._rkind + do iHRU=1,gru_struc(iGRU)%hruCount + totalArea = totalArea + attrStruct%gru(iGRU)%hru(iHRU)%var(iLookATTR%HRUarea) + end do end associate end do ! GRU diff --git a/build/source/driver/summa_type.f90 b/build/source/driver/summa_type.f90 index e1473642b..22f8fc273 100644 --- a/build/source/driver/summa_type.f90 +++ b/build/source/driver/summa_type.f90 @@ -23,7 +23,7 @@ MODULE summa_type ! ***************************************************************************** ! * higher-level derived data types ! ***************************************************************************** -USE nrtype ! variable types, etc. +USE nr_type ! variable types, etc. USE data_types,only:& ! no spatial dimension var_i, & ! x%var(:) (i4b) @@ -71,7 +71,7 @@ MODULE summa_type 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 - type(gru_hru_int8) :: idStruct ! x%gru(:)%hru(:)%var(:) -- + type(gru_hru_int8) :: idStruct ! x%gru(:)%hru(:)%var(:) -- local values of hru and gru IDs ! define the primary data structures (variable length vectors) type(gru_hru_intVec) :: indxStruct ! x%gru(:)%hru(:)%var(:)%dat -- model indices diff --git a/build/source/driver/summa_util.f90 b/build/source/driver/summa_util.f90 index c8dd55fd7..aae33104f 100644 --- a/build/source/driver/summa_util.f90 +++ b/build/source/driver/summa_util.f90 @@ -22,14 +22,14 @@ module summa_util ! utilities to manage summa simulation ! data types -USE nrtype ! high-level data types +USE nr_type ! high-level data types ! global data USE globalData,only:integerMissing ! missing integer value USE globalData,only:realMissing ! missing double precision value ! provide access to file IDs -USE globalData,only:ncid ! file id of netcdf output file +USE globalData,only:ncid ! file id of netcdf output file ! privacy implicit none diff --git a/build/source/driver/summa_writeOutput.f90 b/build/source/driver/summa_writeOutput.f90 index aa333eb45..768d9d4ef 100644 --- a/build/source/driver/summa_writeOutput.f90 +++ b/build/source/driver/summa_writeOutput.f90 @@ -18,13 +18,21 @@ ! You should have received a copy of the GNU General Public License ! along with this program. If not, see . -module summa_writeOutput -! used to define/write output files +module summa_writeOutput ! used to define/write output files ! named variables to define new output files USE globalData, only: noNewFiles ! no new output files USE globalData, only: newFileEveryOct1 ! create a new file on Oct 1 every year (start of the USA water year) +! model decisions +USE globalData,only:model_decisions ! model decision structure + +! provide access to global data +USE globalData,only:maxLayers ! maximum number of layers +USE globalData,only:nSpecBand ! number of spectral bands +USE globalData,only:nTimeDelay ! number of timesteps in the time delay histogram +USE globalData,only:allowRoutingOutput ! flag to allow routing variable output + ! metadata USE globalData,only:time_meta ! metadata on the model time USE globalData,only:forc_meta ! metadata on the model forcing data @@ -57,11 +65,33 @@ module summa_writeOutput USE var_lookup,only:iLookPROG ! named variables for local column model prognostic variables USE var_lookup,only:iLookINDEX ! named variables for local column index variables USE var_lookup,only:iLookFREQ ! named variables for the frequency structure +USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure +USE var_lookup,only:iLookVarType ! named variables for variable types + +! generic variable types +USE nr_type ! variable types, etc. +USE data_types,only:& + ! gru dimension + gru_double, & ! x%gru(:)%var(:) (dp) + ! gru+hru dimension + gru_hru_int, & ! x%gru(:)%hru(:)%var(:) (i4b) + gru_hru_double ! x%gru(:)%hru(:)%var(:) (dp) + +! metadata structure +USE data_types,only:var_info ! data type for metadata +USE data_types,only:extended_info ! data type for extended metadata +USE data_types,only:struct_info ! summary information on all data structures + +! model write options +USE mDecisions_module,only: & + writePerStep, & ! read forcing data per time step (default) + writeFullSeries ! read full forcing series ! safety: set private unless specified otherwise implicit none private public::summa_writeOutputFiles + contains ! used to define/write output files @@ -70,20 +100,23 @@ subroutine summa_writeOutputFiles(modelTimeStep, summa1_struc, err, message) ! * desired modules ! --------------------------------------------------------------------------------------- ! data types - USE nrtype ! variable types, etc. USE summa_type,only:summa1_type_dec ! master summa data type ! subroutines and functions USE time_utils_module,only:elapsedSec ! calculate the elapsed time + USE mDecisions_module,only:mDecisions ! module to read model decisions USE summa_alarms,only:summa_setWriteAlarms ! set alarms to control model output USE summa_defineOutput,only:summa_defineOutputFiles ! define summa output files - USE modelwrite_module,only:writeRestart ! module to write model Restart - USE modelwrite_module,only:writeData,writeBasin ! module to write model output + USE modelwrite_module,only:writeRestart ! module to write model restart + USE modelwrite_module,only:writeData_fullSeries ! module to write buffered model output + USE modelwrite_module,only:writeData_perStep ! module to write per-step model output USE modelwrite_module,only:writeTime ! module to write model time USE output_stats,only:calcStats ! module for compiling output statistics + USE get_ixname_module,only:get_ixFreq ! identify index of model output frequency ! global data: general USE globalData,only:forcingStep ! index of current time step in current forcing file USE globalData,only:gru_struc ! gru-hru mapping structures USE globalData,only:structInfo ! information on the data structures + USE globalData,only:fullIndxSave,fullForcSave,fullProgSave,fullDiagSave,fullFluxSave,fullBvarSave ! buffered output arrays ! global data: time structures USE globalData,only:oldTime ! time from the previous time step USE globalData,only:finshTime ! end time of simulation @@ -91,14 +124,13 @@ subroutine summa_writeOutputFiles(modelTimeStep, summa1_struc, err, message) USE globalData,only:ixProgress ! define frequency to write progress USE globalData,only:ixRestart ! define frequency to write restart files USE globalData,only:newOutputFile ! define option for new output files + ! buffered write + USE globalData,only:numtim ! number of time steps ! controls on statistics output USE globalData,only:statCounter ! time counter for stats USE globalData,only:resetStats ! flags to reset statistics USE globalData,only:finalizeStats ! flags to finalize statistics USE globalData,only:outputTimeStep ! timestep in output files - ! output constraints - USE globalData,only:maxLayers ! maximum number of layers - USE globalData,only:maxSnowLayers ! maximum number of snow layers ! timing variables USE globalData,only:startWrite,endWrite ! date/time for the start and end of the model writing USE globalData,only:elapsedWrite ! elapsed time to write data @@ -113,20 +145,26 @@ subroutine summa_writeOutputFiles(modelTimeStep, summa1_struc, err, message) ! --------------------------------------------------------------------------------------- implicit none ! dummy variables - integer(i4b),intent(in) :: modelTimeStep ! time step index - type(summa1_type_dec),intent(inout) :: summa1_struc ! master summa data structure - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + integer(i4b),intent(in) :: modelTimeStep ! time step index + type(summa1_type_dec),intent(inout) :: summa1_struc ! master summa data structure + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message ! local variables - character(LEN=256) :: cmessage ! error message of downwind routine - character(len=256) :: timeString ! portion of restart file name that contains the write-out time - character(len=256) :: restartFile ! restart file name - logical(lgt) :: printRestart=.false. ! flag to print a re-start file - logical(lgt) :: printProgress=.false. ! flag to print simulation progress - logical(lgt) :: defNewOutputFile=.false. ! flag to define new output files - integer(i4b) :: iGRU,iHRU ! indices of GRUs and HRUs - integer(i4b) :: iStruct ! index of model structure - integer(i4b) :: iFreq ! index of the output frequency + character(len=256) :: timeString ! portion of restart file name that contains the write-out time + character(len=256) :: restartFile ! restart file name + logical(lgt) :: printRestart=.false. ! flag to print a re-start file + logical(lgt) :: printProgress=.false. ! flag to print simulation progress + logical(lgt) :: defNewOutputFile=.false. ! flag to define new output files + logical(lgt) :: is_writingOutput=.false. ! flag to write model output + logical(lgt) :: is_bufferedWrite=.false. ! flag for buffered write + integer(i4b) :: iGRU,iHRU ! indices of GRUs and HRUs + integer(i4b) :: iVar ! index of variable in the data structure + integer(i4b) :: iStruct ! index of model structure + integer(i4b) :: iFreq ! index of the output frequency + integer(i4b) :: maxLengthAll ! maxLength all data writing + integer(i4b) :: maxWrite ! maximum number of time steps written + ! error control + character(LEN=256) :: cmessage ! error message of downwind routine ! --------------------------------------------------------------------------------------- ! associate to elements in the data structure summaVars: associate(& @@ -137,7 +175,7 @@ subroutine summa_writeOutputFiles(modelTimeStep, summa1_struc, err, message) diagStat => summa1_struc%diagStat , & ! x%gru(:)%hru(:)%var(:)%dat -- model diagnostic variables fluxStat => summa1_struc%fluxStat , & ! x%gru(:)%hru(:)%var(:)%dat -- model fluxes indxStat => summa1_struc%indxStat , & ! x%gru(:)%hru(:)%var(:)%dat -- model indices - bvarStat => summa1_struc%bvarStat , & ! x%gru(:)%var(:)%dat -- basin-average variabl + bvarStat => summa1_struc%bvarStat , & ! x%gru(:)%var(:)%dat -- basin-average variable ! primary data structures timeStruct => summa1_struc%timeStruct , & ! x%var(:) -- model time data @@ -156,7 +194,7 @@ subroutine summa_writeOutputFiles(modelTimeStep, summa1_struc, err, message) ! --------------------------------------------------------------------------------------- ! initialize error control err=0; message='summa_writeOutputFiles/' - + ! identify the start of the writing call date_and_time(values=startWrite) @@ -168,8 +206,8 @@ subroutine summa_writeOutputFiles(modelTimeStep, summa1_struc, err, message) if(modelTimeStep==1)then ! initialize time step index - statCounter(1:maxVarFreq) = 1 - outputTimeStep(1:maxVarFreq) = 1 + statCounter(1:maxvarFreq) = 1 + outputTimeStep(1:maxvarFreq) = 1 ! initialize flags to reset/finalize statistics resetStats(:) = .true. ! start by resetting statistics @@ -181,14 +219,43 @@ subroutine summa_writeOutputFiles(modelTimeStep, summa1_struc, err, message) ! initialize number of hru and gru in global data nGRUrun = nGRU nHRUrun = nHRU + endif ! if the first time step + ! ***************************************************************************** + ! *** initialize/populate data structures for the buffered write + ! ***************************************************************************** + + ! if a buffered write + if(model_decisions(iLookDECISIONS%write_buff)%iDecision == writeFullSeries)then + + ! initialize data structures for the buffered write + if(modelTimeStep == 1)then + call initBufferedWrite(structInfo,numtim,err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + endif ! (if the first time step) + + ! populate data structures + call popBufferStruct(structInfo,summa1_struc,modelTimeStep,err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! set the maximum number of data points to write + maxWrite = numtim + + else ! (if buffered write) + + ! standard case of write one data value per time step (not used) + maxWrite = 1 + + endif ! (if not buffered write) + ! ***************************************************************************** ! *** set alarms for writing data ! ***************************************************************************** ! set alarms to control model output - call summa_setWriteAlarms(oldTime%var, timeStruct%var, finshTime%var, & ! time vectors + call summa_setWriteAlarms(modelTimeStep, & ! time index + oldTime%var, timeStruct%var, finshTime%var, & ! time vectors newOutputFile, defNewOutputFile, & ! flag to define new output file ixRestart, printRestart, & ! flag to print the restart file ixProgress, printProgress, & ! flag to print simulation progress @@ -197,6 +264,21 @@ subroutine summa_writeOutputFiles(modelTimeStep, summa1_struc, err, message) err, cmessage) ! error control if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + ! identify the need to write output file + select case(model_decisions(iLookDECISIONS%write_buff)%iDecision) + case(writePerStep); is_writingOutput = .true. + case(writeFullSeries); is_writingOutput = (modelTimeStep == numtim) + case default + err=10; message=trim(message)//"unknown option for method used to write model output [option="//trim(model_decisions(iLookDECISIONS%write_buff)%cDecision)//"]"; return + end select + + ! find longest possible length + maxLengthAll = max(nSpecBand,maxLayers+1) + if(allowRoutingOutput) maxLengthAll = max(maxLengthAll, nTimeDelay) + + ! check if the buffered write + is_bufferedWrite = (model_decisions(iLookDECISIONS%write_buff)%iDecision == writeFullSeries .and. modelTimeStep == numtim) + ! print progress if(printProgress) write(*,'(i4,1x,5(i2,1x))') timeStruct%var(1:5) @@ -207,8 +289,8 @@ subroutine summa_writeOutputFiles(modelTimeStep, summa1_struc, err, message) ! check the need to create a new output file if(defNewOutputFile .or. modelTimeStep==1)then - ! define summa output files - call summa_defineOutputFiles(modelTimeStep, summa1_struc, err, cmessage) + ! define summa output files, also writes attr, type, mpar, and bpar which are constant + call summa_defineOutputFiles(modelTimeStep, model_decisions(iLookDECISIONS%write_buff)%iDecision == writeFullSeries, summa1_struc, err, cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! re-initialize the indices for model writing @@ -217,61 +299,88 @@ subroutine summa_writeOutputFiles(modelTimeStep, summa1_struc, err, message) end if ! if defining a new file ! **************************************************************************** - ! *** calculate output statistics + ! *** calculate output statistics if writing per step ! **************************************************************************** - ! loop through GRUs and HRUs - do iGRU=1,nGRU - do iHRU=1,gru_struc(iGRU)%hruCount - - ! calculate output Statistics - do iStruct=1,size(structInfo) - select case(trim(structInfo(iStruct)%structName)) - case('forc'); call calcStats(forcStat%gru(iGRU)%hru(iHRU)%var,forcStruct%gru(iGRU)%hru(iHRU)%var,statForc_meta,resetStats,finalizeStats,statCounter,err,cmessage) - case('prog'); call calcStats(progStat%gru(iGRU)%hru(iHRU)%var,progStruct%gru(iGRU)%hru(iHRU)%var,statProg_meta,resetStats,finalizeStats,statCounter,err,cmessage) - case('diag'); call calcStats(diagStat%gru(iGRU)%hru(iHRU)%var,diagStruct%gru(iGRU)%hru(iHRU)%var,statDiag_meta,resetStats,finalizeStats,statCounter,err,cmessage) - case('flux'); call calcStats(fluxStat%gru(iGRU)%hru(iHRU)%var,fluxStruct%gru(iGRU)%hru(iHRU)%var,statFlux_meta,resetStats,finalizeStats,statCounter,err,cmessage) - case('indx'); call calcStats(indxStat%gru(iGRU)%hru(iHRU)%var,indxStruct%gru(iGRU)%hru(iHRU)%var,statIndx_meta,resetStats,finalizeStats,statCounter,err,cmessage) - end select - if(err/=0)then; message=trim(message)//trim(cmessage)//'['//trim(structInfo(iStruct)%structName)//']'; return; endif - end do ! (looping through structures) - - end do ! (looping through HRUs) - - ! calc basin stats - call calcStats(bvarStat%gru(iGRU)%var(:),bvarStruct%gru(iGRU)%var(:),statBvar_meta,resetStats,finalizeStats,statCounter,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage)//'[bvar stats]'; return; endif + if(model_decisions(iLookDECISIONS%write_buff)%iDecision == writePerStep)then + ! loop through GRUs and HRUs + do iGRU=1,nGRU + do iHRU=1,gru_struc(iGRU)%hruCount + + ! calculate output statistics + do iStruct=1,size(structInfo) + select case(trim(structInfo(iStruct)%structName)) + case('forc'); call calcStats(forcStat%gru(iGRU)%hru(iHRU)%var,forcStruct%gru(iGRU)%hru(iHRU)%var,statForc_meta,resetStats,finalizeStats,statCounter,err,cmessage) + case('prog'); call calcStats(progStat%gru(iGRU)%hru(iHRU)%var,progStruct%gru(iGRU)%hru(iHRU)%var,statProg_meta,resetStats,finalizeStats,statCounter,err,cmessage) + case('diag'); call calcStats(diagStat%gru(iGRU)%hru(iHRU)%var,diagStruct%gru(iGRU)%hru(iHRU)%var,statDiag_meta,resetStats,finalizeStats,statCounter,err,cmessage) + case('flux'); call calcStats(fluxStat%gru(iGRU)%hru(iHRU)%var,fluxStruct%gru(iGRU)%hru(iHRU)%var,statFlux_meta,resetStats,finalizeStats,statCounter,err,cmessage) + case('indx'); call calcStats(indxStat%gru(iGRU)%hru(iHRU)%var,indxStruct%gru(iGRU)%hru(iHRU)%var,statIndx_meta,resetStats,finalizeStats,statCounter,err,cmessage) + end select + if(err/=0)then; message=trim(message)//trim(cmessage)//'['//trim(structInfo(iStruct)%structName)//']'; return; endif + end do ! (looping through structures) + end do ! (looping through HRUs) + + ! calculate basin stats + call calcStats(bvarStat%gru(iGRU)%var,bvarStruct%gru(iGRU)%var,statBvar_meta,resetStats,finalizeStats,statCounter,err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage)//'[bvar stats]'; return; endif + end do ! (looping through GRUs) + endif ! (if the writePerStep option) - ! write basin-average variables - call writeBasin(iGRU,finalizeStats,outputTimeStep,bvar_meta,bvarStat%gru(iGRU)%var,bvarStruct%gru(iGRU)%var,bvarChild_map,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage)//'[bvar]'; return; endif + ! **************************************************************************** + ! *** write integer time information + ! **************************************************************************** - end do ! (looping through GRUs) + ! NOTE: This is uncommon -- users rarely require integer time variables (iyyy, im, id, ...) because these can be retrieved from julday + ! NOTE: writing integer time variables is currently restricted to the writePerStep option + if(model_decisions(iLookDECISIONS%write_buff)%iDecision == writePerStep)then + call writeTime(finalizeStats,outputTimeStep,time_meta,timeStruct%var,err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + else + if(is_writingOutput .and. any(time_meta(:)%varDesire))then + do iVar = 1, size(time_meta) + if(time_meta(iVar)%varDesire)then + write(*,*)'WARNING: cannot output time structure data when using the buffered write option (writeFullSeries), skipping variable '//trim(time_meta(iVar)%varName) + endif + end do + endif + endif ! (if the writePerStep option) ! **************************************************************************** - ! *** write data + ! *** write model output to the NetCDF file ! **************************************************************************** + if(is_writingOutput)then + do iStruct=1,size(structInfo) ! loop means we can apply error code at the end - ! get the number of HRUs in the run domain - nHRUrun = sum(gru_struc%hruCount) + ! ----- write buffered data -------------------------------------------------- + if(is_bufferedWrite)then + ! write buffered data directly from full*Save arrays + select case(trim(structInfo(iStruct)%structName)) + case('indx'); call writeData_fullSeries(finalizeStats,maxWrite,indx_meta,fullIndxSave,indxChild_map,indxStruct,err,cmessage) + case('forc'); call writeData_fullSeries(finalizeStats,maxWrite,forc_meta,fullForcSave,forcChild_map,indxStruct,err,cmessage) + case('prog'); call writeData_fullSeries(finalizeStats,maxWrite,prog_meta,fullProgSave,progChild_map,indxStruct,err,cmessage) + case('diag'); call writeData_fullSeries(finalizeStats,maxWrite,diag_meta,fullDiagSave,diagChild_map,indxStruct,err,cmessage) + case('flux'); call writeData_fullSeries(finalizeStats,maxWrite,flux_meta,fullFluxSave,fluxChild_map,indxStruct,err,cmessage) + case('bvar'); call writeData_fullSeries(finalizeStats,maxWrite,bvar_meta,fullBvarSave,bvarChild_map,indxStruct,err,cmessage) + end select + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif - ! write time information - call writeTime(finalizeStats,outputTimeStep,time_meta,timeStruct%var,err,message) + ! ----- write data and statistics structures --------------------------------- + else + ! pass one-step data directly to the scalar writeData overload + select case(trim(structInfo(iStruct)%structName)) + case('indx'); call writeData_perStep(finalizeStats,outputTimeStep,maxLengthAll,indx_meta,indxStat,indxStruct,indxChild_map,indxStruct,err,cmessage) + case('forc'); call writeData_perStep(finalizeStats,outputTimeStep,maxLengthAll,forc_meta,forcStat,forcStruct,forcChild_map,indxStruct,err,cmessage) + case('prog'); call writeData_perStep(finalizeStats,outputTimeStep,maxLengthAll,prog_meta,progStat,progStruct,progChild_map,indxStruct,err,cmessage) + case('diag'); call writeData_perStep(finalizeStats,outputTimeStep,maxLengthAll,diag_meta,diagStat,diagStruct,diagChild_map,indxStruct,err,cmessage) + case('flux'); call writeData_perStep(finalizeStats,outputTimeStep,maxLengthAll,flux_meta,fluxStat,fluxStruct,fluxChild_map,indxStruct,err,cmessage) + case('bvar'); call writeData_perStep(finalizeStats,outputTimeStep,maxLengthAll,bvar_meta,bvarStat,bvarStruct,bvarChild_map,indxStruct,err,cmessage) + end select + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif - ! 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. - do iStruct=1,size(structInfo) - select case(trim(structInfo(iStruct)%structName)) - case('forc'); call writeData(finalizeStats,outputTimeStep,nHRUrun,maxLayers,forc_meta,forcStat,forcStruct,forcChild_map,indxStruct,err,cmessage) - case('prog'); call writeData(finalizeStats,outputTimeStep,nHRUrun,maxLayers,prog_meta,progStat,progStruct,progChild_map,indxStruct,err,cmessage) - case('diag'); call writeData(finalizeStats,outputTimeStep,nHRUrun,maxLayers,diag_meta,diagStat,diagStruct,diagChild_map,indxStruct,err,cmessage) - case('flux'); call writeData(finalizeStats,outputTimeStep,nHRUrun,maxLayers,flux_meta,fluxStat,fluxStruct,fluxChild_map,indxStruct,err,cmessage) - case('indx'); call writeData(finalizeStats,outputTimeStep,nHRUrun,maxLayers,indx_meta,indxStat,indxStruct,indxChild_map,indxStruct,err,cmessage) - end select - if(err/=0)then; message=trim(message)//trim(cmessage)//'['//trim(structInfo(iStruct)%structName)//']'; return; endif - end do ! (looping through structures) + endif ! (if buffered write) + + end do ! (looping through data structures) + endif ! (if writing output) ! ***************************************************************************** ! *** write restart file @@ -287,7 +396,7 @@ subroutine summa_writeOutputFiles(modelTimeStep, summa1_struc, err, message) restartFile=trim(STATE_PATH)//trim(OUTPUT_PREFIX)//'_restart_'//trim(timeString)//trim(output_fileSuffix)//'.nc' endif - call writeRestart(restartFile,nGRU,nHRU,prog_meta,progStruct,bvar_meta,bvarStruct,maxLayers,maxSnowLayers,indx_meta,indxStruct,err,cmessage) + call writeRestart(restartFile,nGRU,nHRU,prog_meta,progStruct,bvar_meta,bvarStruct,indx_meta,indxStruct,err,cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return; endif end if @@ -324,6 +433,174 @@ subroutine summa_writeOutputFiles(modelTimeStep, summa1_struc, err, message) end associate summaVars end subroutine summa_writeOutputFiles -end module summa_writeOutput + ! ***************************************************************************** + ! ***************************************************************************** + + ! private subroutine: initialize data structures for buffered write + subroutine initBufferedWrite(structInfo,numtim,err,message) + ! use modules + USE allocspace_module,only:allocGlobal ! module to allocate space + ! use global data + USE globalData,only:fullIndxSave ! x(:)%gru(:)%hru(:)%var(:) -- saved output for indices + USE globalData,only:fullForcSave ! x(:)%gru(:)%hru(:)%var(:) -- saved output for forcing + USE globalData,only:fullProgSave ! x(:)%gru(:)%hru(:)%var(:) -- saved output for prognostic variables + USE globalData,only:fullDiagSave ! x(:)%gru(:)%hru(:)%var(:) -- saved output for diagnostic variables + USE globalData,only:fullFluxSave ! x(:)%gru(:)%hru(:)%var(:) -- saved output for flux variables + USE globalData,only:fullBvarSave ! x(:)%gru(:)%var(:) -- saved output for basin variables + implicit none + ! dummy variables + type(struct_info) , intent(in) :: structInfo(:) ! information on the data structures + integer(i4b) , intent(in) :: numtim ! number of model time steps + integer(i4b) , intent(out) :: err ! error code + character(*) , intent(out) :: message ! error message + ! local variables -- temporary data structures + integer(i4b) :: iStruct ! index of data structure + type(gru_hru_int), allocatable :: tempIndx_struct ! Indx temp structure: x%gru(:)%hru(:)%var(:) (i4b) + type(gru_hru_double), allocatable :: tempForc_struct ! Forc temp structure: x%gru(:)%hru(:)%var(:) (rkind) + type(gru_hru_double), allocatable :: tempProg_struct ! Prog temp structure: x%gru(:)%hru(:)%var(:) (rkind) + type(gru_hru_double), allocatable :: tempDiag_struct ! Diag temp structure: x%gru(:)%hru(:)%var(:) (rkind) + type(gru_hru_double), allocatable :: tempFlux_struct ! Flux temp structure: x%gru(:)%hru(:)%var(:) (rkind) + type(gru_double), allocatable :: tempBvar_struct ! Bvar temp structure: x%gru(:)%hru(:)%var(:) (rkind) + ! error control + character(LEN=256) :: cmessage ! error message of downwind routine + ! --------------------------------------------------------------------------------------- + ! initialize error control + err=0; message='initBufferedWrite/' + + ! allocate space for local data structures + allocate(tempIndx_struct, tempForc_struct, tempProg_struct, tempDiag_struct, tempFlux_struct, tempBvar_struct, stat=err) + if(err/=0)then; err=20; message=trim(message)//'problem allocating temporary data structures'; return; endif + + ! allocate space for temporary data structuress + do iStruct=1,size(structInfo) ! loop means we can apply error code at the end + select case(trim(structInfo(iStruct)%structName)) + case('indx'); call allocGlobal(statIndx_meta%var_info, tempIndx_struct, err, cmessage) + case('forc'); call allocGlobal(statForc_meta%var_info, tempForc_struct, err, cmessage) + case('prog'); call allocGlobal(statProg_meta%var_info, tempProg_struct, err, cmessage) + case('diag'); call allocGlobal(statDiag_meta%var_info, tempDiag_struct, err, cmessage) + case('flux'); call allocGlobal(statFlux_meta%var_info, tempFlux_struct, err, cmessage) + case('bvar'); call allocGlobal(statBvar_meta%var_info, tempBvar_struct, err, cmessage) + end select + if(err/=0)then; err=20; message=trim(message)//trim(cmessage)//'['//trim(structInfo(iStruct)%structName)//']'; return; endif + end do ! (looping through structures) + + ! add a time dimension + do iStruct=1,size(structInfo) ! loop means we can apply error code at the end + select case(trim(structInfo(iStruct)%structName)) + case('indx'); allocate(fullIndxSave(numtim), source=tempIndx_struct, stat=err) + case('forc'); allocate(fullForcSave(numtim), source=tempForc_struct, stat=err) + case('prog'); allocate(fullProgSave(numtim), source=tempProg_struct, stat=err) + case('diag'); allocate(fullDiagSave(numtim), source=tempDiag_struct, stat=err) + case('flux'); allocate(fullFluxSave(numtim), source=tempFlux_struct, stat=err) + case('bvar'); allocate(fullBvarSave(numtim), source=tempBvar_struct, stat=err) + end select + if(err/=0)then; err=20; message=trim(message)//trim(cmessage)//'['//trim(structInfo(iStruct)%structName)//']'; return; endif + end do ! (looping through structues) + + ! deallocate space for data structures + deallocate(tempIndx_struct, tempForc_struct, tempProg_struct, tempDiag_struct, tempFlux_struct, tempBvar_struct, stat=err) + if(err/=0)then; err=20; message=trim(message)//'problem deallocating temporary data structures'; return; endif + + end subroutine initBufferedWrite + + ! ***************************************************************************** + ! ***************************************************************************** + ! private subroutine: populate data structures for buffered write + subroutine popBufferStruct(structInfo,summaStruct,iTime,err,message) + ! global data: structures for buffered write + USE globalData,only:fullIndxSave ! x(:)%gru(:)%hru(:)%var(:) -- saved output for indices + USE globalData,only:fullForcSave ! x(:)%gru(:)%hru(:)%var(:) -- saved output for forcing + USE globalData,only:fullProgSave ! x(:)%gru(:)%hru(:)%var(:) -- saved output for prognostic variables + USE globalData,only:fullDiagSave ! x(:)%gru(:)%hru(:)%var(:) -- saved output for diagnostic variables + USE globalData,only:fullFluxSave ! x(:)%gru(:)%hru(:)%var(:) -- saved output for flux variables + USE globalData,only:fullBvarSave ! x(:)%gru(:)%var(:) -- saved output for basin variables + ! global data: structures for GRU-HRU topology + USE globalData,only:gru_struc ! gru-hru mapping structures + ! derived types + USE summa_type,only:summa1_type_dec ! master summa data type + implicit none + ! input variables + type(struct_info) , intent(in) :: structInfo(:) ! information on the data structures + type(summa1_type_dec), intent(in) :: summaStruct ! master summa data structure + integer(i4b) , intent(in) :: iTime ! index of time (modelTimeStep) + ! output 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) :: iGRU ! index of GRU + integer(i4b) :: iHRU ! index of HRU + integer(i4b) :: iVar ! index of variable + integer(i4b) :: pVar ! index of "parent" variable (i.e., index in the data structure) + integer(i4b) :: nVar ! number of variables in the meta data structure + ! associate to elements in the data structure + ! ---------------------------------------------------------------------------------------------------------------------------- + ! primary data structures + summaAssociate: associate(& + indxStruct => summaStruct%indxStruct , & ! x%gru(:)%hru(:)%var(:)%dat -- model indices + forcStruct => summaStruct%forcStruct , & ! x%gru(:)%hru(:)%var(:) -- model forcing data + progStruct => summaStruct%progStruct , & ! x%gru(:)%hru(:)%var(:)%dat -- model prognostic (state) variables + diagStruct => summaStruct%diagStruct , & ! x%gru(:)%hru(:)%var(:)%dat -- model diagnostic variables + fluxStruct => summaStruct%fluxStruct , & ! x%gru(:)%hru(:)%var(:)%dat -- model fluxes + bvarStruct => summaStruct%bvarStruct , & ! x%gru(:)%var(:)%dat -- basin-average variables + nGRU => summaStruct%nGRU & + ) ! assignment to variables in the data structures + ! ------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message='popBufferStruct/' + + ! loop through data structures + do iStruct=1,size(structInfo) + + ! get variables desired in the output + select case(trim(structInfo(iStruct)%structName)) + case('indx'); nVar = size(statIndx_meta) + case('forc'); nVar = size(statForc_meta) + case('prog'); nVar = size(statProg_meta) + case('diag'); nVar = size(statDiag_meta) + case('flux'); nVar = size(statFlux_meta) + case('bvar'); nVar = size(statBvar_meta) + case default; cycle! restrict attention to the data structures that we are interested in + end select + + do iVar=1,nVar ! skip if size=0 + + ! get index in parent structure, don't do anything if var is not requested or not a scalar variable + select case(trim(structInfo(iStruct)%structName)) + case('indx'); if(.not.statIndx_meta(iVar)%varDesire .or. statIndx_meta(iVar)%varType/=iLookVarType%outstat) cycle; pVar = statIndx_meta(iVar)%ixParent + case('forc'); if(.not.statForc_meta(iVar)%varDesire .or. statForc_meta(iVar)%varType/=iLookVarType%outstat) cycle; pVar = statForc_meta(iVar)%ixParent + case('prog'); if(.not.statProg_meta(iVar)%varDesire .or. statProg_meta(iVar)%varType/=iLookVarType%outstat) cycle; pVar = statProg_meta(iVar)%ixParent + case('diag'); if(.not.statDiag_meta(iVar)%varDesire .or. statDiag_meta(iVar)%varType/=iLookVarType%outstat) cycle; pVar = statDiag_meta(iVar)%ixParent + case('flux'); if(.not.statFlux_meta(iVar)%varDesire .or. statFlux_meta(iVar)%varType/=iLookVarType%outstat) cycle; pVar = statFlux_meta(iVar)%ixParent + case('bvar'); if(.not.statBvar_meta(iVar)%varDesire .or. statBvar_meta(iVar)%varType/=iLookVarType%outstat) cycle; pVar = statBvar_meta(iVar)%ixParent + end select + + ! loop through GRUs and HRUs + do iGRU=1,nGRU + do iHRU=1,gru_struc(iGRU)%hruCount + ! populate GRU+HRU+DOM structures + select case(trim(structInfo(iStruct)%structName)) + case('indx'); fullIndxSave(iTime)%gru(iGRU)%hru(iHRU)%var(iVar) = indxStruct%gru(iGRU)%hru(iHRU)%var(pVar)%dat(1) + case('forc'); fullForcSave(iTime)%gru(iGRU)%hru(iHRU)%var(iVar) = forcStruct%gru(iGRU)%hru(iHRU)%var(pVar) + case('prog'); fullProgSave(iTime)%gru(iGRU)%hru(iHRU)%var(iVar) = progStruct%gru(iGRU)%hru(iHRU)%var(pVar)%dat(1) + case('diag'); fullDiagSave(iTime)%gru(iGRU)%hru(iHRU)%var(iVar) = diagStruct%gru(iGRU)%hru(iHRU)%var(pVar)%dat(1) + case('flux'); fullFluxSave(iTime)%gru(iGRU)%hru(iHRU)%var(iVar) = fluxStruct%gru(iGRU)%hru(iHRU)%var(pVar)%dat(1) + case('bvar') ! GRU-only data structure + if(iHRU==1) fullBvarSave(iTime)%gru(iGRU)%var(iVar) = bvarStruct%gru(iGRU)%var(pVar)%dat(1) + end select + end do ! (looping through HRUs) + end do ! (looping through GRUs) + + end do ! (looping through variables) + + end do ! (looping through structures) + + end associate summaAssociate + + end subroutine popBufferStruct + + ! ***************************************************************************** + ! ***************************************************************************** +end module summa_writeOutput \ No newline at end of file diff --git a/build/source/dshare/data_types.f90 b/build/source/dshare/data_types.f90 index df9a6f9ac..61dc1be88 100644 --- a/build/source/dshare/data_types.f90 +++ b/build/source/dshare/data_types.f90 @@ -20,7 +20,7 @@ MODULE data_types ! used to define model data structures - USE nrtype, integerMissing=>nr_integerMissing + USE nr_type, integerMissing=>nr_integerMissing USE var_lookup,only:maxvarFreq USE var_lookup,only:maxvarStat USE var_lookup,only:maxvarDecisions ! maximum number of decisions @@ -75,10 +75,10 @@ MODULE data_types ! *********************************************************************************************************** ! define derived type for model variables, including name, description, and units type,public :: var_info - character(len=64) :: varname = 'empty' ! variable name + character(len=64) :: varName = 'empty' ! variable name character(len=128) :: vardesc = 'empty' ! variable description character(len=64) :: varunit = 'empty' ! variable units - integer(i4b) :: vartype = integerMissing ! variable type + integer(i4b) :: varType = integerMissing ! variable type integer(i4b),dimension(maxvarFreq) :: ncVarID = integerMissing ! netcdf variable id (missing if frequency is not desired) integer(i4b),dimension(maxvarFreq) :: statIndex = integerMissing ! index of desired statistic for temporal aggregation logical(lgt) :: varDesire = .false. ! flag to denote if the variable is desired for model output @@ -156,7 +156,7 @@ MODULE data_types type, public :: gru_hru_z_vLookup type(hru_z_vLookup),allocatable :: gru(:) ! gru(:)%hru(:)%z(:)%var(:)%lookup(:) endtype gru_hru_z_vLookup - ! define derived types to hold multivariate data for a single variable (different variables have different length) + ! 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 @@ -230,10 +230,6 @@ MODULE data_types type, public :: hru_intVec type(var_ilength),allocatable :: hru(:) ! hru(:)%var(:)%dat endtype hru_intVec - ! ** integer type of variable length (8 byte) - type, public :: hru_int8Vec - type(var_i8length),allocatable :: hru(:) ! hru(:)%var(:)%dat - endtype hru_int8Vec ! ** double precision type of fixed length type, public :: hru_double type(var_d),allocatable :: hru(:) ! hru(:)%var(:) @@ -256,10 +252,6 @@ MODULE data_types type, public :: gru_intVec type(var_ilength),allocatable :: gru(:) ! gru(:)%var(:)%dat endtype gru_intVec - ! ** integer type of variable length (8 byte) - type, public :: gru_int8Vec - type(var_i8length),allocatable :: gru(:) ! gru(:)%var(:)%dat - endtype gru_int8Vec ! ** double precision type of fixed length type, public :: gru_double type(var_d),allocatable :: gru(:) ! gru(:)%var(:) @@ -282,10 +274,6 @@ MODULE data_types type, public :: gru_hru_intVec type(hru_intVec),allocatable :: gru(:) ! gru(:)%hru(:)%var(:)%dat endtype gru_hru_intVec - ! ** integer type of variable length (8 byte) - type, public :: gru_hru_int8Vec - type(hru_int8Vec),allocatable :: gru(:) ! gru(:)%hru(:)%var(:)%dat - endtype gru_hru_int8Vec ! ** double precision type of fixed length type, public :: gru_hru_double type(hru_double),allocatable :: gru(:) ! gru(:)%hru(:)%var(:) @@ -367,8 +355,8 @@ MODULE data_types end type out_type_vegNrgFlux ! ** end vegNrgFlux - ! ** ssdNrgFlux - type, public :: in_type_ssdNrgFlux ! class for intent(in) arguments in ssdNrgFlux call + ! ** snowSoilNrgFlux + type, public :: in_type_snowSoilNrgFlux ! class for intent(in) arguments in snowSoilNrgFlux call logical(lgt) :: scalarSolution ! intent(in): flag to denote if implementing the scalar solution real(rkind) :: scalarGroundNetNrgFlux ! intent(in): net energy flux for the ground surface (W m-2) real(rkind), allocatable :: iLayerLiqFluxSnow(:) ! intent(in): liquid flux at the interface of each snow layer (m s-1) @@ -379,17 +367,17 @@ MODULE data_types real(rkind), allocatable :: dThermalC_dTempAbove(:) ! intent(in): derivative in the thermal conductivity w.r.t. energy state in the layer above real(rkind), allocatable :: dThermalC_dTempBelow(:) ! intent(in): derivative in the thermal conductivity w.r.t. energy state in the layer above contains - procedure :: initialize => initialize_in_ssdNrgFlux - end type in_type_ssdNrgFlux + procedure :: initialize => initialize_in_snowSoilNrgFlux + end type in_type_snowSoilNrgFlux - type, public :: io_type_ssdNrgFlux ! class for intent(inout) arguments in ssdNrgFlux call + type, public :: io_type_snowSoilNrgFlux ! class for intent(inout) arguments in snowSoilNrgFlux call real(rkind) :: dGroundNetFlux_dGroundTemp ! intent(inout): derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) contains - procedure :: initialize => initialize_io_ssdNrgFlux - procedure :: finalize => finalize_io_ssdNrgFlux - end type io_type_ssdNrgFlux + procedure :: initialize => initialize_io_snowSoilNrgFlux + procedure :: finalize => finalize_io_snowSoilNrgFlux + end type io_type_snowSoilNrgFlux - type, public :: out_type_ssdNrgFlux ! class for intent(inout) arguments in ssdNrgFlux call + type, public :: out_type_snowSoilNrgFlux ! class for intent(inout) arguments in snowSoilNrgFlux call real(rkind), allocatable :: iLayerNrgFlux(:) ! intent(out): energy flux at the layer interfaces (W m-2) real(rkind), allocatable :: dNrgFlux_dTempAbove(:) ! intent(out): derivatives in the flux w.r.t. temperature in the layer above (J m-2 s-1 K-1) real(rkind), allocatable :: dNrgFlux_dTempBelow(:) ! intent(out): derivatives in the flux w.r.t. temperature in the layer below (J m-2 s-1 K-1) @@ -398,9 +386,9 @@ MODULE data_types integer(i4b) :: err ! intent(out): error code character(len=len_msg) :: cmessage ! intent(out): error message contains - procedure :: finalize => finalize_out_ssdNrgFlux - end type out_type_ssdNrgFlux - ! ** end ssdNrgFlux + procedure :: finalize => finalize_out_snowSoilNrgFlux + end type out_type_snowSoilNrgFlux + ! ** end snowSoilNrgFlux ! ** vegLiqFlux type, public :: in_type_vegLiqFlux ! class for intent(in) arguments in vegLiqFlux call @@ -423,8 +411,8 @@ MODULE data_types end type out_type_vegLiqFlux ! ** end vegLiqFlux - ! ** snowLiqFlx - type, public :: in_type_snowLiqFlx ! class for intent(in) arguments in snowLiqFlx call + ! ** snowLiqFlux + type, public :: in_type_snowLiqFlux ! class for intent(in) arguments in snowLiqFlux call integer(i4b) :: nSnow ! intent(in): number of snow layers logical(lgt) :: firstFluxCall ! intent(in): the first flux call (compute variables that are constant over the iterations) logical(lgt) :: scalarSolution ! intent(in): flag to indicate the scalar solution @@ -432,27 +420,27 @@ MODULE data_types real(rkind) :: scalarCanopyLiqDrainage ! intent(in): liquid drainage from the vegetation canopy (kg m-2 s-1) real(rkind), allocatable :: mLayerVolFracLiqTrial(:) ! intent(in): trial value of volumetric fraction of liquid water at the current iteration (-) contains - procedure :: initialize => initialize_in_snowLiqFlx - end type in_type_snowLiqFlx + procedure :: initialize => initialize_in_snowLiqFlux + end type in_type_snowLiqFlux - type, public :: io_type_snowLiqFlx ! class for intent(inout) arguments in snowLiqFlx call + type, public :: io_type_snowLiqFlux ! class for intent(inout) arguments in snowLiqFlux call real(rkind), allocatable :: iLayerLiqFluxSnow(:) ! intent(inout): vertical liquid water flux at layer interfaces (m s-1) real(rkind), allocatable :: iLayerLiqFluxSnowDeriv(:) ! intent(inout): derivative in vertical liquid water flux at layer interfaces (m s-1) contains - procedure :: initialize => initialize_io_snowLiqFlx - procedure :: finalize => finalize_io_snowLiqFlx - end type io_type_snowLiqFlx + procedure :: initialize => initialize_io_snowLiqFlux + procedure :: finalize => finalize_io_snowLiqFlux + end type io_type_snowLiqFlux - type, public :: out_type_snowLiqFlx ! class for intent(out) arguments in snowLiqFlx call + type, public :: out_type_snowLiqFlux ! class for intent(out) arguments in snowLiqFlux call integer(i4b) :: err ! intent(out): error code character(len=len_msg) :: cmessage ! intent(out): error message contains - procedure :: finalize => finalize_out_snowLiqFlx - end type out_type_snowLiqFlx - ! ** end snowLiqFlx + procedure :: finalize => finalize_out_snowLiqFlux + end type out_type_snowLiqFlux + ! ** end snowLiqFlux - ! ** soilLiqFlx - type, public :: in_type_soilLiqFlx ! class for intent(in) arguments in soilLiqFlx call + ! ** soilLiqFlux + type, public :: in_type_soilLiqFlux ! class for intent(in) arguments in soilLiqFlux call integer(i4b) :: nSoil ! intent(in): number of soil layers logical(lgt) :: firstSplitOper ! intent(in): flag indicating first flux call in a splitting operation logical(lgt) :: scalarSolution ! intent(in): flag to indicate the scalar solution @@ -472,10 +460,10 @@ MODULE data_types real(rkind) :: scalarGroundEvaporation ! intent(in): ground evaporation (kg m-2 s-1) real(rkind) :: scalarRainPlusMelt ! intent(in): rain plus melt (m s-1) contains - procedure :: initialize => initialize_in_soilLiqFlx - end type in_type_soilLiqFlx + procedure :: initialize => initialize_in_soilLiqFlux + end type in_type_soilLiqFlux - type, public :: io_type_soilLiqFlx ! class for intent(inout) arguments in soilLiqFlx call + type, public :: io_type_soilLiqFlux ! class for intent(inout) arguments in soilLiqFlux call real(rkind) :: scalarMaxInfilRate ! intent(inout): maximum infiltration rate (m s-1) real(rkind) :: scalarInfilArea ! intent(inout): fraction of area where water can infiltrate, may be frozen (-) real(rkind) :: scalarSaturatedArea ! intent(inout): fraction of area that is considered saturated (-) @@ -502,17 +490,17 @@ MODULE data_types real(rkind), allocatable :: mLayerdTrans_dTGround(:) ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. ground temperature real(rkind), allocatable :: mLayerdTrans_dCanWat(:) ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. canopy total water contains - procedure :: initialize => initialize_io_soilLiqFlx - procedure :: finalize => finalize_io_soilLiqFlx - end type io_type_soilLiqFlx + procedure :: initialize => initialize_io_soilLiqFlux + procedure :: finalize => finalize_io_soilLiqFlux + end type io_type_soilLiqFlux - type, public :: out_type_soilLiqFlx ! class for intent(out) arguments in soilLiqFlx call + type, public :: out_type_soilLiqFlux ! class for intent(out) arguments in soilLiqFlux call integer(i4b) :: err ! intent(out): error code character(len=len_msg) :: cmessage ! intent(out): error message contains - procedure :: finalize => finalize_out_soilLiqFlx - end type out_type_soilLiqFlx - ! ** end soilLiqFlx + procedure :: finalize => finalize_out_soilLiqFlux + end type out_type_soilLiqFlux + ! ** end soilLiqFlux ! ** groundwatr type, public :: in_type_groundwatr ! class for intent(in) arguments in groundwatr call @@ -580,7 +568,7 @@ MODULE data_types ! ** end bigAquifer ! *********************************************************************************************************** - ! Define classes used to simplify calls to the subroutines in soilLiqFlx + ! Define classes used to simplify calls to the subroutines in soilLiqFlux ! *********************************************************************************************************** ! ** diagv_node @@ -631,8 +619,8 @@ MODULE data_types end type out_type_diagv_node ! ** end diagv_node - ! ** surfaceFlx - type, public :: in_type_surfaceFlx ! intent(in) data + ! ** surfaceFlux + type, public :: in_type_surfaceFlux ! intent(in) data ! input: model control logical(lgt) :: firstSplitOper ! flag indicating if desire to compute infiltration integer(i4b) :: ixRichards ! index defining the option for Richards' equation (moisture or mixdform) @@ -687,10 +675,10 @@ MODULE data_types real(rkind) :: FUSE_mu ! FUSE TOPMODEL mu distribution lambda parameter real(rkind) :: FUSE_n ! FUSE TOPMODEL exponent contains - procedure :: initialize => initialize_in_surfaceFlx - end type in_type_surfaceFlx + procedure :: initialize => initialize_in_surfaceFlux + end type in_type_surfaceFlux - type, public :: io_type_surfaceFlx ! intent(inout) data + type, public :: io_type_surfaceFlux ! intent(inout) data ! input-output: hydraulic conductivity and diffusivity at the surface ! NOTE: intent(inout) because infiltration may only be computed for the first iteration real(rkind) :: surfaceHydCond ! hydraulic conductivity (m s-1) @@ -702,11 +690,11 @@ MODULE data_types real(rkind) :: scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) real(rkind) :: scalarSoilControl ! soil control on infiltration for derivative contains - procedure :: initialize => initialize_io_surfaceFlx - procedure :: finalize => finalize_io_surfaceFlx - end type io_type_surfaceFlx + procedure :: initialize => initialize_io_surfaceFlux + procedure :: finalize => finalize_io_surfaceFlux + end type io_type_surfaceFlux - type, public :: out_type_surfaceFlx ! intent(out) data + type, public :: out_type_surfaceFlux ! intent(out) data ! output: runoff and infiltration real(rkind) :: scalarSurfaceRunoff ! surface runoff (m s-1) real(rkind) :: scalarSurfaceRunoff_IE ! infiltration excess surface runoff (m s-1) @@ -719,9 +707,9 @@ MODULE data_types integer(i4b) :: err ! error code character(len=len_msg) :: message ! error message contains - procedure :: finalize => finalize_out_surfaceFlx - end type out_type_surfaceFlx - ! ** end surfaceFlx + procedure :: finalize => finalize_out_surfaceFlux + end type out_type_surfaceFlux + ! ** end surfaceFlux ! ** iLayerFlux type, public :: in_type_iLayerFlux ! intent(in) data @@ -891,7 +879,7 @@ MODULE data_types ! ** end varSubstep ! *********************************************************************************************************** - ! Define classes used to simplify calls to the subroutines in summaSolve4homegrown + ! Define classes used to simplify calls to the subroutines in summaSolv4homegrown ! *********************************************************************************************************** type, public :: in_type_computJacob ! class for intent(in) arguments in computJacob call @@ -936,7 +924,7 @@ MODULE data_types ! Define classes used to simplify calls to the subroutines in systemSolv ! *********************************************************************************************************** - type, public :: in_type_summaSolve4homegrown ! class for intent(in) arguments in summaSolve4homegrown call + type, public :: in_type_summaSolv4homegrown ! class for intent(in) arguments in summaSolv4homegrown call real(rkind) :: dt_cur ! intent(in): current stepsize real(rkind) :: dt ! intent(in): entire time step for drainage pond rate integer(i4b) :: iter ! intent(in): iteration index @@ -951,26 +939,26 @@ MODULE data_types logical(lgt) :: scalarSolution ! intent(in): flag to denote if implementing the scalar solution real(rkind) :: fOld ! intent(in): old function evaluation contains - procedure :: initialize => initialize_in_summaSolve4homegrown - end type in_type_summaSolve4homegrown + procedure :: initialize => initialize_in_summaSolv4homegrown + end type in_type_summaSolv4homegrown - type, public :: io_type_summaSolve4homegrown ! class for intent(inout) arguments in summaSolve4homegrown call + type, public :: io_type_summaSolv4homegrown ! class for intent(inout) arguments in summaSolv4homegrown call logical(lgt) :: firstFluxCall ! intent(inout): flag to indicate if we are processing the first flux call real(rkind) :: xMin,xMax ! intent(inout): brackets of the root integer(i4b) :: ixSaturation ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) contains - procedure :: initialize => initialize_io_summaSolve4homegrown - procedure :: finalize => finalize_io_summaSolve4homegrown - end type io_type_summaSolve4homegrown + procedure :: initialize => initialize_io_summaSolv4homegrown + procedure :: finalize => finalize_io_summaSolv4homegrown + end type io_type_summaSolv4homegrown - type, public :: out_type_summaSolve4homegrown ! class for intent(out) arguments in summaSolve4homegrown call + type, public :: out_type_summaSolv4homegrown ! class for intent(out) arguments in summaSolv4homegrown call real(rkind) :: fNew ! intent(out): new function evaluation logical(lgt) :: converged ! intent(out): convergence flag integer(i4b) :: err ! intent(out): error code character(len=len_msg) :: message ! intent(out): error message contains - procedure :: finalize => finalize_out_summaSolve4homegrown - end type out_type_summaSolve4homegrown + procedure :: finalize => finalize_out_summaSolv4homegrown + end type out_type_summaSolv4homegrown contains @@ -1013,7 +1001,7 @@ subroutine finalize_out_vegNrgFlux(out_vegNrgFlux,flux_data,deriv_data,err,cmess type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: cmessage ! error message from ssdNrgFlux + character(*),intent(out) :: cmessage ! error message from snowSoilNrgFlux ! intent(out) arguments: evapotranspiration values and net energy fluxes associate(& @@ -1095,9 +1083,9 @@ subroutine finalize_out_vegNrgFlux(out_vegNrgFlux,flux_data,deriv_data,err,cmess end subroutine finalize_out_vegNrgFlux ! **** end vegNrgFlux **** - ! **** ssdNrgFlux **** - subroutine initialize_in_ssdNrgFlux(in_ssdNrgFlux,scalarSolution,firstFluxCall,mLayerTempTrial,flux_data,deriv_data) - class(in_type_ssdNrgFlux),intent(out) :: in_ssdNrgFlux ! class object for intent(in) ssdNrgFlux arguments + ! **** snowSoilNrgFlux **** + subroutine initialize_in_snowSoilNrgFlux(in_snowSoilNrgFlux,scalarSolution,firstFluxCall,mLayerTempTrial,flux_data,deriv_data) + class(in_type_snowSoilNrgFlux),intent(out) :: in_snowSoilNrgFlux ! class object for intent(in) snowSoilNrgFlux arguments logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution logical(lgt),intent(in) :: firstFluxCall ! flag to indicate if we are processing the first flux call real(rkind),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) @@ -1112,44 +1100,44 @@ subroutine initialize_in_ssdNrgFlux(in_ssdNrgFlux,scalarSolution,firstFluxCall,m dThermalC_dTempAbove => deriv_data%var(iLookDERIV%dThermalC_dTempAbove)%dat, & ! intent(in): [dp(:)] derivative in the thermal conductivity w.r.t. energy state in the layer above dThermalC_dTempBelow => deriv_data%var(iLookDERIV%dThermalC_dTempBelow)%dat ) ! intent(in): [dp(:)] derivative in the thermal conductivity w.r.t. energy state in the layer above ! intent(in) arguments - in_ssdNrgFlux % scalarSolution=scalarSolution .and. .not.firstFluxCall ! intent(in): flag to denote if implementing the scalar solution - in_ssdNrgFlux % scalarGroundNetNrgFlux=scalarGroundNetNrgFlux ! intent(in): net energy flux for the ground surface (W m-2) - in_ssdNrgFlux % iLayerLiqFluxSnow=iLayerLiqFluxSnow ! intent(in): liquid flux at the interface of each snow layer (m s-1) - in_ssdNrgFlux % iLayerLiqFluxSoil=iLayerLiqFluxSoil ! intent(in): liquid flux at the interface of each soil layer (m s-1) - in_ssdNrgFlux % mLayerTempTrial=mLayerTempTrial ! intent(in): temperature in each layer at the current iteration (m) - in_ssdNrgFlux % dThermalC_dWatAbove=dThermalC_dWatAbove ! intent(in): derivative in the thermal conductivity w.r.t. water state in the layer above - in_ssdNrgFlux % dThermalC_dWatBelow=dThermalC_dWatBelow ! intent(in): derivative in the thermal conductivity w.r.t. water state in the layer above - in_ssdNrgFlux % dThermalC_dTempAbove=dThermalC_dTempAbove ! intent(in): derivative in the thermal conductivity w.r.t. energy state in the layer above - in_ssdNrgFlux % dThermalC_dTempBelow=dThermalC_dTempBelow ! intent(in): derivative in the thermal conductivity w.r.t. energy state in the layer above + in_snowSoilNrgFlux % scalarSolution=scalarSolution .and. .not.firstFluxCall ! intent(in): flag to denote if implementing the scalar solution + in_snowSoilNrgFlux % scalarGroundNetNrgFlux=scalarGroundNetNrgFlux ! intent(in): net energy flux for the ground surface (W m-2) + in_snowSoilNrgFlux % iLayerLiqFluxSnow=iLayerLiqFluxSnow ! intent(in): liquid flux at the interface of each snow layer (m s-1) + in_snowSoilNrgFlux % iLayerLiqFluxSoil=iLayerLiqFluxSoil ! intent(in): liquid flux at the interface of each soil layer (m s-1) + in_snowSoilNrgFlux % mLayerTempTrial=mLayerTempTrial ! intent(in): temperature in each layer at the current iteration (m) + in_snowSoilNrgFlux % dThermalC_dWatAbove=dThermalC_dWatAbove ! intent(in): derivative in the thermal conductivity w.r.t. water state in the layer above + in_snowSoilNrgFlux % dThermalC_dWatBelow=dThermalC_dWatBelow ! intent(in): derivative in the thermal conductivity w.r.t. water state in the layer above + in_snowSoilNrgFlux % dThermalC_dTempAbove=dThermalC_dTempAbove ! intent(in): derivative in the thermal conductivity w.r.t. energy state in the layer above + in_snowSoilNrgFlux % dThermalC_dTempBelow=dThermalC_dTempBelow ! intent(in): derivative in the thermal conductivity w.r.t. energy state in the layer above end associate - end subroutine initialize_in_ssdNrgFlux + end subroutine initialize_in_snowSoilNrgFlux - subroutine initialize_io_ssdNrgFlux(io_ssdNrgFlux,deriv_data) - class(io_type_ssdNrgFlux),intent(out) :: io_ssdNrgFlux ! class object for intent(inout) ssdNrgFlux arguments + subroutine initialize_io_snowSoilNrgFlux(io_snowSoilNrgFlux,deriv_data) + class(io_type_snowSoilNrgFlux),intent(out) :: io_snowSoilNrgFlux ! class object for intent(inout) snowSoilNrgFlux arguments type(var_dlength),intent(in) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables associate(& dGroundNetFlux_dGroundTemp => deriv_data%var(iLookDERIV%dGroundNetFlux_dGroundTemp)%dat(1) ) ! intent(out): [dp] derivative in net ground flux w.r.t. ground temperature ! intent(inout) arguments - io_ssdNrgFlux % dGroundNetFlux_dGroundTemp=dGroundNetFlux_dGroundTemp ! intent(inout): derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) + io_snowSoilNrgFlux % dGroundNetFlux_dGroundTemp=dGroundNetFlux_dGroundTemp ! intent(inout): derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) end associate - end subroutine initialize_io_ssdNrgFlux + end subroutine initialize_io_snowSoilNrgFlux - subroutine finalize_io_ssdNrgFlux(io_ssdNrgFlux,deriv_data) - class(io_type_ssdNrgFlux),intent(in) :: io_ssdNrgFlux ! class object for intent(inout) ssdNrgFlux arguments + subroutine finalize_io_snowSoilNrgFlux(io_snowSoilNrgFlux,deriv_data) + class(io_type_snowSoilNrgFlux),intent(in) :: io_snowSoilNrgFlux ! class object for intent(inout) snowSoilNrgFlux arguments type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables associate(& dGroundNetFlux_dGroundTemp => deriv_data%var(iLookDERIV%dGroundNetFlux_dGroundTemp)%dat(1) ) ! intent(out): [dp] derivative in net ground flux w.r.t. ground temperature ! intent(inout) arguments - dGroundNetFlux_dGroundTemp=io_ssdNrgFlux % dGroundNetFlux_dGroundTemp ! intent(inout): derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) + dGroundNetFlux_dGroundTemp=io_snowSoilNrgFlux % dGroundNetFlux_dGroundTemp ! intent(inout): derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) end associate - end subroutine finalize_io_ssdNrgFlux + end subroutine finalize_io_snowSoilNrgFlux - subroutine finalize_out_ssdNrgFlux(out_ssdNrgFlux,flux_data,deriv_data,err,cmessage) - class(out_type_ssdNrgFlux),intent(in) :: out_ssdNrgFlux ! class object for intent(out) ssdNrgFlux arguments + subroutine finalize_out_snowSoilNrgFlux(out_snowSoilNrgFlux,flux_data,deriv_data,err,cmessage) + class(out_type_snowSoilNrgFlux),intent(in) :: out_snowSoilNrgFlux ! class object for intent(out) snowSoilNrgFlux arguments type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: cmessage ! error message from ssdNrgFlux + character(*),intent(out) :: cmessage ! error message from snowSoilNrgFlux associate(& iLayerNrgFlux => flux_data%var(iLookFLUX%iLayerNrgFlux)%dat, & ! intent(out): [dp(0:)] vertical energy flux at the interface of snow and soil layers dNrgFlux_dTempAbove => deriv_data%var(iLookDERIV%dNrgFlux_dTempAbove)%dat, & ! intent(out): [dp(:)] derivatives in the flux w.r.t. temperature in the layer above @@ -1157,16 +1145,16 @@ subroutine finalize_out_ssdNrgFlux(out_ssdNrgFlux,flux_data,deriv_data,err,cmess dNrgFlux_dWatAbove => deriv_data%var(iLookDERIV%dNrgFlux_dWatAbove)%dat, & ! intent(out): [dp(:)] derivatives in the flux w.r.t. water state in the layer above dNrgFlux_dWatBelow => deriv_data%var(iLookDERIV%dNrgFlux_dWatBelow)%dat ) ! intent(out): [dp(:)] derivatives in the flux w.r.t. water state in the layer below ! intent(out) arguments - iLayerNrgFlux =out_ssdNrgFlux % iLayerNrgFlux ! intent(out): energy flux at the layer interfaces (W m-2) - dNrgFlux_dTempAbove=out_ssdNrgFlux % dNrgFlux_dTempAbove ! intent(out): derivatives in the flux w.r.t. temperature in the layer above (J m-2 s-1 K-1) - dNrgFlux_dTempBelow=out_ssdNrgFlux % dNrgFlux_dTempBelow ! intent(out): derivatives in the flux w.r.t. temperature in the layer below (J m-2 s-1 K-1) - dNrgFlux_dWatAbove =out_ssdNrgFlux % dNrgFlux_dWatAbove ! intent(out): derivatives in the flux w.r.t. water state in the layer above (J m-2 s-1 K-1) - dNrgFlux_dWatBelow =out_ssdNrgFlux % dNrgFlux_dWatBelow ! intent(out): derivatives in the flux w.r.t. water state in the layer below (J m-2 s-1 K-1) - err =out_ssdNrgFlux % err ! intent(out): error code - cmessage =out_ssdNrgFlux % cmessage ! intent(out): error message + iLayerNrgFlux =out_snowSoilNrgFlux % iLayerNrgFlux ! intent(out): energy flux at the layer interfaces (W m-2) + dNrgFlux_dTempAbove=out_snowSoilNrgFlux % dNrgFlux_dTempAbove ! intent(out): derivatives in the flux w.r.t. temperature in the layer above (J m-2 s-1 K-1) + dNrgFlux_dTempBelow=out_snowSoilNrgFlux % dNrgFlux_dTempBelow ! intent(out): derivatives in the flux w.r.t. temperature in the layer below (J m-2 s-1 K-1) + dNrgFlux_dWatAbove =out_snowSoilNrgFlux % dNrgFlux_dWatAbove ! intent(out): derivatives in the flux w.r.t. water state in the layer above (J m-2 s-1 K-1) + dNrgFlux_dWatBelow =out_snowSoilNrgFlux % dNrgFlux_dWatBelow ! intent(out): derivatives in the flux w.r.t. water state in the layer below (J m-2 s-1 K-1) + err =out_snowSoilNrgFlux % err ! intent(out): error code + cmessage =out_snowSoilNrgFlux % cmessage ! intent(out): error message end associate - end subroutine finalize_out_ssdNrgFlux - ! **** end ssdNrgFlux **** + end subroutine finalize_out_snowSoilNrgFlux + ! **** end snowSoilNrgFlux **** ! **** vegLiqFlux **** subroutine initialize_in_vegLiqFlux(in_vegLiqFlux,computeVegFlux,scalarCanopyLiqTrial,flux_data) @@ -1204,103 +1192,103 @@ subroutine finalize_out_vegLiqFlux(out_vegLiqFlux,flux_data,deriv_data,err,cmess end subroutine finalize_out_vegLiqFlux ! **** end vegLiqFlux **** - ! **** snowLiqFlx **** - subroutine initialize_in_snowLiqFlx(in_snowLiqFlx,nSnow,firstFluxCall,scalarSolution,mLayerVolFracLiqTrial,flux_data) - class(in_type_snowLiqFlx),intent(out) :: in_snowLiqFlx ! class object for intent(in) snowLiqFlx arguments + ! **** snowLiqFlux **** + subroutine initialize_in_snowLiqFlux(in_snowLiqFlux,nSnow,firstFluxCall,scalarSolution,mLayerVolFracLiqTrial,flux_data) + class(in_type_snowLiqFlux),intent(out) :: in_snowLiqFlux ! class object for intent(in) snowLiqFlux arguments integer(i4b),intent(in) :: nSnow ! number of snow layers logical(lgt),intent(in) :: firstFluxCall ! flag to indicate if we are processing the first flux call logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution real(rkind),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU associate(& - scalarThroughfallRain => flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1), & ! intent(out): [dp] rain that reaches the ground without ever touching the canopy (kg m-2 s-1) - scalarCanopyLiqDrainage => flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1)) ! intent(out): [dp] drainage of liquid water from the vegetation canopy (kg m-2 s-1) + scalarThroughfallRain => flux_data%var(iLookFLUX%scalarThroughfallRain)%dat(1), & ! intent(out): [dp] rain that reaches the ground without ever touching the canopy (kg m-2 s-1) + scalarCanopyLiqDrainage => flux_data%var(iLookFLUX%scalarCanopyLiqDrainage)%dat(1)) ! intent(out): [dp] drainage of liquid water from the vegetation canopy (kg m-2 s-1) ! intent(in) arguments - in_snowLiqFlx % nSnow =nSnow ! intent(in): number of snow layers - in_snowLiqFlx % firstFluxCall =firstFluxCall ! intent(in): the first flux call (compute variables that are constant over the iterations) - in_snowLiqFlx % scalarSolution =(scalarSolution .and. .not.firstFluxCall) ! intent(in): flag to indicate the scalar solution - in_snowLiqFlx % scalarThroughfallRain =scalarThroughfallRain ! intent(in): rain that reaches the snow surface without ever touching vegetation (kg m-2 s-1) - in_snowLiqFlx % scalarCanopyLiqDrainage=scalarCanopyLiqDrainage ! intent(in): liquid drainage from the vegetation canopy (kg m-2 s-1) - in_snowLiqFlx % mLayerVolFracLiqTrial =mLayerVolFracLiqTrial(1:nSnow) ! intent(in): trial value of volumetric fraction of liquid water at the current iteration (-) + in_snowLiqFlux % nSnow =nSnow ! intent(in): number of snow layers + in_snowLiqFlux % firstFluxCall =firstFluxCall ! intent(in): the first flux call (compute variables that are constant over the iterations) + in_snowLiqFlux % scalarSolution =(scalarSolution .and. .not.firstFluxCall) ! intent(in): flag to indicate the scalar solution + in_snowLiqFlux % scalarThroughfallRain =scalarThroughfallRain ! intent(in): rain that reaches the snow surface without ever touching vegetation (kg m-2 s-1) + in_snowLiqFlux % scalarCanopyLiqDrainage=scalarCanopyLiqDrainage ! intent(in): liquid drainage from the vegetation canopy (kg m-2 s-1) + in_snowLiqFlux % mLayerVolFracLiqTrial =mLayerVolFracLiqTrial(1:nSnow) ! intent(in): trial value of volumetric fraction of liquid water at the current iteration (-) end associate - end subroutine initialize_in_snowLiqFlx + end subroutine initialize_in_snowLiqFlux - subroutine initialize_io_snowLiqFlx(io_snowLiqFlx,flux_data,deriv_data) - class(io_type_snowLiqFlx),intent(out) :: io_snowLiqFlx ! class object for intent(inout) snowLiqFlx arguments + subroutine initialize_io_snowLiqFlux(io_snowLiqFlux,flux_data,deriv_data) + class(io_type_snowLiqFlux),intent(out) :: io_snowLiqFlux ! class object for intent(inout) snowLiqFlux arguments type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU type(var_dlength),intent(in) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables associate(& iLayerLiqFluxSnow => flux_data%var(iLookFLUX%iLayerLiqFluxSnow)%dat, & ! intent(out): [dp(0:)] vertical liquid water flux at snow layer interfaces (-) iLayerLiqFluxSnowDeriv => deriv_data%var(iLookDERIV%iLayerLiqFluxSnowDeriv)%dat ) ! intent(out): [dp(:)] derivative in vertical liquid water flux at layer interfaces - io_snowLiqFlx % iLayerLiqFluxSnow =iLayerLiqFluxSnow ! intent(inout): vertical liquid water flux at layer interfaces (m s-1) - io_snowLiqFlx % iLayerLiqFluxSnowDeriv =iLayerLiqFluxSnowDeriv ! intent(inout): derivative in vertical liquid water flux at layer interfaces (m s-1) + io_snowLiqFlux % iLayerLiqFluxSnow =iLayerLiqFluxSnow ! intent(inout): vertical liquid water flux at layer interfaces (m s-1) + io_snowLiqFlux % iLayerLiqFluxSnowDeriv =iLayerLiqFluxSnowDeriv ! intent(inout): derivative in vertical liquid water flux at layer interfaces (m s-1) end associate - end subroutine initialize_io_snowLiqFlx + end subroutine initialize_io_snowLiqFlux - subroutine finalize_io_snowLiqFlx(io_snowLiqFlx,flux_data,deriv_data) - class(io_type_snowLiqFlx),intent(in) :: io_snowLiqFlx ! class object for intent(inout) snowLiqFlx arguments + subroutine finalize_io_snowLiqFlux(io_snowLiqFlux,flux_data,deriv_data) + class(io_type_snowLiqFlux),intent(in) :: io_snowLiqFlux ! class object for intent(inout) snowLiqFlux arguments type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables associate(& iLayerLiqFluxSnow => flux_data%var(iLookFLUX%iLayerLiqFluxSnow)%dat, & ! intent(out): [dp(0:)] vertical liquid water flux at snow layer interfaces (-) iLayerLiqFluxSnowDeriv => deriv_data%var(iLookDERIV%iLayerLiqFluxSnowDeriv)%dat ) ! intent(out): [dp(:)] derivative in vertical liquid water flux at layer interfaces ! intent(inout) arguments - iLayerLiqFluxSnow =io_snowLiqFlx % iLayerLiqFluxSnow ! intent(inout): vertical liquid water flux at layer interfaces (m s-1) - iLayerLiqFluxSnowDeriv=io_snowLiqFlx % iLayerLiqFluxSnowDeriv ! intent(inout): derivative in vertical liquid water flux at layer interfaces (m s-1) + iLayerLiqFluxSnow =io_snowLiqFlux % iLayerLiqFluxSnow ! intent(inout): vertical liquid water flux at layer interfaces (m s-1) + iLayerLiqFluxSnowDeriv=io_snowLiqFlux % iLayerLiqFluxSnowDeriv ! intent(inout): derivative in vertical liquid water flux at layer interfaces (m s-1) end associate - end subroutine finalize_io_snowLiqFlx + end subroutine finalize_io_snowLiqFlux - subroutine finalize_out_snowLiqFlx(out_snowLiqFlx,err,cmessage) - class(out_type_snowLiqFlx),intent(in) :: out_snowLiqFlx ! class object for intent(out) snowLiqFlx arguments + subroutine finalize_out_snowLiqFlux(out_snowLiqFlux,err,cmessage) + class(out_type_snowLiqFlux),intent(in) :: out_snowLiqFlux ! class object for intent(out) snowLiqFlux arguments integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: cmessage ! error message from snowLiqFlx + character(*),intent(out) :: cmessage ! error message from snowLiqFlux ! intent(out) arguments - err =out_snowLiqFlx % err ! intent(out): error code - cmessage=out_snowLiqFlx % cmessage ! intent(out): error message - end subroutine finalize_out_snowLiqFlx - ! **** end snowLiqFlx **** + err =out_snowLiqFlux % err ! intent(out): error code + cmessage=out_snowLiqFlux % cmessage ! intent(out): error message + end subroutine finalize_out_snowLiqFlux + ! **** end snowLiqFlux **** - ! **** soilLiqFlx **** - subroutine initialize_in_soilLiqFlx(in_soilLiqFlx,nSnow,nSoil,nlayers,firstSplitOper,scalarSolution,firstFluxCall,scalarAquiferStorageTrial,& + ! **** soilLiqFlux **** + subroutine initialize_in_soilLiqFlux(in_soilLiqFlux,nSnow,nSoil,nlayers,firstSplitOper,scalarSolution,firstFluxCall,scalarAquiferStorageTrial,& mLayerTempTrial,mLayerMatricHeadTrial,mLayerMatricHeadLiqTrial,mLayerVolFracLiqTrial,mLayerVolFracIceTrial,& flux_data,deriv_data) - class(in_type_soilLiqFlx),intent(out) :: in_soilLiqFlx ! class object for intent(in) soilLiqFlx arguments - integer(i4b),intent(in) :: nSnow ! number of snow layers - integer(i4b),intent(in) :: nSoil ! number of soil layers - integer(i4b),intent(in) :: nLayers ! total number of layers - logical(lgt),intent(in) :: firstSplitOper ! flag to indicate if we are processing the first flux call in a splitting operation - logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution - logical(lgt),intent(in) :: firstFluxCall ! flag to indicate if we are processing the first flux call - real(rkind),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) - real(rkind),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) - real(rkind),intent(in) :: mLayerMatricHeadTrial(:) ! trial value for the total water matric potential (m) - real(rkind),intent(in) :: mLayerMatricHeadLiqTrial(:) ! trial value for the liquid water matric potential (m) - real(rkind),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) - real(rkind),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) - type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU - type(var_dlength),intent(in) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + class(in_type_soilLiqFlux),intent(out) :: in_soilLiqFlux ! class object for intent(in) soilLiqFlux arguments + integer(i4b),intent(in) :: nSnow ! number of snow layers + integer(i4b),intent(in) :: nSoil ! number of soil layers + integer(i4b),intent(in) :: nLayers ! total number of layers + logical(lgt),intent(in) :: firstSplitOper ! flag to indicate if we are processing the first flux call in a splitting operation + logical(lgt),intent(in) :: scalarSolution ! flag to denote if implementing the scalar solution + logical(lgt),intent(in) :: firstFluxCall ! flag to indicate if we are processing the first flux call + real(rkind),intent(in) :: scalarAquiferStorageTrial ! trial value of aquifer storage (m) + real(rkind),intent(in) :: mLayerTempTrial(:) ! trial value for temperature of each snow/soil layer (K) + real(rkind),intent(in) :: mLayerMatricHeadTrial(:) ! trial value for the total water matric potential (m) + real(rkind),intent(in) :: mLayerMatricHeadLiqTrial(:) ! trial value for the liquid water matric potential (m) + real(rkind),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) + real(rkind),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) + type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(in) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables ! intent(in) arguments: model control - in_soilLiqFlx % nSoil =nSoil ! intent(in): number of soil layers - in_soilLiqFlx % firstSplitOper=firstSplitOper ! intent(in): flag indicating first flux call in a splitting operation - in_soilLiqFlx % scalarSolution=(scalarSolution .and. .not.firstFluxCall) ! intent(in): flag to indicate the scalar solution + in_soilLiqFlux % nSoil =nSoil ! intent(in): number of soil layers + in_soilLiqFlux % firstSplitOper=firstSplitOper ! intent(in): flag indicating first flux call in a splitting operation + in_soilLiqFlux % scalarSolution=(scalarSolution .and. .not.firstFluxCall) ! intent(in): flag to indicate the scalar solution ! intent(in) arguments: aquifer variables needed for FUSE parameterizations - in_soilLiqFlx % scalarAquiferStorageTrial = scalarAquiferStorageTrial ! intent(in): trial value of aquifer storage (m) + in_soilLiqFlux % scalarAquiferStorageTrial = scalarAquiferStorageTrial ! intent(in): trial value of aquifer storage (m) ! intent(in) arguments: trial temperature, matric potential, and volumetric fractions - in_soilLiqFlx % mLayerTempTrial=mLayerTempTrial(nSnow+1:nLayers) ! intent(in): trial temperature at the current iteration (K) - in_soilLiqFlx % mLayerMatricHeadTrial =mLayerMatricHeadTrial(1:nSoil) ! intent(in): matric potential (m) - in_soilLiqFlx % mLayerMatricHeadLiqTrial=mLayerMatricHeadLiqTrial(1:nSoil) ! intent(in): liquid water matric potential (m) - in_soilLiqFlx % mLayerVolFracLiqTrial=mLayerVolFracLiqTrial(nSnow+1:nLayers) ! intent(in): volumetric fraction of liquid water (-) - in_soilLiqFlx % mLayerVolFracIceTrial=mLayerVolFracIceTrial(nSnow+1:nLayers) ! intent(in): volumetric fraction of ice (-) + in_soilLiqFlux % mLayerTempTrial=mLayerTempTrial(nSnow+1:nLayers) ! intent(in): trial temperature at the current iteration (K) + in_soilLiqFlux % mLayerMatricHeadTrial =mLayerMatricHeadTrial(1:nSoil) ! intent(in): matric potential (m) + in_soilLiqFlux % mLayerMatricHeadLiqTrial=mLayerMatricHeadLiqTrial(1:nSoil) ! intent(in): liquid water matric potential (m) + in_soilLiqFlux % mLayerVolFracLiqTrial=mLayerVolFracLiqTrial(nSnow+1:nLayers) ! intent(in): volumetric fraction of liquid water (-) + in_soilLiqFlux % mLayerVolFracIceTrial=mLayerVolFracIceTrial(nSnow+1:nLayers) ! intent(in): volumetric fraction of ice (-) ! intent(in) arguments: derivatives for liquid water associate(& mLayerdTheta_dTk => deriv_data%var(iLookDERIV%mLayerdTheta_dTk)%dat, & ! intent(in): [dp(:)] derivative of volumetric liquid water content w.r.t. temperature dPsiLiq_dTemp => deriv_data%var(iLookDERIV%dPsiLiq_dTemp)%dat ) ! intent(in): [dp(:)] derivative in the liquid water matric potential w.r.t. temperature - in_soilLiqFlx % mLayerdTheta_dTk=mLayerdTheta_dTk(nSnow+1:nLayers) ! intent(in): derivative in volumetric liquid water content w.r.t. temperature (K-1) - in_soilLiqFlx % dPsiLiq_dTemp=dPsiLiq_dTemp(1:nSoil) ! intent(in): derivative in liquid water matric potential w.r.t. temperature (m K-1) + in_soilLiqFlux % mLayerdTheta_dTk=mLayerdTheta_dTk(nSnow+1:nLayers) ! intent(in): derivative in volumetric liquid water content w.r.t. temperature (K-1) + in_soilLiqFlux % dPsiLiq_dTemp=dPsiLiq_dTemp(1:nSoil) ! intent(in): derivative in liquid water matric potential w.r.t. temperature (m K-1) end associate ! intent(in) arguments: canopy transpiration derivatives @@ -1309,10 +1297,10 @@ subroutine initialize_in_soilLiqFlx(in_soilLiqFlx,nSnow,nSoil,nlayers,firstSplit dCanopyTrans_dTCanair => deriv_data%var(iLookDERIV%dCanopyTrans_dTCanair)%dat(1), & ! intent(out): [dp] derivative in canopy transpiration w.r.t. canopy air temperature (kg m-2 s-1 K-1) dCanopyTrans_dTCanopy => deriv_data%var(iLookDERIV%dCanopyTrans_dTCanopy)%dat(1), & ! intent(out): [dp] derivative in canopy transpiration w.r.t. canopy temperature (kg m-2 s-1 K-1) dCanopyTrans_dTGround => deriv_data%var(iLookDERIV%dCanopyTrans_dTGround)%dat(1) ) ! intent(out): [dp] derivative in canopy transpiration w.r.t. ground temperature (kg m-2 s-1 K-1) - in_soilLiqFlx % dCanopyTrans_dCanWat =dCanopyTrans_dCanWat ! intent(in): derivative in canopy transpiration w.r.t. canopy total water content (s-1) - in_soilLiqFlx % dCanopyTrans_dTCanair =dCanopyTrans_dTCanair ! intent(in): derivative in canopy transpiration w.r.t. canopy air temperature (kg m-2 s-1 K-1) - in_soilLiqFlx % dCanopyTrans_dTCanopy =dCanopyTrans_dTCanopy ! intent(in): derivative in canopy transpiration w.r.t. canopy temperature (kg m-2 s-1 K-1) - in_soilLiqFlx % dCanopyTrans_dTGround =dCanopyTrans_dTGround ! intent(in): derivative in canopy transpiration w.r.t. ground temperature (kg m-2 s-1 K-1) + in_soilLiqFlux % dCanopyTrans_dCanWat =dCanopyTrans_dCanWat ! intent(in): derivative in canopy transpiration w.r.t. canopy total water content (s-1) + in_soilLiqFlux % dCanopyTrans_dTCanair =dCanopyTrans_dTCanair ! intent(in): derivative in canopy transpiration w.r.t. canopy air temperature (kg m-2 s-1 K-1) + in_soilLiqFlux % dCanopyTrans_dTCanopy =dCanopyTrans_dTCanopy ! intent(in): derivative in canopy transpiration w.r.t. canopy temperature (kg m-2 s-1 K-1) + in_soilLiqFlux % dCanopyTrans_dTGround =dCanopyTrans_dTGround ! intent(in): derivative in canopy transpiration w.r.t. ground temperature (kg m-2 s-1 K-1) end associate ! intent(in) arguments: evaporative fluxes and rain plus melt @@ -1320,19 +1308,19 @@ subroutine initialize_in_soilLiqFlx(in_soilLiqFlx,nSnow,nSoil,nlayers,firstSplit scalarCanopyTranspiration => flux_data%var(iLookFLUX%scalarCanopyTranspiration)%dat(1), & ! intent(out): [dp] canopy transpiration (kg m-2 s-1) scalarGroundEvaporation => flux_data%var(iLookFLUX%scalarGroundEvaporation)%dat(1), & ! intent(out): [dp] ground evaporation/condensation -- below canopy or non-vegetated (kg m-2 s-1) scalarRainPlusMelt => flux_data%var(iLookFLUX%scalarRainPlusMelt)%dat(1) ) ! intent(out): [dp] rain plus melt (m s-1) - in_soilLiqFlx % scalarCanopyTranspiration=scalarCanopyTranspiration ! intent(in): canopy transpiration (kg m-2 s-1) - in_soilLiqFlx % scalarGroundEvaporation =scalarGroundEvaporation ! intent(in): ground evaporation (kg m-2 s-1) - in_soilLiqFlx % scalarRainPlusMelt =scalarRainPlusMelt ! intent(in): rain plus melt (m s-1) + in_soilLiqFlux % scalarCanopyTranspiration=scalarCanopyTranspiration ! intent(in): canopy transpiration (kg m-2 s-1) + in_soilLiqFlux % scalarGroundEvaporation =scalarGroundEvaporation ! intent(in): ground evaporation (kg m-2 s-1) + in_soilLiqFlux % scalarRainPlusMelt =scalarRainPlusMelt ! intent(in): rain plus melt (m s-1) end associate - end subroutine initialize_in_soilLiqFlx + end subroutine initialize_in_soilLiqFlux - subroutine initialize_io_soilLiqFlx(io_soilLiqFlx,nSoil,dHydCond_dMatric,flux_data,diag_data,deriv_data) - class(io_type_soilLiqFlx),intent(out) :: io_soilLiqFlx ! class object for intent(inout) soilLiqFlx arguments - integer(i4b),intent(in) :: nSoil ! number of soil layers - real(rkind),intent(in) :: dHydCond_dMatric(nSoil) ! derivative in hydraulic conductivity w.r.t matric head (s-1) - type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU - type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU - type(var_dlength),intent(in) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + subroutine initialize_io_soilLiqFlux(io_soilLiqFlux,nSoil,dHydCond_dMatric,flux_data,diag_data,deriv_data) + class(io_type_soilLiqFlux),intent(out) :: io_soilLiqFlux ! class object for intent(inout) soilLiqFlux arguments + integer(i4b),intent(in) :: nSoil ! number of soil layers + real(rkind),intent(in) :: dHydCond_dMatric(nSoil) ! derivative in hydraulic conductivity w.r.t matric head (s-1) + type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(in) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables ! intent(inout) arguments: max infiltration rate, frozen area, and surface runoff associate(& @@ -1344,14 +1332,14 @@ subroutine initialize_io_soilLiqFlx(io_soilLiqFlx,nSoil,dHydCond_dMatric,flux_da scalarSurfaceRunoff => flux_data%var(iLookFLUX%scalarSurfaceRunoff)%dat(1), & ! intent(out): [dp] surface runoff (m s-1) scalarSurfaceRunoff_IE => flux_data%var(iLookFLUX%scalarSurfaceRunoff_IE)%dat(1), & ! intent(out): [dp] infiltration excess surface runoff (m s-1) scalarSurfaceRunoff_SE => flux_data%var(iLookFLUX%scalarSurfaceRunoff_SE)%dat(1) ) ! intent(out): [dp] saturation excess surface runoff (m s-1) - io_soilLiqFlx % scalarMaxInfilRate =scalarMaxInfilRate ! intent(inout): maximum infiltration rate (m s-1) - io_soilLiqFlx % scalarInfilArea =scalarInfilArea ! intent(inout): fraction of area where water can infiltrate, may be frozen (-) - io_soilLiqFlx % scalarSaturatedArea =scalarSaturatedArea ! intent(inout): fraction of area that is considered saturated (-) - io_soilLiqFlx % scalarFrozenArea =scalarFrozenArea ! intent(inout): fraction of area that is considered impermeable due to soil ice (-) - io_soilLiqFlx % scalarSoilControl =scalarSoilControl ! intent(inout): soil control on infiltration for derivative - io_soilLiqFlx % scalarSurfaceRunoff =scalarSurfaceRunoff ! intent(inout): surface runoff (m s-1) - io_soilLiqFlx % scalarSurfaceRunoff_IE =scalarSurfaceRunoff_IE ! intent(inout): infiltration excess surface runoff (m s-1) - io_soilLiqFlx % scalarSurfaceRunoff_SE =scalarSurfaceRunoff_SE ! intent(inout): saturation excess surface runoff (m s-1) + io_soilLiqFlux % scalarMaxInfilRate =scalarMaxInfilRate ! intent(inout): maximum infiltration rate (m s-1) + io_soilLiqFlux % scalarInfilArea =scalarInfilArea ! intent(inout): fraction of area where water can infiltrate, may be frozen (-) + io_soilLiqFlux % scalarSaturatedArea =scalarSaturatedArea ! intent(inout): fraction of area that is considered saturated (-) + io_soilLiqFlux % scalarFrozenArea =scalarFrozenArea ! intent(inout): fraction of area that is considered impermeable due to soil ice (-) + io_soilLiqFlux % scalarSoilControl =scalarSoilControl ! intent(inout): soil control on infiltration for derivative + io_soilLiqFlux % scalarSurfaceRunoff =scalarSurfaceRunoff ! intent(inout): surface runoff (m s-1) + io_soilLiqFlux % scalarSurfaceRunoff_IE =scalarSurfaceRunoff_IE ! intent(inout): infiltration excess surface runoff (m s-1) + io_soilLiqFlux % scalarSurfaceRunoff_SE =scalarSurfaceRunoff_SE ! intent(inout): saturation excess surface runoff (m s-1) end associate ! intent(inout) arguments: derivatives, fluxes, and layer properties @@ -1362,13 +1350,13 @@ subroutine initialize_io_soilLiqFlx(io_soilLiqFlx,nSoil,dHydCond_dMatric,flux_da iLayerLiqFluxSoil => flux_data%var(iLookFLUX%iLayerLiqFluxSoil)%dat, & ! intent(out): [dp(0:)] vertical liquid water flux at soil layer interfaces (-) mLayerTranspire => flux_data%var(iLookFLUX%mLayerTranspire)%dat, & ! intent(out): [dp(:)] transpiration loss from each soil layer (m s-1) mLayerHydCond => flux_data%var(iLookFLUX%mLayerHydCond)%dat ) ! intent(out): [dp(:)] hydraulic conductivity in each soil layer (m s-1) - io_soilLiqFlx % mLayerdTheta_dPsi =mLayerdTheta_dPsi ! intent(inout): derivative in the soil water characteristic w.r.t. psi (m-1) - io_soilLiqFlx % mLayerdPsi_dTheta =mLayerdPsi_dTheta ! intent(inout): derivative in the soil water characteristic w.r.t. theta (m) - io_soilLiqFlx % dHydCond_dMatric =dHydCond_dMatric ! intent(inout): derivative in hydraulic conductivity w.r.t matric head (s-1) - io_soilLiqFlx % scalarInfiltration =scalarInfiltration ! intent(inout): surface infiltration rate (m s-1) -- controls on infiltration only computed for iter==1 - io_soilLiqFlx % iLayerLiqFluxSoil =iLayerLiqFluxSoil ! intent(inout): liquid fluxes at layer interfaces (m s-1) - io_soilLiqFlx % mLayerTranspire =mLayerTranspire ! intent(inout): transpiration loss from each soil layer (m s-1) - io_soilLiqFlx % mLayerHydCond =mLayerHydCond ! intent(inout): hydraulic conductivity in each layer (m s-1) + io_soilLiqFlux % mLayerdTheta_dPsi =mLayerdTheta_dPsi ! intent(inout): derivative in the soil water characteristic w.r.t. psi (m-1) + io_soilLiqFlux % mLayerdPsi_dTheta =mLayerdPsi_dTheta ! intent(inout): derivative in the soil water characteristic w.r.t. theta (m) + io_soilLiqFlux % dHydCond_dMatric =dHydCond_dMatric ! intent(inout): derivative in hydraulic conductivity w.r.t matric head (s-1) + io_soilLiqFlux % scalarInfiltration =scalarInfiltration ! intent(inout): surface infiltration rate (m s-1) -- controls on infiltration only computed for iter==1 + io_soilLiqFlux % iLayerLiqFluxSoil =iLayerLiqFluxSoil ! intent(inout): liquid fluxes at layer interfaces (m s-1) + io_soilLiqFlux % mLayerTranspire =mLayerTranspire ! intent(inout): transpiration loss from each soil layer (m s-1) + io_soilLiqFlux % mLayerHydCond =mLayerHydCond ! intent(inout): hydraulic conductivity in each layer (m s-1) end associate ! intent(inout) arguments: flux and surface infiltration derivatives @@ -1379,12 +1367,12 @@ subroutine initialize_io_soilLiqFlx(io_soilLiqFlx,nSoil,dHydCond_dMatric,flux_da dq_dNrgStateAbove => deriv_data%var(iLookDERIV%dq_dNrgStateAbove)%dat, & ! intent(out): [dp(:)] change in flux at layer interfaces w.r.t. states in the layer above dq_dNrgStateBelow => deriv_data%var(iLookDERIV%dq_dNrgStateBelow)%dat, & ! intent(out): [dp(:)] change in flux at layer interfaces w.r.t. states in the layer below dq_dNrgStateLayerSurfVec => deriv_data%var(iLookDERIV%dq_dNrgStateLayerSurfVec)%dat ) ! intent(out): [dp(:)] change in the flux in soil surface interface w.r.t. state variables in layers - io_soilLiqFlx % dq_dHydStateAbove =dq_dHydStateAbove ! intent(inout): derivatives in the flux w.r.t. matric head in the layer above (s-1) - io_soilLiqFlx % dq_dHydStateBelow =dq_dHydStateBelow ! intent(inout): derivatives in the flux w.r.t. matric head in the layer below (s-1) - io_soilLiqFlx % dq_dHydStateLayerSurfVec=dq_dHydStateLayerSurfVec ! intent(inout): derivative in surface infiltration w.r.t. hydrology state in above soil snow or canopy and every soil layer (m s-1 or s-1) - io_soilLiqFlx % dq_dNrgStateAbove =dq_dNrgStateAbove ! intent(inout): derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) - io_soilLiqFlx % dq_dNrgStateBelow =dq_dNrgStateBelow ! intent(inout): derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) - io_soilLiqFlx % dq_dNrgStateLayerSurfVec=dq_dNrgStateLayerSurfVec ! intent(inout): derivative in surface infiltration w.r.t. energy state in above soil snow or canopy and every soil layer (m s-1 K-1) + io_soilLiqFlux % dq_dHydStateAbove =dq_dHydStateAbove ! intent(inout): derivatives in the flux w.r.t. matric head in the layer above (s-1) + io_soilLiqFlux % dq_dHydStateBelow =dq_dHydStateBelow ! intent(inout): derivatives in the flux w.r.t. matric head in the layer below (s-1) + io_soilLiqFlux % dq_dHydStateLayerSurfVec=dq_dHydStateLayerSurfVec ! intent(inout): derivative in surface infiltration w.r.t. hydrology state in above soil snow or canopy and every soil layer (m s-1 or s-1) + io_soilLiqFlux % dq_dNrgStateAbove =dq_dNrgStateAbove ! intent(inout): derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) + io_soilLiqFlux % dq_dNrgStateBelow =dq_dNrgStateBelow ! intent(inout): derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) + io_soilLiqFlux % dq_dNrgStateLayerSurfVec=dq_dNrgStateLayerSurfVec ! intent(inout): derivative in surface infiltration w.r.t. energy state in above soil snow or canopy and every soil layer (m s-1 K-1) end associate ! intent(inout) arguments: transpiration flux derivatives @@ -1393,39 +1381,39 @@ subroutine initialize_io_soilLiqFlx(io_soilLiqFlx,nSoil,dHydCond_dMatric,flux_da mLayerdTrans_dTCanopy => deriv_data%var(iLookDERIV%mLayerdTrans_dTCanopy)%dat, & ! intent(out): derivatives in the soil layer transpiration flux w.r.t. canopy temperature mLayerdTrans_dTGround => deriv_data%var(iLookDERIV%mLayerdTrans_dTGround)%dat, & ! intent(out): derivatives in the soil layer transpiration flux w.r.t. ground temperature mLayerdTrans_dCanWat => deriv_data%var(iLookDERIV%mLayerdTrans_dCanWat)%dat ) ! intent(out): derivatives in the soil layer transpiration flux w.r.t. canopy total water - io_soilLiqFlx % mLayerdTrans_dTCanair =mLayerdTrans_dTCanair ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. canopy air temperature - io_soilLiqFlx % mLayerdTrans_dTCanopy =mLayerdTrans_dTCanopy ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. canopy temperature - io_soilLiqFlx % mLayerdTrans_dTGround =mLayerdTrans_dTGround ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. ground temperature - io_soilLiqFlx % mLayerdTrans_dCanWat =mLayerdTrans_dCanWat ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. canopy total water + io_soilLiqFlux % mLayerdTrans_dTCanair =mLayerdTrans_dTCanair ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. canopy air temperature + io_soilLiqFlux % mLayerdTrans_dTCanopy =mLayerdTrans_dTCanopy ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. canopy temperature + io_soilLiqFlux % mLayerdTrans_dTGround =mLayerdTrans_dTGround ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. ground temperature + io_soilLiqFlux % mLayerdTrans_dCanWat =mLayerdTrans_dCanWat ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. canopy total water end associate - end subroutine initialize_io_soilLiqFlx + end subroutine initialize_io_soilLiqFlux - subroutine finalize_io_soilLiqFlx(io_soilLiqFlx,nSoil,dHydCond_dMatric,flux_data,diag_data,deriv_data) - class(io_type_soilLiqFlx),intent(in) :: io_soilLiqFlx ! class object for intent(inout) soilLiqFlx arguments - integer(i4b),intent(in) :: nSoil ! number of soil layers - real(rkind),intent(out) :: dHydCond_dMatric(nSoil) ! derivative in hydraulic conductivity w.r.t matric head (s-1) - type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU - type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU - type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables + subroutine finalize_io_soilLiqFlux(io_soilLiqFlux,nSoil,dHydCond_dMatric,flux_data,diag_data,deriv_data) + class(io_type_soilLiqFlux),intent(in) :: io_soilLiqFlux ! class object for intent(inout) soilLiqFlux arguments + integer(i4b),intent(in) :: nSoil ! number of soil layers + real(rkind),intent(out) :: dHydCond_dMatric(nSoil) ! derivative in hydraulic conductivity w.r.t matric head (s-1) + type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables ! intent(inout) arguments: max infiltration rate, frozen area, and surface runoff associate(& - scalarMaxInfilRate => flux_data%var(iLookFLUX%scalarMaxInfilRate)%dat(1), & ! intent(out): [dp] maximum infiltration rate (m s-1) - scalarInfilArea => diag_data%var(iLookDIAG%scalarInfilArea )%dat(1), & ! intent(out): [dp] fraction of area where water can infiltrate, may be frozen (-) - scalarSaturatedArea => diag_data%var(iLookDIAG%scalarSaturatedArea)%dat(1), & ! intent(out): [dp] fraction of area that is considered saturated (-) - scalarFrozenArea => diag_data%var(iLookDIAG%scalarFrozenArea )%dat(1), & ! intent(out): [dp] fraction of area that is considered impermeable due to soil ice (-) - scalarSoilControl => diag_data%var(iLookDIAG%scalarSoilControl )%dat(1), & ! intent(out): [dp] soil control on infiltration for derivative + scalarMaxInfilRate => flux_data%var(iLookFLUX%scalarMaxInfilRate)%dat(1), & ! intent(out): [dp] maximum infiltration rate (m s-1) + scalarInfilArea => diag_data%var(iLookDIAG%scalarInfilArea )%dat(1), & ! intent(out): [dp] fraction of area where water can infiltrate, may be frozen (-) + scalarSaturatedArea => diag_data%var(iLookDIAG%scalarSaturatedArea)%dat(1), & ! intent(out): [dp] fraction of area that is considered saturated (-) + scalarFrozenArea => diag_data%var(iLookDIAG%scalarFrozenArea )%dat(1), & ! intent(out): [dp] fraction of area that is considered impermeable due to soil ice (-) + scalarSoilControl => diag_data%var(iLookDIAG%scalarSoilControl )%dat(1), & ! intent(out): [dp] soil control on infiltration for derivative scalarSurfaceRunoff => flux_data%var(iLookFLUX%scalarSurfaceRunoff)%dat(1), & ! intent(out): [dp] surface runoff (m s-1) scalarSurfaceRunoff_IE => flux_data%var(iLookFLUX%scalarSurfaceRunoff_IE)%dat(1), & ! intent(out): [dp] infiltration excess surface runoff (m s-1) scalarSurfaceRunoff_SE => flux_data%var(iLookFLUX%scalarSurfaceRunoff_SE)%dat(1) ) ! intent(out): [dp] saturation excess surface runoff (m s-1) - scalarMaxInfilRate =io_soilLiqFlx % scalarMaxInfilRate ! intent(inout): maximum infiltration rate (m s-1) - scalarInfilArea =io_soilLiqFlx % scalarInfilArea ! intent(inout): fraction of area where water can infiltrate, may be frozen (-) - scalarSaturatedArea =io_soilLiqFlx % scalarSaturatedArea ! intent(inout): fraction of area that is considered saturated (-) - scalarFrozenArea =io_soilLiqFlx % scalarFrozenArea ! intent(inout): fraction of area that is considered impermeable due to soil ice (-) - scalarSoilControl =io_soilLiqFlx % scalarSoilControl ! intent(inout): soil control on infiltration for derivative - scalarSurfaceRunoff =io_soilLiqFlx % scalarSurfaceRunoff ! intent(inout): surface runoff (m s-1) - scalarSurfaceRunoff_IE =io_soilLiqFlx % scalarSurfaceRunoff_IE ! intent(inout): infiltration excess surface runoff (m s-1) - scalarSurfaceRunoff_SE =io_soilLiqFlx % scalarSurfaceRunoff_SE ! intent(inout): saturation excess surface runoff (m s-1) + scalarMaxInfilRate =io_soilLiqFlux % scalarMaxInfilRate ! intent(inout): maximum infiltration rate (m s-1) + scalarInfilArea =io_soilLiqFlux % scalarInfilArea ! intent(inout): fraction of area where water can infiltrate, may be frozen (-) + scalarSaturatedArea =io_soilLiqFlux % scalarSaturatedArea ! intent(inout): fraction of area that is considered saturated (-) + scalarFrozenArea =io_soilLiqFlux % scalarFrozenArea ! intent(inout): fraction of area that is considered impermeable due to soil ice (-) + scalarSoilControl =io_soilLiqFlux % scalarSoilControl ! intent(inout): soil control on infiltration for derivative + scalarSurfaceRunoff =io_soilLiqFlux % scalarSurfaceRunoff ! intent(inout): surface runoff (m s-1) + scalarSurfaceRunoff_IE =io_soilLiqFlux % scalarSurfaceRunoff_IE ! intent(inout): infiltration excess surface runoff (m s-1) + scalarSurfaceRunoff_SE =io_soilLiqFlux % scalarSurfaceRunoff_SE ! intent(inout): saturation excess surface runoff (m s-1) end associate ! intent(inout) arguments: derivatives, fluxes, and layer properties @@ -1436,13 +1424,13 @@ subroutine finalize_io_soilLiqFlx(io_soilLiqFlx,nSoil,dHydCond_dMatric,flux_data iLayerLiqFluxSoil => flux_data%var(iLookFLUX%iLayerLiqFluxSoil)%dat, & ! intent(out): [dp(0:)] vertical liquid water flux at soil layer interfaces (-) mLayerTranspire => flux_data%var(iLookFLUX%mLayerTranspire)%dat, & ! intent(out): [dp(:)] transpiration loss from each soil layer (m s-1) mLayerHydCond => flux_data%var(iLookFLUX%mLayerHydCond)%dat ) ! intent(out): [dp(:)] hydraulic conductivity in each soil layer (m s-1) - mLayerdTheta_dPsi =io_soilLiqFlx % mLayerdTheta_dPsi ! intent(inout): derivative in the soil water characteristic w.r.t. psi (m-1) - mLayerdPsi_dTheta =io_soilLiqFlx % mLayerdPsi_dTheta ! intent(inout): derivative in the soil water characteristic w.r.t. theta (m) - dHydCond_dMatric =io_soilLiqFlx % dHydCond_dMatric ! intent(inout): derivative in hydraulic conductivity w.r.t matric head (s-1) - scalarInfiltration =io_soilLiqFlx % scalarInfiltration ! intent(inout): surface infiltration rate (m s-1) -- controls on infiltration only computed for iter==1 - iLayerLiqFluxSoil =io_soilLiqFlx % iLayerLiqFluxSoil ! intent(inout): liquid fluxes at layer interfaces (m s-1) - mLayerTranspire =io_soilLiqFlx % mLayerTranspire ! intent(inout): transpiration loss from each soil layer (m s-1) - mLayerHydCond =io_soilLiqFlx % mLayerHydCond ! intent(inout): hydraulic conductivity in each layer (m s-1) + mLayerdTheta_dPsi =io_soilLiqFlux % mLayerdTheta_dPsi ! intent(inout): derivative in the soil water characteristic w.r.t. psi (m-1) + mLayerdPsi_dTheta =io_soilLiqFlux % mLayerdPsi_dTheta ! intent(inout): derivative in the soil water characteristic w.r.t. theta (m) + dHydCond_dMatric =io_soilLiqFlux % dHydCond_dMatric ! intent(inout): derivative in hydraulic conductivity w.r.t matric head (s-1) + scalarInfiltration =io_soilLiqFlux % scalarInfiltration ! intent(inout): surface infiltration rate (m s-1) -- controls on infiltration only computed for iter==1 + iLayerLiqFluxSoil =io_soilLiqFlux % iLayerLiqFluxSoil ! intent(inout): liquid fluxes at layer interfaces (m s-1) + mLayerTranspire =io_soilLiqFlux % mLayerTranspire ! intent(inout): transpiration loss from each soil layer (m s-1) + mLayerHydCond =io_soilLiqFlux % mLayerHydCond ! intent(inout): hydraulic conductivity in each layer (m s-1) end associate ! intent(inout) arguments: flux and surface infiltration derivatives @@ -1453,36 +1441,36 @@ subroutine finalize_io_soilLiqFlx(io_soilLiqFlx,nSoil,dHydCond_dMatric,flux_data dq_dNrgStateAbove => deriv_data%var(iLookDERIV%dq_dNrgStateAbove)%dat, & ! intent(out): [dp(:)] change in flux at layer interfaces w.r.t. states in the layer above dq_dNrgStateBelow => deriv_data%var(iLookDERIV%dq_dNrgStateBelow)%dat, & ! intent(out): [dp(:)] change in flux at layer interfaces w.r.t. states in the layer below dq_dNrgStateLayerSurfVec => deriv_data%var(iLookDERIV%dq_dNrgStateLayerSurfVec)%dat ) ! intent(out): [dp(:)] change in the flux in soil surface interface w.r.t. state variables in layers - dq_dHydStateAbove =io_soilLiqFlx % dq_dHydStateAbove ! intent(inout): derivatives in the flux w.r.t. matric head in the layer above (s-1) - dq_dHydStateBelow =io_soilLiqFlx % dq_dHydStateBelow ! intent(inout): derivatives in the flux w.r.t. matric head in the layer below (s-1) - dq_dHydStateLayerSurfVec=io_soilLiqFlx % dq_dHydStateLayerSurfVec ! intent(inout): derivative in surface infiltration w.r.t. hydrology state in above soil snow or canopy and every soil layer (m s-1 or s-1) - dq_dNrgStateAbove =io_soilLiqFlx % dq_dNrgStateAbove ! intent(inout): derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) - dq_dNrgStateBelow =io_soilLiqFlx % dq_dNrgStateBelow ! intent(inout): derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) - dq_dNrgStateLayerSurfVec=io_soilLiqFlx % dq_dNrgStateLayerSurfVec ! intent(inout): derivative in surface infiltration w.r.t. energy state in above soil snow or canopy and every soil layer (m s-1 K-1) + dq_dHydStateAbove =io_soilLiqFlux % dq_dHydStateAbove ! intent(inout): derivatives in the flux w.r.t. matric head in the layer above (s-1) + dq_dHydStateBelow =io_soilLiqFlux % dq_dHydStateBelow ! intent(inout): derivatives in the flux w.r.t. matric head in the layer below (s-1) + dq_dHydStateLayerSurfVec=io_soilLiqFlux % dq_dHydStateLayerSurfVec ! intent(inout): derivative in surface infiltration w.r.t. hydrology state in above soil snow or canopy and every soil layer (m s-1 or s-1) + dq_dNrgStateAbove =io_soilLiqFlux % dq_dNrgStateAbove ! intent(inout): derivatives in the flux w.r.t. temperature in the layer above (m s-1 K-1) + dq_dNrgStateBelow =io_soilLiqFlux % dq_dNrgStateBelow ! intent(inout): derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) + dq_dNrgStateLayerSurfVec=io_soilLiqFlux % dq_dNrgStateLayerSurfVec ! intent(inout): derivative in surface infiltration w.r.t. energy state in above soil snow or canopy and every soil layer (m s-1 K-1) end associate ! intent(inout) arguments: transpiration flux derivatives associate(& - mLayerdTrans_dTCanair => deriv_data%var(iLookDERIV%mLayerdTrans_dTCanair)%dat, & ! intent(out): derivatives in the soil layer transpiration flux w.r.t. canopy air temperature + mLayerdTrans_dTCanair => deriv_data%var(iLookDERIV%mLayerdTrans_dTCanair)%dat, & ! intent(out): derivatives in the soil layer transpiration flux w.r.t. canopy air temperature mLayerdTrans_dTCanopy => deriv_data%var(iLookDERIV%mLayerdTrans_dTCanopy)%dat, & ! intent(out): derivatives in the soil layer transpiration flux w.r.t. canopy temperature mLayerdTrans_dTGround => deriv_data%var(iLookDERIV%mLayerdTrans_dTGround)%dat, & ! intent(out): derivatives in the soil layer transpiration flux w.r.t. ground temperature mLayerdTrans_dCanWat => deriv_data%var(iLookDERIV%mLayerdTrans_dCanWat)%dat ) ! intent(out): derivatives in the soil layer transpiration flux w.r.t. canopy total water - mLayerdTrans_dTCanair =io_soilLiqFlx % mLayerdTrans_dTCanair ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. canopy air temperature - mLayerdTrans_dTCanopy =io_soilLiqFlx % mLayerdTrans_dTCanopy ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. canopy temperature - mLayerdTrans_dTGround =io_soilLiqFlx % mLayerdTrans_dTGround ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. ground temperature - mLayerdTrans_dCanWat =io_soilLiqFlx % mLayerdTrans_dCanWat ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. canopy total water + mLayerdTrans_dTCanair =io_soilLiqFlux % mLayerdTrans_dTCanair ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. canopy air temperature + mLayerdTrans_dTCanopy =io_soilLiqFlux % mLayerdTrans_dTCanopy ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. canopy temperature + mLayerdTrans_dTGround =io_soilLiqFlux % mLayerdTrans_dTGround ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. ground temperature + mLayerdTrans_dCanWat =io_soilLiqFlux % mLayerdTrans_dCanWat ! intent(inout): derivatives in the soil layer transpiration flux w.r.t. canopy total water end associate - end subroutine finalize_io_soilLiqFlx + end subroutine finalize_io_soilLiqFlux - subroutine finalize_out_soilLiqFlx(out_soilLiqFlx,err,cmessage) - class(out_type_soilLiqFlx),intent(in) :: out_soilLiqFlx ! class object for intent(out) soilLiqFlx arguments - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: cmessage ! error message from groundwatr + subroutine finalize_out_soilLiqFlux(out_soilLiqFlux,err,cmessage) + class(out_type_soilLiqFlux),intent(in) :: out_soilLiqFlux ! class object for intent(out) soilLiqFlux arguments + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: cmessage ! error message from groundwatr ! intent(out) arguments - err =out_soilLiqFlx % err ! intent(out): error code - cmessage =out_soilLiqFlx % cmessage ! intent(out): error message - end subroutine finalize_out_soilLiqFlx - ! **** end soilLiqFlx **** + err =out_soilLiqFlux % err ! intent(out): error code + cmessage =out_soilLiqFlux % cmessage ! intent(out): error message + end subroutine finalize_out_soilLiqFlux + ! **** end soilLiqFlux **** ! **** groundwatr **** subroutine initialize_in_groundwatr(in_groundwatr,nSnow,nSoil,nLayers,firstFluxCall,mLayerVolFracLiqTrial,mLayerVolFracIceTrial,deriv_data) @@ -1529,12 +1517,12 @@ subroutine finalize_out_groundwatr(out_groundwatr,dBaseflow_dMatric,flux_data,er integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: cmessage ! error message from groundwatr associate(& - mLayerBaseflow => flux_data%var(iLookFLUX%mLayerBaseflow)%dat ) ! intent(out): [dp(:)] baseflow from each soil layer (m s-1) + mLayerBaseflow => flux_data%var(iLookFLUX%mLayerBaseflow)%dat ) ! intent(out): [dp(:)] baseflow from each soil layer (m s-1) ! intent(out) arguments - mLayerBaseflow = out_groundwatr % mLayerBaseflow ! intent(out): baseflow from each soil layer (m s-1) - dBaseflow_dMatric = out_groundwatr % dBaseflow_dMatric ! intent(out): derivative in baseflow w.r.t. matric head (s-1) - err = out_groundwatr % err ! intent(out): error code - cmessage = out_groundwatr % cmessage ! intent(out): error message + mLayerBaseflow = out_groundwatr % mLayerBaseflow ! intent(out): baseflow from each soil layer (m s-1) + dBaseflow_dMatric = out_groundwatr % dBaseflow_dMatric ! intent(out): derivative in baseflow w.r.t. matric head (s-1) + err = out_groundwatr % err ! intent(out): error code + cmessage = out_groundwatr % cmessage ! intent(out): error message end associate end subroutine finalize_out_groundwatr ! **** end groundwatr **** @@ -1618,10 +1606,10 @@ end subroutine finalize_out_bigAquifer ! **** end bigAquifer **** ! **** diagv_node **** - subroutine initialize_in_diagv_node(in_diagv_node,iSoil,in_soilLiqFlx,model_decisions,diag_data,mpar_data,flux_data) + subroutine initialize_in_diagv_node(in_diagv_node,iSoil,in_soilLiqFlux,model_decisions,diag_data,mpar_data,flux_data) class(in_type_diagv_node),intent(out) :: in_diagv_node ! class object for input diagv_node variables integer(i4b),intent(in) :: iSoil ! index of soil layer - type(in_type_soilLiqFlx),intent(in) :: in_soilLiqFlx ! input data for soilLiqFlx + type(in_type_soilLiqFlux),intent(in) :: in_soilLiqFlux ! input data for soilLiqFlux type(model_options),intent(in) :: model_decisions(maxvarDecisions) ! the model decision structure type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(in) :: mpar_data ! model parameters @@ -1631,11 +1619,11 @@ subroutine initialize_in_diagv_node(in_diagv_node,iSoil,in_soilLiqFlx,model_deci ! intent(in): model control ixRichards => model_decisions(iLookDECISIONS%f_Richards)%iDecision,& ! index of the form of Richards' equation ! intent(in): state variables - mLayerMatricHeadLiqTrial => in_soilLiqFlx % mLayerMatricHeadLiqTrial, & ! liquid matric head in each layer at the current iteration (m) - mLayerVolFracLiqTrial => in_soilLiqFlx % mLayerVolFracLiqTrial, & ! volumetric fraction of liquid water at the current iteration (-) - mLayerVolFracIceTrial => in_soilLiqFlx % mLayerVolFracIceTrial, & ! volumetric fraction of ice at the current iteration (-) - mLayerdTheta_dTk => in_soilLiqFlx % mLayerdTheta_dTk, & ! derivative in volumetric liquid water content w.r.t. temperature (K-1) - dPsiLiq_dTemp => in_soilLiqFlx % dPsiLiq_dTemp, & ! derivative in liquid water matric potential w.r.t. temperature (m K-1) + mLayerMatricHeadLiqTrial => in_soilLiqFlux % mLayerMatricHeadLiqTrial, & ! liquid matric head in each layer at the current iteration (m) + mLayerVolFracLiqTrial => in_soilLiqFlux % mLayerVolFracLiqTrial, & ! volumetric fraction of liquid water at the current iteration (-) + mLayerVolFracIceTrial => in_soilLiqFlux % mLayerVolFracIceTrial, & ! volumetric fraction of ice at the current iteration (-) + mLayerdTheta_dTk => in_soilLiqFlux % mLayerdTheta_dTk, & ! derivative in volumetric liquid water content w.r.t. temperature (K-1) + dPsiLiq_dTemp => in_soilLiqFlux % dPsiLiq_dTemp, & ! derivative in liquid water matric potential w.r.t. temperature (m K-1) ! intent(in): van Genuchten and other soil parameters.. vGn_alpha => mpar_data%var(iLookPARAM%vGn_alpha)%dat, & ! "alpha" parameter (m-1) vGn_n => mpar_data%var(iLookPARAM%vGn_n)%dat, & ! "n" parameter (-) @@ -1670,25 +1658,25 @@ subroutine initialize_in_diagv_node(in_diagv_node,iSoil,in_soilLiqFlx,model_deci end associate end subroutine initialize_in_diagv_node - subroutine finalize_out_diagv_node(out_diagv_node,iSoil,nSoil,io_soilLiqFlx,mLayerDiffuse,iceImpedeFac,& + subroutine finalize_out_diagv_node(out_diagv_node,iSoil,nSoil,io_soilLiqFlux,mLayerDiffuse,iceImpedeFac,& &dHydCond_dVolLiq,dDiffuse_dVolLiq,dHydCond_dTemp,err,cmessage) - class(out_type_diagv_node),intent(in) :: out_diagv_node ! class object for output diagv_node variables - integer(i4b),intent(in) :: nSoil,iSoil ! number of soil layers and index - type(io_type_soilLiqFlx),intent(inout) :: io_soilLiqFlx ! input-output class object for soilLiqFlx - real(rkind),intent(inout) :: mLayerDiffuse(1:nSoil) ! diffusivity at layer mid-point (m2 s-1) - real(rkind),intent(inout) :: iceImpedeFac(1:nSoil) ! ice impedence factor at layer mid-points (-) - real(rkind),intent(inout) :: dHydCond_dVolLiq(1:nSoil) ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) - real(rkind),intent(inout) :: dDiffuse_dVolLiq(1:nSoil) ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) - real(rkind),intent(inout) :: dHydCond_dTemp(1:nSoil) ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: cmessage ! error message + class(out_type_diagv_node),intent(in) :: out_diagv_node ! class object for output diagv_node variables + integer(i4b),intent(in) :: nSoil,iSoil ! number of soil layers and index + type(io_type_soilLiqFlux),intent(inout) :: io_soilLiqFlux ! input-output class object for soilLiqFlux + real(rkind),intent(inout) :: mLayerDiffuse(1:nSoil) ! diffusivity at layer mid-point (m2 s-1) + real(rkind),intent(inout) :: iceImpedeFac(1:nSoil) ! ice impedence factor at layer mid-points (-) + real(rkind),intent(inout) :: dHydCond_dVolLiq(1:nSoil) ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) + real(rkind),intent(inout) :: dDiffuse_dVolLiq(1:nSoil) ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) + real(rkind),intent(inout) :: dHydCond_dTemp(1:nSoil) ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: cmessage ! error message associate(& ! hydraulic conductivity and derivatives - mLayerdPsi_dTheta => io_soilLiqFlx % mLayerdPsi_dTheta, & ! derivative in the soil water characteristic w.r.t. theta (m) - mLayerdTheta_dPsi => io_soilLiqFlx % mLayerdTheta_dPsi, & ! derivative in the soil water characteristic w.r.t. psi (m-1) - mLayerHydCond => io_soilLiqFlx % mLayerHydCond, & ! hydraulic conductivity in each soil layer (m s-1) - dHydCond_dMatric => io_soilLiqFlx % dHydCond_dMatric & ! derivative in hydraulic conductivity w.r.t matric head (s-1) + mLayerdPsi_dTheta => io_soilLiqFlux % mLayerdPsi_dTheta, & ! derivative in the soil water characteristic w.r.t. theta (m) + mLayerdTheta_dPsi => io_soilLiqFlux % mLayerdTheta_dPsi, & ! derivative in the soil water characteristic w.r.t. psi (m-1) + mLayerHydCond => io_soilLiqFlux % mLayerHydCond, & ! hydraulic conductivity in each soil layer (m s-1) + dHydCond_dMatric => io_soilLiqFlux % dHydCond_dMatric & ! derivative in hydraulic conductivity w.r.t matric head (s-1) &) ! output: derivative in the soil water characteristic mLayerdPsi_dTheta(iSoil) = out_diagv_node % scalardPsi_dTheta ! derivative in the soil water characteristic @@ -1709,74 +1697,74 @@ subroutine finalize_out_diagv_node(out_diagv_node,iSoil,nSoil,io_soilLiqFlx,mLay end subroutine finalize_out_diagv_node ! **** end diagv_node **** - ! **** surfaceFlx **** - subroutine initialize_in_surfaceFlx(in_surfaceFlx,nRoots,ixIce,nSoil,ibeg,iend,in_soilLiqFlx,io_soilLiqFlx,& + ! **** surfaceFlux **** + subroutine initialize_in_surfaceFlux(in_surfaceFlux,nRoots,ixIce,nSoil,ibeg,iend,in_soilLiqFlux,io_soilLiqFlux,& &model_decisions,prog_data,mpar_data,flux_data,diag_data,& &iLayerHeight,dHydCond_dTemp,iceImpedeFac) - class(in_type_surfaceFlx),intent(out) :: in_surfaceFlx ! input object for surfaceFlx - integer(i4b),intent(in) :: nRoots ! number of soil layers with roots - integer(i4b),intent(in) :: ixIce ! index of the lowest soil layer that contains ice - integer(i4b),intent(in) :: nSoil ! number of soil layers - integer(i4b),intent(in) :: ibeg,iend ! start and end indices of the soil layers in concatanated snow-soil vector - type(in_type_soilLiqFlx),intent(in) :: in_soilLiqFlx ! input data for soilLiqFlx - type(io_type_soilLiqFlx),intent(in) :: io_soilLiqFlx ! input-output class object for soilLiqFlx - type(model_options),intent(in) :: model_decisions(maxvarDecisions) ! the model decision structure - type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU - type(var_dlength),intent(in) :: mpar_data ! model parameters - type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU - type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU - real(rkind),intent(in) :: iLayerHeight(0:nSoil) ! height of the layer interfaces (m) - real(rkind),intent(in) :: dHydCond_dTemp(1:nSoil) ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) - real(rkind),intent(in) :: iceImpedeFac(1:nSoil) ! ice impedence factor at layer mid-points (-) + class(in_type_surfaceFlux),intent(out) :: in_surfaceFlux ! input object for surfaceFlux + integer(i4b),intent(in) :: nRoots ! number of soil layers with roots + integer(i4b),intent(in) :: ixIce ! index of the lowest soil layer that contains ice + integer(i4b),intent(in) :: nSoil ! number of soil layers + integer(i4b),intent(in) :: ibeg,iend ! start and end indices of the soil layers in concatanated snow-soil vector + type(in_type_soilLiqFlux),intent(in) :: in_soilLiqFlux ! input data for soilLiqFlux + type(io_type_soilLiqFlux),intent(in) :: io_soilLiqFlux ! input-output class object for soilLiqFlux + type(model_options),intent(in) :: model_decisions(maxvarDecisions) ! the model decision structure + type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU + real(rkind),intent(in) :: iLayerHeight(0:nSoil) ! height of the layer interfaces (m) + real(rkind),intent(in) :: dHydCond_dTemp(1:nSoil) ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + real(rkind),intent(in) :: iceImpedeFac(1:nSoil) ! ice impedence factor at layer mid-points (-) associate(& ! model control - firstSplitOper => in_soilLiqFlx % firstSplitOper, & ! flag to compute infiltration + firstSplitOper => in_soilLiqFlux % firstSplitOper, & ! flag to compute infiltration ixRichards => model_decisions(iLookDECISIONS%f_Richards)%iDecision,& ! index of the form of Richards' equation ixBcUpperSoilHydrology => model_decisions(iLookDECISIONS%bcUpprSoiH)%iDecision,& ! index defining the type of boundary conditions ixInfRateMax => model_decisions(iLookDECISIONS%infRateMax)%iDecision,& ! index of the maximum infiltration rate parameterization surfRun_SE => model_decisions(iLookDECISIONS%surfRun_SE)%iDecision & ! index defining the saturation excess surface runoff method &) ! intent(in): model control - in_surfaceFlx % firstSplitOper = firstSplitOper ! flag indicating if desire to compute infiltration - in_surfaceFlx % ixRichards = ixRichards ! index defining the form of Richards' equation (moisture or mixdform) - in_surfaceFlx % bc_upper = ixBcUpperSoilHydrology ! index defining the type of boundary conditions (Neumann or Dirichlet) - in_surfaceFlx % ixInfRateMax = ixInfRateMax ! index defining the maximum infiltration rate parameterization (GreenAmpt or topmodel_GA) - in_surfaceFlx % surfRun_SE = surfRun_SE ! index defining the saturation excess surface runoff method - in_surfaceFlx % nRoots = nRoots ! number of layers that contain roots - in_surfaceFlx % ixIce = ixIce ! index of lowest ice layer - in_surfaceFlx % nSoil = nSoil ! number of soil layers + in_surfaceFlux % firstSplitOper = firstSplitOper ! flag indicating if desire to compute infiltration + in_surfaceFlux % ixRichards = ixRichards ! index defining the form of Richards' equation (moisture or mixdform) + in_surfaceFlux % bc_upper = ixBcUpperSoilHydrology ! index defining the type of boundary conditions (Neumann or Dirichlet) + in_surfaceFlux % ixInfRateMax = ixInfRateMax ! index defining the maximum infiltration rate parameterization (GreenAmpt or topmodel_GA) + in_surfaceFlux % surfRun_SE = surfRun_SE ! index defining the saturation excess surface runoff method + in_surfaceFlux % nRoots = nRoots ! number of layers that contain roots + in_surfaceFlux % ixIce = ixIce ! index of lowest ice layer + in_surfaceFlux % nSoil = nSoil ! number of soil layers end associate associate(& ! state variables - mLayerTempTrial => in_soilLiqFlx % mLayerTempTrial, & ! intent(in): temperature in each layer at the current iteration (m) - mLayerMatricHeadLiqTrial => in_soilLiqFlx % mLayerMatricHeadLiqTrial, & ! liquid matric head in each layer at the current iteration (m) - mLayerMatricHeadTrial => in_soilLiqFlx % mLayerMatricHeadTrial, & ! intent(in): matric head in each layer at the current iteration (m) - mLayerVolFracLiqTrial => in_soilLiqFlx % mLayerVolFracLiqTrial, & ! volumetric fraction of liquid water at the current iteration (-) - mLayerVolFracIceTrial => in_soilLiqFlx % mLayerVolFracIceTrial, & ! volumetric fraction of ice at the current iteration (-) + mLayerTempTrial => in_soilLiqFlux % mLayerTempTrial, & ! intent(in): temperature in each layer at the current iteration (m) + mLayerMatricHeadLiqTrial => in_soilLiqFlux % mLayerMatricHeadLiqTrial, & ! liquid matric head in each layer at the current iteration (m) + mLayerMatricHeadTrial => in_soilLiqFlux % mLayerMatricHeadTrial, & ! intent(in): matric head in each layer at the current iteration (m) + mLayerVolFracLiqTrial => in_soilLiqFlux % mLayerVolFracLiqTrial, & ! volumetric fraction of liquid water at the current iteration (-) + mLayerVolFracIceTrial => in_soilLiqFlux % mLayerVolFracIceTrial, & ! volumetric fraction of ice at the current iteration (-) scalarTotalSoilLiq => diag_data%var(iLookDIAG%scalarTotalSoilLiq)%dat(1) & ! total liquid water in the soil column (kg m-2) &) ! intent(in): state variables - in_surfaceFlx % mLayerTemp = mLayerTempTrial ! temperature (K) - in_surfaceFlx % scalarMatricHeadLiq = mLayerMatricHeadLiqTrial(1) ! liquid matric head in the upper-most soil layer (m) - in_surfaceFlx % mLayerMatricHead = mLayerMatricHeadTrial ! matric head in each soil layer (m) - in_surfaceFlx % scalarVolFracLiq = mLayerVolFracLiqTrial(1) ! volumetric liquid water content the upper-most soil layer (-) - in_surfaceFlx % scalarTotalSoilLiq = scalarTotalSoilLiq ! total liquid water in the soil column (kg m-2) - in_surfaceFlx % mLayerVolFracLiq = mLayerVolFracLiqTrial ! volumetric liquid water content in each soil layer (-) - in_surfaceFlx % mLayerVolFracIce = mLayerVolFracIceTrial ! volumetric ice content in each soil layer (-) + in_surfaceFlux % mLayerTemp = mLayerTempTrial ! temperature (K) + in_surfaceFlux % scalarMatricHeadLiq = mLayerMatricHeadLiqTrial(1) ! liquid matric head in the upper-most soil layer (m) + in_surfaceFlux % mLayerMatricHead = mLayerMatricHeadTrial ! matric head in each soil layer (m) + in_surfaceFlux % scalarVolFracLiq = mLayerVolFracLiqTrial(1) ! volumetric liquid water content the upper-most soil layer (-) + in_surfaceFlux % scalarTotalSoilLiq = scalarTotalSoilLiq ! total liquid water in the soil column (kg m-2) + in_surfaceFlux % mLayerVolFracLiq = mLayerVolFracLiqTrial ! volumetric liquid water content in each soil layer (-) + in_surfaceFlux % mLayerVolFracIce = mLayerVolFracIceTrial ! volumetric ice content in each soil layer (-) end associate associate(& ! pre-computed derivatives - mLayerdTheta_dTk => in_soilLiqFlx % mLayerdTheta_dTk, & ! derivative in volumetric liquid water content w.r.t. temperature (K-1) - mLayerdTheta_dPsi => io_soilLiqFlx % mLayerdTheta_dPsi, & ! derivative in the soil water characteristic w.r.t. psi (m-1) - mLayerdPsi_dTheta => io_soilLiqFlx % mLayerdPsi_dTheta & ! derivative in the soil water characteristic w.r.t. theta (m) + mLayerdTheta_dTk => in_soilLiqFlux % mLayerdTheta_dTk, & ! derivative in volumetric liquid water content w.r.t. temperature (K-1) + mLayerdTheta_dPsi => io_soilLiqFlux % mLayerdTheta_dPsi, & ! derivative in the soil water characteristic w.r.t. psi (m-1) + mLayerdPsi_dTheta => io_soilLiqFlux % mLayerdPsi_dTheta & ! derivative in the soil water characteristic w.r.t. theta (m) &) ! intent(in): pre-computed derivatives - in_surfaceFlx % dTheta_dTk = mLayerdTheta_dTk ! derivative in volumetric liquid water content w.r.t. temperature (K-1) - in_surfaceFlx % dTheta_dPsi = mLayerdTheta_dPsi ! derivative in the soil water characteristic w.r.t. psi (m-1) - in_surfaceFlx % mLayerdPsi_dTheta = mLayerdPsi_dTheta ! derivative in the soil water characteristic w.r.t. theta (m) + in_surfaceFlux % dTheta_dTk = mLayerdTheta_dTk ! derivative in volumetric liquid water content w.r.t. temperature (K-1) + in_surfaceFlux % dTheta_dPsi = mLayerdTheta_dPsi ! derivative in the soil water characteristic w.r.t. psi (m-1) + in_surfaceFlux % mLayerdPsi_dTheta = mLayerdPsi_dTheta ! derivative in the soil water characteristic w.r.t. theta (m) end associate associate(& @@ -1784,8 +1772,8 @@ subroutine initialize_in_surfaceFlx(in_surfaceFlx,nRoots,ixIce,nSoil,ibeg,iend,i mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat(ibeg:iend) & ! depth of the layer (m) &) ! intent(in): depth of each soil layer (m) - in_surfaceFlx % mLayerDepth = mLayerDepth ! depth of each soil layer (m) - in_surfaceFlx % iLayerHeight = iLayerHeight ! height at the interface of each layer (m) + in_surfaceFlux % mLayerDepth = mLayerDepth ! depth of each soil layer (m) + in_surfaceFlux % iLayerHeight = iLayerHeight ! height at the interface of each layer (m) end associate associate(& @@ -1794,16 +1782,16 @@ subroutine initialize_in_surfaceFlx(in_surfaceFlx,nRoots,ixIce,nSoil,ibeg,iend,i upperBoundTheta => mpar_data%var(iLookPARAM%upperBoundTheta)%dat(1) & ! upper boundary condition for volumetric liquid water content (-) &) ! intent(in): boundary conditions - in_surfaceFlx % upperBoundHead = upperBoundHead ! upper boundary condition (m) - in_surfaceFlx % upperBoundTheta = upperBoundTheta ! upper boundary condition (-) + in_surfaceFlux % upperBoundHead = upperBoundHead ! upper boundary condition (m) + in_surfaceFlux % upperBoundTheta = upperBoundTheta ! upper boundary condition (-) end associate associate(& ! flux at the upper boundary - scalarRainPlusMelt => in_soilLiqFlx % scalarRainPlusMelt & ! rain plus melt (m s-1) + scalarRainPlusMelt => in_soilLiqFlux % scalarRainPlusMelt & ! rain plus melt (m s-1) &) ! intent(in): flux at the upper boundary - in_surfaceFlx % scalarRainPlusMelt = scalarRainPlusMelt ! rain plus melt (m s-1) + in_surfaceFlux % scalarRainPlusMelt = scalarRainPlusMelt ! rain plus melt (m s-1) end associate associate(& @@ -1811,37 +1799,37 @@ subroutine initialize_in_surfaceFlx(in_surfaceFlx,nRoots,ixIce,nSoil,ibeg,iend,i iLayerSatHydCond => flux_data%var(iLookFLUX%iLayerSatHydCond)%dat & ! saturated hydraulic conductivity at the interface of each layer (m s-1) &) ! intent(in): transmittance - in_surfaceFlx % surfaceSatHydCond = iLayerSatHydCond(0) ! saturated hydraulic conductivity at the surface (m s-1) - in_surfaceFlx % dHydCond_dTemp = dHydCond_dTemp(1) ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) - in_surfaceFlx % iceImpedeFac = iceImpedeFac(1) ! ice impedence factor in the upper-most soil layer (-) + in_surfaceFlux % surfaceSatHydCond = iLayerSatHydCond(0) ! saturated hydraulic conductivity at the surface (m s-1) + in_surfaceFlux % dHydCond_dTemp = dHydCond_dTemp(1) ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + in_surfaceFlux % iceImpedeFac = iceImpedeFac(1) ! ice impedence factor in the upper-most soil layer (-) end associate associate(& ! soil parameters - vGn_alpha => mpar_data%var(iLookPARAM%vGn_alpha)%dat, & ! "alpha" parameter (m-1) - vGn_n => mpar_data%var(iLookPARAM%vGn_n)%dat, & ! "n" parameter (-) - vGn_m => diag_data%var(iLookDIAG%scalarVGn_m)%dat, & ! "m" parameter (-) - theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat, & ! soil porosity (-) - theta_res => mpar_data%var(iLookPARAM%theta_res)%dat, & ! soil residual volumetric water content (-) - qSurfScale => mpar_data%var(iLookPARAM%qSurfScale)%dat(1), & ! scaling factor in the surface runoff parameterization (-) - zScale_TOPMODEL => mpar_data%var(iLookPARAM%zScale_TOPMODEL)%dat(1),& ! TOPMODEL scaling factor (m) - rootingDepth => mpar_data%var(iLookPARAM%rootingDepth)%dat(1), & ! rooting depth (m) + vGn_alpha => mpar_data%var(iLookPARAM%vGn_alpha)%dat, & ! "alpha" parameter (m-1) + vGn_n => mpar_data%var(iLookPARAM%vGn_n)%dat, & ! "n" parameter (-) + vGn_m => diag_data%var(iLookDIAG%scalarVGn_m)%dat, & ! "m" parameter (-) + theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat, & ! soil porosity (-) + theta_res => mpar_data%var(iLookPARAM%theta_res)%dat, & ! soil residual volumetric water content (-) + qSurfScale => mpar_data%var(iLookPARAM%qSurfScale)%dat(1), & ! scaling factor in the surface runoff parameterization (-) + zScale_TOPMODEL => mpar_data%var(iLookPARAM%zScale_TOPMODEL)%dat(1), & ! TOPMODEL scaling factor (m) + rootingDepth => mpar_data%var(iLookPARAM%rootingDepth)%dat(1), & ! rooting depth (m) wettingFrontSuction => mpar_data%var(iLookPARAM%wettingFrontSuction)%dat(1),& ! Green-Ampt wetting front suction (m) - soilIceScale => mpar_data%var(iLookPARAM%soilIceScale)%dat(1),& ! scaling factor for depth of soil ice, used to get frozen fraction (m) - soilIceCV => mpar_data%var(iLookPARAM%soilIceCV)%dat(1) & ! CV of depth of soil ice, used to get frozen fraction (-) + soilIceScale => mpar_data%var(iLookPARAM%soilIceScale)%dat(1), & ! scaling factor for depth of soil ice, used to get frozen fraction (m) + soilIceCV => mpar_data%var(iLookPARAM%soilIceCV)%dat(1) & ! CV of depth of soil ice, used to get frozen fraction (-) &) ! intent(in): soil parameters - in_surfaceFlx % vGn_alpha = vGn_alpha(1) ! van Genuchten "alpha" parameter (m-1) - in_surfaceFlx % vGn_n = vGn_n(1) ! van Genuchten "n" parameter (-) - in_surfaceFlx % vGn_m = vGn_m(1) ! van Genuchten "m" parameter (-) - in_surfaceFlx % theta_sat = theta_sat(1) ! soil porosity (-) - in_surfaceFlx % theta_res = theta_res(1) ! soil residual volumetric water content (-) - in_surfaceFlx % qSurfScale = qSurfScale ! scaling factor in the surface runoff parameterization (-) - in_surfaceFlx % zScale_TOPMODEL = zScale_TOPMODEL ! scaling factor used to describe decrease in hydraulic conductivity with depth (m) - in_surfaceFlx % rootingDepth = rootingDepth ! rooting depth (m) - in_surfaceFlx % wettingFrontSuction = wettingFrontSuction ! Green-Ampt wetting front suction (m) - in_surfaceFlx % soilIceScale = soilIceScale ! soil ice scaling factor in Gamma distribution used to define frozen area (m) - in_surfaceFlx % soilIceCV = soilIceCV ! soil ice CV in Gamma distribution used to define frozen area (-) + in_surfaceFlux % vGn_alpha = vGn_alpha(1) ! van Genuchten "alpha" parameter (m-1) + in_surfaceFlux % vGn_n = vGn_n(1) ! van Genuchten "n" parameter (-) + in_surfaceFlux % vGn_m = vGn_m(1) ! van Genuchten "m" parameter (-) + in_surfaceFlux % theta_sat = theta_sat(1) ! soil porosity (-) + in_surfaceFlux % theta_res = theta_res(1) ! soil residual volumetric water content (-) + in_surfaceFlux % qSurfScale = qSurfScale ! scaling factor in the surface runoff parameterization (-) + in_surfaceFlux % zScale_TOPMODEL = zScale_TOPMODEL ! scaling factor used to describe decrease in hydraulic conductivity with depth (m) + in_surfaceFlux % rootingDepth = rootingDepth ! rooting depth (m) + in_surfaceFlux % wettingFrontSuction = wettingFrontSuction ! Green-Ampt wetting front suction (m) + in_surfaceFlux % soilIceScale = soilIceScale ! soil ice scaling factor in Gamma distribution used to define frozen area (m) + in_surfaceFlux % soilIceCV = soilIceCV ! soil ice CV in Gamma distribution used to define frozen area (-) end associate ! intent(in): FUSE parameters @@ -1854,111 +1842,111 @@ subroutine initialize_in_surfaceFlx(in_surfaceFlx,nRoots,ixIce,nSoil,ibeg,iend,i FUSE_mu => mpar_data%var(iLookPARAM%FUSE_mu )%dat(1), & ! FUSE TOPMODEL mu distribution lambda parameter FUSE_n => mpar_data%var(iLookPARAM%FUSE_n )%dat(1) & ! FUSE TOPMODEL exponent &) - in_surfaceFlx % FUSE_Ac_max = FUSE_Ac_max ! FUSE PRMS max saturated area - in_surfaceFlx % FUSE_phi_tens = FUSE_phi_tens ! FUSE PRMS tension fraction - in_surfaceFlx % FUSE_b = FUSE_b ! FUSE ARNO/VIC exponent - in_surfaceFlx % FUSE_lambda = FUSE_lambda ! FUSE TOPMODEL gamma distribution lambda parameter - in_surfaceFlx % FUSE_chi = FUSE_chi ! FUSE TOPMODEL chi distribution lambda parameter - in_surfaceFlx % FUSE_mu = FUSE_mu ! FUSE TOPMODEL mu distribution lambda parameter - in_surfaceFlx % FUSE_n = FUSE_n ! FUSE TOPMODEL exponent + in_surfaceFlux % FUSE_Ac_max = FUSE_Ac_max ! FUSE PRMS max saturated area + in_surfaceFlux % FUSE_phi_tens = FUSE_phi_tens ! FUSE PRMS tension fraction + in_surfaceFlux % FUSE_b = FUSE_b ! FUSE ARNO/VIC exponent + in_surfaceFlux % FUSE_lambda = FUSE_lambda ! FUSE TOPMODEL gamma distribution lambda parameter + in_surfaceFlux % FUSE_chi = FUSE_chi ! FUSE TOPMODEL chi distribution lambda parameter + in_surfaceFlux % FUSE_mu = FUSE_mu ! FUSE TOPMODEL mu distribution lambda parameter + in_surfaceFlux % FUSE_n = FUSE_n ! FUSE TOPMODEL exponent end associate - end subroutine initialize_in_surfaceFlx + end subroutine initialize_in_surfaceFlux - subroutine initialize_io_surfaceFlx(io_surfaceFlx,nSoil,io_soilLiqFlx,iLayerHydCond,iLayerDiffuse) - class(io_type_surfaceFlx),intent(out) :: io_surfaceFlx ! input-output object for surfaceFlx + subroutine initialize_io_surfaceFlux(io_surfaceFlux,nSoil,io_soilLiqFlux,iLayerHydCond,iLayerDiffuse) + class(io_type_surfaceFlux),intent(out) :: io_surfaceFlux ! input-output object for surfaceFlux integer(i4b),intent(in) :: nSoil ! number of soil layers - type(io_type_soilLiqFlx),intent(in) :: io_soilLiqFlx ! input-output class object for soilLiqFlx + type(io_type_soilLiqFlux),intent(in) :: io_soilLiqFlux ! input-output class object for soilLiqFlux real(rkind),intent(in) :: iLayerHydCond(0:nSoil) ! hydraulic conductivity at layer interface (m s-1) real(rkind),intent(in) :: iLayerDiffuse(0:nSoil) ! diffusivity at layer interface (m2 s-1) associate(& ! fluxes at layer interfaces and surface runoff - xMaxInfilRate => io_soilLiqFlx % scalarMaxInfilRate, & ! maximum infiltration rate (m s-1) - scalarInfilArea => io_soilLiqFlx % scalarInfilArea, & ! fraction of area where water can infiltrate, may be frozen (-) - scalarSaturatedArea => io_soilLiqFlx % scalarSaturatedArea, & ! fraction of area that is considered saturated (-) - scalarFrozenArea => io_soilLiqFlx % scalarFrozenArea, & ! fraction of area that is considered impermeable due to soil ice (-) - scalarSoilControl => io_soilLiqFlx % scalarSoilControl & ! soil control on infiltration for derivative + xMaxInfilRate => io_soilLiqFlux % scalarMaxInfilRate, & ! maximum infiltration rate (m s-1) + scalarInfilArea => io_soilLiqFlux % scalarInfilArea, & ! fraction of area where water can infiltrate, may be frozen (-) + scalarSaturatedArea => io_soilLiqFlux % scalarSaturatedArea, & ! fraction of area that is considered saturated (-) + scalarFrozenArea => io_soilLiqFlux % scalarFrozenArea, & ! fraction of area that is considered impermeable due to soil ice (-) + scalarSoilControl => io_soilLiqFlux % scalarSoilControl & ! soil control on infiltration for derivative &) ! intent(inout): hydraulic conductivity and diffusivity at the surface - io_surfaceFlx % surfaceHydCond = iLayerHydCond(0) ! hydraulic conductivity at the surface (m s-1) - io_surfaceFlx % surfaceDiffuse = iLayerDiffuse(0) ! hydraulic diffusivity at the surface (m2 s-1) + io_surfaceFlux % surfaceHydCond = iLayerHydCond(0) ! hydraulic conductivity at the surface (m s-1) + io_surfaceFlux % surfaceDiffuse = iLayerDiffuse(0) ! hydraulic diffusivity at the surface (m2 s-1) ! intent(inout): fluxes at layer interfaces and surface runoff - io_surfaceFlx % xMaxInfilRate = xMaxInfilRate ! maximum infiltration rate (m s-1) - io_surfaceFlx % scalarInfilArea = scalarInfilArea ! fraction of area where water can infiltrate, may be frozen (-) - io_surfaceFlx % scalarSaturatedArea = scalarSaturatedArea ! fraction of area that is considered saturated (-) - io_surfaceFlx % scalarFrozenArea = scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) - io_surfaceFlx % scalarSoilControl = scalarSoilControl ! soil control on infiltration for derivative + io_surfaceFlux % xMaxInfilRate = xMaxInfilRate ! maximum infiltration rate (m s-1) + io_surfaceFlux % scalarInfilArea = scalarInfilArea ! fraction of area where water can infiltrate, may be frozen (-) + io_surfaceFlux % scalarSaturatedArea = scalarSaturatedArea ! fraction of area that is considered saturated (-) + io_surfaceFlux % scalarFrozenArea = scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) + io_surfaceFlux % scalarSoilControl = scalarSoilControl ! soil control on infiltration for derivative end associate - end subroutine initialize_io_surfaceFlx + end subroutine initialize_io_surfaceFlux - subroutine finalize_io_surfaceFlx(io_surfaceFlx,nSoil,io_soilLiqFlx,iLayerHydCond,iLayerDiffuse) - class(io_type_surfaceFlx),intent(in) :: io_surfaceFlx ! input-output object for surfaceFlx + subroutine finalize_io_surfaceFlux(io_surfaceFlux,nSoil,io_soilLiqFlux,iLayerHydCond,iLayerDiffuse) + class(io_type_surfaceFlux),intent(in) :: io_surfaceFlux ! input-output object for surfaceFlux integer(i4b),intent(in) :: nSoil ! number of soil layers - type(io_type_soilLiqFlx),intent(inout) :: io_soilLiqFlx ! input-output class object for soilLiqFlx + type(io_type_soilLiqFlux),intent(inout) :: io_soilLiqFlux ! input-output class object for soilLiqFlux real(rkind),intent(inout) :: iLayerHydCond(0:nSoil) ! hydraulic conductivity at layer interface (m s-1) real(rkind),intent(inout) :: iLayerDiffuse(0:nSoil) ! diffusivity at layer interface (m2 s-1) associate(& ! fluxes at layer interfaces and surface runoff - xMaxInfilRate => io_soilLiqFlx % scalarMaxInfilRate, & ! maximum infiltration rate (m s-1) - scalarInfilArea => io_soilLiqFlx % scalarInfilArea, & ! fraction of area where water can infiltrate, may be frozen (-) - scalarSaturatedArea => io_soilLiqFlx % scalarSaturatedArea, & ! fraction of area that is considered saturated (-) - scalarFrozenArea => io_soilLiqFlx % scalarFrozenArea, & ! fraction of area that is considered impermeable due to soil ice (-) - scalarSoilControl => io_soilLiqFlx % scalarSoilControl & ! soil control on infiltration for derivative + xMaxInfilRate => io_soilLiqFlux % scalarMaxInfilRate, & ! maximum infiltration rate (m s-1) + scalarInfilArea => io_soilLiqFlux % scalarInfilArea, & ! fraction of area where water can infiltrate, may be frozen (-) + scalarSaturatedArea => io_soilLiqFlux % scalarSaturatedArea, & ! fraction of area that is considered saturated (-) + scalarFrozenArea => io_soilLiqFlux % scalarFrozenArea, & ! fraction of area that is considered impermeable due to soil ice (-) + scalarSoilControl => io_soilLiqFlux % scalarSoilControl & ! soil control on infiltration for derivative &) ! intent(inout): hydraulic conductivity and diffusivity at the surface - iLayerHydCond(0) = io_surfaceFlx % surfaceHydCond ! hydraulic conductivity at the surface (m s-1) - iLayerDiffuse(0) = io_surfaceFlx % surfaceDiffuse ! hydraulic diffusivity at the surface (m2 s-1) + iLayerHydCond(0) = io_surfaceFlux % surfaceHydCond ! hydraulic conductivity at the surface (m s-1) + iLayerDiffuse(0) = io_surfaceFlux % surfaceDiffuse ! hydraulic diffusivity at the surface (m2 s-1) ! intent(inout): fluxes at layer interfaces and surface runoff - xMaxInfilRate = io_surfaceFlx % xMaxInfilRate ! maximum infiltration rate (m s-1) - scalarInfilArea = io_surfaceFlx % scalarInfilArea ! fraction of area where water can infiltrate, may be frozen (-) - scalarSaturatedArea = io_surfaceFlx % scalarSaturatedArea ! fraction of area that is considered saturated (-) - scalarFrozenArea = io_surfaceFlx % scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) - scalarSoilControl = io_surfaceFlx % scalarSoilControl ! soil control on infiltration for derivative + xMaxInfilRate = io_surfaceFlux % xMaxInfilRate ! maximum infiltration rate (m s-1) + scalarInfilArea = io_surfaceFlux % scalarInfilArea ! fraction of area where water can infiltrate, may be frozen (-) + scalarSaturatedArea = io_surfaceFlux % scalarSaturatedArea ! fraction of area that is considered saturated (-) + scalarFrozenArea = io_surfaceFlux % scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) + scalarSoilControl = io_surfaceFlux % scalarSoilControl ! soil control on infiltration for derivative end associate - end subroutine finalize_io_surfaceFlx + end subroutine finalize_io_surfaceFlux - subroutine finalize_out_surfaceFlx(out_surfaceFlx,io_soilLiqFlx,err,message) - class(out_type_surfaceFlx),intent(in) :: out_surfaceFlx ! output object for surfaceFlx - type(io_type_soilLiqFlx),intent(inout) :: io_soilLiqFlx ! input-output class object for soilLiqFlx + subroutine finalize_out_surfaceFlux(out_surfaceFlux,io_soilLiqFlux,err,message) + class(out_type_surfaceFlux),intent(in) :: out_surfaceFlux ! output object for surfaceFlux + type(io_type_soilLiqFlux),intent(inout) :: io_soilLiqFlux ! input-output class object for soilLiqFlux integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message associate(& ! intent(out): surface runoff and infiltration - scalarSurfaceRunoff => io_soilLiqFlx % scalarSurfaceRunoff, & ! surface runoff (m s-1) - scalarSurfaceRunoff_IE => io_soilLiqFlx % scalarSurfaceRunoff_IE, & ! infiltration excess surface runoff (m s-1) - scalarSurfaceRunoff_SE => io_soilLiqFlx % scalarSurfaceRunoff_SE, & ! saturation excess surface runoff (m s-1) - scalarSurfaceInfiltration => io_soilLiqFlx % scalarInfiltration, & ! surface infiltration rate (m s-1) + scalarSurfaceRunoff => io_soilLiqFlux % scalarSurfaceRunoff, & ! surface runoff (m s-1) + scalarSurfaceRunoff_IE => io_soilLiqFlux % scalarSurfaceRunoff_IE, & ! infiltration excess surface runoff (m s-1) + scalarSurfaceRunoff_SE => io_soilLiqFlux % scalarSurfaceRunoff_SE, & ! saturation excess surface runoff (m s-1) + scalarSurfaceInfiltration => io_soilLiqFlux % scalarInfiltration, & ! surface infiltration rate (m s-1) ! intent(inout): derivatives in surface infiltration in the upper-most soil layer w.r.t ... - dq_dHydStateLayerSurfVec => io_soilLiqFlx % dq_dHydStateLayerSurfVec, & ! ... hydrology state above soil snow or canopy and every soil layer (m s-1 or s-1) - dq_dNrgStateLayerSurfVec => io_soilLiqFlx % dq_dNrgStateLayerSurfVec & ! ... temperature above soil snow or canopy and every soil layer (m s-1 or s-1) + dq_dHydStateLayerSurfVec => io_soilLiqFlux % dq_dHydStateLayerSurfVec, & ! ... hydrology state above soil snow or canopy and every soil layer (m s-1 or s-1) + dq_dNrgStateLayerSurfVec => io_soilLiqFlux % dq_dNrgStateLayerSurfVec & ! ... temperature above soil snow or canopy and every soil layer (m s-1 or s-1) &) ! intent(out): surface runoff and infiltration - scalarSurfaceRunoff = out_surfaceFlx % scalarSurfaceRunoff ! surface runoff (m s-1) - scalarSurfaceRunoff_IE = out_surfaceFlx % scalarSurfaceRunoff_IE ! infiltration excess surface runoff (m s-1) - scalarSurfaceRunoff_SE = out_surfaceFlx % scalarSurfaceRunoff_SE ! saturation excess surface runoff (m s-1) - scalarSurfaceInfiltration = out_surfaceFlx % scalarSurfaceInfiltration ! surface infiltration (m s-1) + scalarSurfaceRunoff = out_surfaceFlux % scalarSurfaceRunoff ! surface runoff (m s-1) + scalarSurfaceRunoff_IE = out_surfaceFlux % scalarSurfaceRunoff_IE ! infiltration excess surface runoff (m s-1) + scalarSurfaceRunoff_SE = out_surfaceFlux % scalarSurfaceRunoff_SE ! saturation excess surface runoff (m s-1) + scalarSurfaceInfiltration = out_surfaceFlux % scalarSurfaceInfiltration ! surface infiltration (m s-1) ! intent(inout): derivatives in surface infiltration in the upper-most soil layer w.r.t. ... - dq_dHydStateLayerSurfVec = out_surfaceFlx % dq_dHydStateVec ! ... hydrology state in above soil snow or canopy and every soil layer (m s-1 or s-1) - dq_dNrgStateLayerSurfVec = out_surfaceFlx % dq_dNrgStateVec ! ... energy state in above soil snow or canopy and every soil layer (m s-1 K-1) + dq_dHydStateLayerSurfVec = out_surfaceFlux % dq_dHydStateVec ! ... hydrology state in above soil snow or canopy and every soil layer (m s-1 or s-1) + dq_dNrgStateLayerSurfVec = out_surfaceFlux % dq_dNrgStateVec ! ... energy state in above soil snow or canopy and every soil layer (m s-1 K-1) end associate ! intent(out): error control - err = out_surfaceFlx % err ! error code - message = out_surfaceFlx % message ! error message - end subroutine finalize_out_surfaceFlx - ! **** end surfaceFlx **** + err = out_surfaceFlux % err ! error code + message = out_surfaceFlux % message ! error message + end subroutine finalize_out_surfaceFlux + ! **** end surfaceFlux **** ! **** iLayerFlux **** - subroutine initialize_in_iLayerFlux(in_iLayerFlux,iLayer,nSoil,ibeg,iend,in_soilLiqFlx,io_soilLiqFlx,model_decisions,& + subroutine initialize_in_iLayerFlux(in_iLayerFlux,iLayer,nSoil,ibeg,iend,in_soilLiqFlux,io_soilLiqFlux,model_decisions,& &prog_data,mLayerDiffuse,dHydCond_dTemp,dHydCond_dVolLiq,dDiffuse_dVolLiq) - class(in_type_iLayerFlux),intent(out) :: in_iLayerFlux ! class object for input iLayerFlux variables - integer(i4b),intent(in) :: nSoil,iLayer ! number of soil layers and index + class(in_type_iLayerFlux),intent(out) :: in_iLayerFlux ! class object for input iLayerFlux variables + integer(i4b),intent(in) :: nSoil,iLayer ! number of soil layers and index integer(i4b),intent(in) :: ibeg,iend ! start and end indices of the soil layers in concatanated snow-soil vector - type(in_type_soilLiqFlx),intent(in) :: in_soilLiqFlx ! input class object for soilLiqFlx - type(io_type_soilLiqFlx),intent(in) :: io_soilLiqFlx ! input-output class object for soilLiqFlx + type(in_type_soilLiqFlux),intent(in) :: in_soilLiqFlux ! input class object for soilLiqFlux + type(io_type_soilLiqFlux),intent(in) :: io_soilLiqFlux ! input-output class object for soilLiqFlux type(model_options),intent(in) :: model_decisions(maxvarDecisions) ! the model decision structure - type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU + type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU real(rkind),intent(in) :: mLayerDiffuse(1:nSoil) ! diffusivity at layer mid-point (m2 s-1) real(rkind),intent(in) :: dHydCond_dTemp(1:nSoil) ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) real(rkind),intent(in) :: dHydCond_dVolLiq(1:nSoil) ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) @@ -1968,16 +1956,16 @@ subroutine initialize_in_iLayerFlux(in_iLayerFlux,iLayer,nSoil,ibeg,iend,in_soil ! intent(in): model control ixRichards => model_decisions(iLookDECISIONS%f_Richards)%iDecision,& ! index of the form of Richards' equation ! intent(in): state variables (adjacent layers) - mLayerMatricHeadLiqTrial => in_soilLiqFlx % mLayerMatricHeadLiqTrial, & ! liquid matric head in each layer at the current iteration (m) - mLayerVolFracLiqTrial => in_soilLiqFlx % mLayerVolFracLiqTrial, & ! volumetric fraction of liquid water at the current iteration (-) + mLayerMatricHeadLiqTrial => in_soilLiqFlux % mLayerMatricHeadLiqTrial, & ! liquid matric head in each layer at the current iteration (m) + mLayerVolFracLiqTrial => in_soilLiqFlux % mLayerVolFracLiqTrial, & ! volumetric fraction of liquid water at the current iteration (-) ! intent(in): model coordinate variables (adjacent layers) mLayerHeight => prog_data%var(iLookPROG%mLayerHeight)%dat(ibeg:iend), & ! height of the layer mid-point (m) ! intent(in): temperature derivatives - dPsiLiq_dTemp => in_soilLiqFlx % dPsiLiq_dTemp, & ! derivative in liquid water matric potential w.r.t. temperature (m K-1) + dPsiLiq_dTemp => in_soilLiqFlux % dPsiLiq_dTemp, & ! derivative in liquid water matric potential w.r.t. temperature (m K-1) ! intent(in): transmittance (adjacent layers) - mLayerHydCond => io_soilLiqFlx % mLayerHydCond, & ! hydraulic conductivity in each soil layer (m s-1) + mLayerHydCond => io_soilLiqFlux % mLayerHydCond, & ! hydraulic conductivity in each soil layer (m s-1) ! intent(in): transmittance derivatives (adjacent layers) - dHydCond_dMatric => io_soilLiqFlx % dHydCond_dMatric & ! derivative in hydraulic conductivity w.r.t matric head (s-1) + dHydCond_dMatric => io_soilLiqFlux % dHydCond_dMatric & ! derivative in hydraulic conductivity w.r.t matric head (s-1) &) ! intent(in): model control in_iLayerFlux % ixRichards = ixRichards ! index defining the form of Richards' equation (moisture or mixdform) @@ -1999,10 +1987,10 @@ subroutine initialize_in_iLayerFlux(in_iLayerFlux,iLayer,nSoil,ibeg,iend,in_soil end associate end subroutine initialize_in_iLayerFlux - subroutine finalize_out_iLayerFlux(out_iLayerFlux,iLayer,nSoil,io_soilLiqFlx,iLayerHydCond,iLayerDiffuse,err,cmessage) + subroutine finalize_out_iLayerFlux(out_iLayerFlux,iLayer,nSoil,io_soilLiqFlux,iLayerHydCond,iLayerDiffuse,err,cmessage) class(out_type_iLayerFlux),intent(in) :: out_iLayerFlux ! class object for output iLayerFlux variables integer(i4b),intent(in) :: nSoil,iLayer ! number of soil layers and index - type(io_type_soilLiqFlx),intent(inout) :: io_soilLiqFlx ! input-output class object for soilLiqFlx + type(io_type_soilLiqFlux),intent(inout) :: io_soilLiqFlux ! input-output class object for soilLiqFlux real(rkind),intent(inout) :: iLayerHydCond(0:nSoil) ! hydraulic conductivity at layer interface (m s-1) real(rkind),intent(inout) :: iLayerDiffuse(0:nSoil) ! diffusivity at layer interface (m2 s-1) integer(i4b),intent(out) :: err ! error code @@ -2010,12 +1998,12 @@ subroutine finalize_out_iLayerFlux(out_iLayerFlux,iLayer,nSoil,io_soilLiqFlx,iLa associate(& ! intent(out): vertical flux at the layer interface (scalars) - iLayerLiqFluxSoil => io_soilLiqFlx % iLayerLiqFluxSoil,& ! liquid flux at soil layer interfaces (m s-1) + iLayerLiqFluxSoil => io_soilLiqFlux % iLayerLiqFluxSoil,& ! liquid flux at soil layer interfaces (m s-1) ! intent(out): derivatives in fluxes in the layer above and layer below w.r.t ... - dq_dHydStateAbove => io_soilLiqFlx % dq_dHydStateAbove,& ! ... state variables in the layer above - dq_dHydStateBelow => io_soilLiqFlx % dq_dHydStateBelow,& ! ... state variables in the layer below - dq_dNrgStateAbove => io_soilLiqFlx % dq_dNrgStateAbove,& ! ... temperature in the layer above (m s-1 K-1) - dq_dNrgStateBelow => io_soilLiqFlx % dq_dNrgStateBelow & ! ... temperature in the layer below (m s-1 K-1) + dq_dHydStateAbove => io_soilLiqFlux % dq_dHydStateAbove,& ! ... state variables in the layer above + dq_dHydStateBelow => io_soilLiqFlux % dq_dHydStateBelow,& ! ... state variables in the layer below + dq_dNrgStateAbove => io_soilLiqFlux % dq_dNrgStateAbove,& ! ... temperature in the layer above (m s-1 K-1) + dq_dNrgStateBelow => io_soilLiqFlux % dq_dNrgStateBelow & ! ... temperature in the layer below (m s-1 K-1) &) ! intent(out): tranmsmittance at the layer interface (scalars) iLayerHydCond(iLayer) = out_iLayerFlux % iLayerHydCond ! hydraulic conductivity at the interface between layers (m s-1) @@ -2035,19 +2023,19 @@ end subroutine finalize_out_iLayerFlux ! **** end iLayerFlux **** ! **** qDrainFlux **** - subroutine initialize_in_qDrainFlux(in_qDrainFlux,nSoil,ibeg,iend,in_soilLiqFlx,io_soilLiqFlx,model_decisions,& + subroutine initialize_in_qDrainFlux(in_qDrainFlux,nSoil,ibeg,iend,in_soilLiqFlux,io_soilLiqFlux,model_decisions,& &prog_data,mpar_data,flux_data,diag_data,iceImpedeFac,& &dHydCond_dVolLiq,dHydCond_dTemp) - class(in_type_qDrainFlux),intent(out) :: in_qDrainFlux ! class object for input qDrainFlux variables - integer(i4b),intent(in) :: nSoil ! number of soil layers - integer(i4b),intent(in) :: ibeg,iend ! start and end indices of the soil layers in concatanated snow-soil vector - type(in_type_soilLiqFlx),intent(in) :: in_soilLiqFlx ! input class object for soilLiqFlx - type(io_type_soilLiqFlx),intent(in) :: io_soilLiqFlx ! input-output class object for soilLiqFlx + class(in_type_qDrainFlux),intent(out) :: in_qDrainFlux ! class object for input qDrainFlux variables + integer(i4b),intent(in) :: nSoil ! number of soil layers + integer(i4b),intent(in) :: ibeg,iend ! start and end indices of the soil layers in concatanated snow-soil vector + type(in_type_soilLiqFlux),intent(in) :: in_soilLiqFlux ! input class object for soilLiqFlux + type(io_type_soilLiqFlux),intent(in) :: io_soilLiqFlux ! input-output class object for soilLiqFlux type(model_options),intent(in) :: model_decisions(maxvarDecisions) ! the model decision structure - type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU - type(var_dlength),intent(in) :: mpar_data ! model parameters - type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU - type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU + type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_dlength),intent(in) :: flux_data ! model fluxes for a local HRU + type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU real(rkind),intent(in) :: iceImpedeFac(1:nSoil) ! ice impedence factor at layer mid-points (-) real(rkind),intent(in) :: dHydCond_dVolLiq(1:nSoil) ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) real(rkind),intent(in) :: dHydCond_dTemp(1:nSoil) ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) @@ -2057,8 +2045,8 @@ subroutine initialize_in_qDrainFlux(in_qDrainFlux,nSoil,ibeg,iend,in_soilLiqFlx, ixRichards => model_decisions(iLookDECISIONS%f_Richards)%iDecision,& ! index of the form of Richards' equation ixBcLowerSoilHydrology => model_decisions(iLookDECISIONS%bcLowrSoiH)%iDecision,& ! index of the lower boundary conditions for soil hydrology ! intent(in): state variables - mLayerMatricHeadLiqTrial => in_soilLiqFlx % mLayerMatricHeadLiqTrial, & ! liquid matric head in each layer at the current iteration (m) - mLayerVolFracLiqTrial => in_soilLiqFlx % mLayerVolFracLiqTrial, & ! volumetric fraction of liquid water at the current iteration (-) + mLayerMatricHeadLiqTrial => in_soilLiqFlux % mLayerMatricHeadLiqTrial, & ! liquid matric head in each layer at the current iteration (m) + mLayerVolFracLiqTrial => in_soilLiqFlux % mLayerVolFracLiqTrial, & ! volumetric fraction of liquid water at the current iteration (-) ! intent(in): model coordinate variables mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat(ibeg:iend), & ! depth of the layer (m) mLayerHeight => prog_data%var(iLookPROG%mLayerHeight)%dat(ibeg:iend),& ! height of the layer mid-point (m) @@ -2066,13 +2054,13 @@ subroutine initialize_in_qDrainFlux(in_qDrainFlux,nSoil,ibeg,iend,in_soilLiqFlx, lowerBoundHead => mpar_data%var(iLookPARAM%lowerBoundHead)%dat(1), & ! lower boundary condition for matric head (m) lowerBoundTheta => mpar_data%var(iLookPARAM%lowerBoundTheta)%dat(1),& ! lower boundary condition for volumetric liquid water content (-) ! intent(in): derivative in the soil water characteristic - mLayerdPsi_dTheta => io_soilLiqFlx % mLayerdPsi_dTheta, & ! derivative in the soil water characteristic w.r.t. theta (m) - dPsiLiq_dTemp => in_soilLiqFlx % dPsiLiq_dTemp, & ! derivative in liquid water matric potential w.r.t. temperature (m K-1) + mLayerdPsi_dTheta => io_soilLiqFlux % mLayerdPsi_dTheta, & ! derivative in the soil water characteristic w.r.t. theta (m) + dPsiLiq_dTemp => in_soilLiqFlux % dPsiLiq_dTemp, & ! derivative in liquid water matric potential w.r.t. temperature (m K-1) ! intent(in): transmittance iLayerSatHydCond => flux_data%var(iLookFLUX%iLayerSatHydCond)%dat,& ! saturated hydraulic conductivity at the interface of each layer (m s-1) - mLayerHydCond => io_soilLiqFlx % mLayerHydCond, & ! hydraulic conductivity in each soil layer (m s-1) + mLayerHydCond => io_soilLiqFlux % mLayerHydCond, & ! hydraulic conductivity in each soil layer (m s-1) ! intent(in): transmittance derivatives - dHydCond_dMatric => io_soilLiqFlx % dHydCond_dMatric,& ! derivative in hydraulic conductivity w.r.t matric head (s-1) + dHydCond_dMatric => io_soilLiqFlux % dHydCond_dMatric,& ! derivative in hydraulic conductivity w.r.t matric head (s-1) ! intent(in): soil parameters vGn_alpha => mpar_data%var(iLookPARAM%vGn_alpha)%dat, & ! "alpha" parameter (m-1) vGn_n => mpar_data%var(iLookPARAM%vGn_n)%dat, & ! "n" parameter (-) @@ -2117,21 +2105,21 @@ subroutine initialize_in_qDrainFlux(in_qDrainFlux,nSoil,ibeg,iend,in_soilLiqFlx, end associate end subroutine initialize_in_qDrainFlux - subroutine finalize_out_qDrainFlux(out_qDrainFlux,nSoil,io_soilLiqFlx,iLayerHydCond,iLayerDiffuse,err,cmessage) - class(out_type_qDrainFlux),intent(in) :: out_qDrainFlux ! class object for output qDrainFlux variables - integer(i4b),intent(in) :: nSoil ! number of soil layers - type(io_type_soilLiqFlx),intent(inout) :: io_soilLiqFlx ! input-output class object for soilLiqFlx - real(rkind),intent(inout) :: iLayerHydCond(0:nSoil) ! hydraulic conductivity at layer interface (m s-1) - real(rkind),intent(inout) :: iLayerDiffuse(0:nSoil) ! diffusivity at layer interface (m2 s-1) - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: cmessage ! error message + subroutine finalize_out_qDrainFlux(out_qDrainFlux,nSoil,io_soilLiqFlux,iLayerHydCond,iLayerDiffuse,err,cmessage) + class(out_type_qDrainFlux),intent(in) :: out_qDrainFlux ! class object for output qDrainFlux variables + integer(i4b),intent(in) :: nSoil ! number of soil layers + type(io_type_soilLiqFlux),intent(inout) :: io_soilLiqFlux ! input-output class object for soilLiqFlux + real(rkind),intent(inout) :: iLayerHydCond(0:nSoil) ! hydraulic conductivity at layer interface (m s-1) + real(rkind),intent(inout) :: iLayerDiffuse(0:nSoil) ! diffusivity at layer interface (m2 s-1) + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: cmessage ! error message associate(& ! intent(out): drainage flux - iLayerLiqFluxSoil => io_soilLiqFlx % iLayerLiqFluxSoil,& ! liquid flux at soil layer interfaces (m s-1) + iLayerLiqFluxSoil => io_soilLiqFlux % iLayerLiqFluxSoil,& ! liquid flux at soil layer interfaces (m s-1) ! intent(out): derivatives in drainage flux w.r.t. ... - dq_dHydStateAbove => io_soilLiqFlx % dq_dHydStateAbove,& ! ... state variables in the layer above - dq_dNrgStateAbove => io_soilLiqFlx % dq_dNrgStateAbove & ! ... temperature in the layer above (m s-1 K-1) + dq_dHydStateAbove => io_soilLiqFlux % dq_dHydStateAbove,& ! ... state variables in the layer above + dq_dNrgStateAbove => io_soilLiqFlux % dq_dNrgStateAbove & ! ... temperature in the layer above (m s-1 K-1) &) ! intent(out): hydraulic conductivity and diffusivity at the surface iLayerHydCond(nSoil) = out_qDrainFlux % bottomHydCond ! hydraulic conductivity at the bottom of the unsatuarted zone (m s-1) @@ -2307,10 +2295,10 @@ subroutine finalize_out_lineSearchRefinement(out_lineSearchRefinement,fNew,conve message = out_lineSearchRefinement % message ! intent(out): error message end subroutine finalize_out_lineSearchRefinement - ! **** summaSolve4homegrown **** + ! **** summaSolv4homegrown **** - subroutine initialize_in_summaSolve4homegrown(in_SS4NR,dt_cur,dt,iter,nSnow,nSoil,nLayers,nLeadDim,nState,ixMatrix,firstSubStep,computeVegFlux,scalarSolution,fOld) - class(in_type_summaSolve4homegrown),intent(out) :: in_SS4NR ! class object for intent(out) arguments + subroutine initialize_in_summaSolv4homegrown(in_SS4NR,dt_cur,dt,iter,nSnow,nSoil,nLayers,nLeadDim,nState,ixMatrix,firstSubStep,computeVegFlux,scalarSolution,fOld) + class(in_type_summaSolv4homegrown),intent(out) :: in_SS4NR ! class object for intent(out) arguments real(rkind) ,intent(in) :: dt_cur ! intent(in): current stepsize real(rkind) ,intent(in) :: dt ! intent(in): entire time step for drainage pond rate integer(i4b),intent(in) :: iter ! intent(in): iteration index @@ -2338,10 +2326,10 @@ subroutine initialize_in_summaSolve4homegrown(in_SS4NR,dt_cur,dt,iter,nSnow,nSoi in_SS4NR % computeVegFlux = computeVegFlux in_SS4NR % scalarSolution = scalarSolution in_SS4NR % fOld = fOld - end subroutine initialize_in_summaSolve4homegrown + end subroutine initialize_in_summaSolv4homegrown - subroutine initialize_io_summaSolve4homegrown(io_SS4NR,firstFluxCall,xMin,xMax,ixSaturation) - class(io_type_summaSolve4homegrown),intent(out) :: io_SS4NR ! class object for intent(inout) arguments + subroutine initialize_io_summaSolv4homegrown(io_SS4NR,firstFluxCall,xMin,xMax,ixSaturation) + class(io_type_summaSolv4homegrown),intent(out) :: io_SS4NR ! class object for intent(inout) arguments logical(lgt),intent(in) :: firstFluxCall ! intent(inout): flag to indicate if we are processing the first flux call real(rkind) ,intent(in) :: xMin,xMax ! intent(inout): brackets of the root integer(i4b),intent(in) :: ixSaturation ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) @@ -2350,10 +2338,10 @@ subroutine initialize_io_summaSolve4homegrown(io_SS4NR,firstFluxCall,xMin,xMax,i io_SS4NR % xMin = xMin io_SS4NR % xMax = xMax io_SS4NR % ixSaturation = ixSaturation - end subroutine initialize_io_summaSolve4homegrown + end subroutine initialize_io_summaSolv4homegrown - subroutine finalize_io_summaSolve4homegrown(io_SS4NR,firstFluxCall,xMin,xMax,ixSaturation) - class(io_type_summaSolve4homegrown),intent(in) :: io_SS4NR ! class object for intent(inout) arguments + subroutine finalize_io_summaSolv4homegrown(io_SS4NR,firstFluxCall,xMin,xMax,ixSaturation) + class(io_type_summaSolv4homegrown),intent(in) :: io_SS4NR ! class object for intent(inout) arguments logical(lgt),intent(out) :: firstFluxCall ! intent(inout): flag to indicate if we are processing the first flux call real(rkind) ,intent(out) :: xMin,xMax ! intent(inout): brackets of the root integer(i4b),intent(out) :: ixSaturation ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) @@ -2362,10 +2350,10 @@ subroutine finalize_io_summaSolve4homegrown(io_SS4NR,firstFluxCall,xMin,xMax,ixS xMin = io_SS4NR % xMin xMax = io_SS4NR % xMax ixSaturation = io_SS4NR % ixSaturation - end subroutine finalize_io_summaSolve4homegrown + end subroutine finalize_io_summaSolv4homegrown - subroutine finalize_out_summaSolve4homegrown(out_SS4NR,fNew,converged,err,message) - class(out_type_summaSolve4homegrown),intent(in) :: out_SS4NR ! class object for intent(out) arguments + subroutine finalize_out_summaSolv4homegrown(out_SS4NR,fNew,converged,err,message) + class(out_type_summaSolv4homegrown),intent(in) :: out_SS4NR ! class object for intent(out) arguments real(rkind) ,intent(out) :: fNew ! intent(out): new function evaluation logical(lgt),intent(out) :: converged ! intent(out): convergence flag integer(i4b),intent(out) :: err ! intent(out): error code @@ -2375,6 +2363,6 @@ subroutine finalize_out_summaSolve4homegrown(out_SS4NR,fNew,converged,err,messag converged = out_SS4NR % converged err = out_SS4NR % err message = out_SS4NR % message - end subroutine finalize_out_summaSolve4homegrown + end subroutine finalize_out_summaSolv4homegrown END MODULE data_types diff --git a/build/source/dshare/flxMapping.f90 b/build/source/dshare/fluxMapping.f90 similarity index 97% rename from build/source/dshare/flxMapping.f90 rename to build/source/dshare/fluxMapping.f90 index 95294e621..77507f9aa 100644 --- a/build/source/dshare/flxMapping.f90 +++ b/build/source/dshare/fluxMapping.f90 @@ -1,11 +1,11 @@ -module flxMapping_module +module fluxMapping_module implicit none private -public::flxMapping +public::fluxMapping contains - subroutine flxMapping(err,message) - USE nrtype + subroutine fluxMapping(err,message) + USE nr_type ! 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 @@ -37,7 +37,7 @@ subroutine flxMapping(err,message) 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/' + err=0; message='fluxMapping/' ! get the number of fluxes nFlux = size(flux_meta) @@ -131,7 +131,6 @@ subroutine flxMapping(err,message) 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) @@ -181,7 +180,7 @@ subroutine flxMapping(err,message) ! ** 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)//'"' + message=trim(message)//'flux-to-state mapping is undefined for variable "'//trim(flux_meta(iVar)%varName)//'"' err=20; return endif end do @@ -214,6 +213,6 @@ subroutine flxMapping(err,message) flux2state_liq(iVar)%var_info = flux_meta(iVar) end do - end subroutine flxMapping + end subroutine fluxMapping -end module flxMapping_module +end module fluxMapping_module diff --git a/build/source/dshare/get_ixname.f90 b/build/source/dshare/get_ixname.f90 index 4daed6c20..1d24af26e 100644 --- a/build/source/dshare/get_ixname.f90 +++ b/build/source/dshare/get_ixname.f90 @@ -20,7 +20,7 @@ module get_ixname_module ! used to get the index of a named variable -USE nrtype, integerMissing=>nr_integerMissing +USE nr_type, integerMissing=>nr_integerMissing implicit none private public::get_ixdecisions @@ -99,6 +99,8 @@ function get_ixdecisions(varName) case('aquiferIni' ); get_ixdecisions=iLookDECISIONS%aquiferIni ! choice of full or empty aquifer at start case('infRateMax' ); get_ixdecisions=iLookDECISIONS%infRateMax ! choice of maximum infiltration rate method case('surfRun_SE' ); get_ixdecisions=iLookDECISIONS%surfRun_SE ! choice of parameterization for saturation excess surface runoff + case('read_force' ); get_ixdecisions=iLookDECISIONS%read_force ! method used to read forcing data (per step or full read) + case('write_buff' ); get_ixdecisions=iLookDECISIONS%write_buff ! method used to buffer writing of model output (none, full) ! get to here if cannot find the variable case default get_ixdecisions = integerMissing @@ -521,21 +523,15 @@ function get_ixDiag(varName) case('scalarCanopyIceMax' ); get_ixDiag = iLookDIAG%scalarCanopyIceMax ! maximum interception storage capacity for ice (kg m-2) case('scalarCanopyLiqMax' ); get_ixDiag = iLookDIAG%scalarCanopyLiqMax ! maximum interception storage capacity for liquid water (kg m-2) case('scalarGrowingSeasonIndex' ); get_ixDiag = iLookDIAG%scalarGrowingSeasonIndex ! growing season index (0=off, 1=on) - case('scalarVolHtCap_air' ); get_ixDiag = iLookDIAG%scalarVolHtCap_air ! volumetric heat capacity air (J m-3 K-1) - case('scalarVolHtCap_ice' ); get_ixDiag = iLookDIAG%scalarVolHtCap_ice ! volumetric heat capacity ice (J m-3 K-1) - case('scalarVolHtCap_soil' ); get_ixDiag = iLookDIAG%scalarVolHtCap_soil ! volumetric heat capacity dry soil (J m-3 K-1) - case('scalarVolHtCap_water' ); get_ixDiag = iLookDIAG%scalarVolHtCap_water ! volumetric heat capacity liquid wat (J m-3 K-1) case('mLayerVolHtCapBulk' ); get_ixDiag = iLookDIAG%mLayerVolHtCapBulk ! volumetric heat capacity in each layer (J m-3 K-1) case('mLayerCm' ); get_ixDiag = iLookDIAG%mLayerCm ! Cm for each layer (J m-3) - case('scalarLambda_drysoil' ); get_ixDiag = iLookDIAG%scalarLambda_drysoil ! thermal conductivity of dry soil (W m-1) - case('scalarLambda_wetsoil' ); get_ixDiag = iLookDIAG%scalarLambda_wetsoil ! thermal conductivity of wet soil (W m-1) case('mLayerThermalC' ); get_ixDiag = iLookDIAG%mLayerThermalC ! thermal conductivity at the mid-point of each layer (W m-1 K-1) case('iLayerThermalC' ); get_ixDiag = iLookDIAG%iLayerThermalC ! thermal conductivity at the interface of each layer (W m-1 K-1) ! enthalpy case('scalarCanopyEnthTemp' ); get_ixDiag = iLookDIAG%scalarCanopyEnthTemp ! temperature component of enthalpy of the vegetation canopy (J m-3) case('mLayerEnthTemp' ); get_ixDiag = iLookDIAG%mLayerEnthTemp ! temperature component of enthalpy of the snow+soil layers (J m-3) - case('scalarTotalSoilEnthalpy' ); get_ixDiag = iLookDIAG%scalarTotalSoilEnthalpy ! total enthalpy of the soil column (J m-3) case('scalarTotalSnowEnthalpy' ); get_ixDiag = iLookDIAG%scalarTotalSnowEnthalpy ! total enthalpy of the snow column (J m-3) + case('scalarTotalSoilEnthalpy' ); get_ixDiag = iLookDIAG%scalarTotalSoilEnthalpy ! total enthalpy of the soil column (J m-3) ! forcing case('scalarVPair' ); get_ixDiag = iLookDIAG%scalarVPair ! vapor pressure of the air above the vegetation canopy (Pa) case('scalarVP_CanopyAir' ); get_ixDiag = iLookDIAG%scalarVP_CanopyAir ! vapor pressure of the canopy air space (Pa) @@ -588,7 +584,9 @@ function get_ixDiag(varName) 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 + ! total mass changes + case('scalarTotalMassChange' ); get_ixDiag = iLookDIAG%scalarTotalMassChange ! mass change of all system together (kg m-2 s-1) + ! soil hydrology case('scalarInfilArea' ); get_ixDiag = iLookDIAG%scalarInfilArea ! fraction of area where water can infiltrate, may be frozen (-) case('scalarSaturatedArea' ); get_ixDiag = iLookDIAG%scalarSaturatedArea ! fraction of area that is considered saturated (-) case('scalarFrozenArea' ); get_ixDiag = iLookDIAG%scalarFrozenArea ! fraction of area that is considered impermeable due to soil ice (-) @@ -604,8 +602,6 @@ function get_ixDiag(varName) case('scalarTotalSoilWat' ); get_ixDiag = iLookDIAG%scalarTotalSoilWat ! total mass of water in the soil (kg m-2) ! variable shortcuts case('scalarVGn_m' ); get_ixDiag = iLookDIAG%scalarVGn_m ! van Genuchten "m" parameter (-) - case('scalarKappa' ); get_ixDiag = iLookDIAG%scalarKappa ! constant in the freezing curve function (m K-1) - case('scalarVolLatHt_fus' ); get_ixDiag = iLookDIAG%scalarVolLatHt_fus ! volumetric latent heat of fusion (J m-3) ! timing information case('numFluxCalls' ); get_ixDiag = iLookDIAG%numFluxCalls ! number of flux calls (-) case('wallClockTime' ); get_ixDiag = iLookDIAG%wallClockTime ! wall clock time for physics routines (s) @@ -716,7 +712,6 @@ function get_ixFlux(varName) 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) @@ -1014,6 +1009,7 @@ function get_ixBvar(varName) case('basin__AquiferTranspire' ); get_ixBvar = iLookBVAR%basin__AquiferTranspire ! transpiration from the aquifer (m s-1) case('basin__TotalRunoff' ); get_ixBvar = iLookBVAR%basin__TotalRunoff ! total runoff to channel from all active components (m s-1) case('basin__SoilDrainage' ); get_ixBvar = iLookBVAR%basin__SoilDrainage ! soil drainage (m s-1) + case('basin__StorageChange' ); get_ixBvar = iLookBVAR%basin__StorageChange ! change in total basin storage (kg m-2 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 (-) @@ -1077,16 +1073,16 @@ function get_varTypeName(varType) case(iLookVarType%unknown);get_varTypeName='unknown' ! get to here if cannot find the variable case default - get_VarTypeName = 'missing' + get_varTypeName = 'missing' end select - end function get_VarTypeName + end function get_varTypeName ! ******************************************************************************************************************* ! public subroutine get_ixUnknown: get the index of the named variable type from ANY structure, as well as the ! structure that it was found in ! ******************************************************************************************************************* subroutine get_ixUnknown(varName,typeName,vDex,err,message) - USE nrtype + USE nr_type USE globalData,only:structInfo ! information on the data structures implicit none @@ -1132,7 +1128,7 @@ subroutine get_ixUnknown(varName,typeName,vDex,err,message) end subroutine get_ixUnknown ! ******************************************************************************************************************* - ! public function get_ixFreq: get the index of the named variables for the output frequencies + ! public function get_ixLookup: get the index of the named variables for lookup ! ******************************************************************************************************************* function get_ixLookup(varName) USE var_lookup,only:iLookLOOKUP ! indices of the named variables @@ -1189,7 +1185,6 @@ function get_ixStat(varName) case('variance'); get_ixStat = iLookSTAT%vari case('minimum' ); get_ixStat = iLookSTAT%mini case('maximum' ); get_ixStat = iLookSTAT%maxi - case('mode' ); get_ixStat = iLookSTAT%mode ! get to here if cannot find the variable case default get_ixStat = integerMissing @@ -1234,7 +1229,6 @@ function get_statName(istat) case(iLookSTAT%vari);get_statName='variance' case(iLookSTAT%mini);get_statName='minimum' case(iLookSTAT%maxi);get_statName='maximum' - case(iLookSTAT%mode);get_statName='mode' ! get to here if cannot find the variable case default get_statName = 'unknown' diff --git a/build/source/dshare/globalData.f90 b/build/source/dshare/globalData.f90 index b1e7267c2..3216c25c5 100644 --- a/build/source/dshare/globalData.f90 +++ b/build/source/dshare/globalData.f90 @@ -24,7 +24,7 @@ MODULE globalData ! data types - USE nrtype + USE nr_type USE netcdf USE,intrinsic :: ieee_arithmetic ! IEEE arithmetic USE data_types,only:gru2hru_map ! mapping between the GRUs and HRUs @@ -37,6 +37,9 @@ MODULE globalData 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 + USE data_types,only:gru_hru_int ! x%gru(:)%hru(:)%var(:) (i4b) + USE data_types,only:gru_hru_double ! x%gru(:)%hru(:)%var(:) (rkind) + USE data_types,only:gru_double ! x%gru(:)%var(:) (rkind) ! 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 @@ -62,9 +65,9 @@ MODULE globalData ! ---------------------------------------------------------------------------------------------------------------- ! define missing values - real(rkind),parameter,public :: quadMissing = nr_quadMissing ! (from nrtype) missing quadruple precision number - real(rkind),parameter,public :: realMissing = nr_realMissing ! (from nrtype) missing real number - integer(i4b),parameter,public :: integerMissing = nr_integerMissing ! (from nrtype) missing integer + real(rkind),parameter,public :: quadMissing = nr_quadMissing ! (from nr_type) missing quadruple precision number + real(rkind),parameter,public :: realMissing = nr_realMissing ! (from nr_type) missing real number + integer(i4b),parameter,public :: integerMissing = nr_integerMissing ! (from nr_type) 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) @@ -142,7 +145,6 @@ MODULE globalData struct_info('lookup','LOOKUP',maxvarLookup) /) ! the lookup table data structure ! fixed model decisions logical(lgt) , parameter, public :: overwriteRSMIN=.false. ! flag to overwrite RSMIN - integer(i4b) , parameter, public :: maxSoilLayers=10000 ! Maximum Number of Soil Layers ! ---------------------------------------------------------------------------------------------------------------- ! * part 2: globally constant variables/structures that require initialization @@ -207,8 +209,10 @@ MODULE globalData character(len=256),save,public :: output_fileSuffix='' ! suffix for the output file ! define controls on model output logical(lgt),dimension(maxvarFreq),save,public :: finalizeStats=.false. ! flags to finalize statistics + logical(lgt),save,public :: allowRoutingOutput=.false. ! flag to allow routing variable output (currently very large and slow to write, so turned off by default) integer(i4b),save,public :: maxLayers ! maximum number of layers integer(i4b),save,public :: maxSnowLayers ! maximum number of snow layers + integer(i4b),save,public :: maxSoilLayers ! maximum number of soil layers ! define control variables integer(i4b),save,public :: startGRU ! index of the starting GRU for parallelization run integer(i4b),save,public :: checkHRU ! index of the HRU for a single HRU run @@ -232,6 +236,17 @@ MODULE globalData integer(i4b),save,public :: chunksize=1024 ! chunk size for the netcdf read/write integer(i4b),save,public :: outputPrecision=nf90_double ! variable type integer(i4b),save,public :: outputCompressionLevel=4 ! output netcdf file deflate level: 0-9. 0 is no compression. + ! define data structures for the buffered read + integer(i4b),save,public :: ixStartRead ! start index of the data read + real(rkind),save,public,allocatable :: fulltimeVec(:) ! full time vector in an input file (nRead) + type(gru_hru_double),save,public,allocatable :: fullforcingStruct(:) ! x(:)%gru(:)%hru(:)%var(:) -- full model forcing data + ! define data structures for the buffered write + type(gru_hru_int), save,public,allocatable :: fullIndxSave(:) ! x(:)%gru(:)%hru(:)%var(:) -- saved output for indices + type(gru_hru_double),save,public,allocatable :: fullForcSave(:) ! x(:)%gru(:)%hru(:)%var(:) -- saved output for forcing + type(gru_hru_double),save,public,allocatable :: fullProgSave(:) ! x(:)%gru(:)%hru(:)%var(:) -- saved output for prognostic variables + type(gru_hru_double),save,public,allocatable :: fullDiagSave(:) ! x(:)%gru(:)%hru(:)%var(:) -- saved output for diagnostic variables + type(gru_hru_double),save,public,allocatable :: fullFluxSave(:) ! x(:)%gru(:)%hru(:)%var(:) -- saved output for flux variables + type(gru_double), save,public,allocatable :: fullBvarSave(:) ! x(:)%gru(:)%var(:) -- saved output for basin variables ! define result from the time calls integer(i4b),dimension(8),save,public :: startInit,endInit ! date/time for the start and end of the initialization integer(i4b),dimension(8),save,public :: startSetup,endSetup ! date/time for the start and end of the parameter setup @@ -239,7 +254,7 @@ MODULE globalData integer(i4b),dimension(8),save,public :: startRead,endRead ! date/time for the start and end of the data read integer(i4b),dimension(8),save,public :: startWrite,endWrite ! date/time for the start and end of the stats/write integer(i4b),dimension(8),save,public :: startPhysics,endPhysics ! date/time for the start and end of the physics - ! define elapsed time + ! define elapsed time real(rkind),save,public :: elapsedInit ! elapsed time for the initialization real(rkind),save,public :: elapsedSetup ! elapsed time for the parameter setup real(rkind),save,public :: elapsedRestart ! elapsed time to read restart data diff --git a/build/source/dshare/multiconst.f90 b/build/source/dshare/multiconst.f90 index 7d1a48519..f3a604d89 100644 --- a/build/source/dshare/multiconst.f90 +++ b/build/source/dshare/multiconst.f90 @@ -19,7 +19,7 @@ ! along with this program. If not, see . MODULE multiconst - USE nrtype + USE nr_type ! define physical constants real(rkind), PARAMETER :: ave_slp = 101325.0_rkind ! mean sea level pressure (Pa) real(rkind), PARAMETER :: vkc = 0.4_rkind ! von Karman constant (-) diff --git a/build/source/dshare/outpt_stat.f90 b/build/source/dshare/outpt_stat.f90 index d0c12ff63..0c9f99f43 100644 --- a/build/source/dshare/outpt_stat.f90 +++ b/build/source/dshare/outpt_stat.f90 @@ -20,8 +20,8 @@ ! used to manage output statistics of the model and forcing variables module output_stats -USE nrtype, realMissing=>nr_realMissing -USE nrtype, integerMissing=>nr_integerMissing +USE nr_type, realMissing=>nr_realMissing +USE nr_type, integerMissing=>nr_integerMissing implicit none private public :: calcStats @@ -32,10 +32,11 @@ module output_stats ! from model variables ! ****************************************************************************************************** subroutine calcStats(stat,dat,meta,resetStats,finalizeStats,statCounter,err,message) - USE nrtype + USE nr_type USE data_types,only:extended_info,dlength,ilength ! metadata structure type USE var_lookup,only:iLookVarType ! named variables for variable types USE var_lookup,only:iLookSTAT ! named variables for output statistics types + USE get_ixname_module,only:get_freqName ! get name of frequency from frequency index implicit none ! input variables @@ -45,11 +46,9 @@ subroutine calcStats(stat,dat,meta,resetStats,finalizeStats,statCounter,err,mess logical(lgt) ,intent(in) :: resetStats(:) ! vector of flags to reset statistics logical(lgt) ,intent(in) :: finalizeStats(:) ! vector of flags to reset statistics integer(i4b) ,intent(in) :: statCounter(:) ! number of time steps in each output frequency - ! output variables 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 @@ -65,7 +64,7 @@ subroutine calcStats(stat,dat,meta,resetStats,finalizeStats,statCounter,err,mess ! don't do anything if var is not requested if (.not.meta(iVar)%varDesire) cycle - ! only treat stats of scalars - all others handled separately + ! only treat stats of scalars for now (may want to change this in the future) if (meta(iVar)%varType==iLookVarType%outstat) then ! index in parent structure @@ -73,9 +72,9 @@ subroutine calcStats(stat,dat,meta,resetStats,finalizeStats,statCounter,err,mess ! extract data from the structures select type (dat) - type is (real(rkind)); tdata = dat(pVar) - class is (dlength) ; tdata = dat(pVar)%dat(1) - class is (ilength) ; tdata = real(dat(pVar)%dat(1), kind(rkind)) + type is (real(rkind)); tdata = dat(pVar) + class is (dlength) ; tdata = dat(pVar)%dat(1) + class is (ilength) ; tdata = real(dat(pVar)%dat(1), kind(rkind)) class default;err=20;message=trim(message)//'dat type not found';return end select @@ -87,7 +86,8 @@ subroutine calcStats(stat,dat,meta,resetStats,finalizeStats,statCounter,err,mess end if if(err/=0)then; message=trim(message)//trim(cmessage);return; end if - end if ! if calculating statistics + end if ! (if stat of scalar) + end do ! looping through variables return @@ -96,13 +96,12 @@ end subroutine calcStats ! *********************************************************************************** ! Private subroutine calc_stats is a generic function to deal with any variable type. - ! Called from compile_stats ! *********************************************************************************** subroutine calc_stats(meta,stat,tdata,resetStats,finalizeStats,statCounter,err,message) - USE nrtype + USE nr_type ! data structures USE data_types,only:var_info,ilength,dlength ! type dec for meta data structures - USE var_lookup,only:maxVarFreq ! # of output frequencies + USE var_lookup,only:maxvarFreq ! # of output frequencies ! global variables USE globalData,only:data_step ! forcing timestep ! structures of named variables @@ -112,18 +111,18 @@ subroutine calc_stats(meta,stat,tdata,resetStats,finalizeStats,statCounter,err,m USE var_lookup,only:iLookTIME ! named variables for time information implicit none ! input variables - class(var_info),intent(in) :: meta ! meta data structure - class(*) ,intent(inout) :: stat ! statistics structure - real(rkind) ,intent(in) :: tdata ! data value - logical(lgt) ,intent(in) :: resetStats(:) ! vector of flags to reset statistics - logical(lgt) ,intent(in) :: finalizeStats(:) ! vector of flags to reset statistics - integer(i4b) ,intent(in) :: statCounter(:) ! number of time steps in each output frequency + class(var_info),intent(in) :: meta ! meta data structure + class(*) ,intent(inout) :: stat ! statistics structure + real(rkind) ,intent(in) :: tdata ! data value + logical(lgt) ,intent(in) :: resetStats(:) ! vector of flags to reset statistics + logical(lgt) ,intent(in) :: finalizeStats(:) ! vector of flags to reset statistics + integer(i4b) ,intent(in) :: statCounter(:) ! number of time steps in each output frequency ! output variables - 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 ! internals - real(rkind),dimension(maxvarFreq*2):: tstat ! temporary stats vector - integer(i4b) :: iFreq ! index of output frequency + real(rkind),dimension(maxvarFreq*2) :: tstat ! temporary stats vector + integer(i4b) :: iFreq ! index of output frequency ! initialize error control err=0; message='calc_stats/' @@ -137,25 +136,22 @@ subroutine calc_stats(meta,stat,tdata,resetStats,finalizeStats,statCounter,err,m ! --------------------------------------------- ! reset statistics at new frequency period ! --------------------------------------------- - do iFreq=1,maxVarFreq ! loop through output statistics + do iFreq=1,maxvarFreq ! loop through output statistics if(resetStats(iFreq))then ! flag to reset statistics if(meta%statIndex(iFreq)==integerMissing) cycle ! don't bother if output frequency is not desired for a given variable - if(meta%varType/=iLookVarType%outstat) cycle ! only calculate stats for scalars select case(meta%statIndex(iFreq)) ! act depending on the statistic ! ------------------------------------------------------------------------------------- case (iLookSTAT%totl) ! * summation over period - tstat(iFreq) = 0._rkind ! - resets stat at beginning of period + tstat(iFreq) = 0._rkind ! - resets stat at beginning of period case (iLookSTAT%mean) ! * mean over period - tstat(iFreq) = 0._rkind ! - resets stat at beginning of period + tstat(iFreq) = 0._rkind ! - resets stat at beginning of period case (iLookSTAT%vari) ! * variance over period - tstat(iFreq) = 0._rkind ! - resets E[X^2] term in var calc - tstat(maxVarFreq+iFreq) = 0._rkind ! - resets E[X]^2 term + tstat(iFreq) = 0._rkind ! - resets E[X^2] term in var calc + tstat(maxvarFreq+iFreq) = 0._rkind ! - resets E[X]^2 term case (iLookSTAT%mini) ! * minimum over period tstat(iFreq) = huge(tstat(iFreq)) ! - resets stat at beginning of period case (iLookSTAT%maxi) ! * maximum over period tstat(iFreq) = -huge(tstat(iFreq)) ! - resets stat at beginning of period - case (iLookSTAT%mode) ! * mode over period - tstat(iFreq) = realMissing ! - does not work case (iLookSTAT%inst) ! * instantaneous -- no need to reset case default message=trim(message)//'unable to identify type of statistic [reset]' @@ -168,9 +164,8 @@ subroutine calc_stats(meta,stat,tdata,resetStats,finalizeStats,statCounter,err,m ! --------------------------------------------- ! Calculate each statistic that is requested by user ! --------------------------------------------- - do iFreq=1,maxVarFreq ! loop through output statistics - if(meta%statIndex(iFreq)==integerMissing) cycle ! don't bother if output frequency is not desired for a given variab;e - if(meta%varType/=iLookVarType%outstat) cycle ! only calculate stats for scalars + do iFreq=1,maxvarFreq ! loop through output statistics + if(meta%statIndex(iFreq)==integerMissing) cycle ! don't bother if output frequency is not desired for a given variable select case(meta%statIndex(iFreq)) ! act depending on the statistic ! ------------------------------------------------------------------------------------- case (iLookSTAT%inst) ! * instantaneous value @@ -181,13 +176,11 @@ subroutine calc_stats(meta,stat,tdata,resetStats,finalizeStats,statCounter,err,m tstat(iFreq) = tstat(iFreq) + tdata ! - increment data case (iLookSTAT%vari) ! * variance over period tstat(iFreq) = tstat(iFreq) + tdata**2 ! - E[X^2] term in var calc - tstat(maxVarFreq+iFreq) = tstat(maxVarFreq+iFreq) + tdata ! - E[X]^2 term + tstat(maxvarFreq+iFreq) = tstat(maxvarFreq+iFreq) + tdata ! - E[X]^2 term case (iLookSTAT%mini) ! * minimum over period if (tdatatstat(iFreq)) tstat(iFreq) = tdata ! - check value - case (iLookSTAT%mode) ! * mode over period (does not workind) - tstat(iFreq) = realMissing case default message=trim(message)//'unable to identify type of statistic [calculating stats]' err=20; return @@ -198,7 +191,7 @@ subroutine calc_stats(meta,stat,tdata,resetStats,finalizeStats,statCounter,err,m ! --------------------------------------------- ! finalize statistics at end of frequency period ! --------------------------------------------- - do iFreq=1,maxVarFreq ! loop through output statistics + do iFreq=1,maxvarFreq ! loop through output statistics if(finalizeStats(iFreq))then if(meta%statIndex(iFreq)==integerMissing) cycle ! don't bother if output frequency is not desired for a given variable if(meta%varType/=iLookVarType%outstat) cycle ! only calculate stats for scalars @@ -207,8 +200,8 @@ subroutine calc_stats(meta,stat,tdata,resetStats,finalizeStats,statCounter,err,m case (iLookSTAT%mean) ! * mean over period tstat(iFreq) = tstat(iFreq)/statCounter(iFreq) ! - normalize sum into mean case (iLookSTAT%vari) ! * variance over period - tstat(maxVarFreq+iFreq) = tstat(maxVarFreq+1)/statCounter(iFreq) ! E[X] term - tstat(iFreq) = tstat(iFreq)/statCounter(iFreq) - tstat(maxVarFreq+iFreq)**2 ! full variance + tstat(maxvarFreq+iFreq) = tstat(maxvarFreq+1)/statCounter(iFreq) ! E[X] term + tstat(iFreq) = tstat(iFreq)/statCounter(iFreq) - tstat(maxvarFreq+iFreq)**2 ! full variance case default ! do nothing -- don't need finalization for most stats ! ------------------------------------------------------------------------------------- end select diff --git a/build/source/dshare/popMetadat.f90 b/build/source/dshare/popMetadat.f90 index 9340c3949..0be151612 100644 --- a/build/source/dshare/popMetadat.f90 +++ b/build/source/dshare/popMetadat.f90 @@ -1,5 +1,5 @@ module popMetadat_module -USE nrtype, integerMissing=>nr_integerMissing +USE nr_type, integerMissing=>nr_integerMissing implicit none ! define indices in metadata structures integer(i4b),parameter :: nameIndex=1 ! index of the variable name @@ -49,14 +49,15 @@ subroutine popMetadat(err,message) USE var_lookup, only: iLookLOOKUP ! named variables for lookup tables USE var_lookup, only: maxvarFreq ! number of output frequencies USE var_lookup, only: maxvarStat ! number of statistics - USE get_ixName_module,only:get_ixVarType ! to turn vartype strings to integers + USE get_ixName_module,only:get_ixVarType ! to turn varType strings to integers + implicit none ! dummy variables integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! internals character(256) :: cmessage ! error message - integer,dimension(maxVarFreq) :: iMissVec ! vector of missing integers + integer,dimension(maxvarFreq) :: iMissVec ! vector of missing integers ! initialize error control err=0; message='popMetadat/' @@ -373,21 +374,15 @@ subroutine popMetadat(err,message) diag_meta(iLookDIAG%scalarCanopyIceMax) = var_info('scalarCanopyIceMax' , 'maximum interception storage capacity for ice' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) diag_meta(iLookDIAG%scalarCanopyLiqMax) = var_info('scalarCanopyLiqMax' , 'maximum interception storage capacity for liquid water' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) diag_meta(iLookDIAG%scalarGrowingSeasonIndex) = var_info('scalarGrowingSeasonIndex' , 'growing season index (0=off, 1=on)' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarVolHtCap_air) = var_info('scalarVolHtCap_air' , 'volumetric heat capacity air' , 'J m-3 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarVolHtCap_ice) = var_info('scalarVolHtCap_ice' , 'volumetric heat capacity ice' , 'J m-3 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarVolHtCap_soil) = var_info('scalarVolHtCap_soil' , 'volumetric heat capacity dry soil' , 'J m-3 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarVolHtCap_water) = var_info('scalarVolHtCap_water' , 'volumetric heat capacity liquid wat' , 'J m-3 K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) diag_meta(iLookDIAG%mLayerVolHtCapBulk) = var_info('mLayerVolHtCapBulk' , 'volumetric heat capacity in each layer' , 'J m-3 K-1' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) diag_meta(iLookDIAG%mLayerCm) = var_info('mLayerCm' , 'Cm for each layer' , 'J m-3' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarLambda_drysoil) = var_info('scalarLambda_drysoil' , 'thermal conductivity of dry soil' , 'W m-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarLambda_wetsoil) = var_info('scalarLambda_wetsoil' , 'thermal conductivity of wet soil' , 'W m-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) diag_meta(iLookDIAG%mLayerThermalC) = var_info('mLayerThermalC' , 'thermal conductivity at the mid-point of each layer' , 'W m-1 K-1' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) diag_meta(iLookDIAG%iLayerThermalC) = var_info('iLayerThermalC' , 'thermal conductivity at the interface of each layer' , 'W m-1 K-1' , get_ixVarType('ifcToto'), iMissVec, iMissVec, .false.) ! enthalpy diag_meta(iLookDIAG%scalarCanopyEnthTemp) = var_info('scalarCanopyEnthTemp' , 'temperature component of enthalpy of the vegetation canopy' , 'J m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) diag_meta(iLookDIAG%mLayerEnthTemp) = var_info('mLayerEnthTemp' , 'temperature component of enthalpy of the snow+soil layers' , 'J m-3' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarTotalSoilEnthalpy) = var_info('scalarTotalSoilEnthalpy' , 'total enthalpy of the soil column' , 'J m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) diag_meta(iLookDIAG%scalarTotalSnowEnthalpy) = var_info('scalarTotalSnowEnthalpy' , 'total enthalpy of the snow column' , 'J m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + diag_meta(iLookDIAG%scalarTotalSoilEnthalpy) = var_info('scalarTotalSoilEnthalpy' , 'total enthalpy of the soil column' , 'J m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) ! forcing diag_meta(iLookDIAG%scalarVPair) = var_info('scalarVPair' , 'vapor pressure of the air above the vegetation canopy' , 'Pa' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) diag_meta(iLookDIAG%scalarVP_CanopyAir) = var_info('scalarVP_CanopyAir' , 'vapor pressure of the canopy air space' , 'Pa' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) @@ -440,6 +435,8 @@ subroutine popMetadat(err,message) diag_meta(iLookDIAG%mLayerThetaResid) = var_info('mLayerThetaResid' , 'residual volumetric water content in each snow layer' , '-' , get_ixVarType('midSnow'), iMissVec, iMissVec, .false.) diag_meta(iLookDIAG%mLayerPoreSpace) = var_info('mLayerPoreSpace' , 'total pore space in each snow layer' , '-' , get_ixVarType('midSnow'), iMissVec, iMissVec, .false.) diag_meta(iLookDIAG%mLayerMeltFreeze) = var_info('mLayerMeltFreeze' , 'ice content change from melt/freeze in each layer' , 'kg m-3' , get_ixVarType('midToto'), iMissVec, iMissVec, .false.) + ! total mass changes + diag_meta(iLookDIAG%scalarTotalMassChange) = var_info('scalarTotalMassChange' , 'mass change of all system together (kg m-2 s-1)' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) ! soil hydrology diag_meta(iLookDIAG%scalarInfilArea) = var_info('scalarInfilArea' , 'fraction of unfrozen area where water can infiltrate' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) diag_meta(iLookDIAG%scalarSaturatedArea) = var_info('scalarSaturatedArea' , 'fraction of area that is considered saturated' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) @@ -455,8 +452,6 @@ subroutine popMetadat(err,message) diag_meta(iLookDIAG%scalarTotalSoilWat) = var_info('scalarTotalSoilWat' , 'total mass of water in the soil' , 'kg m-2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) ! variable shortcuts diag_meta(iLookDIAG%scalarVGn_m) = var_info('scalarVGn_m' , 'van Genuchten "m" parameter' , '-' , get_ixVarType('midSoil'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarKappa) = var_info('scalarKappa' , 'constant in the freezing curve function' , 'm K-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - diag_meta(iLookDIAG%scalarVolLatHt_fus) = var_info('scalarVolLatHt_fus' , 'volumetric latent heat of fusion' , 'J m-3' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) ! timing information diag_meta(iLookDIAG%numFluxCalls) = var_info('numFluxCalls' , 'number of flux calls' , '-' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) diag_meta(iLookDIAG%wallClockTime) = var_info('wallClockTime' , 'wall clock time for physics routines' , 's' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) @@ -483,7 +478,6 @@ subroutine popMetadat(err,message) diag_meta(iLookDIAG%hLast) = var_info('hLast' , 'step size used on the last internal step' , 's' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) diag_meta(iLookDIAG%hCur) = var_info('hCur' , 'step size to be used on the next internal step' , 's' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) diag_meta(iLookDIAG%tCur) = var_info('tCur' , 'current time reached by the integrator' , 's' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - ! ----- ! * local model fluxes... ! ----------------------- @@ -553,7 +547,6 @@ subroutine popMetadat(err,message) flux_meta(iLookFLUX%scalarThroughfallRain) = var_info('scalarThroughfallRain' , 'rain that reaches the ground without ever touching the canopy' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) flux_meta(iLookFLUX%scalarCanopySnowUnloading) = var_info('scalarCanopySnowUnloading' , 'unloading of snow from the vegetation canopy' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) flux_meta(iLookFLUX%scalarCanopyLiqDrainage) = var_info('scalarCanopyLiqDrainage' , 'drainage of liquid water from the vegetation canopy' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - flux_meta(iLookFLUX%scalarCanopyMeltFreeze) = var_info('scalarCanopyMeltFreeze' , 'melt/freeze of water stored in the canopy' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) ! energy fluxes and for the snow and soil domains flux_meta(iLookFLUX%iLayerConductiveFlux) = var_info('iLayerConductiveFlux' , 'conductive energy flux at layer interfaces' , 'W m-2' , get_ixVarType('ifcToto'), iMissVec, iMissVec, .false.) flux_meta(iLookFLUX%iLayerAdvectiveFlux) = var_info('iLayerAdvectiveFlux' , 'advective energy flux at layer interfaces' , 'W m-2' , get_ixVarType('ifcToto'), iMissVec, iMissVec, .false.) @@ -697,19 +690,20 @@ subroutine popMetadat(err,message) ! ----- ! * basin-wide runoff and aquifer fluxes... ! ----------------------------------------- - bvar_meta(iLookBVAR%basin__TotalArea) = var_info('basin__TotalArea' , 'total basin area' , 'm2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - bvar_meta(iLookBVAR%basin__SurfaceRunoff) = var_info('basin__SurfaceRunoff' , 'surface runoff' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - bvar_meta(iLookBVAR%basin__ColumnOutflow) = var_info('basin__ColumnOutflow' , 'outflow from all "outlet" HRUs (with no downstream HRU)', 'm3 s-1', get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - bvar_meta(iLookBVAR%basin__AquiferStorage) = var_info('basin__AquiferStorage' , 'aquifer storage' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - bvar_meta(iLookBVAR%basin__AquiferRecharge) = var_info('basin__AquiferRecharge' , 'recharge to the aquifer' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - bvar_meta(iLookBVAR%basin__AquiferBaseflow) = var_info('basin__AquiferBaseflow' , 'baseflow from the aquifer' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - bvar_meta(iLookBVAR%basin__AquiferTranspire) = var_info('basin__AquiferTranspire', 'transpiration loss from the aquifer' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - bvar_meta(iLookBVAR%basin__TotalRunoff) = var_info('basin__TotalRunoff' , 'total runoff to channel from all active components' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - bvar_meta(iLookBVAR%basin__SoilDrainage) = var_info('basin__SoilDrainage' , 'soil drainage' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - bvar_meta(iLookBVAR%routingRunoffFuture) = var_info('routingRunoffFuture' , 'runoff in future time steps' , 'm s-1' , get_ixVarType('routing'), iMissVec, iMissVec, .false.) - bvar_meta(iLookBVAR%routingFractionFuture) = var_info('routingFractionFuture' , 'fraction of runoff in future time steps' , '-' , get_ixVarType('routing'), iMissVec, iMissVec, .false.) - bvar_meta(iLookBVAR%averageInstantRunoff) = var_info('averageInstantRunoff' , 'instantaneous runoff' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) - bvar_meta(iLookBVAR%averageRoutedRunoff) = var_info('averageRoutedRunoff' , 'routed runoff' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%basin__TotalArea) = var_info('basin__TotalArea' , 'total basin area' , 'm2' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%basin__SurfaceRunoff) = var_info('basin__SurfaceRunoff' , 'surface runoff' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%basin__ColumnOutflow) = var_info('basin__ColumnOutflow' , 'outflow from all "outlet" HRUs (with no downstream HRU)', 'm3 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%basin__AquiferStorage) = var_info('basin__AquiferStorage' , 'aquifer storage' , 'm' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%basin__AquiferRecharge) = var_info('basin__AquiferRecharge' , 'recharge to the aquifer' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%basin__AquiferBaseflow) = var_info('basin__AquiferBaseflow' , 'baseflow from the aquifer' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%basin__AquiferTranspire) = var_info('basin__AquiferTranspire', 'transpiration loss from the aquifer' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%basin__TotalRunoff) = var_info('basin__TotalRunoff' , 'total runoff to channel from all active components' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%basin__SoilDrainage) = var_info('basin__SoilDrainage' , 'soil drainage' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%basin__StorageChange) = var_info('basin__StorageChange' , 'change in total basin storage' , 'kg m-2 s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%routingRunoffFuture) = var_info('routingRunoffFuture' , 'runoff in future time steps' , 'm s-1' , get_ixVarType('routing'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%routingFractionFuture) = var_info('routingFractionFuture' , 'fraction of runoff in future time steps' , '-' , get_ixVarType('routing'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%averageInstantRunoff) = var_info('averageInstantRunoff' , 'instantaneous runoff' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) + bvar_meta(iLookBVAR%averageRoutedRunoff) = var_info('averageRoutedRunoff' , 'routed runoff' , 'm s-1' , get_ixVarType('scalarv'), iMissVec, iMissVec, .false.) ! ----- ! * temperature and enthalpy lookup tables... ! ------------------------------------------- @@ -795,7 +789,7 @@ subroutine popMetadat(err,message) ! read file to define model output (modifies metadata structures) call read_output_file(err,cmessage) - if (err.ne.0) message=trim(message)//trim(cmessage) + if (err/=0) message=trim(message)//trim(cmessage) end subroutine popMetadat @@ -808,31 +802,32 @@ subroutine read_output_file(err,message) USE summaFileManager,only:SETTINGS_PATH ! path for metadata files USE summaFileManager,only:OUTPUT_CONTROL ! file with output controls ! some dimensional parameters - USE globalData, only:outFreq ! output frequencies - USE var_lookup, only:maxvarFreq ! maximum # of output files - USE var_lookup, only:maxvarStat ! maximum # of statistics + USE globalData,only:outFreq ! output frequencies + USE globalData,only:allowRoutingOutput ! flag to allow routing variable output + USE var_lookup,only:maxvarFreq ! maximum # of output files + USE var_lookup,only:maxvarStat ! maximum # of statistics ! metadata structures - USE globalData, only: time_meta ! data structure for time metadata - USE globalData, only: forc_meta ! data structure for forcing metadata - USE globalData, only: type_meta ! data structure for categorical metadata - USE globalData, only: attr_meta ! data structure for attribute metadata - USE globalData, only: mpar_meta ! data structure for local parameter metadata - USE globalData, only: bpar_meta ! data structure for basin parameter metadata - USE globalData, only: bvar_meta ! data structure for basin model variable metadata - USE globalData, only: indx_meta ! data structure for index metadata - USE globalData, only: prog_meta ! data structure for local prognostic (state) variables - USE globalData, only: diag_meta ! data structure for local diagnostic variables - USE globalData, only: flux_meta ! data structure for local flux variables - USE globalData, only: deriv_meta ! data structure for local flux derivatives - USE globalData, only: outputPrecision ! data structure for output precision - USE globalData, only: outputCompressionLevel ! data structure for output netcdf deflate level + 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:outputPrecision ! data structure for output precision + USE globalData,only:outputCompressionLevel ! data structure for output netcdf deflate level ! structures of named variables - USE var_lookup, only: iLookTYPE ! named variables for categorical data - USE var_lookup, only: iLookID ! named variables for hru and gru ID metadata - USE var_lookup, only: iLookFORCE ! named variables for forcing data structure - USE var_lookup, only: iLookINDEX ! named variables for index variable data structure - USE var_lookup, only: iLookSTAT ! named variables for statitics variable data structure - USE var_lookup, only: iLookFREQ ! named variables for model output frequencies + USE var_lookup,only:iLookTYPE ! named variables for categorical data + USE var_lookup,only:iLookID ! named variables for hru and gru ID metadata + USE var_lookup,only:iLookFORCE ! named variables for forcing data structure + USE var_lookup,only:iLookINDEX ! named variables for index variable data structure + USE var_lookup,only:iLookSTAT ! named variables for statitics variable data structure + USE var_lookup,only:iLookFREQ ! named variables for model output frequencies + USE var_lookup,only:iLookVarType ! named variables for variable types ! identify indices within structures USE get_ixName_module,only:get_ixUnknown ! identify index in any structure USE get_ixname_module,only:get_ixFreq ! identify index of model output frequency @@ -849,28 +844,29 @@ subroutine read_output_file(err,message) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! define file format - integer(i4b),parameter :: noStatsDesired=1001 ! no statistic desired (temporally constant variables) - integer(i4b),parameter :: provideStatName=1002 ! provide the name of the desired statistic - integer(i4b),parameter :: provideStatFlags=1003 ! provide flags defining the desired statistic - integer(i4b) :: fileFormat ! the file format + integer(i4b),parameter :: noStatsDesired=1001 ! no statistic desired (temporally constant variables) + integer(i4b),parameter :: provideStatName=1002 ! provide the name of the desired statistic + integer(i4b),parameter :: provideStatFlags=1003 ! provide flags defining the desired statistic + integer(i4b) :: fileFormat ! the file format ! define statistics flags - logical(lgt),dimension(maxvarStat) :: statFlag ! vector of statistics flags - character(len=32) :: statName ! name of desired statistic - integer(i4b) :: iStat ! index of statistics vector + logical(lgt),dimension(maxvarStat) :: statFlag ! vector of statistics flags + character(len=32) :: statName ! name of desired statistic + integer(i4b) :: iStat ! index of statistics vector + integer(i4b) :: varType ! variable type ! define frequency of model output - character(len=64) :: freqName ! name of desired output frequency - integer(i4b) :: iFreq ! index of frequency vector + character(len=64) :: freqName ! name of desired output frequency + integer(i4b) :: iFreq ! index of frequency vector ! general local variables - character(LEN=256) :: cmessage ! error message of downwind routine - character(LEN=256) :: outfile ! full path of model output file - integer(i4b) :: unt ! file unit - character(LEN=linewidth),allocatable :: charlines(:) ! vector of character strings - character(LEN=64),allocatable :: lineWords(:) ! vector to parse textline - integer(i4b) :: nWords ! number of words in line - character(LEN=128) :: varName ! variable name - character(LEN=5) :: structName ! name of structure - integer(i4b) :: vLine ! index for loop through variables - integer(i4b) :: vDex ! index into type lists + character(LEN=256) :: cmessage ! error message of downwind routine + character(LEN=256) :: outfile ! full path of model output file + integer(i4b) :: unt ! file unit + character(LEN=linewidth),allocatable :: charlines(:) ! vector of character strings + character(LEN=64),allocatable :: lineWords(:) ! vector to parse textline + integer(i4b) :: nWords ! number of words in line + character(LEN=128) :: varName ! variable name + character(LEN=6) :: structName ! name of structure + integer(i4b) :: vLine ! index for loop through variables + integer(i4b) :: vDex ! index into type lists ! initialize error control err=0; message='read_output_file/' @@ -909,9 +905,9 @@ subroutine read_output_file(err,message) varName = trim(lineWords(nameIndex)) ! user cannot control time output - if (trim(varName)=='time') cycle + if (varName=='time') cycle ! set precision if it is given - if (trim(varName)=='outputPrecision') then + if (varName=='outputPrecision') then statName = trim(lineWords(nWords)) if (statName=='single' .or. statName=='float') then outputPrecision = nf90_float @@ -945,18 +941,11 @@ subroutine read_output_file(err,message) call get_ixUnknown(trim(varName),structName,vDex,err,cmessage) if (err/=0) then; message=trim(message)//trim(cmessage)// ': deprecated variable name, remove from output file'; return; end if; - ! id variables should not be specified in output control file - if (trim(structName)=='id')then - print*,'id variable requested in outputControl, will be skipped: variable='//trim(varName) - cycle - end if - ! --- identify the desired frequency in the metadata structure ----------- ! process time-varying variables select case(trim(structName)) - case('indx','forc','prog','diag','flux','bvar','deriv') - + case('forc','prog','diag','flux','bvar') ! * ensure that the frequency index exists for time varying variables if(nWords included for backwards compatibility case(provideStatFlags) ! get statistic name statFlag(:) = .false. - do iStat = 1,maxVarStat + do iStat = 1,maxvarStat if (lineWords(freqIndex + 2*iStat)=='1') then statFlag(iStat)=.true. - statName = get_statName(istat) + statName = get_statName(iStat) end if end do - ! check actually defined the statistic (and only defined one statistic) + ! check actually defined the statistic (and only defined one statistic) that is not the deprecated mode statistic + if(nWords==freqIndex + 2*(maxvarStat+1))then + if(lineWords(freqIndex + 2*(maxvarStat+1))=='1')& + write(*,*)'WARNING: the mode statistic is no longer supported, ignoring mode flag for variable '//trim(varName) + endif if(count(statFlag)/=1)then - message=trim(message)//'expect only one statistic is defined when using flags to define statistics'& - //': entered "'//trim(charLines(vLine))//'"' + if(count(statFlag)==0)then + message=trim(message)//'no statistic was defined for variable '//trim(varName) + else + message=trim(message)//'expect only one statistic is defined when using flags to define statistics'& + //': entered "'//trim(charLines(vLine))//'"' + endif err=20; return endif @@ -1057,43 +1060,47 @@ subroutine read_output_file(err,message) iStat = get_ixStat(trim(statName)) if(iStat<0 .or. iStat>maxvarStat)then message=trim(message)//'unable to identify desired statistic for variable '//trim(varName)& - //' [evaluating '//trim(statName)//']' + //' [evaluating '//trim(statName)//', names should be total, instant, mean, variance, minimum, or maximum]' err=20; return endif + ! if frequency is timestep, only allow instantaneous statistic, change it to this if it is not already this and give a warning + if(iFreq==iLookFREQ%timestep .and. iStat/=iLookSTAT%inst)then + write(*,*)'WARNING: statistics at timestep level are meaningless, outputting instantaneous variable '//trim(varName)//' in timestep output file ' + iStat = iLookSTAT%inst + endif + ! --- populate the metadata that controls the model output --------------- + varType = -1_i4b ! initialize variable type (only need for temporally varying structures) ! identify data structure select case (trim(structName)) + + ! time and index structures -- request instantaneous, timestep-level output (no aggregation possible) + case('time' ); time_meta(vDex)%statIndex(iLookFREQ%timestep) = iLookSTAT%inst; time_meta(vDex)%varDesire=.true. ! time variable + case('indx' ); indx_meta(vDex)%statIndex(iLookFREQ%timestep) = iLookSTAT%inst; indx_meta(vDex)%varDesire=.true. ! index variables ! temporally constant structures -- request instantaneous timestep-level output (no aggregation) - case('time' ); time_meta(vDex)%statIndex(iLookFREQ%timestep) = iLookSTAT%inst; time_meta(vDex)%varDesire=.true. ! timing data - case('bpar' ); bpar_meta(vDex)%statIndex(iLookFREQ%timestep) = iLookSTAT%inst; bpar_meta(vDex)%varDesire=.true. ! basin parameters - case('attr' ); attr_meta(vDex)%statIndex(iLookFREQ%timestep) = iLookSTAT%inst; attr_meta(vDex)%varDesire=.true. ! local attributes - case('type' ); type_meta(vDex)%statIndex(iLookFREQ%timestep) = iLookSTAT%inst; type_meta(vDex)%varDesire=.true. ! local classification - case('mpar' ); mpar_meta(vDex)%statIndex(iLookFREQ%timestep) = iLookSTAT%inst; mpar_meta(vDex)%varDesire=.true. ! model parameters - - ! index structures -- can only be output at the model time step - case('indx' ); indx_meta(vDex)%statIndex(iLookFREQ%timestep) = iLookSTAT%inst; indx_meta(vDex)%varDesire=.true. - if(iFreq/=iLookFREQ%timestep)then - message=trim(message)//'index variables can only be output at model timestep'& - //' [evaluating variable "'//trim(varName)//'" for output frequency "'//trim(freqName)//'"]' - err=20; return - endif + case('bpar' ); bpar_meta(vDex)%statIndex(iLookFREQ%timestep) = iLookSTAT%inst; bpar_meta(vDex)%varDesire=.true. ! basin parameters + case('attr' ); attr_meta(vDex)%statIndex(iLookFREQ%timestep) = iLookSTAT%inst; attr_meta(vDex)%varDesire=.true. ! local attributes + case('type' ); type_meta(vDex)%statIndex(iLookFREQ%timestep) = iLookSTAT%inst; type_meta(vDex)%varDesire=.true. ! local classification + case('mpar' ); mpar_meta(vDex)%statIndex(iLookFREQ%timestep) = iLookSTAT%inst; mpar_meta(vDex)%varDesire=.true. ! model parameters ! temporally varying structures - case('forc' ); call popStat(forc_meta(vDex) , iFreq, iStat, err, cmessage) ! model forcing data - case('prog' ); call popStat(prog_meta(vDex) , iFreq, iStat, err, cmessage) ! model prognostics - case('diag' ); call popStat(diag_meta(vDex) , iFreq, iStat, err, cmessage) ! model diagnostics - case('flux' ); call popStat(flux_meta(vDex) , iFreq, iStat, err, cmessage) ! model fluxes - case('bvar' ); call popStat(bvar_meta(vDex) , iFreq, iStat, err, cmessage) ! basin variables - case('deriv'); call popStat(deriv_meta(vDex), iFreq, iStat, err, cmessage) ! model derivs - - ! error control - case default; err=20;message=trim(message)//'unable to identify lookup structure';return + case('forc' ); call popStat(forc_meta(vDex), iFreq, iStat, err, cmessage); varType = forc_meta(vDex)%varType ! model forcing data + case('prog' ); call popStat(prog_meta(vDex), iFreq, iStat, err, cmessage); varType = prog_meta(vDex)%varType ! model prognostics + case('diag' ); call popStat(diag_meta(vDex), iFreq, iStat, err, cmessage); varType = diag_meta(vDex)%varType ! model diagnostics + case('flux' ); call popStat(flux_meta(vDex), iFreq, iStat, err, cmessage); varType = flux_meta(vDex)%varType ! model fluxes + case('bvar' ); call popStat(bvar_meta(vDex), iFreq, iStat, err, cmessage); varType = bvar_meta(vDex)%varType ! basin variables end select ! select data structure + ! warnings for variables that we cannot write + if(.not.allowRoutingOutput .and. varType==iLookVarType%routing)& + write(*,*)'WARNING: cannot output routing histogram type data, skipping variable '//trim(varName) + if(varType==iLookVarType%unknown .or. varType==integerMissing)& + write(*,*)'WARNING: cannot output unknown or missing type data, skipping variable '//trim(varName) + ! error control from popStat if (err/=0) then; message=trim(message)//trim(cmessage);return; end if @@ -1120,7 +1127,9 @@ end subroutine read_output_file ! This routine is called by read_output_file ! ******************************************************************************************** subroutine popStat(meta, iFreq, iStat, err, message) - USE data_types,only:var_info ! meta_data type declaration + USE 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 get_ixname_module,only:get_freqName ! get name of frequency from frequency index (error control) implicit none ! dummy variables @@ -1135,16 +1144,22 @@ subroutine popStat(meta, iFreq, iStat, err, message) ! check that the variable is not already defined for a given frequency if(meta%statIndex(iFreq)/=integerMissing)then message=trim(message)//'variable "'//trim(meta%varName)//'" is already defined '& - //'for output frequency "'//trim(get_freqName(iFreq))//'"' + //'for output frequency "'//trim(get_freqName(iFreq))//'"' err=20; return endif - ! identify desired variabe + ! identify desired variable meta%varDesire = .true. ! populate structure meta%statIndex(iFreq) = iStat + ! if variable is not scalar, can only be at instantaneous statistic + if(meta%varType/=iLookVarType%scalarv .and. iStat/=iLookSTAT%inst)then + meta%statIndex(iFreq) = iLookSTAT%inst + write(*,*)'WARNING: cannot compute statistics of non-scalar type data, outputting instantaneous variable '//trim(meta%varName)//' in '//trim(get_freqName(iFreq))//' output file' + endif + end subroutine popStat end module popMetadat_module diff --git a/build/source/dshare/type4ida.f90 b/build/source/dshare/type4ida.f90 index 0341f0ef1..7fa277fad 100644 --- a/build/source/dshare/type4ida.f90 +++ b/build/source/dshare/type4ida.f90 @@ -1,7 +1,7 @@ module type4ida ! data types -USE nrtype +USE nr_type USE, intrinsic :: iso_c_binding ! provide access to the derived types to define the data structures diff --git a/build/source/dshare/type4kinsol.f90 b/build/source/dshare/type4kinsol.f90 index 906451831..271450a0b 100644 --- a/build/source/dshare/type4kinsol.f90 +++ b/build/source/dshare/type4kinsol.f90 @@ -1,7 +1,7 @@ module type4kinsol ! data types -USE nrtype +USE nr_type USE, intrinsic :: iso_c_binding USE data_types,only:& diff --git a/build/source/dshare/var_lookup.f90 b/build/source/dshare/var_lookup.f90 index 659ea7d2b..e026317ea 100644 --- a/build/source/dshare/var_lookup.f90 +++ b/build/source/dshare/var_lookup.f90 @@ -23,7 +23,7 @@ MODULE var_lookup #ifdef ACTORS_ACTIVE USE, intrinsic :: iso_c_binding #endif - USE nrtype, integerMissing=>nr_integerMissing + USE nr_type, integerMissing=>nr_integerMissing implicit none private ! local variables @@ -78,6 +78,8 @@ MODULE var_lookup integer(i4b) :: aquiferIni = integerMissing ! choice of full or empty aquifer at start integer(i4b) :: infRateMax = integerMissing ! choice of method to determine maximum infiltration rate integer(i4b) :: surfRun_SE = integerMissing ! choice of parameterization for saturation excess surface runoff + integer(i4b) :: read_force = integerMissing ! method used to read forcing data (per step or full read) + integer(i4b) :: write_buff = integerMissing ! method used to buffer model write (none, per file) endtype iLook_decision @@ -402,21 +404,15 @@ MODULE var_lookup 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) :: mLayerCm = integerMissing ! Cm for each layer (J m-3) - integer(i4b) :: scalarLambda_drysoil = integerMissing ! thermal conductivity of dry soil (W m-1 K-1) - integer(i4b) :: scalarLambda_wetsoil = integerMissing ! thermal conductivity of wet soil (W m-1 K-1) integer(i4b) :: mLayerThermalC = integerMissing ! thermal conductivity at the mid-point of each layer (W m-1 K-1) integer(i4b) :: iLayerThermalC = integerMissing ! thermal conductivity at the interface of each layer (W m-1 K-1) ! enthalpy integer(i4b) :: scalarCanopyEnthTemp = integerMissing ! temperature component of enthalpy of the vegetation canopy (J m-3) integer(i4b) :: mLayerEnthTemp = integerMissing ! temperature component of enthalpy of the snow+soil layers (J m-3) - integer(i4b) :: scalarTotalSoilEnthalpy = integerMissing ! total enthalpy of the soil column (J m-3) integer(i4b) :: scalarTotalSnowEnthalpy = integerMissing ! total enthalpy of the snow column (J m-3) + integer(i4b) :: scalarTotalSoilEnthalpy = integerMissing ! total enthalpy of the soil column (J m-3) ! forcing integer(i4b) :: scalarVPair = integerMissing ! vapor pressure of the air above the vegetation canopy (Pa) integer(i4b) :: scalarVP_CanopyAir = integerMissing ! vapor pressure of the canopy air space (Pa) @@ -469,6 +465,8 @@ MODULE var_lookup 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) + ! total mass changes + integer(i4b) :: scalarTotalMassChange = integerMissing ! mass change of all system together (kg m-2 s-1) ! soil hydrology integer(i4b) :: scalarInfilArea = integerMissing ! fraction of area where water can infiltrate, may be frozen (-) integer(i4b) :: scalarSaturatedArea = integerMissing ! fraction of area that is considered saturated (-) @@ -485,8 +483,6 @@ MODULE var_lookup integer(i4b) :: scalarTotalSoilWat = integerMissing ! total mass of water 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 (-) integer(i4b) :: wallClockTime = integerMissing ! wall clock time for physics routines(s) @@ -585,7 +581,6 @@ MODULE var_lookup 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) @@ -837,6 +832,7 @@ MODULE var_lookup integer(i4b) :: basin__AquiferTranspire = integerMissing ! transpiration from the aquifer (m s-1) integer(i4b) :: basin__TotalRunoff = integerMissing ! total runoff to channel from all active components (m s-1) integer(i4b) :: basin__SoilDrainage = integerMissing ! soil drainage (m s-1) + integer(i4b) :: basin__StorageChange = integerMissing ! change in total basin storage (kg m-2 s-1) ! define variables for runoff integer(i4b) :: routingRunoffFuture = integerMissing ! runoff in future time steps (m s-1) integer(i4b) :: routingFractionFuture = integerMissing ! fraction of runoff in future time steps (-) @@ -845,8 +841,7 @@ MODULE var_lookup endtype iLook_bvar ! *********************************************************************************************************** - ! (13) structure for looking up the type of a model variable (this is only needed for backward - ! compatability, and should be removed eventually) + ! (13) structure for looking up the type of a model variable ! *********************************************************************************************************** #ifdef ACTORS_ACTIVE type, public, bind(C) :: iLook_varType @@ -877,7 +872,6 @@ MODULE var_lookup 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 ! *********************************************************************************************************** @@ -908,7 +902,7 @@ MODULE var_lookup 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) + 41, 42, 43, 44) ! named variables: model time type(iLook_time), public,parameter :: iLookTIME =iLook_time ( 1, 2, 3, 4, 5, 6, 7) ! named variables: model forcing data @@ -954,8 +948,7 @@ MODULE var_lookup 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) + 101,102,103, 104) ! 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,& @@ -965,8 +958,7 @@ 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) + 81, 82, 83, 84, 85, 86, 87, 88, 89, 90) ! 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,& @@ -978,26 +970,26 @@ MODULE var_lookup 71, 72, 73, 74, 75, 76, 77, 78, 79, 80,& 81, 82) ! named variables: model indices - type(iLook_index), public,parameter :: iLookINDEX =ilook_index ( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,& + 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, 59, 60) ! named variables: basin-average parameters - type(iLook_bpar), public,parameter :: iLookBPAR =ilook_bpar ( 1, 2, 3, 4, 5) + type(iLook_bpar), public,parameter :: iLookBPAR =iLook_bpar ( 1, 2, 3, 4, 5) ! named variables: basin-average variables - type(iLook_bvar), public,parameter :: iLookBVAR =ilook_bvar ( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,& - 11, 12, 13) - ! named variables in varibale type structure - type(iLook_varType), public,parameter :: iLookVarType =ilook_varType ( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,& + type(iLook_bvar), public,parameter :: iLookBVAR =iLook_bvar ( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,& + 11, 12, 13, 14) + ! named variables in variable type structure + type(iLook_varType), public,parameter :: iLookVarType =iLook_varType ( 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,& 11, 12) ! number of possible output statistics - type(iLook_stat), public,parameter :: iLookSTAT =ilook_stat ( 1, 2, 3, 4, 5, 6, 7) + type(iLook_stat), public,parameter :: iLookSTAT =iLook_stat ( 1, 2, 3, 4, 5, 6) ! number of possible output frequencies - type(iLook_freq), public,parameter :: iLookFREQ =ilook_freq ( 1, 2, 3, 4) + type(iLook_freq), public,parameter :: iLookFREQ =iLook_freq ( 1, 2, 3, 4) ! named variables in the lookup table structure - type(iLook_vLookup), public,parameter :: iLookLOOKUP =ilook_vLookup ( 1, 2, 3) + type(iLook_vLookup), public,parameter :: iLookLOOKUP =iLook_vLookup ( 1, 2, 3) ! define maximum number of variables of each type integer(i4b),parameter,public :: maxvarDecisions = storage_size(iLookDECISIONS)/iLength integer(i4b),parameter,public :: maxvarTime = storage_size(iLookTIME)/iLength diff --git a/build/source/engine/allocspace.f90 b/build/source/engine/allocspace.f90 index dd77f4eb9..2e42d6ae5 100644 --- a/build/source/engine/allocspace.f90 +++ b/build/source/engine/allocspace.f90 @@ -21,7 +21,7 @@ module allocspace_module ! data types -USE nrtype +USE nr_type ! provide access to the derived types to define the data structures USE data_types,only:& @@ -57,8 +57,8 @@ module allocspace_module USE globalData,only:integerMissing ! missing integer USE globalData,only:realMissing ! missing real number -USE globalData,only: nTimeDelay ! number of timesteps in the time delay histogram -USE globalData,only: nSpecBand ! number of spectral bands +USE globalData,only:nTimeDelay ! number of timesteps in the time delay histogram +USE globalData,only:nSpecBand ! number of spectral bands ! access variable types USE var_lookup,only:iLookVarType ! look up structure for variable typed @@ -117,7 +117,7 @@ subroutine allocGlobal(metaStruct,dataStruct,err,message) class is (gru_hru_intVec); if(allocated(dataStruct%gru))then; check=.true.; else; allocate(dataStruct%gru(nGRU),stat=err); end if class is (gru_hru_double); if(allocated(dataStruct%gru))then; check=.true.; else; allocate(dataStruct%gru(nGRU),stat=err); end if class is (gru_hru_doubleVec); if(allocated(dataStruct%gru))then; check=.true.; else; allocate(dataStruct%gru(nGRU),stat=err); end if - ! gru+hru+z dimensions + ! gru+hru+z dimensions class is (gru_hru_z_vLookup); if(allocated(dataStruct%gru))then; check=.true.; else; allocate(dataStruct%gru(nGRU),stat=err); end if end select @@ -134,7 +134,7 @@ subroutine allocGlobal(metaStruct,dataStruct,err,message) class is (gru_hru_intVec); if(allocated(dataStruct%gru(iGRU)%hru))then; check=.true.; else; allocate(dataStruct%gru(iGRU)%hru(gru_struc(iGRU)%hruCount),stat=err); end if class is (gru_hru_double); if(allocated(dataStruct%gru(iGRU)%hru))then; check=.true.; else; allocate(dataStruct%gru(iGRU)%hru(gru_struc(iGRU)%hruCount),stat=err); end if class is (gru_hru_doubleVec); if(allocated(dataStruct%gru(iGRU)%hru))then; check=.true.; else; allocate(dataStruct%gru(iGRU)%hru(gru_struc(iGRU)%hruCount),stat=err); end if - class is (gru_hru_z_vLookup); if(allocated(dataStruct%gru(iGRU)%hru))then; check=.true.; else; allocate(dataStruct%gru(iGRU)%hru(gru_struc(iGRU)%hruCount),stat=err); end if + class is (gru_hru_z_vLookup); if(allocated(dataStruct%gru(iGRU)%hru))then; check=.true.; else; allocate(dataStruct%gru(iGRU)%hru(gru_struc(iGRU)%hruCount),stat=err); end if class default ! do nothing: It is acceptable to not be any of these specified cases end select ! check errors @@ -235,7 +235,7 @@ subroutine allocLocal(metaStruct,dataStruct,nSnow,nSoil,err,message) ! 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 + 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 @@ -335,20 +335,20 @@ subroutine resizeData(metaStruct,dataStructOrig,dataStructNew,copy,err,message) class is (var_dlength) select type(dataStructNew) class is (var_dlength); call copyStruct_rkind( 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 + class default; err=20; message=trim(message)//'mismatch data structure for variable'//trim(metaStruct(iVar)%varName); return end select ! integer class is (var_ilength) select type(dataStructNew) class 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 + 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 + 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 @@ -533,7 +533,7 @@ end subroutine copyStruct_i4b ! private subroutine allocateDat_rkind: initialize data dimension of the data structures ! ************************************************************************************************ subroutine allocateDat_rkind(metadata,nSnow,nSoil,nLayers, & ! input - varData,err,message) ! output + varData,err,message) ! output ! access subroutines USE get_ixName_module,only:get_varTypeName ! to access type strings for error messages @@ -562,7 +562,7 @@ subroutine allocateDat_rkind(metadata,nSnow,nSoil,nLayers, & ! input ! check allocated if(allocated(varData%var(iVar)%dat))then - message=trim(message)//'variable '//trim(metadata(iVar)%varname)//' is unexpectedly allocated' + message=trim(message)//'variable '//trim(metadata(iVar)%varName)//' is unexpectedly allocated' err=20; return ! allocate structures @@ -570,7 +570,7 @@ subroutine allocateDat_rkind(metadata,nSnow,nSoil,nLayers, & ! input ! -- however, this vector must store two values for the variance calculation, thus the *2 in this allocate ! (need enough space in the event that variance is the desired statistic for all output frequencies) else - select case(metadata(iVar)%vartype) + select case(metadata(iVar)%varType) case(iLookVarType%scalarv); allocate(varData%var(iVar)%dat(1),stat=err) case(iLookVarType%wLength); allocate(varData%var(iVar)%dat(nSpecBand),stat=err) case(iLookVarType%midSnow); allocate(varData%var(iVar)%dat(nSnow),stat=err) @@ -581,14 +581,14 @@ subroutine allocateDat_rkind(metadata,nSnow,nSoil,nLayers, & ! input 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(maxvarfreq*2),stat=err) + case(iLookVarType%outstat); allocate(varData%var(iVar)%dat(maxvarFreq*2),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))//"']" + 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 + 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 @@ -628,7 +628,7 @@ subroutine allocateDat_int(metadata,nSnow,nSoil,nLayers, & ! input ! check allocated if(allocated(varData%var(iVar)%dat))then - message=trim(message)//'variable '//trim(metadata(iVar)%varname)//' is unexpectedly allocated' + message=trim(message)//'variable '//trim(metadata(iVar)%varName)//' is unexpectedly allocated' err=20; return ! allocate structures @@ -636,7 +636,7 @@ subroutine allocateDat_int(metadata,nSnow,nSoil,nLayers, & ! input ! -- however, this vector must store two values for the variance calculation, thus the *2 in this allocate ! (need enough space in the event that variance is the desired statistic for all output frequencies) else - select case(metadata(iVar)%vartype) + select case(metadata(iVar)%varType) case(iLookVarType%scalarv); allocate(varData%var(iVar)%dat(1),stat=err) case(iLookVarType%wLength); allocate(varData%var(iVar)%dat(nSpecBand),stat=err) case(iLookVarType%midSnow); allocate(varData%var(iVar)%dat(nSnow),stat=err) @@ -648,10 +648,10 @@ subroutine allocateDat_int(metadata,nSnow,nSoil,nLayers, & ! input case(iLookVarType%routing); allocate(varData%var(iVar)%dat(nTimeDelay),stat=err) case(iLookVarType%outstat); allocate(varData%var(iVar)%dat(maxvarFreq*2),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 + 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 + 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 @@ -691,7 +691,7 @@ subroutine allocateDat_flag(metadata,nSnow,nSoil,nLayers, & ! input ! check allocated if(allocated(varData%var(iVar)%dat))then - message=trim(message)//'variable '//trim(metadata(iVar)%varname)//' is unexpectedly allocated' + message=trim(message)//'variable '//trim(metadata(iVar)%varName)//' is unexpectedly allocated' err=20; return ! allocate structures @@ -699,7 +699,7 @@ subroutine allocateDat_flag(metadata,nSnow,nSoil,nLayers, & ! input ! -- however, this vector must store two values for the variance calculation, thus the *2 in this allocate ! (need enough space in the event that variance is the desired statistic for all output frequencies) else - select case(metadata(iVar)%vartype) + select case(metadata(iVar)%varType) case(iLookVarType%scalarv); allocate(varData%var(iVar)%dat(1),stat=err) case(iLookVarType%wLength); allocate(varData%var(iVar)%dat(nSpecBand),stat=err) case(iLookVarType%midSnow); allocate(varData%var(iVar)%dat(nSnow),stat=err) @@ -711,10 +711,10 @@ subroutine allocateDat_flag(metadata,nSnow,nSoil,nLayers, & ! input case(iLookVarType%routing); allocate(varData%var(iVar)%dat(nTimeDelay),stat=err) case(iLookVarType%outstat); allocate(varData%var(iVar)%dat(maxvarFreq*2),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 + 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 + if(err/=0)then; err=20; message=trim(message)//'problem allocating variable '//trim(metadata(iVar)%varName); return; end if ! set to false varData%var(iVar)%dat(:) = .false. end if ! if not allocated diff --git a/build/source/engine/bigAquifer.f90 b/build/source/engine/bigAquifer.f90 index 19ea9093b..07d805154 100644 --- a/build/source/engine/bigAquifer.f90 +++ b/build/source/engine/bigAquifer.f90 @@ -21,7 +21,7 @@ module bigAquifer_module ! ----------------------------------------------------------------------------------------------------------- ! homegrown solver data types -USE nrtype +USE nr_type ! access missing values USE globalData,only:integerMissing ! missing integer diff --git a/build/source/engine/canopySnow.f90 b/build/source/engine/canopySnow.f90 index ebb5ab79b..aee4c9e78 100644 --- a/build/source/engine/canopySnow.f90 +++ b/build/source/engine/canopySnow.f90 @@ -21,7 +21,7 @@ module canopySnow_module ! data types -USE nrtype +USE nr_type USE globalData,only:realMissing ! missing real number ! derived types to define the data structures diff --git a/build/source/engine/checkStruc.f90 b/build/source/engine/checkStruc.f90 index d40bbcb21..2823bbd72 100644 --- a/build/source/engine/checkStruc.f90 +++ b/build/source/engine/checkStruc.f90 @@ -19,7 +19,7 @@ ! along with this program. If not, see . module checkStruc_module -USE nrtype +USE nr_type USE globalData,only:integerMissing implicit none private @@ -36,17 +36,13 @@ subroutine checkStruc(err,message) ! summary of data structures USE globalData,only:structInfo ! metadata structures - USE globalData,only:time_meta,forc_meta,attr_meta,type_meta,id_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 - USE globalData,only:lookup_meta ! metadata structures + USE globalData,only:time_meta,forc_meta,attr_meta,type_meta,id_meta ! metadata structures + USE globalData,only:prog_meta,diag_meta,flux_meta,mpar_meta,indx_meta ! metadata structures + USE globalData,only:bpar_meta,bvar_meta,deriv_meta,lookup_meta ! metadata structures ! named variables defining strructure elements - USE var_lookup,only:iLookTIME,iLookFORCE,iLookATTR,iLookTYPE,iLookID ! named variables showing the elements of each data structure - USE var_lookup,only:iLookPROG,iLookDIAG,iLookFLUX,iLookDERIV ! named variables showing the elements of each data structure - USE var_lookup,only:iLookPARAM,iLookINDEX ! named variables showing the elements of each data structure - USE var_lookup,only:iLookBPAR,iLookBVAR ! named variables showing the elements of each data structure - USE var_lookup,only:iLookLOOKUP ! named variables showing the elements of each data structure + USE var_lookup,only:iLookTIME,iLookFORCE,iLookATTR,iLookTYPE,iLookID ! named variables showing the elements of each data structure + USE var_lookup,only:iLookPROG,iLookDIAG,iLookFLUX,iLookPARAM,iLookINDEX ! named variables showing the elements of each data structure + USE var_lookup,only:iLookBPAR,iLookBVAR,iLookDERIV,iLookLOOKUP ! named variables showing the elements of each data structure implicit none ! dummy variables integer(i4b),intent(out) :: err ! error code @@ -158,32 +154,32 @@ subroutine checkPopulated(iStruct,metadata,err,message) do iVar=1,size(metadata) ! check that this variable is populated - if (trim(metadata(iVar)%varname)=='empty') then + 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) + 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; '// & + 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' + 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, & + write(message,'(a,i0,a,i0,a)') trim(message)//'variable '//trim(metadata(iVar)%varName)//' has index ', iVar, & ' (expect index ', jVar, '); problem possible in popMetadat, get_ix'//trim(structInfo(iStruct)%structName)//', or var_lookup' err=20; return end if diff --git a/build/source/engine/check_icond.f90 b/build/source/engine/check_icond.f90 index 2449fa889..c4e08e367 100644 --- a/build/source/engine/check_icond.f90 +++ b/build/source/engine/check_icond.f90 @@ -19,7 +19,10 @@ ! along with this program. If not, see . module check_icond_module -USE nrtype +USE nr_type + +! constants +USE globalData,only:verySmall ! a small number ! access missing values USE globalData,only:integerMissing ! missing integer @@ -45,7 +48,7 @@ subroutine check_icond(nGRU, & ! intent(in): number err,message) ! intent(out): error control ! -------------------------------------------------------------------------------------------------------- ! modules - USE nrtype + USE nr_type USE var_lookup,only:iLookPARAM ! variable lookup structure USE var_lookup,only:iLookPROG ! variable lookup structure USE var_lookup,only:iLookDIAG ! variable lookup structure @@ -62,12 +65,12 @@ subroutine check_icond(nGRU, & ! intent(in): number 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 - USE enthalpyTemp_module,only:T2enthTemp_cas ! convert temperature to enthalpy for canopy air space - USE enthalpyTemp_module,only:T2enthTemp_veg ! convert temperature to enthalpy for vegetation - USE enthalpyTemp_module,only:T2enthTemp_snow ! convert temperature to enthalpy for snow - USE enthalpyTemp_module,only:T2enthTemp_soil ! convert temperature to enthalpy for soil + USE updatState_module,only:updatSnow ! update snow states + USE updatState_module,only:updatSoil ! update soil states + USE convertEnthalpyTemp_module,only:T2enthTemp_cas ! convert temperature to enthalpy for canopy air space + USE convertEnthalpyTemp_module,only:T2enthTemp_veg ! convert temperature to enthalpy for vegetation + USE convertEnthalpyTemp_module,only:T2enthTemp_snow ! convert temperature to enthalpy for snow + USE convertEnthalpyTemp_module,only:T2enthTemp_soil ! convert temperature to enthalpy for soil implicit none @@ -264,7 +267,7 @@ subroutine check_icond(nGRU, & ! intent(in): number end if ! ensure consistency among state variables - call updateSnow(& + call updatSnow(& mLayerTemp(iLayer), & ! intent(in): temperature (K) scalarTheta, & ! intent(in): volumetric fraction of total water (-) snowfrz_scale, & ! intent(in): scaling parameter for the snow freezing curve (K-1) @@ -291,7 +294,7 @@ subroutine check_icond(nGRU, & ! intent(in): number case(iname_soil) ! ensure consistency among state variables - call updateSoil(& + call updatSoil(& 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 @@ -330,7 +333,7 @@ subroutine check_icond(nGRU, & ! intent(in): number end associate ! if snow layers exist, compute snow depth and SWE - if(nSnow > 0)then + 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) ) @@ -340,7 +343,7 @@ subroutine check_icond(nGRU, & ! intent(in): number 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-6_rkind)then + if(abs(h1 - h2) > verySmall)then write(message,'(a,1x,i0,a,f5.3,a,f5.3)') trim(message)//'mis-match between layer depth and layer height; layer = ', iLayer, '; sum depths = ',h1,'; height = ',h2 err=20; return end if diff --git a/build/source/engine/childStruc.f90 b/build/source/engine/childStruc.f90 index 01061eebc..c28cba89e 100644 --- a/build/source/engine/childStruc.f90 +++ b/build/source/engine/childStruc.f90 @@ -19,9 +19,9 @@ ! along with this program. If not, see . module childStruc_module -USE nrtype +USE nr_type USE globalData,only:integerMissing ! missing value -USE nr_utility_module,only:arth ! get a sequence of numbers +USE nr_utils_module,only:arth ! use to build vectors with regular increments implicit none private diff --git a/build/source/engine/computFlux.f90 b/build/source/engine/computFlux.f90 index c33645d6b..5013bf56f 100644 --- a/build/source/engine/computFlux.f90 +++ b/build/source/engine/computFlux.f90 @@ -21,7 +21,7 @@ module computFlux_module ! data types -USE nrtype +USE nr_type ! provide access to the derived types and classes used to define data structures and class objects USE data_types,only:& @@ -31,10 +31,10 @@ module computFlux_module var_dlength, & ! data vector with variable length dimension (rkind) model_options, & ! defines the model decisions in_type_vegNrgFlux,out_type_vegNrgFlux, & ! classes for vegNrgFlux call - in_type_ssdNrgFlux,io_type_ssdNrgFlux,out_type_ssdNrgFlux,& ! classes for ssdNrgFlux call + in_type_snowSoilNrgFlux,io_type_snowSoilNrgFlux,out_type_snowSoilNrgFlux,& ! classes for snowSoilNrgFlux call in_type_vegLiqFlux,out_type_vegLiqFlux, & ! classes for vegLiqFlux call - in_type_snowLiqFlx,io_type_snowLiqFlx,out_type_snowLiqFlx,& ! classes for snowLiqFlx call - in_type_soilLiqFlx,io_type_soilLiqFlx,out_type_soilLiqFlx,& ! classes for soilLiqFlx call + in_type_snowLiqFlux,io_type_snowLiqFlux,out_type_snowLiqFlux,& ! classes for snowLiqFlux call + in_type_soilLiqFlux,io_type_soilLiqFlux,out_type_soilLiqFlux,& ! classes for soilLiqFlux call in_type_groundwatr,io_type_groundwatr,out_type_groundwatr,& ! classes for groundwatr call in_type_bigAquifer,io_type_bigAquifer,out_type_bigAquifer ! classes for bigAquifer call @@ -138,10 +138,10 @@ subroutine computFlux(& err,message) ! intent(out): error code and error message ! provide access to flux subroutines USE vegNrgFlux_module,only:vegNrgFlux ! compute energy fluxes over vegetation - USE ssdNrgFlux_module,only:ssdNrgFlux ! compute energy fluxes throughout the snow and soil subdomains + USE snowSoilNrgFlux_module,only:snowSoilNrgFlux ! 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 snowLiqFlux_module,only:snowLiqFlux ! compute liquid water fluxes through snow + USE soilLiqFlux_module,only:soilLiqFlux ! compute liquid water fluxes through soil USE groundwatr_module,only:groundwatr ! compute the baseflow flux USE bigAquifer_module,only:bigAquifer ! compute fluxes for the big aquifer implicit none @@ -202,10 +202,10 @@ subroutine computFlux(& ! ---------------------- classes for flux subroutine arguments (classes defined in data_types module) ---------------------- ! ** intent(in) arguments ** || ** intent(inout) arguments ** || ** intent(out) arguments ** type(in_type_vegNrgFlux) :: in_vegNrgFlux; type(out_type_vegNrgFlux) :: out_vegNrgFlux ! vegNrgFlux arguments - type(in_type_ssdNrgFlux) :: in_ssdNrgFlux; type(io_type_ssdNrgFlux) :: io_ssdNrgFlux; type(out_type_ssdNrgFlux) :: out_ssdNrgFlux ! ssdNrgFlux arguments + type(in_type_snowSoilNrgFlux) :: in_snowSoilNrgFlux; type(io_type_snowSoilNrgFlux) :: io_snowSoilNrgFlux; type(out_type_snowSoilNrgFlux) :: out_snowSoilNrgFlux ! snowSoilNrgFlux arguments type(in_type_vegLiqFlux) :: in_vegLiqFlux; type(out_type_vegLiqFlux) :: out_vegLiqFlux ! vegLiqFlux arguments - type(in_type_snowLiqFlx) :: in_snowLiqFlx; type(io_type_snowLiqFlx) :: io_snowLiqFlx; type(out_type_snowLiqFlx) :: out_snowLiqFlx ! snowLiqFlx arguments - type(in_type_soilLiqFlx) :: in_soilLiqFlx; type(io_type_soilLiqFlx) :: io_soilLiqFlx; type(out_type_soilLiqFlx) :: out_soilLiqFlx ! soilLiqFlx arguments + type(in_type_snowLiqFlux) :: in_snowLiqFlux; type(io_type_snowLiqFlux) :: io_snowLiqFlux; type(out_type_snowLiqFlux) :: out_snowLiqFlux ! snowLiqFlux arguments + type(in_type_soilLiqFlux) :: in_soilLiqFlux; type(io_type_soilLiqFlux) :: io_soilLiqFlux; type(out_type_soilLiqFlux) :: out_soilLiqFlux ! soilLiqFlux arguments type(in_type_groundwatr) :: in_groundwatr; type(io_type_groundwatr) :: io_groundwatr; type(out_type_groundwatr) :: out_groundwatr ! groundwatr arguments type(in_type_bigAquifer) :: in_bigAquifer; type(io_type_bigAquifer) :: io_bigAquifer; type(out_type_bigAquifer) :: out_bigAquifer ! bigAquifer arguments ! ------------------------------------------------------------------------------------------------------------------------- @@ -231,9 +231,9 @@ subroutine computFlux(& ! *** CALCULATE ENERGY FLUXES THROUGH THE SNOW-SOIL DOMAIN *** associate(nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg)%dat(1)) ! intent(in): [i4b] number of energy state variables in the snow+soil domain if (nSnowSoilNrg>0) then ! if necessary, calculate energy fluxes at layer interfaces through the snow and soil domain - call initialize_ssdNrgFlux - call ssdNrgFlux(in_ssdNrgFlux,mpar_data,indx_data,prog_data,diag_data,flux_data,io_ssdNrgFlux,out_ssdNrgFlux) - call finalize_ssdNrgFlux; if(err/=0)then; return; endif + call initialize_snowSoilNrgFlux + call snowSoilNrgFlux(in_snowSoilNrgFlux,mpar_data,indx_data,prog_data,diag_data,flux_data,io_snowSoilNrgFlux,out_snowSoilNrgFlux) + call finalize_snowSoilNrgFlux; if(err/=0)then; return; endif end if end associate @@ -249,9 +249,9 @@ subroutine computFlux(& ! *** CALCULATE THE LIQUID FLUX THROUGH SNOW *** associate(nSnowOnlyHyd => indx_data%var(iLookINDEX%nSnowOnlyHyd)%dat(1)) ! intent(in): [i4b] number of hydrology variables in the snow domain if (nSnowOnlyHyd>0) then ! if necessary, compute liquid fluxes through snow - call initialize_snowLiqFlx - call snowLiqFlx(in_snowLiqFlx,indx_data,mpar_data,prog_data,diag_data,io_snowLiqFlx,out_snowLiqFlx) - call finalize_snowLiqFlx; if(err/=0)then; return; endif + call initialize_snowLiqFlux + call snowLiqFlux(in_snowLiqFlux,indx_data,mpar_data,prog_data,diag_data,io_snowLiqFlux,out_snowLiqFlux) + call finalize_snowLiqFlux; if(err/=0)then; return; endif else call soilForcingNoSnow ! define forcing for the soil domain for the case of no snow layers end if @@ -260,9 +260,9 @@ subroutine computFlux(& ! *** CALCULATE THE LIQUID FLUX THROUGH SOIL *** associate(nSoilOnlyHyd => indx_data%var(iLookINDEX%nSoilOnlyHyd)%dat(1)) ! intent(in): [i4b] number of hydrology variables in the soil domain if (nSoilOnlyHyd>0) then ! if necessary, calculate the liquid flux through soil - call initialize_soilLiqFlx - call soilLiqFlx(in_soilLiqFlx,mpar_data,indx_data,prog_data,diag_data,flux_data,io_soilLiqFlx,out_soilLiqFlx) - call finalize_soilLiqFlx; if(err/=0)then; return; endif + call initialize_soilLiqFlux + call soilLiqFlux(in_soilLiqFlux,mpar_data,indx_data,prog_data,diag_data,flux_data,io_soilLiqFlux,out_soilLiqFlux) + call finalize_soilLiqFlux; if(err/=0)then; return; endif end if end associate @@ -276,7 +276,7 @@ subroutine computFlux(& call groundwatr(in_groundwatr,attr_data,mpar_data,prog_data,flux_data,io_groundwatr,out_groundwatr) call finalize_groundwatr; if(err/=0)then; return; endif end if - call computeBaseflowRunoff ! compute total baseflow from soil and runoff + call computBaseflowRunoff ! compute total baseflow from soil and runoff end if end associate @@ -326,7 +326,7 @@ subroutine zeroBaseflowFluxes end associate end subroutine zeroBaseflowFluxes - subroutine computeBaseflowRunoff + subroutine computBaseflowRunoff ! compute total baseflow from the soil zone (needed for mass balance checks) and total runoff ! (Note: scalarSoilBaseflow is zero if topmodel is not used) ! (Note: scalarSoilBaseflow may need to re-envisioned in topmodel formulation if parts of it flow into neighboring soil rather than exfiltrate) @@ -339,7 +339,7 @@ subroutine computeBaseflowRunoff scalarSoilBaseflow = sum(mLayerBaseflow) ! baseflow from the soil zone scalarTotalRunoff = scalarSurfaceRunoff + scalarSoilDrainage + scalarSoilBaseflow ! total runoff end associate - end subroutine computeBaseflowRunoff + end subroutine computBaseflowRunoff subroutine zeroAquiferFluxes ! set aquifer fluxes to zero (if no aquifer exists) @@ -460,15 +460,15 @@ subroutine finalize_vegNrgFlux end subroutine finalize_vegNrgFlux ! **** end vegNrgFlux **** - ! **** ssdNrgFlux **** - subroutine initialize_ssdNrgFlux - call in_ssdNrgFlux%initialize(scalarSolution,firstFluxCall,mLayerTempTrial,flux_data,deriv_data) - call io_ssdNrgFlux%initialize(deriv_data) - end subroutine initialize_ssdNrgFlux + ! **** snowSoilNrgFlux **** + subroutine initialize_snowSoilNrgFlux + call in_snowSoilNrgFlux%initialize(scalarSolution,firstFluxCall,mLayerTempTrial,flux_data,deriv_data) + call io_snowSoilNrgFlux%initialize(deriv_data) + end subroutine initialize_snowSoilNrgFlux - subroutine finalize_ssdNrgFlux - call io_ssdNrgFlux%finalize(deriv_data) - call out_ssdNrgFlux%finalize(flux_data,deriv_data,err,cmessage) + subroutine finalize_snowSoilNrgFlux + call io_snowSoilNrgFlux%finalize(deriv_data) + call out_snowSoilNrgFlux%finalize(flux_data,deriv_data,err,cmessage) associate(& mLayerNrgFlux => flux_data%var(iLookFLUX%mLayerNrgFlux)%dat, & ! intent(out): [dp] net energy flux for each layer within the snow+soil domain (J m-3 s-1) iLayerNrgFlux => flux_data%var(iLookFLUX%iLayerNrgFlux)%dat, & ! intent(out): [dp(0:)] vertical energy flux at the interface of snow and soil layers @@ -480,8 +480,8 @@ subroutine finalize_ssdNrgFlux mLayerNrgFlux(iLayer) = -(iLayerNrgFlux(iLayer) - iLayerNrgFlux(iLayer-1))/mLayerDepth(iLayer) end do end associate - end subroutine finalize_ssdNrgFlux - ! **** end ssdNrgFlux **** + end subroutine finalize_snowSoilNrgFlux + ! **** end snowSoilNrgFlux **** ! **** vegLiqFlux **** subroutine initialize_vegLiqFlux @@ -509,15 +509,15 @@ subroutine finalize_vegLiqFlux end subroutine finalize_vegLiqFlux ! **** end vegLiqFlux **** - ! **** snowLiqFlx **** - subroutine initialize_snowLiqFlx - call in_snowLiqFlx%initialize(nSnow,firstFluxCall,scalarSolution,mLayerVolFracLiqTrial,flux_data) - call io_snowLiqFlx%initialize(flux_data,deriv_data) - end subroutine initialize_snowLiqFlx + ! **** snowLiqFlux **** + subroutine initialize_snowLiqFlux + call in_snowLiqFlux%initialize(nSnow,firstFluxCall,scalarSolution,mLayerVolFracLiqTrial,flux_data) + call io_snowLiqFlux%initialize(flux_data,deriv_data) + end subroutine initialize_snowLiqFlux - subroutine finalize_snowLiqFlx - call io_snowLiqFlx%finalize(flux_data,deriv_data) - call out_snowLiqFlx%finalize(err,cmessage) + subroutine finalize_snowLiqFlux + call io_snowLiqFlux%finalize(flux_data,deriv_data) + call out_snowLiqFlux%finalize(err,cmessage) ! error control if (err/=0) then; message=trim(message)//trim(cmessage); return; end if associate(& @@ -535,20 +535,20 @@ subroutine finalize_snowLiqFlx ! compute drainage from the soil zone (needed for mass balance checks) scalarSnowDrainage = iLayerLiqFluxSnow(nSnow) end associate - end subroutine finalize_snowLiqFlx - ! **** end snowLiqFlx **** + end subroutine finalize_snowLiqFlux + ! **** end snowLiqFlux **** - ! **** soilLiqFlx **** - subroutine initialize_soilLiqFlx - call in_soilLiqFlx%initialize(nSnow,nSoil,nlayers,firstSplitOper,scalarSolution,firstFluxCall,scalarAquiferStorageTrial,& + ! **** soilLiqFlux **** + subroutine initialize_soilLiqFlux + call in_soilLiqFlux%initialize(nSnow,nSoil,nlayers,firstSplitOper,scalarSolution,firstFluxCall,scalarAquiferStorageTrial,& mLayerTempTrial,mLayerMatricHeadTrial,mLayerMatricHeadLiqTrial,mLayerVolFracLiqTrial,mLayerVolFracIceTrial,& flux_data,deriv_data) - call io_soilLiqFlx%initialize(nSoil,dHydCond_dMatric,flux_data,diag_data,deriv_data) - end subroutine initialize_soilLiqFlx + call io_soilLiqFlux%initialize(nSoil,dHydCond_dMatric,flux_data,diag_data,deriv_data) + end subroutine initialize_soilLiqFlux - subroutine finalize_soilLiqFlx - call io_soilLiqFlx%finalize(nSoil,dHydCond_dMatric,flux_data,diag_data,deriv_data) - call out_soilLiqFlx%finalize(err,cmessage) + subroutine finalize_soilLiqFlux + call io_soilLiqFlux%finalize(nSoil,dHydCond_dMatric,flux_data,diag_data,deriv_data) + call out_soilLiqFlux%finalize(err,cmessage) ! error control if (err/=0) then; message=trim(message)//trim(cmessage); return; end if associate(& @@ -575,8 +575,8 @@ subroutine finalize_soilLiqFlx dq_dHydStateBelow(0:nSoil-1) = dq_dHydStateBelow(0:nSoil-1)*dPsiLiq_dPsi0(1:nSoil) if(all(dq_dHydStateLayerSurfVec/=realMissing)) dq_dHydStateLayerSurfVec(1:nSoil) = dq_dHydStateLayerSurfVec(1:nSoil)*dPsiLiq_dPsi0(1:nSoil) end associate - end subroutine finalize_soilLiqFlx - ! **** end soilLiqFlx **** + end subroutine finalize_soilLiqFlux + ! **** end soilLiqFlux **** ! **** groundwatr **** subroutine initialize_groundwatr @@ -628,7 +628,7 @@ subroutine soilCmpres(& ! input: dt, & ! intent(in): length of the time step (seconds) ixRichards, & ! intent(in): choice of option for Richards' equation - ixBeg,ixEnd, & ! intent(in): start and end indices defining desired layers + ixTop,ixBot, & ! intent(in): top and bottom defining desired layers mLayerMatricHead, & ! intent(in): matric head at the start of the time step (m) mLayerMatricHeadTrial, & ! intent(in): trial value of matric head (m) mLayerVolFracLiqTrial, & ! intent(in): trial value for the volumetric liquid water content in each soil layer (-) @@ -641,9 +641,9 @@ subroutine soilCmpres(& err,message) ! intent(out): error code and error message implicit none ! input: - real(rkind),intent(in) :: dt ! length of the time step (seconds) + real(rkind),intent(in) :: dt ! length of the time step (seconds) integer(i4b),intent(in) :: ixRichards ! choice of option for Richards' equation - integer(i4b),intent(in) :: ixBeg,ixEnd ! start and end indices defining desired layers + integer(i4b),intent(in) :: ixTop,ixBot ! top and bottom defining desired layers real(rkind),intent(in) :: mLayerMatricHead(:) ! matric head at the start of the time step (m) real(rkind),intent(in) :: mLayerMatricHeadTrial(:) ! trial value for matric head (m) real(rkind),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) @@ -663,11 +663,11 @@ subroutine soilCmpres(& ! (only compute for the mixed form of Richards' equation) if (ixRichards==mixdform) then do iLayer=1,size(mLayerMatricHead) - if (iLayer>=ixBeg .and. iLayer<=ixEnd) then - ! compute the derivative for the compressibility term (m-1), no volume expansion for total water - dCompress_dPsi(iLayer) = specificStorage*(mLayerVolFracLiqTrial(iLayer) + mLayerVolFracIceTrial(iLayer))/theta_sat(iLayer) - ! compute the compressibility term (-) per second - compress(iLayer) = (mLayerMatricHeadTrial(iLayer) - mLayerMatricHead(iLayer))*dCompress_dPsi(iLayer)/dt + if (iLayer>=ixTop .and. iLayer<=ixBot) then + ! compute the derivative for the compressibility term (m-1), no volume expansion for total water + dCompress_dPsi(iLayer) = specificStorage*(mLayerVolFracLiqTrial(iLayer) + mLayerVolFracIceTrial(iLayer))/theta_sat(iLayer) + ! compute the compressibility term (-) per second + compress(iLayer) = (mLayerMatricHeadTrial(iLayer) - mLayerMatricHead(iLayer))*dCompress_dPsi(iLayer)/dt end if end do else @@ -682,7 +682,7 @@ end subroutine soilCmpres subroutine soilCmpresPrime(& ! input: ixRichards, & ! intent(in): choice of option for Richards' equation - ixBeg,ixEnd, & ! intent(in): start and end indices defining desired layers + ixTop,ixBot, & ! intent(in): top and bottom defining desired layers mLayerMatricHeadPrime, & ! intent(in): matric head at the start of the time step (m) mLayerVolFracLiqTrial, & ! intent(in): trial value for the volumetric liquid water content in each soil layer (-) mLayerVolFracIceTrial, & ! intent(in): trial value for the volumetric ice content in each soil layer (-) @@ -695,7 +695,7 @@ subroutine soilCmpresPrime(& implicit none ! input: integer(i4b),intent(in) :: ixRichards ! choice of option for Richards' equation - integer(i4b),intent(in) :: ixBeg,ixEnd ! start and end indices defining desired layers + integer(i4b),intent(in) :: ixTop,ixBot ! top and bottom defining desired layers real(rkind),intent(in) :: mLayerMatricHeadPrime(:) ! matric head at the start of the time step (m) real(rkind),intent(in) :: mLayerVolFracLiqTrial(:) ! trial value for volumetric fraction of liquid water (-) real(rkind),intent(in) :: mLayerVolFracIceTrial(:) ! trial value for volumetric fraction of ice (-) @@ -714,11 +714,11 @@ subroutine soilCmpresPrime(& ! (only compute for the mixed form of Richards' equation) if (ixRichards==mixdform) then do iLayer=1,size(mLayerMatricHeadPrime) - if (iLayer>=ixBeg .and. iLayer<=ixEnd) then - ! compute the derivative for the compressibility term (m-1), no volume expansion for total water - dCompress_dPsi(iLayer) = specificStorage*(mLayerVolFracLiqTrial(iLayer) + mLayerVolFracIceTrial(iLayer))/theta_sat(iLayer) - ! compute the compressibility term (-) instantaneously - compress(iLayer) = mLayerMatricHeadPrime(iLayer) * dCompress_dPsi(iLayer) + if (iLayer>=ixTop .and. iLayer<=ixBot) then + ! compute the derivative for the compressibility term (m-1), no volume expansion for total water + dCompress_dPsi(iLayer) = specificStorage*(mLayerVolFracLiqTrial(iLayer) + mLayerVolFracIceTrial(iLayer))/theta_sat(iLayer) + ! compute the compressibility term (-) instantaneously + compress(iLayer) = mLayerMatricHeadPrime(iLayer) * dCompress_dPsi(iLayer) end if end do else diff --git a/build/source/engine/computJacob.f90 b/build/source/engine/computJacob.f90 index 07974fcde..97ed30a87 100644 --- a/build/source/engine/computJacob.f90 +++ b/build/source/engine/computJacob.f90 @@ -21,7 +21,7 @@ module computJacob_module ! data types -USE nrtype +USE nr_type ! derived types to define the data structures USE data_types,only:& @@ -731,8 +731,10 @@ subroutine fluxJacAdd(& ! ---------------------------------------- if(ixAqWat/=integerMissing) then aJac(ixInd(full,ixAqWat,ixAqWat),ixAqWat) = -dBaseflow_dAquifer*dt + dMat(ixAqWat) - if(ixSoilOnlyNrg(nSoil)/=integerMissing) aJac(ixInd(full,ixAqWat,ixSoilOnlyNrg(nSoil)),ixSoilOnlyNrg(nSoil)) = -dq_dNrgStateAbove(nSoil)*dt ! dAquiferRecharge_dTk = d_iLayerLiqFluxSoil(nSoil)_dTk - if(ixSoilOnlyHyd(nSoil)/=integerMissing) aJac(ixInd(full,ixAqWat,ixSoilOnlyHyd(nSoil)),ixSoilOnlyHyd(nSoil)) = -dq_dHydStateAbove(nSoil)*dt ! dAquiferRecharge_dWat = d_iLayerLiqFluxSoil(nSoil)_dWat + if(nSoil>0)then + if(ixSoilOnlyNrg(nSoil)/=integerMissing) aJac(ixInd(full,ixAqWat,ixSoilOnlyNrg(nSoil)),ixSoilOnlyNrg(nSoil)) = -dq_dNrgStateAbove(nSoil)*dt ! dAquiferRecharge_dTk = d_iLayerLiqFluxSoil(nSoil)_dTk + if(ixSoilOnlyHyd(nSoil)/=integerMissing) aJac(ixInd(full,ixAqWat,ixSoilOnlyHyd(nSoil)),ixSoilOnlyHyd(nSoil)) = -dq_dHydStateAbove(nSoil)*dt ! dAquiferRecharge_dWat = d_iLayerLiqFluxSoil(nSoil)_dWat + endif ! - include derivatives of energy and water w.r.t soil transpiration (dependent on canopy transpiration) if(computeVegFlux)then if(ixCasNrg/=integerMissing)then diff --git a/build/source/engine/computJacobWithPrime.f90 b/build/source/engine/computJacobWithPrime.f90 index aa327af11..5c26c3058 100644 --- a/build/source/engine/computJacobWithPrime.f90 +++ b/build/source/engine/computJacobWithPrime.f90 @@ -21,7 +21,7 @@ module computJacobWithPrime_module ! data types -USE nrtype +USE nr_type ! derived types to define the data structures USE data_types,only:& @@ -76,8 +76,8 @@ module computJacobWithPrime_module ! look-up values for the choice of variable in energy equations (BE residual or IDA state variable) USE mDecisions_module,only: & closedForm, & ! use temperature with closed form heat capacity - enthalpyFormLU, & ! use enthalpy with soil temperature-enthalpy lookup tables - enthalpyForm ! use enthalpy with soil temperature-enthalpy analytical solution + enthalpyForm, & ! use enthalpy with soil temperature-enthalpy lookup tables + enthalpyFormAN ! use enthalpy with soil temperature-enthalpy analytical solution implicit none private diff --git a/build/source/engine/computResid.f90 b/build/source/engine/computResid.f90 index 82f51d903..196d4c781 100644 --- a/build/source/engine/computResid.f90 +++ b/build/source/engine/computResid.f90 @@ -21,7 +21,7 @@ module computResid_module ! data types -USE nrtype +USE nr_type ! derived types to define the data structures USE data_types,only:& @@ -283,7 +283,7 @@ subroutine computResid(& 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 + end do ! looping through non-missing hydrology state variables in the snow+soil domain endif ! compute the residual vector for the aquifer @@ -296,28 +296,28 @@ subroutine computResid(& write(*,'(a,i4)') ' nSoil = ', nSoil write(*,'(a,i4)') ' nLayers = ', nLayers write(*,'(a,f12.5)') ' dt = ', dt - write(*,'(a,1x,100(e12.5,1x))') ' sMul = ', sMul(min(iJac1,size(sMul)):min(iJac2,size(sMul))) - write(*,'(a,1x,100(e12.5,1x))') ' fVec = ', fVec(min(iJac1,size(fVec)):min(iJac2,size(fVec))) - write(*,'(a,f12.5)') ' scalarCanairTempTrial = ', scalarCanairTempTrial - write(*,'(a,f12.5)') ' scalarCanopyTempTrial = ', scalarCanopyTempTrial - write(*,'(a,f12.5)') ' scalarCanopyWatTrial = ', scalarCanopyWatTrial + write(*,'(a,e12.5)') ' scalarCanairTempTrial = ', scalarCanairTempTrial + write(*,'(a,e12.5)') ' scalarCanopyTempTrial = ', scalarCanopyTempTrial + write(*,'(a,e12.5)') ' scalarCanopyWatTrial = ', scalarCanopyWatTrial write(*,'(a,1x,100(e12.5,1x))') ' mLayerTempTrial = ', mLayerTempTrial(min(iJac1,size(mLayerTempTrial)):min(iJac2,size(mLayerTempTrial))) - write(*,'(a,f12.5)') ' scalarAquiferStorageTrial = ', scalarAquiferStorageTrial - write(*,'(a,f12.5)') ' scalarCanopyIceTrial = ', scalarCanopyIceTrial - write(*,'(a,f12.5)') ' scalarCanopyLiqTrial = ', scalarCanopyLiqTrial + write(*,'(a,e12.5)') ' scalarAquiferStorageTrial = ', scalarAquiferStorageTrial + write(*,'(a,e12.5)') ' scalarCanopyIceTrial = ', scalarCanopyIceTrial + write(*,'(a,e12.5)') ' scalarCanopyLiqTrial = ', scalarCanopyLiqTrial write(*,'(a,1x,100(e12.5,1x))') ' mLayerVolFracIceTrial = ', mLayerVolFracIceTrial(min(iJac1,size(mLayerVolFracIceTrial)):min(iJac2,size(mLayerVolFracIceTrial))) write(*,'(a,1x,100(e12.5,1x))') ' mLayerVolFracWatTrial = ', mLayerVolFracWatTrial(min(iJac1,size(mLayerVolFracWatTrial)):min(iJac2,size(mLayerVolFracWatTrial))) write(*,'(a,1x,100(e12.5,1x))') ' mLayerVolFracLiqTrial = ', mLayerVolFracLiqTrial(min(iJac1,size(mLayerVolFracLiqTrial)):min(iJac2,size(mLayerVolFracLiqTrial))) - write(*,'(a,f12.5)') ' scalarCanopyCmTrial = ', scalarCanopyCmTrial + write(*,'(a,e12.5)') ' scalarCanopyCmTrial = ', scalarCanopyCmTrial write(*,'(a,1x,100(e12.5,1x))') ' mLayerCmTrial = ', mLayerCmTrial(min(iJac1,size(mLayerCmTrial)):min(iJac2,size(mLayerCmTrial))) - write(*,'(a,f12.5)') ' scalarCanairEnthalpyTrial = ', scalarCanairEnthalpyTrial - write(*,'(a,f12.5)') ' scalarCanopyEnthTempTrial = ', scalarCanopyEnthTempTrial + write(*,'(a,e12.5)') ' scalarCanairEnthalpyTrial = ', scalarCanairEnthalpyTrial + write(*,'(a,e12.5)') ' scalarCanopyEnthTempTrial = ', scalarCanopyEnthTempTrial write(*,'(a,1x,100(e12.5,1x))') ' mLayerEnthTempTrial = ', mLayerEnthTempTrial(min(iJac1,size(mLayerEnthTempTrial)):min(iJac2,size(mLayerEnthTempTrial))) + write(*,'(a,1x,100(e12.5,1x))') 'sMul = ', sMul(min(iJac1,size(sMul)):min(iJac2,size(sMul))) endif + ! print result if(globalPrintFlag .or. any(isNan(rVec)))then - write(*,'(a,1x,100(e12.5,1x))') 'rVec = ', rVec(min(iJac1,size(rVec)):min(iJac2,size(rVec))) write(*,'(a,1x,100(e12.5,1x))') 'fVec = ', fVec(min(iJac1,size(rVec)):min(iJac2,size(rVec))) + write(*,'(a,1x,100(e12.5,1x))') 'rVec = ', rVec(min(iJac1,size(rVec)):min(iJac2,size(rVec))) endif if(any(isNan(rVec)))then; message=trim(message)//'NaN in residuals'; err=20; return; endif diff --git a/build/source/engine/computResidWithPrime.f90 b/build/source/engine/computResidWithPrime.f90 index 0e91931d5..80ce36496 100644 --- a/build/source/engine/computResidWithPrime.f90 +++ b/build/source/engine/computResidWithPrime.f90 @@ -3,7 +3,7 @@ module computResidWithPrime_module ! data types -USE nrtype +USE nr_type ! derived types to define the data structures USE data_types,only:& @@ -248,7 +248,7 @@ subroutine computResidWithPrime(& mLayerVolFracHydPrime(iLayer) = merge(mLayerVolFracWatPrime(iLayer), mLayerVolFracLiqPrime(iLayer), (ixHydType(iLayer)==iname_watLayer .or. ixHydType(iLayer)==iname_matLayer) ) ! (compute the residual) rVec( ixSnowSoilHyd(iLayer) ) = mLayerVolFracHydPrime(iLayer) - ( fVec( ixSnowSoilHyd(iLayer) )*dt + rAdd( ixSnowSoilHyd(iLayer) ) ) - end do ! looping through non-missing energy state variables in the snow+soil domain + end do ! looping through non-missing hydrology state variables in the snow+soil domain endif ! compute the residual vector for the aquifer @@ -261,29 +261,28 @@ subroutine computResidWithPrime(& write(*,'(a,i4)') ' nSoil = ', nSoil write(*,'(a,i4)') ' nLayers = ', nLayers write(*,'(a,f12.5)') ' dt = ', dt - write(*,'(a,1x,100(e12.5,1x))') ' sMul = ', sMul(min(iJac1,size(sMul)):min(iJac2,size(sMul))) - write(*,'(a,1x,100(e12.5,1x))') ' fVec = ', fVec(min(iJac1,size(fVec)):min(iJac2,size(fVec))) - write(*,'(a,f12.5)') ' scalarCanairTempPrime = ', scalarCanairTempPrime - write(*,'(a,f12.5)') ' scalarCanopyTempPrime = ', scalarCanopyTempPrime - write(*,'(a,f12.5)') ' scalarCanopyWatPrime = ', scalarCanopyWatPrime + write(*,'(a,e12.5)') ' scalarCanairTempPrime = ', scalarCanairTempPrime + write(*,'(a,e12.5)') ' scalarCanopyTempPrime = ', scalarCanopyTempPrime + write(*,'(a,e12.5)') ' scalarCanopyWatPrime = ', scalarCanopyWatPrime write(*,'(a,1x,100(e12.5,1x))') ' mLayerTempPrime = ', mLayerTempPrime(min(iJac1,size(mLayerTempPrime)):min(iJac2,size(mLayerTempPrime))) - write(*,'(a,f12.5)') ' scalarAquiferStoragePrime = ', scalarAquiferStoragePrime - write(*,'(a,f12.5)') ' scalarCanopyIcePrime = ', scalarCanopyIcePrime - write(*,'(a,f12.5)') ' scalarCanopyLiqPrime = ', scalarCanopyLiqPrime + write(*,'(a,e12.5)') ' scalarAquiferStoragePrime = ', scalarAquiferStoragePrime + write(*,'(a,e12.5)') ' scalarCanopyIcePrime = ', scalarCanopyIcePrime + write(*,'(a,e12.5)') ' scalarCanopyLiqPrime = ', scalarCanopyLiqPrime write(*,'(a,1x,100(e12.5,1x))') ' mLayerVolFracIcePrime = ', mLayerVolFracIcePrime(min(iJac1,size(mLayerVolFracIcePrime)):min(iJac2,size(mLayerVolFracIcePrime))) write(*,'(a,1x,100(e12.5,1x))') ' mLayerVolFracWatPrime = ', mLayerVolFracWatPrime(min(iJac1,size(mLayerVolFracWatPrime)):min(iJac2,size(mLayerVolFracWatPrime))) write(*,'(a,1x,100(e12.5,1x))') ' mLayerVolFracLiqPrime = ', mLayerVolFracLiqPrime(min(iJac1,size(mLayerVolFracLiqPrime)):min(iJac2,size(mLayerVolFracLiqPrime))) - write(*,'(a,f12.5)') ' scalarCanopyCmTrial = ', scalarCanopyCmTrial + write(*,'(a,e12.5)') ' scalarCanopyCmTrial = ', scalarCanopyCmTrial write(*,'(a,1x,100(e12.5,1x))') ' mLayerCmTrial = ', mLayerCmTrial(min(iJac1,size(mLayerCmTrial)):min(iJac2,size(mLayerCmTrial))) - write(*,'(a,f12.5)') ' scalarCanairEnthalpyPrime = ', scalarCanairEnthalpyPrime - write(*,'(a,f12.5)') ' scalarCanopyEnthalpyPrime = ', scalarCanopyEnthalpyPrime + write(*,'(a,e12.5)') ' scalarCanairEnthalpyPrime = ', scalarCanairEnthalpyPrime + write(*,'(a,e12.5)') ' scalarCanopyEnthalpyPrime = ', scalarCanopyEnthalpyPrime write(*,'(a,1x,100(e12.5,1x))') ' mLayerEnthalpyPrime = ', mLayerEnthalpyPrime(min(iJac1,size(mLayerEnthalpyPrime)):min(iJac2,size(mLayerEnthalpyPrime))) + write(*,'(a,1x,100(e12.5,1x))') 'sMul = ', sMul(min(iJac1,size(sMul)):min(iJac2,size(sMul))) endif ! print result if(globalPrintFlag .or. any(isNan(rVec)))then - write(*,'(a,1x,100(e12.5,1x))') 'rVec = ', rVec(min(iJac1,size(rVec)):min(iJac2,size(rVec))) write(*,'(a,1x,100(e12.5,1x))') 'fVec = ', fVec(min(iJac1,size(rVec)):min(iJac2,size(rVec))) + write(*,'(a,1x,100(e12.5,1x))') 'rVec = ', rVec(min(iJac1,size(rVec)):min(iJac2,size(rVec))) endif if(any(isNan(rVec)))then; message=trim(message)//'NaN in residuals'; err=20; return; endif diff --git a/build/source/engine/computSnowDepth.f90 b/build/source/engine/computSnowDepth.f90 deleted file mode 100644 index ff4215068..000000000 --- a/build/source/engine/computSnowDepth.f90 +++ /dev/null @@ -1,146 +0,0 @@ -module computSnowDepth_module - -! data types -USE nrtype - -! physical constants -USE multiconst,only:& - iden_ice, & ! intrinsic density of ice (kg m-3) - iden_water ! intrinsic density of liquid water (kg m-3) - -! data types -USE data_types,only:& - var_i, & ! x%var(:) (i4b) - var_d, & ! x%var(:) (rkind) - var_ilength, & ! x%var(:)%dat (i4b) - var_dlength, & ! x%var(:)%dat (rkind) - zLookup ! x%z(:)%var(:)%lookup(:) (rkind) - -! named variables for parent structures -USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure -USE var_lookup,only:iLookPROG ! named variables for structure elements -USE var_lookup,only:iLookDIAG ! named variables for structure elements -USE var_lookup,only:iLookFLUX ! named variables for structure elements -USE var_lookup,only:iLookPARAM ! named variables for structure elements -USE var_lookup,only:iLookINDEX ! named variables for structure elements -USE globalData,only:iname_snow ! named variables for snow -USE globalData,only:iname_soil ! named variables for soil - - -! privacy -implicit none -private -public::computSnowDepth - -real(rkind),parameter :: verySmall=1.e-6_rkind ! used as an additive constant to check if substantial difference among real numbers - -contains - -! ************************************************************************************************ -! public subroutine computSnowDepth: compute snow depth for one sub timestep -! ************************************************************************************************ -subroutine computSnowDepth(& - dt_sub, & - nSnow, & ! intent(in) - scalarSnowSublimation, & ! intent(in) - mLayerVolFracLiq, & ! intent(inout) - mLayerVolFracIce, & ! intent(inout) - mLayerTemp, & ! intent(in) - mLayerMeltFreeze, & ! intent(in) - mpar_data, & ! intent(in) - ! output - tooMuchSublim, & ! intent(out): flag to denote that there was too much sublimation in a given time step - mLayerDepth, & ! intent(inout) - ! error control - err,message) ! intent(out): error control - - USE snwDensify_module,only:snwDensify ! snow densification (compaction and cavitation) - - implicit none - real(qp),intent(in) :: dt_sub - integer(i4b),intent(in) :: nSnow ! number of snow layers - real(rkind),intent(in) :: scalarSnowSublimation - real(rkind),intent(inout) :: mLayerVolFracLiq(:) - real(rkind),intent(inout) :: mLayerVolFracIce(:) - real(rkind),intent(in) :: mLayerTemp(:) - real(rkind),intent(in) :: mLayerMeltFreeze(:) - type(var_dlength),intent(in) :: mpar_data ! model parameters - logical(lgt) :: tooMuchSublim ! flag to denote that there was too much sublimation in a given time step - real(rkind),intent(inout) :: mLayerDepth(:) - - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - - ! local variables - character(len=256) :: cmessage ! error message - integer(i4b) :: iSnow ! index of snow layers - real(rkind) :: massLiquid ! mass liquid water (kg m-2) - - ! * compute change in ice content of the top snow layer due to sublimation... - ! --------------------------------------------------------------------------- - ! initialize the flags - tooMuchSublim=.false. ! too much sublimation (merge snow layers) - ! NOTE: this is done BEFORE densification - if(nSnow > 0)then ! snow layers exist - - ! try to remove ice from the top layer - iSnow=1 - - ! save the mass of liquid water (kg m-2) - massLiquid = mLayerDepth(iSnow)*mLayerVolFracLiq(iSnow)*iden_water - - ! add/remove the depth of snow gained/lost by frost/sublimation (m) - ! NOTE: assume constant density - mLayerDepth(iSnow) = mLayerDepth(iSnow) + dt_sub*scalarSnowSublimation/(mLayerVolFracIce(iSnow)*iden_ice) - - ! check that we did not remove the entire layer - if(mLayerDepth(iSnow) < verySmall)then - tooMuchSublim=.true. - return - endif - - ! update the volumetric fraction of liquid water - mLayerVolFracLiq(iSnow) = massLiquid / (mLayerDepth(iSnow)*iden_water) - - ! no snow - else - - ! no snow: check that sublimation is zero - if(abs(scalarSnowSublimation) > verySmall)then - message=trim(message)//'sublimation of snow has been computed when no snow exists' - err=20; return - end if - - end if ! (if snow layers exist) - - - ! *** account for compaction and cavitation in the snowpack... - ! ------------------------------------------------------------ - if(nSnow>0)then - call snwDensify(& - ! intent(in): variables - dt_sub, & ! intent(in): time step (s) - nSnow, & ! intent(in): number of snow layers - mLayerTemp(1:nSnow), & ! intent(in): temperature of each layer (K) - mLayerMeltFreeze(1:nSnow), & ! intent(in): volumetric melt in each layer (kg m-3) - ! intent(in): parameters - mpar_data%var(iLookPARAM%densScalGrowth)%dat(1), & ! intent(in): density scaling factor for grain growth (kg-1 m3) - mpar_data%var(iLookPARAM%tempScalGrowth)%dat(1), & ! intent(in): temperature scaling factor for grain growth (K-1) - mpar_data%var(iLookPARAM%grainGrowthRate)%dat(1), & ! intent(in): rate of grain growth (s-1) - mpar_data%var(iLookPARAM%densScalOvrbdn)%dat(1), & ! intent(in): density scaling factor for overburden pressure (kg-1 m3) - mpar_data%var(iLookPARAM%tempScalOvrbdn)%dat(1), & ! intent(in): temperature scaling factor for overburden pressure (K-1) - mpar_data%var(iLookPARAM%baseViscosity)%dat(1), & ! intent(in): viscosity coefficient at T=T_frz and snow density=0 (kg m-2 s) - ! intent(inout): state variables - mLayerDepth(1:nSnow), & ! intent(inout): depth of each layer (m) - mLayerVolFracLiq(1:nSnow), & ! intent(inout): volumetric fraction of liquid water after itertations (-) - mLayerVolFracIce(1:nSnow), & ! intent(inout): volumetric fraction of ice after itertations (-) - ! output: error control - err,cmessage) ! intent(out): error control - if(err/=0)then; err=55; message=trim(message)//trim(cmessage); return; end if - end if ! if snow layers exist - -end subroutine computSnowDepth - - -end module computSnowDepth_module - diff --git a/build/source/engine/enthalpyTemp.f90 b/build/source/engine/convertEnthalpyTemp.f90 similarity index 99% rename from build/source/engine/enthalpyTemp.f90 rename to build/source/engine/convertEnthalpyTemp.f90 index 63321c2fb..a068748de 100644 --- a/build/source/engine/enthalpyTemp.f90 +++ b/build/source/engine/convertEnthalpyTemp.f90 @@ -18,21 +18,22 @@ ! You should have received a copy of the GNU General Public License ! along with this program. If not, see . -module enthalpyTemp_module - -! constants -USE multiconst, only: gravity, & ! gravitational acceleration (m s-1) - Tfreeze, & ! freezing point of water (K) - Cp_soil,Cp_water,Cp_ice,Cp_air,& ! specific heat of soil, water and ice (J kg-1 K-1) - iden_water,iden_ice,iden_air,& ! intrinsic density of water and ice (kg m-3) - LH_fus ! latent heat of fusion (J kg-1) +module convertEnthalpyTemp_module ! data types -USE nrtype +USE nr_type USE data_types,only:var_iLength ! var(:)%dat(:) USE data_types,only:var_dLength ! var(:)%dat(:) USE data_types,only:zLookup ! z(:)%var(:)%lookup(:) +! constants +USE multiconst,only:gravity, & ! gravitational acceleration (m s-1) + Tfreeze, & ! freezing point of water (K) + Cp_soil,Cp_water,Cp_ice,Cp_air,& ! specific heat of soil, water and ice (J kg-1 K-1) + iden_water,iden_ice,iden_air,& ! intrinsic density of water and ice (kg m-3) + LH_fus ! latent heat of fusion (J kg-1) +USE globalData,only:verySmall ! a small number + ! indices within parameter structure USE var_lookup,only:iLookPARAM ! named variables to define structure element USE var_lookup,only:iLookINDEX ! named variables to define structure element @@ -90,7 +91,7 @@ subroutine T2H_lookup_snWat(mpar_data, & ! intent(in): p err,message) ! ------------------------------------------------------------------------------------------------------------------------- ! downwind routines - USE nr_utility_module,only:arth ! use to build vectors with regular increments + USE nr_utils_module,only:arth ! use to build vectors with regular increments USE spline_int_module,only:spline,splint ! use for cubic spline interpolation implicit none ! ------------------------------------------------------------------------------------------------------------------------- @@ -151,7 +152,7 @@ subroutine T2L_lookup_soil(nSoil, & ! intent(in): nu err,message) ! ------------------------------------------------------------------------------------------------------------------------- ! downwind routines - USE nr_utility_module,only:arth ! use to build vectors with regular increments + USE nr_utils_module,only:arth ! use to build vectors with regular increments USE spline_int_module,only:spline,splint ! use for cubic spline interpolation USE soil_utils_module,only:volFracLiq ! use to compute the volumetric fraction of liquid water implicit none @@ -725,7 +726,6 @@ subroutine enthTemp_or_enthalpy(& ! number of model layers, and layer type nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in): [i4b] total number of snow layers ! mapping between the full state vector and the state subset - ixMapFull2Subset => indx_data%var(iLookINDEX%ixMapFull2Subset)%dat ,& ! intent(in): [i4b(:)] list of indices in the state subset for each state in the full state vector ixMapSubset2Full => indx_data%var(iLookINDEX%ixMapSubset2Full)%dat ,& ! intent(in): [i4b(:)] [state subset] list of indices of the full state vector in the state subset ! type of domain, type of state variable, and index of control volume within domain ixDomainType_subset => indx_data%var(iLookINDEX%ixDomainType_subset)%dat ,& ! intent(in): [i4b(:)] [state subset] id of domain for desired model state variables @@ -1017,7 +1017,7 @@ subroutine enthalpy2T_snow(& vec = 0._rkind vec(1:3) = (/mLayerEnthalpy, snowfrz_scale, mLayerVolFracWat/) if(mLayerEnthalpy>0._rkind)then - T = Tfreeze - 1.e-6_rkind ! need to merge layers, don't iterate to find the temperature + T = Tfreeze - verySmall ! need to merge layers, don't iterate to find the temperature else call brent(diff_H_snow, T, T_out, 0._rkind, Tfreeze, vec, err, cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return; endif @@ -1711,4 +1711,4 @@ function diff_H_soil ( mLayerTemp, vec, use_lookup, lookup_data, ixControlIndex) end function diff_H_soil -end module enthalpyTemp_module \ No newline at end of file +end module convertEnthalpyTemp_module \ No newline at end of file diff --git a/build/source/engine/conv_funcs.f90 b/build/source/engine/convert_funcs.f90 similarity index 67% rename from build/source/engine/conv_funcs.f90 rename to build/source/engine/convert_funcs.f90 index 9e05805c4..d6eb8591c 100644 --- a/build/source/engine/conv_funcs.f90 +++ b/build/source/engine/convert_funcs.f90 @@ -18,9 +18,9 @@ ! You should have received a copy of the GNU General Public License ! along with this program. If not, see . -module conv_funcs_module -USE nrtype ! variable types -USE multiconst ! fixed parameters (lh vapzn, etc.) +module convert_funcs_module +USE nr_type ! variable types +USE multiconst ! fixed parameters (lh vapzn, etc.) implicit none private public::RELHM2SPHM,SPHM2RELHM,WETBULBTMP,satVapPress,vapPress,getLatentHeatValue @@ -38,6 +38,7 @@ function getLatentHeatValue(T) implicit none real(rkind),intent(in) :: T ! temperature (K) real(rkind) :: getLatentHeatValue ! latent heat of sublimation/vaporization (J kg-1) +!--------------------------------------------------------------------------------------------------- if(T > Tfreeze)then getLatentHeatValue = LH_vap ! latent heat of vaporization (J kg-1) else @@ -45,45 +46,35 @@ function getLatentHeatValue(T) end if end function getLatentHeatValue - ! *************************************************************************************************************** ! public function vapPress: convert specific humidity (g g-1) to vapor pressure (Pa) ! *************************************************************************************************************** function vapPress(q,p) implicit none -! input real(rkind),intent(in) :: q ! specific humidity (g g-1) real(rkind),intent(in) :: p ! pressure (Pa) -! output real(rkind) :: vapPress ! vapor pressure (Pa) -! local real(rkind) :: w ! mixing ratio -w = q / (1._rkind - q) ! mixing ratio (-) +!--------------------------------------------------------------------------------------------------- +w = q / (1._rkind - q) ! mixing ratio (-) vapPress = (w/(w + w_ratio))*p ! vapor pressure (Pa) end function vapPress - ! *************************************************************************************************************** ! public subroutine satVapPress: Uses Teten's formula to compute saturated vapor pressure (Pa) ! *************************************************************************************************************** ! NOTE: temperature units are degC !!!! ! *************************************************************************************************************** subroutine satVapPress(TC, SVP, dSVP_dT) -IMPLICIT NONE -! input +implicit none real(rkind), intent(in) :: TC ! temperature (C) -! output real(rkind), intent(out) :: SVP ! saturation vapor pressure (Pa) real(rkind), intent(out) :: dSVP_dT ! d(SVP)/dT -! local real(rkind), parameter :: X1 = 17.27_rkind real(rkind), parameter :: X2 = 237.30_rkind -! local (use to test derivative calculations) -real(rkind),parameter :: dx = 1.e-8_rkind ! finite difference increment !--------------------------------------------------------------------------------------------------- ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) - if(X2 + TC <= 0.0_rkind)then ! will fail if divide by 0, but will blow up if negative top and bottom of fraction SVP = tiny(1.0_rkind) dSVP_dT = tiny(1.0_rkind) @@ -91,30 +82,7 @@ subroutine satVapPress(TC, SVP, dSVP_dT) SVP = SATVPFRZ * EXP( (X1*TC)/(X2 + TC) ) ! Saturated Vapour Press (Pa) dSVP_dT = SVP * (X1/(X2 + TC) - X1*TC/(X2 + TC)**2_i4b) end if -END SUBROUTINE satVapPress - - -! *************************************************************************************************************** -! private function MSLP2AIRP: compute air pressure using mean sea level pressure and elevation -! *************************************************************************************************************** -! (after Shuttleworth, 1993) -! -! -- actually returns MSLP2AIRP in the same units as MSLP, because -! ( (293.-0.0065*ELEV) / 293. )**5.256 is dimensionless -! -! *************************************************************************************************************** -FUNCTION MSLP2AIRP(MSLP, ELEV) -IMPLICIT NONE - -real(rkind), INTENT(IN) :: MSLP ! base pressure (Pa) -real(rkind), INTENT(IN) :: ELEV ! elevation difference from base (m) - -real(rkind) :: MSLP2AIRP ! Air pressure (Pa) - -MSLP2AIRP = MSLP * ( (293.-0.0065*ELEV) / 293. )**5.256 - -END FUNCTION MSLP2AIRP - +end subroutine satVapPress ! *************************************************************************************************************** ! private function RLHUM2DEWPT: compute dewpoint temperature from relative humidity @@ -124,30 +92,22 @@ END FUNCTION MSLP2AIRP ! All units are SI standard - i.e. Kelvin and pascals ! Based on Tetens' formula (1930) ! *************************************************************************************************************** -FUNCTION RLHUM2DEWPT(T, RLHUM) -! Compute Dewpoint temperature from Relative Humidity -IMPLICIT NONE - -real(rkind), INTENT(IN) :: T ! Temperature (K) -real(rkind), INTENT(IN) :: RLHUM ! Relative Humidity (%) - - -real(rkind) :: RLHUM2DEWPT ! Dewpoint Temp (K) - -real(rkind) :: VPSAT ! Sat. vapour pressure at T (Pa) -real(rkind) :: TDCEL ! Dewpoint temp Celcius (C) - +function RLHUM2DEWPT(T, RLHUM) +implicit none +real(rkind),intent(in) :: T ! Temperature (K) +real(rkind),intent(in) :: RLHUM ! Relative Humidity (%) +real(rkind) :: RLHUM2DEWPT ! Dewpoint Temp (K) +real(rkind) :: VPSAT ! Sat. vapour pressure at T (Pa) +real(rkind) :: TDCEL ! Dewpoint temp Celcius (C) +!--------------------------------------------------------------------------------------------------- ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) ! W_RATIO = 0.622 ! molecular weight ratio of water to dry air (-) - VPSAT = SATVPFRZ * EXP( (17.27*(T-TFREEZE)) / (237.30 + (T-TFREEZE)) ) ! sat vapor press at grid cell (Pa) TDCEL = 237.30 * LOG( (VPSAT/SATVPFRZ)*(RLHUM/100.) ) / & ! dewpoint temperature (C) (17.27 - LOG( (VPSAT/SATVPFRZ)*(RLHUM/100.) ) ) RLHUM2DEWPT = TDCEL + TFREEZE - -END FUNCTION RLHUM2DEWPT - +end function RLHUM2DEWPT ! *************************************************************************************************************** ! private function DEWPT2RLHUM: compute relative humidity from dewpoint temperature @@ -157,26 +117,20 @@ END FUNCTION RLHUM2DEWPT ! All units are SI standard - i.e. Kelvin and pascals ! Based on Tetens' formula (1930) ! *************************************************************************************************************** -FUNCTION DEWPT2RLHUM(T, DEWPT) -IMPLICIT NONE - -real(rkind), INTENT(IN) :: T ! Temperature (K) -real(rkind), INTENT(IN) :: DEWPT ! Dewpoint temp (K) - -real(rkind) :: DEWPT2RLHUM ! Relative Humidity (%) - -real(rkind) :: VPSAT ! Sat. vapour pressure at T (Pa) -real(rkind) :: TDCEL ! Dewpt in celcius (C) - +function DEWPT2RLHUM(T, DEWPT) +implicit none +real(rkind),intent(in) :: T ! Temperature (K) +real(rkind),intent(in) :: DEWPT ! Dewpoint temp (K) +real(rkind) :: DEWPT2RLHUM ! Relative Humidity (%) +real(rkind) :: VPSAT ! Sat. vapour pressure at T (Pa) +real(rkind) :: TDCEL ! Dewpt in celcius (C) +!--------------------------------------------------------------------------------------------------- ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) - TDCEL = DEWPT-TFREEZE VPSAT = SATVPFRZ * EXP( (17.27*(T-TFREEZE)) / (237.30 + (T-TFREEZE)) ) ! Sat vapor press (Pa) DEWPT2RLHUM = 100. * (SATVPFRZ/VPSAT) * EXP((17.27*TDCEL)/(237.30+TDCEL)) ! Relative Humidity (%) - -END FUNCTION DEWPT2RLHUM - +end function DEWPT2RLHUM ! *************************************************************************************************************** ! private function DEWPT2SPHM: compute specific humidity from dewpoint temperature @@ -187,26 +141,20 @@ END FUNCTION DEWPT2RLHUM ! Based on Tetens' formula (1930) ! VPAIR is the current vapor pressure as it used dewpoint to compute staurated VP ! *************************************************************************************************************** -FUNCTION DEWPT2SPHM(DEWPT, PRESS) -IMPLICIT NONE - -real(rkind), INTENT(IN) :: DEWPT ! Dewpoint temp (K) -real(rkind), INTENT(IN) :: PRESS ! Pressure (Pa) - -real(rkind) :: DEWPT2SPHM ! Specific Humidity (g/g) - -real(rkind) :: VPAIR ! vapour pressure at T (Pa) -real(rkind) :: TDCEL ! Dewpt in celcius (C) - +function DEWPT2SPHM(DEWPT, PRESS) +implicit none +real(rkind),intent(in) :: DEWPT ! Dewpoint temp (K) +real(rkind),intent(in) :: PRESS ! Pressure (Pa) +real(rkind) :: DEWPT2SPHM ! Specific Humidity (g/g) +real(rkind) :: VPAIR ! vapour pressure at T (Pa) +real(rkind) :: TDCEL ! Dewpt in celcius (C) +!--------------------------------------------------------------------------------------------------- ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) - TDCEL = DEWPT-TFREEZE VPAIR = SATVPFRZ * EXP( (17.27*TDCEL) / (237.30 + TDCEL) ) ! Vapour Press (Pa) DEWPT2SPHM = (VPAIR * W_RATIO)/(PRESS - (1.-W_RATIO)*VPAIR) ! Specific humidity (g/g) - -END FUNCTION DEWPT2SPHM - +end function DEWPT2SPHM ! *************************************************************************************************************** ! private function DEWPT2VPAIR: compute vapor pressure of air from dewpoint temperature @@ -217,22 +165,17 @@ END FUNCTION DEWPT2SPHM ! Based on Tetens' formula (1930) ! VPAIR is the current vapor pressure as it used dewpoint to compute saturated VP ! *************************************************************************************************************** -FUNCTION DEWPT2VPAIR(DEWPT) -IMPLICIT NONE - -real(rkind), INTENT(IN) :: DEWPT ! Dewpoint temp (K) -real(rkind) :: TDCEL ! Dewpt in celcius (C) - -real(rkind) :: DEWPT2VPAIR ! Vapour Press (Pa) - +function DEWPT2VPAIR(DEWPT) +implicit none +real(rkind),intent(in) :: DEWPT ! Dewpoint temp (K) +real(rkind) :: TDCEL ! Dewpt in celcius (C) +real(rkind) :: DEWPT2VPAIR ! Vapour Press (Pa) +!--------------------------------------------------------------------------------------------------- ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) - TDCEL = DEWPT-TFREEZE DEWPT2VPAIR = SATVPFRZ * EXP( (17.27*TDCEL) / (237.30 + TDCEL) ) ! Vapour Press (Pa) - -END FUNCTION DEWPT2VPAIR - +end function DEWPT2VPAIR ! *************************************************************************************************************** ! public function SPHM2RELHM: compute relative humidity from specific humidity @@ -242,27 +185,21 @@ END FUNCTION DEWPT2VPAIR ! All units are SI standard - i.e. Kelvin and pascals ! Based on Tetens' formula (1930) ! *************************************************************************************************************** -FUNCTION SPHM2RELHM(SPHM, PRESS, TAIR) -IMPLICIT NONE - -real(rkind), INTENT(IN) :: SPHM ! Specific Humidity (g/g) -real(rkind), INTENT(IN) :: PRESS ! Pressure (Pa) -real(rkind), INTENT(IN) :: TAIR ! Air temp - -real(rkind) :: SPHM2RELHM ! Dewpoint Temp (K) - -real(rkind) :: VPSAT ! vapour pressure at T (Pa) -real(rkind) :: TDCEL ! Dewpt in celcius (C) - +function SPHM2RELHM(SPHM, PRESS, TAIR) +implicit none +real(rkind),intent(in) :: SPHM ! Specific Humidity (g/g) +real(rkind),intent(in) :: PRESS ! Pressure (Pa) +real(rkind),intent(in) :: TAIR ! Air temp +real(rkind) :: SPHM2RELHM ! Dewpoint Temp (K) +real(rkind) :: VPSAT ! vapour pressure at T (Pa) +real(rkind) :: TDCEL ! Dewpt in celcius (C) +!--------------------------------------------------------------------------------------------------- ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) - TDCEL = TAIR-TFREEZE VPSAT = SATVPFRZ * EXP( (17.27*TDCEL) / (237.30 + TDCEL) ) ! Vapour Press (Pa) SPHM2RELHM = (SPHM * PRESS)/(VPSAT * (W_RATIO + SPHM*(1.-W_RATIO))) - -END FUNCTION SPHM2RELHM - +end function SPHM2RELHM ! *************************************************************************************************************** ! public function RELHM2SPHM: compute specific humidity from relative humidity @@ -272,53 +209,45 @@ END FUNCTION SPHM2RELHM ! All units are SI standard - i.e. Kelvin and pascals ! Based on Tetens' formula (1930) ! *************************************************************************************************************** -FUNCTION RELHM2SPHM(RELHM, PRESS, TAIR) -IMPLICIT NONE - -real(rkind), INTENT(IN) :: RELHM ! Relative Humidity (%) -real(rkind), INTENT(IN) :: PRESS ! Pressure (Pa) -real(rkind), INTENT(IN) :: TAIR ! Air temp - -real(rkind) :: RELHM2SPHM ! Specific Humidity (g/g) - -real(rkind) :: PVP ! Partial vapour pressure at T (Pa) -real(rkind) :: TDCEL ! Dewpt in celcius (C) - +function RELHM2SPHM(RELHM, PRESS, TAIR) +implicit none +real(rkind),intent(in) :: RELHM ! Relative Humidity (%) +real(rkind),intent(in) :: PRESS ! Pressure (Pa) +real(rkind),intent(in) :: TAIR ! Air temp +real(rkind) :: RELHM2SPHM ! Specific Humidity (g/g) +real(rkind) :: PVP ! Partial vapour pressure at T (Pa) +real(rkind) :: TDCEL ! Dewpt in celcius (C) +!--------------------------------------------------------------------------------------------------- ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) - TDCEL = TAIR-TFREEZE PVP = RELHM * SATVPFRZ * EXP( (17.27*TDCEL)/(237.30 + TDCEL) ) ! Partial Vapour Press (Pa) RELHM2SPHM = (PVP * W_RATIO)/(PRESS - (1. - W_RATIO)*PVP) - -END FUNCTION RELHM2SPHM - +end function RELHM2SPHM ! *************************************************************************************************************** ! public function WETBULBTMP: compute wet bulb temperature based on humidity and pressure ! *************************************************************************************************************** -FUNCTION WETBULBTMP(TAIR, RELHM, PRESS) -IMPLICIT NONE -! input -real(rkind), INTENT(IN) :: TAIR ! Air temp (K) -real(rkind), INTENT(IN) :: RELHM ! Relative Humidity (-) -real(rkind), INTENT(IN) :: PRESS ! Pressure (Pa) -! output -real(rkind) :: WETBULBTMP ! Wet bulb temperature (K) -! locals -real(rkind) :: Tcel ! Temperature in celcius (C) -real(rkind) :: PVP ! Partial vapor pressure (Pa) -real(rkind) :: TWcel ! Wet bulb temperature in celcius (C) -real(rkind),PARAMETER :: k=6.54E-4_DP ! normalizing factor in wet bulb estimate (C-1) -real(rkind) :: Twet_trial0 ! trial value for wet bulb temperature (C) -real(rkind) :: Twet_trial1 ! trial value for wet bulb temperature (C) -real(rkind) :: f0,f1 ! function evaluations (C) -real(rkind) :: df_dT ! derivative (-) -real(rkind) :: TWinc ! wet bulb temperature increment (C) -INTEGER(I4B) :: iter ! iterattion index -real(rkind),PARAMETER :: Xoff=1.E-5_DP ! finite difference increment (C) -real(rkind),PARAMETER :: Xtol=1.E-8_DP ! convergence tolerance (C) -INTEGER(I4B) :: maxiter=15 ! maximum number of iterations +function WETBULBTMP(TAIR, RELHM, PRESS) +implicit none +real(rkind),intent(in) :: TAIR ! Air temp (K) +real(rkind),intent(in) :: RELHM ! Relative Humidity (-) +real(rkind),intent(in) :: PRESS ! Pressure (Pa) +real(rkind) :: WETBULBTMP ! Wet bulb temperature (K) +real(rkind) :: Tcel ! Temperature in celcius (C) +real(rkind) :: PVP ! Partial vapor pressure (Pa) +real(rkind) :: TWcel ! Wet bulb temperature in celcius (C) +real(rkind),parameter :: k=6.54E-4_DP ! normalizing factor in wet bulb estimate (C-1) +real(rkind) :: Twet_trial0 ! trial value for wet bulb temperature (C) +real(rkind) :: Twet_trial1 ! trial value for wet bulb temperature (C) +real(rkind) :: f0,f1 ! function evaluations (C) +real(rkind) :: df_dT ! derivative (-) +real(rkind) :: TWinc ! wet bulb temperature increment (C) +INTEGER(I4B) :: iter ! iterattion index +real(rkind),parameter :: Xoff=1.E-5_DP ! finite difference increment (C) +real(rkind),parameter :: Xtol=1.E-8_DP ! convergence tolerance (C) +INTEGER(I4B) :: maxiter=15 ! maximum number of iterations +!--------------------------------------------------------------------------------------------------- ! convert temperature to Celcius Tcel = TAIR-TFREEZE ! compute partial vapor pressure based on temperature (Pa) @@ -343,12 +272,9 @@ FUNCTION WETBULBTMP(TAIR, RELHM, PRESS) ! check convergence if(iter==maxiter)stop 'failed to converge in WETBULBTMP' end do ! (iterating) - ! return value in K WETBULBTMP = TWcel + TFREEZE - -END FUNCTION WETBULBTMP - +end function WETBULBTMP ! *************************************************************************************************************** ! private function SATVPRESS: compute saturated vapor pressure (Pa) @@ -356,12 +282,13 @@ END FUNCTION WETBULBTMP ! Units note : Pa = N m-2 = kg m-1 s-2 ! SATVPFRZ= 610.8 ! Saturation water vapour pressure at 273.16K (Pa) ! *************************************************************************************************************** -FUNCTION SATVPRESS(TCEL) -IMPLICIT NONE -real(rkind),INTENT(IN) :: TCEL ! Temperature (C) +function SATVPRESS(TCEL) +implicit none +real(rkind),intent(in) :: TCEL ! Temperature (C) real(rkind) :: SATVPRESS ! Saturated vapor pressure (Pa) +!--------------------------------------------------------------------------------------------------- SATVPRESS = SATVPFRZ * EXP( (17.27_rkind*TCEL)/(237.30_rkind + TCEL) ) ! Saturated Vapour Press (Pa) -END FUNCTION SATVPRESS +end function SATVPRESS -end module conv_funcs_module +end module convert_funcs_module diff --git a/build/source/engine/coupled_em.f90 b/build/source/engine/coupled_em.f90 index 06f18ab9b..1c2d40233 100644 --- a/build/source/engine/coupled_em.f90 +++ b/build/source/engine/coupled_em.f90 @@ -20,9 +20,14 @@ module coupled_em_module -! homegrown solver data types -USE nrtype -USE globalData,only: verySmall ! a very small number used as an additive constant to check if substantial difference among real numbers +! data types +USE nr_type +USE data_types,only:& + var_i, & ! x%var(:) (i4b) + var_d, & ! x%var(:) (rkind) + var_ilength, & ! x%var(:)%dat (i4b) + var_dlength, & ! x%var(:)%dat (rkind) + zLookup ! x%z(:)%var(:)%lookup(:) (rkind) ! physical constants USE multiconst,only:& @@ -31,14 +36,7 @@ module coupled_em_module 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) - -! data types -USE data_types,only:& - var_i, & ! x%var(:) (i4b) - var_d, & ! x%var(:) (rkind) - var_ilength, & ! x%var(:)%dat (i4b) - var_dlength, & ! x%var(:)%dat (rkind) - zLookup ! x%z(:)%var(:)%lookup(:) (rkind) +USE globalData,only: verySmall ! a small number ! named variables for parent structures USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure @@ -85,15 +83,15 @@ module coupled_em_module ! look-up values for the numerical method USE mDecisions_module,only: & - homegrown ,& ! homegrown backward Euler solution based on concepts from numerical recipes + homegrown ,& ! homegrown backward Euler solution based on concepts from numerical recipes kinsol ,& ! SUNDIALS backward Euler solution using Kinsol ida ! SUNDIALS solution using IDA ! look-up values for the choice of variable in energy equations (BE residual or IDA state variable) USE mDecisions_module,only: & closedForm, & ! use temperature with closed form heat capacity - enthalpyFormLU, & ! use enthalpy with soil temperature-enthalpy lookup tables - enthalpyForm ! use enthalpy with soil temperature-enthalpy analytical solution + enthalpyForm, & ! use enthalpy with soil temperature-enthalpy lookup tables + enthalpyFormAN ! use enthalpy with soil temperature-enthalpy analytical solution ! privacy @@ -129,31 +127,32 @@ subroutine coupled_em(& ! error control err,message) ! intent(out): error control ! structure allocations - USE allocspace_module,only:allocLocal ! allocate local data structures - USE allocspace_module,only:resizeData ! clone a data structure + USE allocspace_module,only:allocLocal ! allocate local data structures + USE allocspace_module,only:resizeData ! clone a data structure ! simulation of fluxes and residuals given a trial state vector - USE soil_utils_module,only:liquidHead ! compute the liquid water matric potential + USE soil_utils_module,only:liquidHead ! compute the liquid water matric potential ! preliminary subroutines - USE vegPhenlgy_module,only:vegPhenlgy ! compute vegetation phenology - USE vegNrgFlux_module,only:wettedFrac ! compute wetted fraction of the canopy (used in sw radiation fluxes) - USE snowAlbedo_module,only:snowAlbedo ! compute snow albedo - USE vegSWavRad_module,only:vegSWavRad ! compute canopy sw radiation fluxes - USE canopySnow_module,only:canopySnow ! compute interception and unloading of snow from the vegetation canopy - USE volicePack_module,only:newsnwfall ! compute change in the top snow layer due to throughfall and unloading - USE volicePack_module,only:volicePack ! merge and sub-divide snow layers, if necessary - USE diagn_evar_module,only:diagn_evar ! compute diagnostic energy variables -- thermal conductivity and heat capacity + USE vegPhenlgy_module,only:vegPhenlgy ! compute vegetation phenology + USE vegNrgFlux_module,only:wettedFrac ! compute wetted fraction of the canopy (used in sw radiation fluxes) + USE snowAlbedo_module,only:snowAlbedo ! compute snow albedo + USE vegSWavRad_module,only:vegSWavRad ! compute canopy sw radiation fluxes + USE canopySnow_module,only:canopySnow ! compute interception and unloading of snow from the vegetation canopy + USE volicePack_module,only:newsnwfall ! compute change in the top snow layer due to throughfall and unloading + USE volicePack_module,only:volicePack ! merge and sub-divide snow layers, if necessary + USE thermConductivity_module,only:init_thermConductivity ! compute initialthermal conductivity of soil and snow layers + USE heat_Cp_Cm_module,only:init_heatCapacity ! compute initial heat capacity (Cp) ! the model solver - 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 - USE time_utils_module,only:elapsedSec ! calculate the elapsed time + 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 + USE time_utils_module,only:elapsedSec ! calculate the elapsed time ! additional subroutines - USE tempAdjust_module,only:tempAdjust ! adjust snow temperature associated with new snowfall - USE var_derive_module,only:calcHeight ! module to calculate height at layer interfaces and layer mid-point - USE computSnowDepth_module,only:computSnowDepth ! compute snow depth - USE enthalpyTemp_module,only:T2enthTemp_veg ! convert temperature to enthalpy for vegetation - USE enthalpyTemp_module,only:T2enthTemp_snow ! convert temperature to enthalpy for snow - USE enthalpyTemp_module,only:T2enthTemp_soil ! convert temperature to enthalpy for soil - USE enthalpyTemp_module,only:enthTemp_or_enthalpy ! add phase change terms to delta temperature component of enthalpy or vice versa + USE tempAdjust_module,only:tempAdjust ! adjust snow temperature associated with new snowfall + USE var_derive_module,only:calcHeight ! module to calculate height at layer interfaces and layer mid-point + USE snowDepth_module,only:snowDepth ! compute snow depth + USE convertEnthalpyTemp_module,only:T2enthTemp_veg ! convert temperature to enthalpy for vegetation + USE convertEnthalpyTemp_module,only:T2enthTemp_snow ! convert temperature to enthalpy for snow + USE convertEnthalpyTemp_module,only:T2enthTemp_soil ! convert temperature to enthalpy for soil + USE convertEnthalpyTemp_module,only:enthTemp_or_enthalpy ! add phase change terms to delta temperature component of enthalpy or vice versa implicit none @@ -251,6 +250,7 @@ subroutine coupled_em(& logical(lgt) :: bal_soil ! flag to denote if computed a soil balance logical(lgt) :: bal_aq ! flag to denote if computed an aquifer balance integer(i4b) :: iVar ! loop through model variables + real(rkind) :: delCanWat ! change in canopy water (kg m-2) real(rkind) :: balanceSoilCompress ! total soil compression (kg m-2) real(rkind) :: scalarCanopyWatBalError! water balance error for the vegetation canopy (kg m-2) real(rkind) :: scalarSoilWatBalError ! water balance error (kg m-2) @@ -270,7 +270,7 @@ subroutine coupled_em(& real(rkind),allocatable :: innerBalanceLayerNrg(:) ! inner step balances for domain with multiple layers ! test balance checks logical(lgt),parameter :: printBalance=.false. ! flag to print the balance checks - real(rkind),allocatable :: liqSnowInit(:) ! volumetric liquid water conetnt of snow at the start of the time step + real(rkind),allocatable :: liqSnowInit(:) ! volumetric liquid water content of snow at the start of the time step real(rkind),allocatable :: liqSoilInit(:) ! soil moisture at the start of the time step ! timing information integer(kind=8) :: count_rate @@ -284,7 +284,7 @@ subroutine coupled_em(& logical(lgt) :: lastInnerStep ! flag to denote if the last time step in maxstep subStep logical(lgt) :: do_outer ! flag to denote if doing the outer steps surrounding the call to opSplittin real(rkind) :: dt_solvInner ! seconds in the maxstep subStep that have been completed - logical(lgt),parameter :: computNrgBalance_var=.true. ! flag to compute enthalpy, must have computNrgBalance true in varSubStep (will compute enthalpy for BE even if not using enthalpy formulation) + logical(lgt),parameter :: computNrgBalance_var=.true. ! flag to compute enthalpy, must have computNrgBalance true in varSubstep (will compute enthalpy for BE even if not using enthalpy formulation) logical(lgt) :: computeEnthalpy ! flag to compute enthalpy regardless of the model decision logical(lgt) :: enthalpyStateVec ! flag if enthalpy is a state variable (IDA) logical(lgt) :: use_lookup ! flag to use the lookup table for soil enthalpy, otherwise use analytical solution @@ -344,7 +344,7 @@ subroutine coupled_em(& call allocLocal(averageFlux_meta(:)%var_info,flux_inner,nSnow,nSoil,err,cmessage) if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if - ! initialize fluxes to average over data_step (averaged over substep in varSubStep) + ! initialize fluxes to average over data_step (averaged over substep in varSubstep) do iVar=1,size(averageFlux_meta) flux_mean%var(iVar)%dat(:) = 0._rkind end do @@ -392,15 +392,20 @@ subroutine coupled_em(& else ! enthalpy state variable only implemented for IDA, energy conserved in IDA without using enthTemp if(ixNrgConserv.ne.closedForm) enthalpyStateVec = .true. ! enthalpy as state variable endif - if(ixNrgConserv==enthalpyFormLU) use_lookup = .true. ! use lookup tables for soil temperature-enthalpy instead of analytical solution + if(ixNrgConserv==enthalpyForm) use_lookup = .true. ! use lookup tables for soil temperature-enthalpy instead of analytical solution ! save the liquid water and ice on the vegetation canopy scalarInitCanopyLiq = scalarCanopyLiq ! initial liquid water on the vegetation canopy (kg m-2) scalarInitCanopyIce = scalarCanopyIce ! initial ice on the vegetation canopy (kg m-2) ! compute total soil moisture and ice at the *START* of the step (kg m-2) - scalarTotalSoilLiq = sum(iden_water*mLayerVolFracLiq(1:nSoil)*mLayerDepth(1:nSoil)) - scalarTotalSoilIce = sum(iden_water*mLayerVolFracIce(1:nSoil)*mLayerDepth(1:nSoil)) ! NOTE: no expansion and hence use iden_water + if(nSoil>0)then + 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 + else + scalarTotalSoilLiq = 0._rkind + scalarTotalSoilIce = 0._rkind + endif ! compute storage of water in the canopy and the soil balanceCanopyWater0 = scalarCanopyLiq + scalarCanopyIce @@ -417,7 +422,7 @@ subroutine coupled_em(& err=20; return endif if(nSnow>0) liqSnowInit = prog_data%var(iLookPROG%mLayerVolFracLiq)%dat(1:nSnow) - liqSoilInit = mLayerVolFracLiq + if(nSoil>0) liqSoilInit = mLayerVolFracLiq endif ! end association of local variables with information in the data structures @@ -431,12 +436,14 @@ subroutine coupled_em(& maxstep = mpar_data%var(iLookPARAM%maxstep)%dat(1) ! maximum time step (s) maxstep_op = mpar_data%var(iLookPARAM%maxstep)%dat(1)/be_steps ! maximum time step (s) to run opSplittin over - ! compute the number of layers with roots - nLayersRoots = count(prog_data%var(iLookPROG%iLayerHeight)%dat(nSnow:nLayers-1) < mpar_data%var(iLookPARAM%rootingDepth)%dat(1)-verySmall) - if(nLayersRoots == 0)then - message=trim(message)//'no roots within the soil profile' - err=20; return - end if + ! compute the number of layers with roots or layers that take infiltration + if(nSoil>0)then + 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 + endif ! define the foliage nitrogen factor diag_data%var(iLookDIAG%scalarFoliageNitrogenFactor)%dat(1) = 1._rkind ! foliage nitrogen concentration (1.0 = saturated) @@ -448,7 +455,11 @@ subroutine coupled_em(& ! ------------------------ ! compute the temperature of the root zone: used in vegetation phenology - diag_data%var(iLookDIAG%scalarRootZoneTemp)%dat(1) = sum(prog_data%var(iLookPROG%mLayerTemp)%dat(nSnow+1:nSnow+nLayersRoots)) / real(nLayersRoots, kind(rkind)) + if(nSoil>0)then + diag_data%var(iLookDIAG%scalarRootZoneTemp)%dat(1) = sum(prog_data%var(iLookPROG%mLayerTemp)%dat(nSnow+1:nSnow+nLayersRoots)) / real(nLayersRoots, kind(rkind)) + else + diag_data%var(iLookDIAG%scalarRootZoneTemp)%dat(1) = realMissing + endif ! remember if we compute the vegetation flux on the previous sub-step computeVegFluxOld = computeVegFlux @@ -538,7 +549,7 @@ subroutine coupled_em(& 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 + (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 @@ -720,11 +731,6 @@ subroutine coupled_em(& end select end do ! looping through variables - ! re-assign dimension lengths - nSnow = count(indx_data%var(iLookINDEX%layerType)%dat==iname_snow) - nSoil = count(indx_data%var(iLookINDEX%layerType)%dat==iname_soil) - nLayers = nSnow+nSoil - ! *** merge/sub-divide snow layers... ! ----------------------------------- call volicePack(& @@ -777,18 +783,16 @@ subroutine coupled_em(& theta_res => mpar_data%var(iLookPARAM%theta_res)%dat & ! soil residual volumetric water content (-) ) ! (associate local variables with model parameters) - if(nSnow>0)then - do iLayer=1,nSnow - mLayerVolFracWat(iLayer) = mLayerVolFracLiq(iLayer) + mLayerVolFracIce(iLayer)*(iden_ice/iden_water) - ! compute enthalpy for snow layers - call T2enthTemp_snow(& - snowfrz_scale, & ! intent(in): scaling parameter for the snow freezing curve (K-1) - mLayerTemp(iLayer), & ! intent(in): layer temperature (K) - mLayerVolFracWat(iLayer), & ! intent(in): volumetric total water content (-) - mLayerEnthTemp(iLayer)) ! intent(out): temperature component of enthalpy of each snow layer (J m-3) - mLayerEnthalpy(iLayer) = mLayerEnthTemp(iLayer) - iden_ice * LH_fus * mLayerVolFracIce(iLayer) - end do ! looping through snow layers - endif + do iLayer=1,nSnow + mLayerVolFracWat(iLayer) = mLayerVolFracLiq(iLayer) + mLayerVolFracIce(iLayer)*(iden_ice/iden_water) + ! compute enthalpy for snow layers + call T2enthTemp_snow(& + snowfrz_scale, & ! intent(in): scaling parameter for the snow freezing curve (K-1) + mLayerTemp(iLayer), & ! intent(in): layer temperature (K) + mLayerVolFracWat(iLayer), & ! intent(in): volumetric total water content (-) + mLayerEnthTemp(iLayer)) ! intent(out): temperature component of enthalpy of each snow layer (J m-3) + mLayerEnthalpy(iLayer) = mLayerEnthTemp(iLayer) - iden_ice * LH_fus * mLayerVolFracIce(iLayer) + end do ! looping through snow layers do iLayer=nSnow+1,nLayers mLayerVolFracWat(iLayer) = mLayerVolFracLiq(iLayer) + mLayerVolFracIce(iLayer) ! compute enthalpy for soil layers @@ -840,20 +844,29 @@ subroutine coupled_em(& ! *** compute diagnostic variables for each layer... ! -------------------------------------------------- - ! NOTE: this needs to be done AFTER volicePack, since layers may have been sub-divided and/or merged, and need to specifically send in canopy depth - call diagn_evar(& - ! input: control variables - computeVegFlux, & ! intent(in): flag to denote if computing the vegetation flux - diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1), & ! intent(in): canopy depth (m), send in specific value since diag_data may have changed - ! input/output: data structures - mpar_data, & ! intent(in): model parameters - indx_data, & ! intent(in): model layer indices - prog_data, & ! intent(in): model prognostic variables for a local HRU - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - ! output: error control - err,cmessage) ! intent(out): error control + ! NOTE: this needs to be done AFTER volicePack, since layers may have been sub-divided and/or merged + call init_heatCapacity(& + ! input: control variables + computeVegFlux, & ! intent(in): flag to denote if computing the vegetation flux + diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1), & ! intent(in): canopy depth (m), send in specific value since diag_data may have changed + ! input/output: data structures + mpar_data, & ! intent(in): model parameters + indx_data, & ! intent(in): model layer indices + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + ! output: error control + err,cmessage) ! intent(out): error control if(err/=0)then; err=55; message=trim(message)//trim(cmessage); return; end if - + call init_thermConductivity(& + ! input/output: data structures + mpar_data, & ! intent(in): model parameters + indx_data, & ! intent(in): model layer indices + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + ! output: error control + err,cmessage) ! intent(out): error control + if(err/=0)then; err=55; message=trim(message)//trim(cmessage); return; end if + ! *** compute melt of the "snow without a layer"... ! ------------------------------------------------- ! NOTE: forms a surface melt pond, which drains into the upper-most soil layer through the time step @@ -879,7 +892,7 @@ subroutine coupled_em(& if (allocated(mLayerVolFracIceInit)) deallocate(mLayerVolFracIceInit) ! prep for potential size change allocate(mLayerVolFracIceInit(nLayers)); mLayerVolFracIceInit = prog_data%var(iLookPROG%mLayerVolFracIce)%dat - ! make sure have consistent state variables to start, later done in updateVars + ! make sure have consistent state variables to start, later done in updatDiagn ! associate local variables with information in the data structures init: associate(& ! depth-varying soil parameters @@ -905,12 +918,11 @@ subroutine coupled_em(& scalarCanopyWat = scalarCanopyLiq + scalarCanopyIce ! kg m-2 ! compute the total water content in snow and soil, no ice expansion allowed for soil - if(nSnow>0)& - mLayerVolFracWat( 1:nSnow ) = mLayerVolFracLiq( 1:nSnow ) + mLayerVolFracIce( 1:nSnow )*(iden_ice/iden_water) - mLayerVolFracWat(nSnow+1:nLayers) = mLayerVolFracLiq(nSnow+1:nLayers) + mLayerVolFracIce(nSnow+1:nLayers) + mLayerVolFracWat( 1:nSnow ) = mLayerVolFracLiq( 1:nSnow ) + mLayerVolFracIce( 1:nSnow )*(iden_ice/iden_water) + mLayerVolFracWat(nSnow+1:nLayers) = mLayerVolFracLiq(nSnow+1:nLayers) + mLayerVolFracIce(nSnow+1:nLayers) ! compute enthalpy of the top soil layer if changed with surface melt pond - if( (enthalpyStateVec .or. computeEnthalpy) .and. nSnow==0 .and. prog_data%var(iLookPROG%scalarSWE)%dat(1)>0._rkind )then + if( (enthalpyStateVec .or. computeEnthalpy) .and. nSnow==0 .and. prog_data%var(iLookPROG%scalarSWE)%dat(1)>0._rkind .and. nSoil>0)then call T2enthTemp_soil(& use_lookup, & ! intent(in): flag to use the lookup table for soil enthalpy soil_dens_intr, & ! intent(in): intrinsic soil density (kg m-3) @@ -949,7 +961,7 @@ subroutine coupled_em(& sumSnowSublimation = 0._rkind sumLatHeatCanopyEvap = 0._rkind sumSenHeatCanopy = 0._rkind - ! initialize fluxes to average over whole_step (averaged over substep in varSubStep) + ! initialize fluxes to average over whole_step (averaged over substep in varSubstep) do iVar=1,size(averageFlux_meta) flux_inner%var(iVar)%dat(:) = 0._rkind end do @@ -1114,7 +1126,7 @@ subroutine coupled_em(& ! * compute change in ice content of the top snow layer due to sublimation ! and account for compaction and cavitation in the snowpack... ! ------------------------------------------------------------------------ - call computSnowDepth(& + call snowDepth(& whole_step, & ! intent(in) nSnow, & ! intent(in) sumSnowSublimation/whole_step, & ! intent(in) @@ -1166,7 +1178,7 @@ subroutine coupled_em(& if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; end if ! recompute snow depth, SWE, and layer water - if(nSnow > 0)then + if(nSnow>0)then prog_data%var(iLookPROG%scalarSnowDepth)%dat(1) = sum( mLayerDepth(1:nSnow) ) prog_data%var(iLookPROG%scalarSWE)%dat(1) = sum( (mLayerVolFracLiq(1:nSnow)*iden_water & + mLayerVolFracIce(1:nSnow)*iden_ice) * mLayerDepth(1:nSnow) ) @@ -1305,7 +1317,7 @@ subroutine coupled_em(& call newsnwfall(& ! input: model control data_step, & ! time step (seconds) - (nSnow > 0), & ! logical flag if snow layers exist + (nSnow>0), & ! logical flag if snow layers exist snowfrz_scale, & ! freeezing curve parameter for snow (K-1) ! input: diagnostic scalar variables diag_data%var(iLookDIAG%scalarSnowfallTemp)%dat(1), & ! computed temperature of fresh snow (K) @@ -1324,7 +1336,7 @@ subroutine coupled_em(& if(err/=0)then; err=30; message=trim(message)//trim(cmessage); return; end if ! recompute snow depth, SWE, and top layer water - if(nSnow > 0)then + 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) & @@ -1344,7 +1356,7 @@ subroutine coupled_em(& ! 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 + nLayers = nSnow + nSoil ! update coordinate variables call calcHeight(& @@ -1415,6 +1427,8 @@ subroutine coupled_em(& scalarTotalSnowEnthalpy => diag_data%var(iLookDIAG%scalarTotalSnowEnthalpy)%dat(1) ,& ! total enthalpy of the snow column (J m-3) ! state variables in the aquifer scalarAquiferStorage => prog_data%var(iLookPROG%scalarAquiferStorage)%dat(1) ,& ! aquifer storage (m) + ! mass change of the system + scalarTotalMassChange => diag_data%var(iLookDIAG%scalarTotalMassChange)%dat(1) ,& ! mass change of system (kg m-2 s-1) ! error tolerance absConvTol_liquid => mpar_data%var(iLookPARAM%absConvTol_liquid)%dat(1) & ! absolute convergence tolerance for vol frac liq water (-) ) ! (association of local variables with information in the data structures @@ -1448,12 +1462,10 @@ subroutine coupled_em(& ! ----- ! * balance checks for the canopy... ! ---------------------------------- - - ! if computing the vegetation flux if(computeVegFlux)then - ! balance checks for the canopy ! NOTE: need to put the balance checks in the sub-step loop so that we can recompute if necessary - scalarCanopyWatBalError = scalarCanopyWat - (balanceCanopyWater0 + (scalarSnowfall - averageThroughfallSnow)*data_step + (scalarRainfall - averageThroughfallRain)*data_step & + delCanWat = scalarCanopyWat - balanceCanopyWater0 + scalarCanopyWatBalError = delCanWat - ( (scalarSnowfall - averageThroughfallSnow)*data_step + (scalarRainfall - averageThroughfallRain)*data_step & - averageCanopySnowUnloading*data_step - averageCanopyLiqDrainage*data_step + averageCanopySublimation*data_step + averageCanopyEvaporation*data_step) if(abs(scalarCanopyWatBalError) > absConvTol_liquid*iden_water*10._rkind .and. checkMassBalance_ds)then write(*,'(a,1x,f20.10)') 'data_step = ', data_step @@ -1471,19 +1483,23 @@ subroutine coupled_em(& message=trim(message)//'canopy hydrology does not balance' err=20; return end if + else + delCanWat = 0._rkind + scalarCanopyWatBalError = 0._rkind endif ! if computing the vegetation flux ! ----- ! * balance checks for SWE... ! --------------------------- - ! check the individual layers - if(printBalance .and. nSnow>0)then - write(*,'(a,1x,10(f12.8,1x))') 'liqSnowInit = ', liqSnowInit - write(*,'(a,1x,10(f12.8,1x))') 'volFracLiq = ', mLayerVolFracLiq(1:nSnow) - write(*,'(a,1x,10(f12.8,1x))') 'iLayerLiqFluxSnow = ', flux_data%var(iLookFLUX%iLayerLiqFluxSnow)%dat*iden_water*data_step - write(*,'(a,1x,10(f12.8,1x))') 'mLayerLiqFluxSnow = ', flux_data%var(iLookFLUX%mLayerLiqFluxSnow)%dat*data_step - write(*,'(a,1x,10(f12.8,1x))') 'change volFracLiq = ', mLayerVolFracLiq(1:nSnow) - liqSnowInit + if(printBalance)then + if(nSnow>0)then + write(*,'(a,1x,10(f12.8,1x))') 'liqSnowInit = ', liqSnowInit + write(*,'(a,1x,10(f12.8,1x))') 'volFracLiq = ', mLayerVolFracLiq(1:nSnow) + write(*,'(a,1x,10(f12.8,1x))') 'iLayerLiqFluxSnow = ', flux_data%var(iLookFLUX%iLayerLiqFluxSnow)%dat*iden_water*data_step + write(*,'(a,1x,10(f12.8,1x))') 'mLayerLiqFluxSnow = ', flux_data%var(iLookFLUX%mLayerLiqFluxSnow)%dat*iden_water*data_step + write(*,'(a,1x,10(f12.8,1x))') 'change volFracLiq = ', mLayerVolFracLiq(1:nSnow) - liqSnowInit + endif deallocate(liqSnowInit, stat=err) if(err/=0)then message=trim(message)//'unable to deallocate space for the initial volumetric liquid water content of snow' @@ -1513,36 +1529,22 @@ subroutine coupled_em(& message=trim(message)//'SWE does not balance' err=20; return endif ! if failed mass balance check + else + delSWE = 0._rkind endif ! if snow layers exist ! ----- ! * balance checks for soil... ! ---------------------------- - - ! compute the liquid water and ice content at the end of the time step - scalarTotalSoilLiq = sum(iden_water*mLayerVolFracLiq(nSnow+1:nLayers)*mLayerDepth(nSnow+1:nLayers)) - scalarTotalSoilIce = sum(iden_water*mLayerVolFracIce(nSnow+1:nLayers)*mLayerDepth(nSnow+1:nLayers)) ! NOTE: no expansion of soil, hence use iden_water - - ! get the total water in the soil (liquid plus ice) at the end of the time step (kg m-2) - scalarTotalSoilWat = scalarTotalSoilLiq + scalarTotalSoilIce - - ! get the total aquifer storage at the start of the time step (kg m-2) - balanceAquifer1 = scalarAquiferStorage*iden_water - - ! get the input and output to/from the soil zone (kg m-2) - balanceSoilInflux = averageSoilInflux*iden_water*data_step - balanceSoilBaseflow = averageSoilBaseflow*iden_water*data_step - balanceSoilDrainage = averageSoilDrainage*iden_water*data_step - balanceSoilET = (averageCanopyTranspiration + averageGroundEvaporation)*data_step - balanceSoilCompress = averageSoilCompress*data_step - ! check the individual layers if(printBalance)then - write(*,'(a,1x,10(f12.8,1x))') 'liqSoilInit = ', liqSoilInit - write(*,'(a,1x,10(f12.8,1x))') 'volFracLiq = ', mLayerVolFracLiq(nSnow+1:nLayers) - write(*,'(a,1x,10(f12.8,1x))') 'iLayerLiqFluxSoil = ', flux_data%var(iLookFLUX%iLayerLiqFluxSoil)%dat*iden_water*data_step - write(*,'(a,1x,10(f12.8,1x))') 'mLayerLiqFluxSoil = ', flux_data%var(iLookFLUX%mLayerLiqFluxSoil)%dat*data_step - write(*,'(a,1x,10(f12.8,1x))') 'change volFracLiq = ', mLayerVolFracLiq(nSnow+1:nLayers) - liqSoilInit + if(nSoil>0)then + write(*,'(a,1x,10(f12.8,1x))') 'liqSoilInit = ', liqSoilInit + write(*,'(a,1x,10(f12.8,1x))') 'volFracLiq = ', mLayerVolFracLiq(nSnow+1:nLayers) + write(*,'(a,1x,10(f12.8,1x))') 'iLayerLiqFluxSoil = ', flux_data%var(iLookFLUX%iLayerLiqFluxSoil)%dat*iden_water*data_step + write(*,'(a,1x,10(f12.8,1x))') 'mLayerLiqFluxSoil = ', flux_data%var(iLookFLUX%mLayerLiqFluxSoil)%dat*iden_water*data_step + write(*,'(a,1x,10(f12.8,1x))') 'change volFracLiq = ', mLayerVolFracLiq(nSnow+1:nLayers) - liqSoilInit + endif deallocate(liqSoilInit, stat=err) if(err/=0)then message=trim(message)//'unable to deallocate space for the initial soil moisture' @@ -1550,24 +1552,58 @@ subroutine coupled_em(& endif endif - ! check the soil water balance - scalarSoilWatBalError = scalarTotalSoilWat - (balanceSoilWater0 + (balanceSoilInflux + balanceSoilET - balanceSoilBaseflow - balanceSoilDrainage - balanceSoilCompress) ) - if(abs(scalarSoilWatBalError) > absConvTol_liquid*iden_water*10._rkind .and. checkMassBalance_ds)then ! NOTE: kg m-2, so need coarse tolerance to account for precision issues - write(*,*) 'solution method = ', ixSolution - write(*,'(a,1x,f20.10)') 'data_step = ', data_step - write(*,'(a,1x,f20.10)') 'balanceSoilCompress = ', balanceSoilCompress - write(*,'(a,1x,f20.10)') 'scalarTotalSoilLiq = ', scalarTotalSoilLiq - write(*,'(a,1x,f20.10)') 'scalarTotalSoilIce = ', scalarTotalSoilIce - write(*,'(a,1x,f20.10)') 'balanceSoilWater0 = ', balanceSoilWater0 - write(*,'(a,1x,f20.10)') 'balanceSoilWater1 = ', scalarTotalSoilWat - write(*,'(a,1x,f20.10)') 'balanceSoilInflux = ', balanceSoilInflux - write(*,'(a,1x,f20.10)') 'balanceSoilBaseflow = ', balanceSoilBaseflow - write(*,'(a,1x,f20.10)') 'balanceSoilDrainage = ', balanceSoilDrainage - write(*,'(a,1x,f20.10)') 'balanceSoilET = ', balanceSoilET - write(*,'(a,1x,f20.10)') 'scalarSoilWatBalError = ', scalarSoilWatBalError - message=trim(message)//'soil hydrology does not balance' - err=20; return - end if + ! check soil water balance + if(nSoil>0)then + ! compute the liquid water and ice content at the end of the time step + scalarTotalSoilLiq = sum(iden_water*mLayerVolFracLiq(nSnow+1:nLayers)*mLayerDepth(nSnow+1:nLayers)) + scalarTotalSoilIce = sum(iden_water*mLayerVolFracIce(nSnow+1:nLayers)*mLayerDepth(nSnow+1:nLayers)) ! NOTE: no expansion of soil, hence use iden_water + + ! get the total water in the soil (liquid plus ice) at the end of the time step (kg m-2) + scalarTotalSoilWat = scalarTotalSoilLiq + scalarTotalSoilIce + + ! get the input and output to/from the soil zone (kg m-2) + balanceSoilInflux = averageSoilInflux*iden_water*data_step + balanceSoilBaseflow = averageSoilBaseflow*iden_water*data_step + balanceSoilDrainage = averageSoilDrainage*iden_water*data_step + balanceSoilET = (averageCanopyTranspiration + averageGroundEvaporation)*data_step + balanceSoilCompress = averageSoilCompress*data_step + + ! check the soil water balance + scalarSoilWatBalError = scalarTotalSoilWat - (balanceSoilWater0 + (balanceSoilInflux + balanceSoilET - balanceSoilBaseflow - balanceSoilDrainage - balanceSoilCompress) ) + if(abs(scalarSoilWatBalError) > absConvTol_liquid*iden_water*10._rkind .and. checkMassBalance_ds)then ! NOTE: kg m-2, so need coarse tolerance to account for precision issues + write(*,*) 'solution method = ', ixSolution + write(*,'(a,1x,f20.10)') 'data_step = ', data_step + write(*,'(a,1x,f20.10)') 'balanceSoilCompress = ', balanceSoilCompress + write(*,'(a,1x,f20.10)') 'scalarTotalSoilLiq = ', scalarTotalSoilLiq + write(*,'(a,1x,f20.10)') 'scalarTotalSoilIce = ', scalarTotalSoilIce + write(*,'(a,1x,f20.10)') 'balanceSoilWater0 = ', balanceSoilWater0 + write(*,'(a,1x,f20.10)') 'balanceSoilWater1 = ', scalarTotalSoilWat + write(*,'(a,1x,f20.10)') 'balanceSoilInflux = ', balanceSoilInflux + write(*,'(a,1x,f20.10)') 'balanceSoilBaseflow = ', balanceSoilBaseflow + write(*,'(a,1x,f20.10)') 'balanceSoilDrainage = ', balanceSoilDrainage + write(*,'(a,1x,f20.10)') 'balanceSoilET = ', balanceSoilET + write(*,'(a,1x,f20.10)') 'scalarSoilWatBalError = ', scalarSoilWatBalError + message=trim(message)//'soil hydrology does not balance' + err=20; return + end if + else + scalarTotalSoilLiq = 0._rkind + scalarTotalSoilIce = 0._rkind + scalarTotalSoilWat = 0._rkind + scalarSoilWatBalError = 0._rkind + endif ! if soil layers exist + + ! ----- + ! * balance checks for the aquifer... + ! ------------------------------------ + ! Currently no balance checks for the aquifer + ! get the total aquifer storage at the end of the time step (kg m-2) + balanceAquifer1 = scalarAquiferStorage*iden_water + + ! ----- + ! sum of water changes in all of the domains to get the total water change rate + ! ------------------------------------------------------- + scalarTotalMassChange = ((scalarTotalSoilWat - balanceSoilWater0) + delSWE + delCanWat + (balanceAquifer1-balanceAquifer0))/data_step ! ----- ! save the enthalpy or temperature component of enthalpy, and total enthalpy @@ -1614,10 +1650,11 @@ subroutine coupled_em(& err,cmessage) ! intent(out): error control if(err/=0)then; message=trim(message)//trim(cmessage); return; endif endif - ! save the total soil enthalpy - scalarTotalSoilEnthalpy = sum(mLayerEnthalpy(nSnow+1:nLayers) * mLayerDepth(nSnow+1:nLayers))/sum(mLayerDepth(nSnow+1:nLayers)) - ! save the total snow enthalpy + scalarTotalSnowEnthalpy = realMissing + scalarTotalSoilEnthalpy = realMissing + ! save the total enthalpies if(nSnow>0) scalarTotalSnowEnthalpy = sum(mLayerEnthalpy(1:nSnow) * mLayerDepth(1:nSnow))/sum(mLayerDepth(1:nSnow)) + if(nSoil>0) scalarTotalSoilEnthalpy = sum(mLayerEnthalpy(nSnow+1:nLayers) * mLayerDepth(nSnow+1:nLayers))/sum(mLayerDepth(nSnow+1:nLayers)) ! save the surface temperature (just to make things easier to visualize) prog_data%var(iLookPROG%scalarSurfaceTemp)%dat(1) = prog_data%var(iLookPROG%mLayerTemp)%dat(1) @@ -1682,7 +1719,7 @@ subroutine initialize_coupled_em ! initialize surface melt pond sfcMeltPond = 0._rkind ! change in storage associated with the surface melt pond (kg m-2) - ! initialize average over data_step (averaged over substep in varSubStep) + ! initialize average over data_step (averaged over substep in varSubstep) meanCanopySublimation = 0._rkind ! mean canopy sublimation meanLatHeatCanopyEvap = 0._rkind ! mean latent heat flux for evaporation from the canopy meanSenHeatCanopy = 0._rkind ! mean sensible heat flux from the canopy diff --git a/build/source/engine/derivforce.f90 b/build/source/engine/derivforce.f90 index 4f60278be..fe29b7704 100644 --- a/build/source/engine/derivforce.f90 +++ b/build/source/engine/derivforce.f90 @@ -21,7 +21,7 @@ module derivforce_module ! data types -USE nrtype +USE nr_type USE data_types,only:var_dlength ! data structure: x%var(:)%dat (rkind) ! model constants @@ -65,12 +65,12 @@ module derivforce_module ! public subroutine derivforce: compute derived forcing data ! ************************************************************************************************ subroutine derivforce(time_data,forc_data,attr_data,mpar_data,prog_data,diag_data,flux_data,tmZoneOffsetFracDay,err,message) - USE sunGeomtry_module,only:clrsky_rad ! compute cosine of the solar zenith angle - USE conv_funcs_module,only:vapPress ! compute vapor pressure of air (Pa) - USE conv_funcs_module,only:SPHM2RELHM,RELHM2SPHM,WETBULBTMP ! conversion functions - USE snow_utils_module,only:fracliquid,templiquid ! functions to compute temperature/liquid water - USE time_utils_module,only:compcalday ! convert julian day to calendar date - USE summaFileManager,only: NC_TIME_ZONE ! time zone option from control file + USE sunGeomtry_module,only:clrsky_rad ! compute cosine of the solar zenith angle + USE convert_funcs_module,only:vapPress ! compute vapor pressure of air (Pa) + USE convert_funcs_module,only:SPHM2RELHM,RELHM2SPHM,WETBULBTMP ! conversion functions + USE snow_utils_module,only:fracliquid,templiquid ! functions to compute temperature/liquid water + USE time_utils_module,only:compcalday ! convert julian day to calendar date + USE summaFileManager,only: NC_TIME_ZONE ! time zone option from control file ! compute derived forcing data variables implicit none ! input variables diff --git a/build/source/engine/diagn_evar.f90 b/build/source/engine/diagn_evar.f90 deleted file mode 100644 index 6b4e780c2..000000000 --- a/build/source/engine/diagn_evar.f90 +++ /dev/null @@ -1,324 +0,0 @@ -! SUMMA - Structure for Unifying Multiple Modeling Alternatives -! Copyright (C) 2014-2020 NCAR/RAL; University of Saskatchewan; University of Washington -! -! This file is part of SUMMA -! -! For more information see: http://www.ral.ucar.edu/projects/summa -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see . - -module diagn_evar_module - -! data types -USE nrtype -USE globalData,only:realMissing ! missing real number - -! derived types to define the data structures -USE data_types,only:& - var_d, & ! data vector (rkind) - var_ilength, & ! data vector with variable length dimension (i4b) - var_dlength ! data vector with variable length dimension (rkind) - -! named variables defining elements in the data structures -USE var_lookup,only:iLookPARAM,iLookPROG,iLookDIAG,iLookINDEX ! named variables for structure elements -USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure - -! physical constants -USE multiconst,only:& - 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) - ! specific heat - 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) - ! thermal conductivity - lambda_air, & ! thermal conductivity of air (J s-1 m-1) - lambda_ice, & ! thermal conductivity of ice (J s-1 m-1) - lambda_water ! thermal conductivity of water (J s-1 m-1) - -! missing values -USE globalData,only:integerMissing ! missing integer -USE globalData,only:realMissing ! missing real number - -! named variables that define the layer type -USE globalData,only:iname_snow ! snow -USE globalData,only:iname_soil ! soil - -! provide access to named variables for thermal conductivity of soil -USE globalData,only:model_decisions ! model decision structure - -! decisions for thermal conductivity of soil -USE mDecisions_module,only:Smirnova2000 ! option for temporally constant thermal conductivity - -! decisions for thermal conductivity of soil -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 - -! privacy -implicit none -private -public::diagn_evar -contains - - - ! ********************************************************************************************************** - ! public subroutine diagn_evar: compute diagnostic energy variables (thermal conductivity and heat capacity) - ! ********************************************************************************************************** - subroutine diagn_evar(& - ! input: control variables - computeVegFlux, & ! intent(in): flag to denote if computing the vegetation flux - canopyDepth, & ! intent(in): canopy depth (m) - ! input/output: data structures - mpar_data, & ! intent(in): model parameters - indx_data, & ! intent(in): model layer indices - prog_data, & ! intent(in): model prognostic variables for a local HRU - diag_data, & ! intent(inout): model diagnostic variables for a local HRU - ! output: error control - err,message) ! intent(out): error control - ! -------------------------------------------------------------------------------------------------------------------------------------- - ! provide access to external subroutines - USE snow_utils_module,only:tcond_snow ! compute thermal conductivity of snow - ! -------------------------------------------------------------------------------------------------------------------------------------- - ! input: model control - logical(lgt),intent(in) :: computeVegFlux ! logical flag to denote if computing the vegetation flux - real(rkind),intent(in) :: canopyDepth ! depth of the vegetation canopy (m) - ! input/output: data structures - type(var_dlength),intent(in) :: mpar_data ! model parameters - type(var_ilength),intent(in) :: indx_data ! model layer indices - type(var_dlength),intent(in) :: prog_data ! model prognostic variables for a local HRU - type(var_dlength),intent(inout) :: diag_data ! model diagnostic variables for a local HRU - ! output: error control - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message - ! -------------------------------------------------------------------------------------------------------------------------------- - ! local variables - character(LEN=256) :: cmessage ! error message of downwind routine - integer(i4b) :: iLayer ! index of model layer - integer(i4b) :: iSoil ! index of soil layer - real(rkind) :: TCn ! thermal conductivity below the layer interface (W m-1 K-1) - real(rkind) :: TCp ! thermal conductivity above the layer interface (W m-1 K-1) - real(rkind) :: zdn ! height difference between interface and lower value (m) - real(rkind) :: zdp ! height difference between interface and upper value (m) - real(rkind) :: bulkden_soil ! bulk density of soil (kg m-3) - real(rkind) :: lambda_drysoil ! thermal conductivity of dry soil (W m-1) - real(rkind) :: lambda_wetsoil ! thermal conductivity of wet soil (W m-1) - real(rkind) :: lambda_wet ! thermal conductivity of the wet material - real(rkind) :: relativeSat ! relative saturation (-) - real(rkind) :: kerstenNum ! the Kersten number (-), defining weight applied to conductivity of the wet medium - real(rkind) :: den ! denominator in the thermal conductivity calculations - ! local variables to reproduce the thermal conductivity of Hansson et al. VZJ 2005 - real(rkind),parameter :: c1=0.55_rkind ! optimized parameter from Hansson et al. VZJ 2005 (W m-1 K-1) - real(rkind),parameter :: c2=0.8_rkind ! optimized parameter from Hansson et al. VZJ 2005 (W m-1 K-1) - real(rkind),parameter :: c3=3.07_rkind ! optimized parameter from Hansson et al. VZJ 2005 (-) - real(rkind),parameter :: c4=0.13_rkind ! optimized parameter from Hansson et al. VZJ 2005 (W m-1 K-1) - real(rkind),parameter :: c5=4._rkind ! optimized parameter from Hansson et al. VZJ 2005 (-) - real(rkind),parameter :: f1=13.05_rkind ! optimized parameter from Hansson et al. VZJ 2005 (-) - real(rkind),parameter :: f2=1.06_rkind ! optimized parameter from Hansson et al. VZJ 2005 (-) - real(rkind) :: fArg,xArg ! temporary variables (see Hansson et al. VZJ 2005 for details) - ! -------------------------------------------------------------------------------------------------------------------------------- - ! 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 => 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 - 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)%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 => 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 - scalarBulkVolHeatCapVeg = specificHeatVeg*maxMassVegetation/canopyDepth + & ! vegetation component - Cp_water*scalarCanopyLiquid/canopyDepth + & ! liquid water component - Cp_ice*scalarCanopyIce/canopyDepth ! ice component - else - scalarBulkVolHeatCapVeg = realMissing - end if - - - ! loop through layers - do iLayer=1,nLayers - - ! get the soil layer - if(iLayer>nSnow) iSoil = iLayer-nSnow - - ! compute the thermal conductivity of dry and wet soils (W m-1) - ! NOTE: this is actually constant over the simulation, and included here for clarity - if(ixThCondSoil == funcSoilWet .and. layerType(iLayer)==iname_soil)then - bulkden_soil = iden_soil(iSoil)*( 1._rkind - theta_sat(iSoil) ) - lambda_drysoil = (0.135_rkind*bulkden_soil + 64.7_rkind) / (iden_soil(iSoil) - 0.947_rkind*bulkden_soil) - lambda_wetsoil = (8.80_rkind*frac_sand(iSoil) + 2.92_rkind*frac_clay(iSoil)) / (frac_sand(iSoil) + frac_clay(iSoil)) - end if - - ! ***** - ! * compute the volumetric fraction of air in each layer... - ! ********************************************************* - select case(layerType(iLayer)) - case(iname_soil); mLayerVolFracAir(iLayer) = theta_sat(iSoil) - (mLayerVolFracIce(iLayer) + mLayerVolFracLiq(iLayer)) - case(iname_snow); mLayerVolFracAir(iLayer) = 1._rkind - (mLayerVolFracIce(iLayer) + mLayerVolFracLiq(iLayer)) - case default; err=20; message=trim(message)//'unable to identify type of layer (snow or soil) to compute volumetric fraction of air'; return - end select - - ! ***** - ! * compute the volumetric heat capacity of each layer (J m-3 K-1)... - ! ******************************************************************* - select case(layerType(iLayer)) - ! * soil - case(iname_soil) - mLayerVolHtCapBulk(iLayer) = iden_soil(iSoil) * Cp_soil * ( 1._rkind - theta_sat(iSoil) ) + & ! soil component - iden_ice * Cp_ice * mLayerVolFracIce(iLayer) + & ! ice component - iden_water * Cp_water * mLayerVolFracLiq(iLayer) + & ! liquid water component - iden_air * Cp_air * mLayerVolFracAir(iLayer) ! air component - ! * snow - 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 volumetric heat capacity'; return - end select - - ! ***** - ! * compute the thermal conductivity of snow and soil at the mid-point of each layer... - ! ************************************************************************************* - select case(layerType(iLayer)) - - ! ***** soil - case(iname_soil) - - ! select option for thermal conductivity of soil - select case(ixThCondSoil) - - ! ** function of soil wetness - case(funcSoilWet) - - ! compute the thermal conductivity of the wet material (W m-1) - lambda_wet = lambda_wetsoil**( 1._rkind - theta_sat(iSoil) ) * lambda_water**theta_sat(iSoil) * lambda_ice**(theta_sat(iSoil) - mLayerVolFracLiq(iLayer)) - relativeSat = (mLayerVolFracIce(iLayer) + mLayerVolFracLiq(iLayer))/theta_sat(iSoil) ! relative saturation - ! compute the Kersten number (-) - if(relativeSat > 0.1_rkind)then ! log10(0.1) = -1 - kerstenNum = log10(relativeSat) + 1._rkind - else - kerstenNum = 0._rkind ! dry thermal conductivity - endif - ! ...and, compute the thermal conductivity - mLayerThermalC(iLayer) = kerstenNum*lambda_wet + (1._rkind - kerstenNum)*lambda_drysoil - - ! ** mixture of constituents - case(mixConstit) - mLayerThermalC(iLayer) = thCond_soil(iSoil) * ( 1._rkind - theta_sat(iSoil) ) + & ! soil component - lambda_ice * mLayerVolFracIce(iLayer) + & ! ice component - lambda_water * mLayerVolFracLiq(iLayer) + & ! liquid water component - lambda_air * mLayerVolFracAir(iLayer) ! air component - - ! ** test case for the mizoguchi lab experiment, Hansson et al. VZJ 2004 - case(hanssonVZJ) - fArg = 1._rkind + f1*mLayerVolFracIce(iLayer)**f2 - xArg = mLayerVolFracLiq(iLayer) + fArg*mLayerVolFracIce(iLayer) - mLayerThermalC(iLayer) = c1 + c2*xArg + (c1 - c4)*exp(-(c3*xArg)**c5) - - ! ** check - case default; err=20; message=trim(message)//'unable to identify option for thermal conductivity of soil'; return - - end select ! option for the thermal conductivity of soil - - ! ***** snow - case(iname_snow) - ! 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 - - end do ! looping through layers - - ! ***** - ! * compute the thermal conductivity of snow at the interface of each layer... - ! **************************************************************************** - do iLayer=1,nLayers-1 ! (loop through layers) - ! get temporary variables - TCn = mLayerThermalC(iLayer) ! thermal conductivity below the layer interface (W m-1 K-1) - TCp = mLayerThermalC(iLayer+1) ! thermal conductivity above the layer interface (W m-1 K-1) - zdn = iLayerHeight(iLayer) - mLayerHeight(iLayer) ! height difference between interface and lower value (m) - zdp = mLayerHeight(iLayer+1) - iLayerHeight(iLayer) ! height difference between interface and upper value (m) - den = TCn*zdp + TCp*zdn ! denominator - ! compute thermal conductivity - if(TCn+TCp > epsilon(TCn))then - iLayerThermalC(iLayer) = (TCn*TCp*(zdn + zdp)) / den - else - iLayerThermalC(iLayer) = (TCn*zdn + TCp*zdp) / (zdn + zdp) - endif - end do ! looping through layers - - ! special case of hansson - if(ixThCondSoil==hanssonVZJ)then - iLayerThermalC(0) = 28._rkind*(0.5_rkind*(iLayerHeight(1) - iLayerHeight(0))) - else - iLayerThermalC(0) = mLayerThermalC(1) - end if - - ! assume the thermal conductivity at the domain boundaries is equal to the thermal conductivity of the layer - iLayerThermalC(nLayers) = mLayerThermalC(nLayers) - - ! end association to variables in the data structure - end associate - - end subroutine diagn_evar - - -end module diagn_evar_module diff --git a/build/source/engine/eval8summa.f90 b/build/source/engine/eval8summa.f90 index 5d120fbdc..147f9816c 100644 --- a/build/source/engine/eval8summa.f90 +++ b/build/source/engine/eval8summa.f90 @@ -21,7 +21,7 @@ module eval8summa_module ! data types -USE nrtype +USE nr_type ! access missing values USE globalData,only:integerMissing ! missing integer @@ -63,8 +63,8 @@ module eval8summa_module ! look-up values for the choice of variable in energy equations (BE residual or IDA state variable) USE mDecisions_module,only: & closedForm, & ! use temperature with closed form heat capacity - enthalpyFormLU, & ! use enthalpy with soil temperature-enthalpy lookup tables - enthalpyForm ! use enthalpy with soil temperature-enthalpy analytical solution + enthalpyForm, & ! use enthalpy with soil temperature-enthalpy lookup tables + enthalpyFormAN ! use enthalpy with soil temperature-enthalpy analytical solution ! look-up values for the numerical method USE mDecisions_module,only: & @@ -130,16 +130,16 @@ subroutine eval8summa(& err,message) ! intent(out): error control ! -------------------------------------------------------------------------------------------------------------------------------- ! provide access to subroutines - USE getVectorz_module, only:varExtract ! extract variables from the state vector - USE getVectorz_module, only:checkFeas ! check feasibility of state vector - USE 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 computHeatCap_module,only:computHeatCapAnalytic ! recompute closed form heat capacity (Cp) and derivatives - USE computHeatCap_module,only:computCm ! compute Cm and derivatives - USE computHeatCap_module, only:computStatMult ! recompute state multiplier - USE computResid_module,only:computResid ! compute residuals given a state vector - USE computThermConduct_module,only:computThermConduct ! recompute thermal conductivity and derivatives + USE getVectorz_module,only:varExtract ! extract variables from the state vector + USE getVectorz_module,only:checkFeas ! check feasibility of state vector + USE updatDiagn_module,only:updatDiagn ! update diagnostic variables + USE computFlux_module,only:soilCmpres ! compute soil compression + USE computFlux_module,only:computFlux ! compute fluxes given a state vector + USE heat_Cp_Cm_module,only:heatCapacity ! update heat capacity (Cp) and derivatives + USE heat_Cp_Cm_module,only:heatAdvectWat ! compute heat advected with water (Cm) and derivatives + USE heat_Cp_Cm_module,only:stateMultiplier ! update state multiplier + USE computResid_module,only:computResid ! compute residuals given a state vector + USE thermConductivity_module,only:thermConductivity ! update thermal conductivity and derivatives implicit none ! -------------------------------------------------------------------------------------------------------------------------------- ! -------------------------------------------------------------------------------------------------------------------------------- @@ -209,8 +209,8 @@ subroutine eval8summa(& real(rkind),dimension(nLayers) :: mLayerEnthTempTrial ! trial vector of temperature component of enthalpy for snow+soil layers (J m-3) ! other local variables logical(lgt) :: checkLWBalance ! flag to check longwave balance - integer(i4b) :: jState(1) ! index of model state for the scalar solution within the soil domain - integer(i4b) :: ixBeg,ixEnd ! index of indices for the soil compression routine + integer(i4b) :: ixLayerDesired(1) ! layer desired (scalar solution) + integer(i4b) :: ixTop,ixBot ! top and bottom defining desired layers real(rkind),dimension(nState) :: rVecScaled ! scaled residual vector character(LEN=256) :: cmessage ! error message of downwind routine logical(lgt) :: updateStateCp ! flag to indicate if we update Cp at each step for LHS, set with nrgConserv choice and updateCp_closedForm flag @@ -313,7 +313,7 @@ subroutine eval8summa(& end if end if ! ( feasibility check ) - if(ixNrgConserv == enthalpyForm .or. ixNrgConserv == enthalpyFormLU)then + if(ixNrgConserv == enthalpyFormAN .or. ixNrgConserv == enthalpyForm)then ! use mixed form of energy equation, need these true to use for Jacobian updateStateCp = .true. updateFluxCp = .true. @@ -327,16 +327,6 @@ subroutine eval8summa(& err=1; return end if - ! get the start and end indices for the soil compression calculations - if(scalarSolution)then - jState = pack(ixControlVolume, ixMapFull2Subset/=integerMissing) - ixBeg = jState(1) - ixEnd = jState(1) - else - ixBeg = 1 - ixEnd = nSoil - endif - ! initialize to state variable from the last update incase splitting is used scalarCanairTempTrial = scalarCanairTemp scalarCanopyTempTrial = scalarCanopyTemp @@ -377,10 +367,10 @@ subroutine eval8summa(& if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) ! update diagnostic variables and derivatives - call updateVars(& + call updatDiagn(& ! input ixNrgConserv.ne.closedForm, & ! intent(in): flag if computing temperature compoment of enthalpy - ixNrgConserv==enthalpyFormLU, & ! intent(in): flag to use the lookup table for soil temperature-enthalpy + ixNrgConserv==enthalpyForm, & ! intent(in): flag to use the lookup table for soil temperature-enthalpy .false., & ! intent(in): logical flag to adjust temperature to account for the energy used in melt+freeze mpar_data, & ! intent(in): model parameters for a local HRU indx_data, & ! intent(in): indices defining model states and layers @@ -410,8 +400,8 @@ subroutine eval8summa(& if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) if(updateStateCp)then - ! *** compute volumetric heat capacity C_p - call computHeatCapAnalytic(& + ! update heat capacity Cp and its derivatives + call heatCapacity(& ! input: state variables canopyDepth, & ! intent(in): canopy depth (m) scalarCanopyIceTrial, & ! intent(in): trial value for mass of ice on the vegetation canopy (kg m-2) @@ -442,8 +432,8 @@ subroutine eval8summa(& err,cmessage) ! intent(out): error control if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - ! compute multiplier of state vector - call computStatMult(& + ! recompute multiplier of state vector + call stateMultiplier(& ! input heatCapVegTrial, & ! intent(in): volumetric heat capacity of vegetation canopy mLayerHeatCapTrial, & ! intent(in): volumetric heat capacity of soil and snow @@ -452,8 +442,7 @@ subroutine eval8summa(& sMul, & ! intent(out): multiplier for state vector (used in the residual calculations) err,cmessage) ! intent(out): error control if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (check for errors) - else - ! set state heat capacity derivatives to 0 for constant through step + else ! set state heat capacity derivatives to 0 for constant through step dVolHtCapBulk_dPsi0 = 0._rkind dVolHtCapBulk_dTheta = 0._rkind dVolHtCapBulk_dCanWat = 0._rkind @@ -462,33 +451,32 @@ subroutine eval8summa(& endif ! updateStateCp if(updateFluxCp)then - ! update thermal conductivity - call computThermConduct(& - ! input: control variables - nLayers, & ! intent(in): total number of layers + ! update thermal conductivity and its derivatives + call thermConductivity(& ! input: state variables - mLayerTempTrial, & ! intent(in): trial temperature of layer temperature (K) - mLayerMatricHeadTrial, & ! intent(in): trial value for total water matric potential (m) + nLayers, & ! intent(in): total number of layers + scalarSolution, & ! intent(in): flag to indicate the scalar solution mLayerVolFracIceTrial, & ! intent(in): volumetric fraction of ice at the start of the sub-step (-) mLayerVolFracLiqTrial, & ! intent(in): volumetric fraction of liquid water at the start of the sub-step (-) - ! input: pre-computed derivatives - mLayerdTheta_dTk, & ! intent(in): derivative in volumetric liquid water content w.r.t. temperature (K-1) - mLayerFracLiqSnow, & ! intent(in): fraction of liquid water (-) ! input/output: data structures mpar_data, & ! intent(in): model parameters indx_data, & ! intent(in): model layer indices prog_data, & ! intent(in): model prognostic variables for a local HRU diag_data, & ! intent(inout): model diagnostic variables for a local HRU - ! output: derivatives - dThermalC_dWatAbove, & ! intent(out): derivative in the thermal conductivity w.r.t. water state in the layer above - dThermalC_dWatBelow, & ! intent(out): derivative in the thermal conductivity w.r.t. water state in the layer above - dThermalC_dTempAbove, & ! intent(out): derivative in the thermal conductivity w.r.t. energy state in the layer above - dThermalC_dTempBelow, & ! intent(out): derivative in the thermal conductivity w.r.t. energy state in the layer above + ! input: pre-computed derivatives + mLayerTempTrial, & ! intent(in): trial temperature of layer temperature (K) + mLayerMatricHeadTrial, & ! intent(in): trial value for total water matric potential (m) + mLayerdTheta_dTk, & ! intent(in): derivative in volumetric liquid water content w.r.t. temperature (K-1) + mLayerFracLiqSnow, & ! intent(in): fraction of liquid water (-) + ! input/output: derivatives + dThermalC_dWatAbove, & ! intent(inout): derivative in the thermal conductivity w.r.t. water state in the layer above + dThermalC_dWatBelow, & ! intent(inout): derivative in the thermal conductivity w.r.t. water state in the layer above + dThermalC_dTempAbove, & ! intent(inout): derivative in the thermal conductivity w.r.t. energy state in the layer above + dThermalC_dTempBelow, & ! intent(inout): derivative in the thermal conductivity w.r.t. energy state in the layer above ! output: error control - err,cmessage) ! intent(out): error control + err,cmessage) ! intent(out): error control if(err/=0)then; err=55; message=trim(message)//trim(cmessage); return; end if - else - ! set flux heat capacity derivatives to 0 for constant through step + else ! set flux heat capacity derivatives to 0 for constant through step dThermalC_dWatAbove = 0._rkind dThermalC_dWatBelow = 0._rkind dThermalC_dTempAbove = 0._rkind @@ -496,8 +484,8 @@ subroutine eval8summa(& endif ! updateFluxCp if(needStateCm)then - ! compute C_m - call computCm(& + ! compute heat advected with water Cm and its derivatives + call heatAdvectWat(& ! input: state variables scalarCanopyTempTrial, & ! intent(in): trial value of canopy temperature (K) mLayerTempTrial, & ! intent(in): trial value of layer temperature (K) @@ -512,7 +500,7 @@ subroutine eval8summa(& dCm_dTk, & ! intent(inout): derivative in Cm w.r.t. temperature (J kg K-2) dCm_dTkCanopy, & ! intent(inout): derivative in Cm w.r.t. temperature (J kg K-2) err,cmessage) ! intent(inout): error control - else + else ! set Cm and its derivatives to 0 for energy equation without Cm in LHS scalarCanopyCmTrial = 0._rkind mLayerCmTrial = 0._rkind dCm_dPsi0 = 0._rkind @@ -575,26 +563,36 @@ subroutine eval8summa(& ! compute soil compressibility (-) and its derivative w.r.t. matric head (m) ! NOTE: we already extracted trial matrix head and volumetric liquid water as part of the flux calculations - ! use non-prime version - call soilCmpres(& - ! input: - dt_cur, & ! intent(in): length of the time step (seconds) - ixRichards, & ! intent(in): choice of option for Richards' equation - ixBeg,ixEnd, & ! intent(in): start and end indices defining desired layers - mLayerMatricHead(1:nSoil), & ! intent(in): matric head at the start of the time step (m) - mLayerMatricHeadTrial(1:nSoil), & ! intent(in): trial value of matric head (m) - mLayerVolFracLiqTrial(nSnow+1:nLayers), & ! intent(in): trial value for the volumetric liquid water content in each soil layer (-) - mLayerVolFracIceTrial(nSnow+1:nLayers), & ! intent(in): trial value for the volumetric ice content in each soil layer (-) - specificStorage, & ! intent(in): specific storage coefficient (m-1) - theta_sat, & ! intent(in): soil porosity (-) - ! output: - mLayerCompress, & ! intent(inout): compressibility of the soil matrix (-) - dCompress_dPsi, & ! intent(inout): derivative in compressibility w.r.t. matric head (m-1) - err,cmessage) ! intent(out): error code and error message - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - - ! compute the total change in storage associated with compression of the soil matrix (kg m-2 s-1) - scalarSoilCompress = sum(mLayerCompress(1:nSoil)*mLayerDepth(nSnow+1:nLayers))*iden_water + if(nSoil>0)then + if(scalarSolution)then + ixLayerDesired = pack(ixControlVolume, ixMapFull2Subset/=integerMissing) + ixTop = ixLayerDesired(1) + ixBot = ixLayerDesired(1) + else + ixTop = 1 + ixBot = nSoil + endif + call soilCmpres(& + ! input: + dt_cur, & ! intent(in): length of the time step (seconds) + ixRichards, & ! intent(in): choice of option for Richards' equation + ixTop,ixBot, & ! intent(in): top and bottom defining desired layers + mLayerMatricHead(1:nSoil), & ! intent(in): matric head at the start of the time step (m) + mLayerMatricHeadTrial(1:nSoil), & ! intent(in): trial value of matric head (m) + mLayerVolFracLiqTrial(nSnow+1:nLayers), & ! intent(in): trial value for the volumetric liquid water content in each soil layer (-) + mLayerVolFracIceTrial(nSnow+1:nLayers), & ! intent(in): trial value for the volumetric ice content in each soil layer (-) + specificStorage, & ! intent(in): specific storage coefficient (m-1) + theta_sat, & ! intent(in): soil porosity (-) + ! output: + mLayerCompress, & ! intent(inout): compressibility of the soil matrix (-) + dCompress_dPsi, & ! intent(inout): derivative in compressibility w.r.t. matric head (m-1) + err,cmessage) ! intent(out): error code and error message + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) + ! compute the total change in storage associated with compression of the soil matrix (kg m-2 s-1) + scalarSoilCompress = sum(mLayerCompress(1:nSoil)*mLayerDepth(nSnow+1:nLayers))*iden_water + else + scalarSoilCompress = 0._qp + endif ! compute the residual vector call computResid(& @@ -882,6 +880,7 @@ subroutine imposeConstraints(model_decisions,indx_data, prog_data, mpar_data, st case default; err=20; message=trim(message)//'expect num_method to be ida, kinsol, or homegrown (or itertive, which is homegrown)'; return end select + ! shortcut variables vGn_m = 1._rkind - 1._rkind/vGn_n ! ** limit temperature increment to zMaxTempIncrement diff --git a/build/source/engine/eval8summaWithPrime.f90 b/build/source/engine/eval8summaWithPrime.f90 index fd95387ea..ee5e393f8 100644 --- a/build/source/engine/eval8summaWithPrime.f90 +++ b/build/source/engine/eval8summaWithPrime.f90 @@ -2,7 +2,7 @@ module eval8summaWithPrime_module ! data types -USE nrtype +USE nr_type ! access missing values USE globalData,only:integerMissing ! missing integer @@ -36,8 +36,8 @@ module eval8summaWithPrime_module ! look-up values for the choice of variable in energy equations (BE residual or IDA state variable) USE mDecisions_module,only: & closedForm, & ! use temperature with closed form heat capacity - enthalpyFormLU, & ! use enthalpy with soil temperature-enthalpy lookup tables - enthalpyForm ! use enthalpy with soil temperature-enthalpy analytical solution + enthalpyForm, & ! use enthalpy with soil temperature-enthalpy lookup tables + enthalpyFormAN ! use enthalpy with soil temperature-enthalpy analytical solution implicit none private @@ -104,16 +104,16 @@ subroutine eval8summaWithPrime(& err,message) ! intent(out): error control ! -------------------------------------------------------------------------------------------------------------------------------- ! provide access to subroutines - USE getVectorz_module, only:varExtract ! extract variables from the state vector - USE getVectorz_module, only:checkFeas ! check feasibility of state vector - USE updateVarsWithPrime_module, only:updateVarsWithPrime ! update variables - USE computFlux_module, only:soilCmpresPrime ! compute soil compression - USE computFlux_module, only:computFlux ! compute fluxes given a state vector - USE computHeatCap_module,only:computHeatCapAnalytic ! recompute closed form heat capacity (Cp) and derivatives - USE computHeatCap_module,only:computCm ! compute Cm and derivatives - USE computHeatCap_module, only:computStatMult ! recompute state multiplier + USE getVectorz_module,only:varExtract ! extract variables from the state vector + USE getVectorz_module,only:checkFeas ! check feasibility of state vector + USE updatDiagnWithPrime_module,only:updatDiagnWithPrime ! update variables + USE computFlux_module,only:soilCmpresPrime ! compute soil compression + USE computFlux_module,only:computFlux ! compute fluxes given a state vector + USE heat_Cp_Cm_module,only:heatCapacity ! update heat capacity (Cp) and derivatives + USE heat_Cp_Cm_module,only:heatAdvectWat ! compute heat advected with water (Cm) and derivatives + USE heat_Cp_Cm_module,only:stateMultiplier ! update state multiplier USE computResidWithPrime_module,only:computResidWithPrime ! compute residuals given a state vector - USE computThermConduct_module,only:computThermConduct ! recompute thermal conductivity and derivatives + USE thermConductivity_module,only:thermConductivity ! update thermal conductivity and derivatives implicit none ! -------------------------------------------------------------------------------------------------------------------------------- ! -------------------------------------------------------------------------------------------------------------------------------- @@ -204,8 +204,8 @@ subroutine eval8summaWithPrime(& real(rkind) :: scalarCanopyNrgPrime ! prime value for energy of the vegetation canopy real(rkind),dimension(nLayers) :: mLayerNrgPrime ! prime vector of energy of each snow and soil layer ! other local variables - integer(i4b) :: jState(1) ! index of model state for the scalar solution within the soil domain - integer(i4b) :: ixBeg,ixEnd ! index of indices for the soil compression routine + integer(i4b) :: ixLayerDesired(1) ! layer desired (scalar solution) + integer(i4b) :: ixTop,ixBot ! top and bottom defining desired layers character(LEN=256) :: cmessage ! error message of downwind routine logical(lgt) :: updateStateCp ! flag to indicate if we update Cp at each step for LHS, set with nrgConserv choice and updateCp_closedForm flag logical(lgt) :: updateFluxCp ! flag to indicate if we update Cp at each step for RHS, set with nrgConserv choice and updateCp_closedForm flag @@ -253,6 +253,10 @@ subroutine eval8summaWithPrime(& dCm_dTk => deriv_data%var(iLookDERIV%dCm_dTk)%dat ,& ! intent(out): [dp(:)] derivative in heat capacity w.r.t. temperature (J kg-1 K-2) dCm_dTkCanopy => deriv_data%var(iLookDERIV%dCm_dTkCanopy)%dat(1) ,& ! intent(out): [dp ] derivative in heat capacity w.r.t. canopy temperature (J kg-1 K-2) ! mapping + nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg)%dat(1), & ! intent(in): [i4b] number of energy state variables in the snow+soil domain + ixLayerState => indx_data%var(iLookINDEX%ixLayerState)%dat, & ! intent(in): list of indices for all model layers + ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat, & ! intent(in): index in the state subset for energy state variables in the snow+soil domain + ixMapFull2Subset => indx_data%var(iLookINDEX%ixMapFull2Subset)%dat ,& ! intent(in): [i4b(:)] mapping of full state vector to the state subset ixControlVolume => indx_data%var(iLookINDEX%ixControlVolume)%dat ,& ! intent(in): [i4b(:)] index of control volume for different domains (veg, snow, soil) ! heat capacity @@ -290,7 +294,7 @@ subroutine eval8summaWithPrime(& end if end if ! ( feasibility check ) - if(ixNrgConserv == enthalpyForm .or. ixNrgConserv == enthalpyFormLU)then ! use enthalpy as state variable, do not need state terms but do need flux term + if(ixNrgConserv == enthalpyFormAN .or. ixNrgConserv == enthalpyForm)then ! use enthalpy as state variable, do not need state terms but do need flux term updateStateCp = .false. updateFluxCp = .true. needStateCm = .false. @@ -303,18 +307,8 @@ subroutine eval8summaWithPrime(& err=1; return end if - ! get the start and end indices for the soil compression calculations - if(scalarSolution)then - jState = pack(ixControlVolume, ixMapFull2Subset/=integerMissing) - ixBeg = jState(1) - ixEnd = jState(1) - else - ixBeg = 1 - ixEnd = nSoil - endif - ! Canopy layer can disappear even without splitting (snow burial), so need to take last values - if(ixNrgConserv== enthalpyForm .or. ixNrgConserv == enthalpyFormLU)then ! use state variable as enthalpy, need to compute temperature + if(ixNrgConserv== enthalpyFormAN .or. ixNrgConserv == enthalpyForm)then ! use state variable as enthalpy, need to compute temperature scalarCanopyNrgTrial = scalarCanopyEnthalpyTrial else ! use state variable as temperature scalarCanopyNrgTrial = scalarCanopyTempTrial @@ -389,7 +383,7 @@ subroutine eval8summaWithPrime(& err,cmessage) ! intent(out): error control if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - if(ixNrgConserv== enthalpyForm .or. ixNrgConserv == enthalpyFormLU)then ! use state variable as enthalpy, need to compute temperature + if(ixNrgConserv== enthalpyFormAN .or. ixNrgConserv == enthalpyForm)then ! use state variable as enthalpy, need to compute temperature scalarCanairEnthalpyTrial = scalarCanairNrgTrial scalarCanopyEnthalpyTrial = scalarCanopyNrgTrial mLayerEnthalpyTrial = mLayerNrgTrial @@ -419,10 +413,10 @@ subroutine eval8summaWithPrime(& ! update diagnostic variables and derivatives ! NOTE: if we are using enthalpy as a state variable, currently all *TempPrime, *IcePrime, and *LiqPrime are set to realMissing ! This possibly could cause problems (?) if we use splitting, but we are not using splitting at the moment - call updateVarsWithPrime(& + call updatDiagnWithPrime(& ! input ixNrgConserv.ne.closedForm, & ! intent(in): flag if need to update temperature from enthalpy - ixNrgConserv==enthalpyFormLU, & ! intent(in): flag to use the lookup table for soil temperature-enthalpy + ixNrgConserv==enthalpyForm, & ! intent(in): flag to use the lookup table for soil temperature-enthalpy .true., & ! intent(in): flag if computing for Jacobian update .false., & ! intent(in): flag to adjust temperature to account for the energy mpar_data, & ! intent(in): model parameters for a local HRU @@ -463,8 +457,8 @@ subroutine eval8summaWithPrime(& if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) if(updateStateCp)then - ! *** compute volumetric heat capacity C_p - call computHeatCapAnalytic(& + ! update heat capacity Cp and its derivatives + call heatCapacity(& ! input: state variables canopyDepth, & ! intent(in): canopy depth (m) scalarCanopyIceTrial, & ! intent(in): trial value for mass of ice on the vegetation canopy (kg m-2) @@ -495,8 +489,8 @@ subroutine eval8summaWithPrime(& err,cmessage) ! intent(out): error control if(err/=0)then; message=trim(message)//trim(cmessage); return; endif - ! compute multiplier of state vector - call computStatMult(& + ! recompute multiplier of state vector + call stateMultiplier(& ! input heatCapVegTrial, & ! intent(in): volumetric heat capacity of vegetation canopy mLayerHeatCapTrial, & ! intent(in): volumetric heat capacity of soil and snow @@ -505,8 +499,7 @@ subroutine eval8summaWithPrime(& sMul, & ! intent(out): multiplier for state vector (used in the residual calculations) err,cmessage) ! intent(out): error control if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (check for errors) - else - ! set state heat capacity derivatives to 0 for constant through step + else ! set state heat capacity derivatives to 0 for constant through step dVolHtCapBulk_dPsi0 = 0._rkind dVolHtCapBulk_dTheta = 0._rkind dVolHtCapBulk_dCanWat = 0._rkind @@ -515,34 +508,32 @@ subroutine eval8summaWithPrime(& endif ! updateStateCp if(updateFluxCp)then - ! update thermal conductivity - call computThermConduct(& - ! input: control variables - nLayers, & ! intent(in): total number of layers + ! update thermal conductivity and its derivatives + call thermConductivity(& ! input: state variables - mLayerTempTrial, & ! intent(in): trial temperature of layer temperature (K) - mLayerMatricHeadTrial, & ! intent(in): trial value for total water matric potential (m) + nLayers, & ! intent(in): total number of layers + scalarSolution, & ! intent(in): flag to indicate the scalar solution mLayerVolFracIceTrial, & ! intent(in): volumetric fraction of ice at the start of the sub-step (-) mLayerVolFracLiqTrial, & ! intent(in): volumetric fraction of liquid water at the start of the sub-step (-) - ! input: pre-computed derivatives - mLayerdTheta_dTk, & ! intent(in): derivative in volumetric liquid water content w.r.t. temperature (K-1) - mLayerFracLiqSnow, & ! intent(in): fraction of liquid water (-) ! input/output: data structures mpar_data, & ! intent(in): model parameters indx_data, & ! intent(in): model layer indices prog_data, & ! intent(in): model prognostic variables for a local HRU diag_data, & ! intent(inout): model diagnostic variables for a local HRU - ! output: derivative - dThermalC_dWatAbove, & ! intent(out): derivative in the thermal conductivity w.r.t. water state in the layer above - dThermalC_dWatBelow, & ! intent(out): derivative in the thermal conductivity w.r.t. water state in the layer above - dThermalC_dTempAbove, & ! intent(out): derivative in the thermal conductivity w.r.t. energy state in the layer above - dThermalC_dTempBelow, & ! intent(out): derivative in the thermal conductivity w.r.t. energy state in the layer above - ! output: error control + ! input: pre-computed derivatives + mLayerTempTrial, & ! intent(in): trial temperature of layer temperature (K) + mLayerMatricHeadTrial, & ! intent(in): trial value for total water matric potential (m) + mLayerdTheta_dTk, & ! intent(in): derivative in volumetric liquid water content w.r.t. temperature (K-1) + mLayerFracLiqSnow, & ! intent(in): fraction of liquid water (-) + ! input/output: derivatives + dThermalC_dWatAbove, & ! intent(inout): derivative in the thermal conductivity w.r.t. water state in the layer above + dThermalC_dWatBelow, & ! intent(inout): derivative in the thermal conductivity w.r.t. water state in the layer above + dThermalC_dTempAbove, & ! intent(inout): derivative in the thermal conductivity w.r.t. energy state in the layer above + dThermalC_dTempBelow, & ! intent(inout): derivative in the thermal conductivity w.r.t. energy state in the layer above ! output: error control - err,cmessage) ! intent(out): error control + err,cmessage) ! intent(out): error control if(err/=0)then; err=55; message=trim(message)//trim(cmessage); return; end if - else - ! set flux heat capacity derivatives to 0 for constant through step + else ! set flux heat capacity derivatives to 0 for constant through step dThermalC_dWatAbove = 0._rkind dThermalC_dWatBelow = 0._rkind dThermalC_dTempAbove = 0._rkind @@ -550,8 +541,8 @@ subroutine eval8summaWithPrime(& endif ! updateFluxCp if(needStateCm)then - ! compute C_m - call computCm(& + ! compute heat advected with water Cm and its derivatives + call heatAdvectWat(& ! input: state variables scalarCanopyTempTrial, & ! intent(in): trial value of canopy temperature (K) mLayerTempTrial, & ! intent(in): trial value of layer temperature (K) @@ -627,23 +618,34 @@ subroutine eval8summaWithPrime(& ! compute soil compressibility (-) and its derivative w.r.t. matric head (m) ! NOTE: we already extracted trial matrix head and volumetric liquid water as part of the flux calculations - call soilCmpresPrime(& - ! input: - ixRichards, & ! intent(in): choice of option for Richards' equation - ixBeg,ixEnd, & ! intent(in): start and end indices defining desired layers - mLayerMatricHeadPrime(1:nSoil), & ! intent(in): matric head at the start of the time step (m s-1) - mLayerVolFracLiqTrial(nSnow+1:nLayers), & ! intent(in): trial value for the volumetric liquid water content in each soil layer (-) - mLayerVolFracIceTrial(nSnow+1:nLayers), & ! intent(in): trial value for the volumetric ice content in each soil layer (-) - specificStorage, & ! intent(in): specific storage coefficient (m-1) - theta_sat, & ! intent(in): soil porosity (-) - ! output: - mLayerCompress, & ! intent(inout): compressibility of the soil matrix (-) - dCompress_dPsi, & ! intent(inout): derivative in compressibility w.r.t. matric head (m-1) - err,cmessage) ! intent(out): error code and error message - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) - - ! compute the total change in storage associated with compression of the soil matrix (kg m-2 s-1) - scalarSoilCompress = sum(mLayerCompress(1:nSoil)*mLayerDepth(nSnow+1:nLayers))*iden_water + if(nSoil>0)then + if(scalarSolution)then + ixLayerDesired = pack(ixControlVolume, ixMapFull2Subset/=integerMissing) + ixTop = ixLayerDesired(1) + ixBot = ixLayerDesired(1) + else + ixTop = 1 + ixBot = nSoil + endif + call soilCmpresPrime(& + ! input: + ixRichards, & ! intent(in): choice of option for Richards' equation + ixTop,ixBot, & ! intent(in): top and bottom defining desired layers + mLayerMatricHeadPrime(1:nSoil), & ! intent(in): matric head at the start of the time step (m s-1) + mLayerVolFracLiqTrial(nSnow+1:nLayers), & ! intent(in): trial value for the volumetric liquid water content in each soil layer (-) + mLayerVolFracIceTrial(nSnow+1:nLayers), & ! intent(in): trial value for the volumetric ice content in each soil layer (-) + specificStorage, & ! intent(in): specific storage coefficient (m-1) + theta_sat, & ! intent(in): soil porosity (-) + ! output: + mLayerCompress, & ! intent(inout): compressibility of the soil matrix (-) + dCompress_dPsi, & ! intent(inout): derivative in compressibility w.r.t. matric head (m-1) + err,cmessage) ! intent(out): error code and error message + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! (check for errors) + ! compute the total change in storage associated with compression of the soil matrix (kg m-2 s-1) + scalarSoilCompress = sum(mLayerCompress(1:nSoil)*mLayerDepth(nSnow+1:nLayers))*iden_water + else + scalarSoilCompress = 0._qp + endif ! compute the residual vector if (insideSUN)then diff --git a/build/source/engine/ffile_info.f90 b/build/source/engine/ffile_info.f90 index 2d0988261..8f3768bfc 100644 --- a/build/source/engine/ffile_info.f90 +++ b/build/source/engine/ffile_info.f90 @@ -19,7 +19,7 @@ ! along with this program. If not, see . module ffile_info_module -USE nrtype +USE nr_type USE netcdf USE globalData,only:integerMissing implicit none @@ -66,7 +66,7 @@ subroutine ffile_info(nGRU,err,message) character(LEN=256) :: infile ! input filename integer(i4b) :: unt ! file unit (free unit output from file_open) character(LEN=256) :: filenameData ! name of forcing datafile - integer(i4b) :: ivar ! index of model variable + integer(i4b) :: iVar ! index of model variable integer(i4b) :: iFile ! counter for forcing files integer(i4b) :: nFile ! number of forcing files in forcing file list integer(i4b) :: file_nHRU ! number of HRUs in current forcing file @@ -188,22 +188,22 @@ subroutine ffile_info(nGRU,err,message) 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 + 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)) + 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 index of the forcing structure in the metadata structure if(trim(varName)/='time')then - forcFileInfo(iFile)%var_ix(iNC) = ivar - forcFileInfo(iFile)%varName(ivar) = trim(varName) + forcFileInfo(iFile)%var_ix(iNC) = iVar + forcFileInfo(iFile)%varName(iVar) = trim(varName) ! get first time from file, place into forcFileInfo else - err = nf90_get_var(ncid,forcFileInfo(iFile)%data_id(ivar),forcFileInfo(iFile)%firstJulDay,start=(/1/)) + 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 @@ -232,7 +232,7 @@ subroutine ffile_info(nGRU,err,message) case('hruId') ! check to see if hruId exists as a variable, this is a required variable - err = nf90_inq_varid(ncid,trim(varname),varId) + 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 @@ -263,7 +263,7 @@ subroutine ffile_info(nGRU,err,message) ! 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 + 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 diff --git a/build/source/engine/getVectorz.f90 b/build/source/engine/getVectorz.f90 index dc98ddd0e..e4bb25a6a 100644 --- a/build/source/engine/getVectorz.f90 +++ b/build/source/engine/getVectorz.f90 @@ -21,7 +21,7 @@ module getVectorz_module ! data types -USE nrtype +USE nr_type ! missing values USE globalData,only:integerMissing ! missing integer @@ -249,7 +249,7 @@ end subroutine popStateVec ! ********************************************************************************************************** -! public subroutine getScaling: get scale factors +! public subroutine getScaling: get scale factors and state multipliers for the function evaluations and state variables ! ********************************************************************************************************** subroutine getScaling(& ! input: data structures @@ -262,9 +262,6 @@ subroutine getScaling(& dMat, & ! intent(out): diagonal of the Jacobian matrix excluding fluxes, not depending on the state vector err,message) ! intent(out): error control ! -------------------------------------------------------------------------------------------------------------------------------- - USE nr_utility_module,only:arth ! get a sequence of numbers arth(start, incr, count) - USE f2008funcs_module,only:findIndex ! finds the index of the first value within a vector - ! -------------------------------------------------------------------------------------------------------------------------------- ! input: data structures type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers diff --git a/build/source/engine/groundwatr.f90 b/build/source/engine/groundwatr.f90 index 90c90659f..4f7b91ff0 100644 --- a/build/source/engine/groundwatr.f90 +++ b/build/source/engine/groundwatr.f90 @@ -21,7 +21,7 @@ module groundwatr_module ! data types -USE nrtype +USE nr_type ! model constants USE multiconst,only:iden_water ! density of water (kg m-3) @@ -172,7 +172,7 @@ subroutine groundwatr(& ! ************************************************************************************************ ! use private subroutine to compute baseflow (for multiple calls for numerical Jacobian) - call computeBaseflow(& + call computBaseflow(& ! input: control and state variables nSnow, & ! intent(in): number of snow layers nSoil, & ! intent(in): number of soil layers @@ -203,9 +203,9 @@ end subroutine groundwatr ! *********************************************************************************************************************** -! * private subroutine computeBaseflow: private subroutine so can be used to test the numerical jacobian +! * private subroutine computBaseflow: private subroutine so can be used to test the numerical jacobian ! *********************************************************************************************************************** -subroutine computeBaseflow(& +subroutine computBaseflow(& ! input: control and state variables nSnow, & ! intent(in): number of snow layers nSoil, & ! intent(in): number of soil layers @@ -403,6 +403,6 @@ subroutine computeBaseflow(& end associate ! end association to data in structures -end subroutine computeBaseflow +end subroutine computBaseflow end module groundwatr_module diff --git a/build/source/engine/computHeatCap.f90 b/build/source/engine/heat_Cp_Cm.f90 similarity index 81% rename from build/source/engine/computHeatCap.f90 rename to build/source/engine/heat_Cp_Cm.f90 index aafdf62b4..b860fabf5 100644 --- a/build/source/engine/computHeatCap.f90 +++ b/build/source/engine/heat_Cp_Cm.f90 @@ -18,19 +18,18 @@ ! You should have received a copy of the GNU General Public License ! along with this program. If not, see . -module computHeatCap_module +module heat_Cp_Cm_module ! data types -USE nrtype +USE nr_type ! derived types to define the data structures USE data_types,only:& - var_d, & ! data vector (rkind) var_ilength, & ! data vector with variable length dimension (i4b) var_dlength ! data vector with variable length dimension (rkind) ! named variables defining elements in the data structures -USE var_lookup,only:iLookPARAM,iLookDIAG,iLookINDEX ! named variables for structure elements +USE var_lookup,only:iLookPARAM,iLookDIAG,iLookINDEX,iLookPROG ! named variables for structure elements ! physical constants USE multiconst,only: gravity, & ! gravitational acceleration (m s-1) @@ -65,17 +64,18 @@ module computHeatCap_module ! privacy implicit none private -public::computStatMult -public::computHeatCapAnalytic -public::computCm +public::stateMultiplier +public::init_heatCapacity +public::heatCapacity +public::heatAdvectWat contains ! ********************************************************************************************************** -! public subroutine computStatMult: get scale factors +! public subroutine stateMultiplier: get scale factors for the temperature and water state vector ! ********************************************************************************************************** -subroutine computStatMult(& +subroutine stateMultiplier(& heatCapVeg, & ! intent(in): heat capacity for canopy mLayerHeatCap, & ! intent(in): heat capacity for snow and soil ! input: data structures @@ -83,9 +83,6 @@ subroutine computStatMult(& ! output sMul, & ! intent(out): multiplier for state vector (used in the residual calculations) err,message) ! intent(out): error control -! -------------------------------------------------------------------------------------------------------------------------------- -USE nr_utility_module,only:arth ! get a sequence of numbers arth(start, incr, count) -USE f2008funcs_module,only:findIndex ! finds the index of the first value within a vector ! -------------------------------------------------------------------------------------------------------------------------------- ! input: data structures real(qp),intent(in) :: heatCapVeg ! volumetric heat capacity of vegetation (J m-3 K-1) @@ -96,14 +93,10 @@ subroutine computStatMult(& ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message - ! -------------------------------------------------------------------------------------------------------------------------------- - ! local variables - ! -------------------------------------------------------------------------------------------------------------------------------- - ! state subsets - integer(i4b) :: iLayer ! index of layer within the snow+soil domain + ! local variables + integer(i4b) :: iLayer ! index of layer within the snow+soil domain integer(i4b) :: ixStateSubset ! index within the state subset ! -------------------------------------------------------------------------------------------------------------------------------- - ! -------------------------------------------------------------------------------------------------------------------------------- ! make association with variables in the data structures associate(& ! vector of energy and hydrology indices for the snow and soil domains @@ -118,7 +111,7 @@ subroutine computStatMult(& ) ! end association with variables in the data structures ! -------------------------------------------------------------------------------------------------------------------------------- ! initialize error control - err=0; message='computStatMult/' + err=0; message='stateMultiplier/' ! ----- ! * define components of derivative matrices at start of time step (substep)... @@ -150,18 +143,105 @@ subroutine computStatMult(& ! define the scaling factor and diagonal elements for the aquifer where(ixStateType_subset==iname_watAquifer) sMul = 1._rkind - ! ------------------------------------------------------------------------------------------ - ! ------------------------------------------------------------------------------------------ - end associate -! end association to variables in the data structure where vector length does not change -end subroutine computStatMult +end subroutine stateMultiplier ! ********************************************************************************************************** -! public subroutine computHeatCapAnalytic: compute diagnostic energy variables (heat capacity) -! NOTE: computing on whole vector, could just compute on state subset +! public subroutine init_heatCapacity: compute start-of-step heat capacity Cp ! ********************************************************************************************************** -subroutine computHeatCapAnalytic(& +subroutine init_heatCapacity(& + ! input: control variables + computeVegFlux, & ! intent(in): flag to denote if computing the vegetation flux + canopyDepth, & ! intent(in): canopy depth (m) + ! input/output: data structures + mpar_data, & ! intent(in): model parameters + indx_data, & ! intent(in): model layer indices + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + ! output: error control + err,message) ! intent(out): error control + ! -------------------------------------------------------------------------------------------------------------------------------------- + ! input: model control + logical(lgt),intent(in) :: computeVegFlux ! logical flag to denote if computing the vegetation flux + real(rkind),intent(in) :: canopyDepth ! depth of the vegetation canopy (m) + ! input/output: data structures + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_ilength),intent(in) :: indx_data ! model layer indices + type(var_dlength),intent(in) :: prog_data ! model prognostic variables for a local HRU + type(var_dlength),intent(inout) :: diag_data ! model diagnostic variables for a local HRU + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! -------------------------------------------------------------------------------------------------------------------------------- + ! local variables + integer(i4b) :: iLayer ! index of model layer + integer(i4b) :: iSoil ! index of soil layer + ! -------------------------------------------------------------------------------------------------------------------------------- + ! associate variables in data structure + associate(& + ! input: state variables + 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 + 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) + ! input: heat capacity + specificHeatVeg => mpar_data%var(iLookPARAM%specificHeatVeg)%dat(1), & ! intent(in): specific heat of vegetation (J kg-1 K-1) + maxMassVegetation => mpar_data%var(iLookPARAM%maxMassVegetation)%dat(1), & ! intent(in): maximum mass of vegetation (kg m-2) + ! input: depth varying soil parameters + iden_soil => mpar_data%var(iLookPARAM%soil_dens_intr)%dat, & ! intent(in): intrinsic density of soil (kg m-3) + theta_sat => mpar_data%var(iLookPARAM%theta_sat)%dat, & ! intent(in): soil porosity (-) + ! output: diagnostic variables + 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) + ) ! end associate statement + ! -------------------------------------------------------------------------------------------------------------------------------- + ! initialize error control + err=0; message="init_heatCapacity/" + + ! initialize the soil layer + iSoil=integerMissing + + ! compute the bulk volumetric heat capacity of vegetation (J m-3 K-1) + if(computeVegFlux)then + scalarBulkVolHeatCapVeg = specificHeatVeg*maxMassVegetation/canopyDepth + & ! vegetation component + Cp_water*scalarCanopyLiquid/canopyDepth + & ! liquid water component + Cp_ice*scalarCanopyIce/canopyDepth ! ice component + else + scalarBulkVolHeatCapVeg = realMissing + end if + + ! loop through layers + do iLayer=1,nLayers + ! get the soil layer + if(iLayer>nSnow) iSoil = iLayer-nSnow + + select case(layerType(iLayer)) + ! * soil + case(iname_soil) + mLayerVolHtCapBulk(iLayer) = iden_soil(iSoil) * Cp_soil * ( 1._rkind - theta_sat(iSoil) ) + & ! soil component + iden_ice * Cp_ice * mLayerVolFracIce(iLayer) + & ! ice component + iden_water * Cp_water * mLayerVolFracLiq(iLayer) + & ! liquid water component + iden_air * Cp_air * ( theta_sat(iSoil) - (mLayerVolFracIce(iLayer) + mLayerVolFracLiq(iLayer)) ) ! air component + ! * snow + 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 * ( 1._rkind - (mLayerVolFracIce(iLayer) + mLayerVolFracLiq(iLayer)) ) ! air component + case default; err=20; message=trim(message)//'unable to identify type of layer (snow or soil) to compute volumetric heat capacity'; return + end select + end do ! looping through layers + + end associate +end subroutine init_heatCapacity + +! ************************************************************************************************************************** +! public subroutine heatCapacity: compute diagnostic energy variable Cp (change in enthTemp with temperature) +! ************************************************************************************************************************** +subroutine heatCapacity(& ! input: state variables canopyDepth, & ! intent(in): canopy depth (m) scalarCanopyIce, & ! intent(in): trial value for mass of ice on the vegetation canopy (kg m-2) @@ -238,13 +318,12 @@ subroutine computHeatCapAnalytic(& ! input: coordinate variables nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in): number of snow layers ! mapping between the full state vector and the state subset - ixMapFull2Subset => indx_data%var(iLookINDEX%ixMapFull2Subset)%dat ,& ! intent(in): [i4b(:)] list of indices in the state subset for each state in the full state vector ixMapSubset2Full => indx_data%var(iLookINDEX%ixMapSubset2Full)%dat ,& ! intent(in): [i4b(:)] [state subset] list of indices of the full state vector in the state subset ! type of domain, type of state variable, and index of control volume within domain ixDomainType_subset => indx_data%var(iLookINDEX%ixDomainType_subset)%dat ,& ! intent(in): [i4b(:)] [state subset] id of domain for desired model state variables ixControlVolume => indx_data%var(iLookINDEX%ixControlVolume)%dat ,& ! intent(in): [i4b(:)] index of the control volume for different domains (veg, snow, soil) ixStateType => indx_data%var(iLookINDEX%ixStateType)%dat ,& ! intent(in): [i4b(:)] indices defining the type of the state (iname_nrgLayer...) - ! input: heat capacity and thermal conductivity + ! input: heat capacity specificHeatVeg => mpar_data%var(iLookPARAM%specificHeatVeg)%dat(1) ,& ! intent(in): specific heat of vegetation (J kg-1 K-1) maxMassVegetation => mpar_data%var(iLookPARAM%maxMassVegetation)%dat(1) ,& ! intent(in): maximum mass of vegetation (kg m-2) ! input: depth varying soil parameters @@ -253,7 +332,7 @@ subroutine computHeatCapAnalytic(& ) ! end associate statement ! -------------------------------------------------------------------------------------------------------------------------------- ! initialize error control - err=0; message="computHeatCapAnalytic/" + err=0; message="heatCapacity/" ! loop through model state variables do iState=1,size(ixMapSubset2Full) @@ -332,13 +411,12 @@ subroutine computHeatCapAnalytic(& end associate -end subroutine computHeatCapAnalytic +end subroutine heatCapacity ! ********************************************************************************************************** -! public subroutine computCm: compute diagnostic energy variables (change in enthTemp with water) -! NOTE: computing on whole vector, could just compute on state subset +! public subroutine heatAdvectWat: compute diagnostic energy variable Cm (change in enthTemp with water) ! ********************************************************************************************************** -subroutine computCm(& +subroutine heatAdvectWat(& ! input: state variables scalarCanopyTemp, & ! intent(in): value of canopy temperature (K) mLayerTemp, & ! intent(in): vector of temperature (K) @@ -394,10 +472,9 @@ subroutine computCm(& ! associate variables in data structure associate(& ! input: coordinate variables - nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in): number of snow layers + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in): [i4b] number of snow layers snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1) ,& ! intent(in): [dp] scaling parameter for the snow freezing curve (K-1) ! mapping between the full state vector and the state subset - ixMapFull2Subset => indx_data%var(iLookINDEX%ixMapFull2Subset)%dat ,& ! intent(in): [i4b(:)] list of indices in the state subset for each state in the full state vector ixMapSubset2Full => indx_data%var(iLookINDEX%ixMapSubset2Full)%dat ,& ! intent(in): [i4b(:)] [state subset] list of indices of the full state vector in the state subset ! type of domain, type of state variable, and index of control volume within domain ixDomainType_subset => indx_data%var(iLookINDEX%ixDomainType_subset)%dat ,& ! intent(in): [i4b(:)] [state subset] id of domain for desired model state variables @@ -406,7 +483,7 @@ subroutine computCm(& ) ! end associate statement ! -------------------------------------------------------------------------------------------------------------------------------- ! initialize error control - err=0; message="computCm/" + err=0; message="heatAdvectWat/" ! loop through model state variables do iState=1,size(ixMapSubset2Full) @@ -488,7 +565,7 @@ subroutine computCm(& end associate -end subroutine computCm +end subroutine heatAdvectWat -end module computHeatCap_module +end module heat_Cp_Cm_module diff --git a/build/source/engine/indexState.f90 b/build/source/engine/indexState.f90 index d1eb29366..e160f232d 100644 --- a/build/source/engine/indexState.f90 +++ b/build/source/engine/indexState.f90 @@ -21,7 +21,7 @@ module indexState_module ! data types -USE nrtype +USE nr_type ! derived types to define the data structures USE data_types,only:var_ilength ! data vector with variable length dimension (i4b) @@ -73,7 +73,7 @@ subroutine indexState(computeVegFlux, & ! intent(in): flag to denote indx_data, & ! intent(inout): indices defining model states and layers err,message) ! intent(out): error control ! provide access to the numerical recipes utility modules - USE nr_utility_module,only:arth ! creates a sequence of numbers (start, incr, n) + USE nr_utils_module,only:arth ! use to build vectors with regular increments implicit none ! -------------------------------------------------------------------------------------------------------------------------------- ! -------------------------------------------------------------------------------------------------------------------------------- @@ -213,8 +213,8 @@ subroutine indexState(computeVegFlux, & ! intent(in): flag to denote 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 + ixStateType( ixHydLayer(1:nLayers)) = iname_watLayer + if(nSoil>0) ixStateType( ixHydLayer(nSnow+1:nLayers) ) = iname_matLayer ! refine later to be either iname_watLayer or iname_matLayer ! define the state type for the aquifer if(includeAquifer) ixStateType( ixWatAquifer(1) ) = iname_watAquifer @@ -228,13 +228,15 @@ subroutine indexState(computeVegFlux, & ! intent(in): flag to denote ! define the domain type for snow if(nSnow>0)then - ixDomainType( ixNrgLayer(1:nSnow) ) = iname_snow - ixDomainType( ixHydLayer(1:nSnow) ) = iname_snow + 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 + if(nSoil>0)then + ixDomainType( ixNrgLayer(nSnow+1:nLayers) ) = iname_soil + ixDomainType( ixHydLayer(nSnow+1:nLayers) ) = iname_soil + endif ! define the domain type for the aquifer if(includeAquifer) ixDomainType( ixWatAquifer(1) ) = iname_aquifer @@ -253,8 +255,10 @@ subroutine indexState(computeVegFlux, & ! intent(in): flag to denote 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) + if(nSoil>0)then + ixControlVolume( ixNrgLayer(nSnow+1:nLayers) ) = ixSoilState(1:nSoil) + ixControlVolume( ixHydLayer(nSnow+1:nLayers) ) = ixSoilState(1:nSoil) + endif ! define the index for the control volumes in the aquifer if(includeAquifer) ixControlVolume( ixWatAquifer(1) ) = 1 @@ -278,7 +282,7 @@ subroutine indexSplit(in_indexSplit, & ! intent(in) : number of out_indexSplit) ! intent(out) : error control ! external modules USE f2008funcs_module,only:findIndex ! finds the index of the first value within a vector - USE nr_utility_module,only:arth ! creates a sequence of numbers (start, incr, n) + USE nr_utils_module,only:arth ! use to build vectors with regular increments implicit none ! -------------------------------------------------------------------------------------------------------------------------------- ! input @@ -399,7 +403,7 @@ subroutine indexSplit(in_indexSplit, & ! intent(in) : number of 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 + 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 @@ -468,7 +472,7 @@ subroutine indexSplit(in_indexSplit, & ! intent(in) : number of ! 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 + 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 @@ -592,14 +596,14 @@ subroutine resizeIndx(ixDesire,indx_data,nVec,err,message) ! 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) + 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) + message=trim(message)//'unable to allocate space for variable '//trim(indx_meta(iVar)%varName) err=20; return endif diff --git a/build/source/engine/layerDivide.f90 b/build/source/engine/layerDivide.f90 index 3e69d5f73..6451cde0d 100644 --- a/build/source/engine/layerDivide.f90 +++ b/build/source/engine/layerDivide.f90 @@ -21,7 +21,7 @@ module layerDivide_module ! variable types -USE nrtype +USE nr_type ! physical constants USE multiconst,only:& @@ -386,7 +386,7 @@ subroutine addModelLayer(dataStruct,metaStruct,ix_divide,nSnow,nLayers,err,messa character(*),intent(out) :: message ! error message ! --------------------------------------------------------------------------------------------- ! local variables - integer(i4b) :: ivar ! index of model variable + 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 @@ -398,10 +398,10 @@ subroutine addModelLayer(dataStruct,metaStruct,ix_divide,nSnow,nLayers,err,messa err=0; message='addModelLayer/' ! ***** add a layer to each model variable - do ivar=1,size(metaStruct) + do iVar=1,size(metaStruct) ! define bounds - select case(metaStruct(ivar)%vartype) + 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 @@ -410,7 +410,7 @@ subroutine addModelLayer(dataStruct,metaStruct,ix_divide,nSnow,nLayers,err,messa end select ! identify whether it is a state variable - select case(trim(metaStruct(ivar)%varname)) + select case(trim(metaStruct(iVar)%varName)) case('mLayerDepth','mLayerTemp','mLayerVolFracIce','mLayerVolFracLiq'); stateVariable=.true. case default; stateVariable=.false. end select @@ -421,28 +421,28 @@ subroutine addModelLayer(dataStruct,metaStruct,ix_divide,nSnow,nLayers,err,messa ! ** 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 + 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_rkind, ix_lower, source=dataStruct%var(ivar)%dat, err=err, message=cmessage) + call cloneStruc(tempVec_rkind, 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) + 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) + 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_rkind(1:ix_divide) ! copy data - dataStruct%var(ivar)%dat(ix_divide+1) = tempVec_rkind(ix_divide) ! repeat data for the sub-divided layer + dataStruct%var(iVar)%dat(1:ix_divide) = tempVec_rkind(1:ix_divide) ! copy data + dataStruct%var(iVar)%dat(ix_divide+1) = tempVec_rkind(ix_divide) ! repeat data for the sub-divided layer end if if(ix_upper > ix_divide) & - dataStruct%var(ivar)%dat(ix_divide+2:ix_upper+1) = tempVec_rkind(ix_divide+1:ix_upper) ! copy data + dataStruct%var(iVar)%dat(ix_divide+2:ix_upper+1) = tempVec_rkind(ix_divide+1:ix_upper) ! copy data end if ! if the vector exists ! not a state variable else - dataStruct%var(ivar)%dat(:) = realMissing + dataStruct%var(iVar)%dat(:) = realMissing end if ! deallocate the temporary vector: strictly not necessary, but include to be safe deallocate(tempVec_rkind,stat=err) @@ -451,28 +451,28 @@ subroutine addModelLayer(dataStruct,metaStruct,ix_divide,nSnow,nLayers,err,messa ! ** 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 + 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) + 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) + 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) + 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 + 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 + 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(:) = integerMissing + dataStruct%var(iVar)%dat(:) = integerMissing end if ! deallocate the temporary vector: strictly not necessary, but include to be safe deallocate(tempVec_i4b,stat=err) diff --git a/build/source/engine/layerMerge.f90 b/build/source/engine/layerMerge.f90 index ef9cd0961..5710e1600 100644 --- a/build/source/engine/layerMerge.f90 +++ b/build/source/engine/layerMerge.f90 @@ -21,7 +21,7 @@ module layerMerge_module ! data types -USE nrtype +USE nr_type ! access missing values USE globalData,only:integerMissing ! missing integer @@ -296,8 +296,8 @@ subroutine layer_combine(mpar_data,prog_data,diag_data,flux_data,indx_data,iSnow 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 enthalpyTemp_module,only:enthalpy2T_snwWat,T2enthalpy_snwWat ! convert temperature to liq+ice enthalpy for a snow layer + USE snow_utils_module,only:fracliquid ! compute fraction of liquid water + USE convertEnthalpyTemp_module,only:enthalpy2T_snwWat,T2enthalpy_snwWat ! convert temperature to liq+ice enthalpy for a snow layer implicit none ! ------------------------------------------------------------------------------------------------------------ ! input/output: data structures @@ -454,7 +454,7 @@ subroutine rmLyAllVars(dataStruct,metaStruct,iSnow,nSnow,nLayers,err,message) integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! locals - integer(i4b) :: ivar ! variable index + integer(i4b) :: iVar ! variable index integer(i4b) :: ix_lower ! lower bound of the vector integer(i4b) :: ix_upper ! upper bound of the vector real(rkind),allocatable :: tempVec_rkind(:) ! temporary vector (double precision) @@ -472,10 +472,10 @@ subroutine rmLyAllVars(dataStruct,metaStruct,iSnow,nSnow,nLayers,err,message) 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(metaStruct) + do iVar=1,size(metaStruct) ! define bounds - select case(metaStruct(ivar)%vartype) + 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 @@ -489,19 +489,19 @@ subroutine rmLyAllVars(dataStruct,metaStruct,iSnow,nSnow,nLayers,err,message) ! ** 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 + 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_rkind(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_rkind(iSnow) = realMissing ! set merged layer to missing (fill in later) - if(iSnow>ix_lower) tempVec_rkind(ix_lower:iSnow-1) = dataStruct%var(ivar)%dat(ix_lower:iSnow-1) - if(iSnow+1ix_lower) tempVec_rkind(ix_lower:iSnow-1) = dataStruct%var(iVar)%dat(ix_lower:iSnow-1) + if(iSnow+1=ix_lower) tempVec_i4b(iSnow) = integerMissing ! 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+1ix_lower) tempVec_i4b(ix_lower:iSnow-1) = dataStruct%var(iVar)%dat(ix_lower:iSnow-1) + if(iSnow+1. module mDecisions_module -USE nrtype +USE nr_type USE var_lookup, only: maxvarDecisions ! maximum number of decisions implicit none private @@ -149,8 +149,8 @@ module mDecisions_module integer(i4b),parameter,public :: windUnload = 322 ! Roesch et al 2001, formulate unloading based on wind and temperature ! look-up values for the choice of variable in energy equations (BE residual or IDA state variable) integer(i4b),parameter,public :: closedForm = 323 ! use temperature with closed form heat capacity -integer(i4b),parameter,public :: enthalpyFormLU = 324 ! use enthalpy with soil temperature-enthalpy lookup tables -integer(i4b),parameter,public :: enthalpyForm = 325 ! use enthalpy with soil temperature-enthalpy analytical solution +integer(i4b),parameter,public :: enthalpyForm = 324 ! use enthalpy with soil temperature-enthalpy lookup tables +integer(i4b),parameter,public :: enthalpyFormAN = 325 ! use enthalpy with soil temperature-enthalpy analytical solution ! look-up values for the choice of choice of full or empty aquifer at start integer(i4b),parameter,public :: fullStart = 326 ! full aquifer at start integer(i4b),parameter,public :: emptyStart = 327 ! empty aquifer at start @@ -164,6 +164,12 @@ module mDecisions_module integer(i4b),parameter,public :: FUSEPRMS = 353 ! FUSE PRMS surface runoff integer(i4b),parameter,public :: FUSEAVIC = 354 ! FUSE ARNO/VIC surface runoff integer(i4b),parameter,public :: FUSETOPM = 355 ! FUSE TOPMODEL surface runoff +! look-up values for the buffered read of forcing data +integer(i4b),parameter,public :: readPerStep = 361 ! read forcing data per time step (default) +integer(i4b),parameter,public :: readFullSeries = 362 ! read full forcing series +! look-up values for the buffered write of model output +integer(i4b),parameter,public :: writePerStep = 371 ! write data per time step (default) +integer(i4b),parameter,public :: writeFullSeries = 372 ! write all data for a given output file ! ----------------------------------------------------------------------------------------------------------- @@ -427,12 +433,12 @@ subroutine mDecisions(err,message) #endif ! choice of variable in either energy backward Euler residual or IDA state variable - ! for backward Euler solution, enthalpyForm has better coincidence of energy conservation - ! in IDA solution, enthalpyForm makes the state variables to be enthalpy and the residual is computed in enthalpy space + ! for backward Euler solution, enthalpyFormAN has better coincidence of energy conservation + ! in IDA solution, enthalpyFormAN makes the state variables to be enthalpy and the residual is computed in enthalpy space select case(trim(model_decisions(iLookDECISIONS%nrgConserv)%cDecision)) - case('closedForm' ); model_decisions(iLookDECISIONS%nrgConserv)%iDecision = closedForm ! use temperature with closed form heat capacity - case('enthalpyFormLU'); model_decisions(iLookDECISIONS%nrgConserv)%iDecision = enthalpyFormLU ! use enthalpy with soil temperature-enthalpy lookup tables - case('enthalpyForm' ); model_decisions(iLookDECISIONS%nrgConserv)%iDecision = enthalpyForm ! use enthalpy with soil temperature-enthalpy analytical solution + case('closedForm' ); model_decisions(iLookDECISIONS%nrgConserv)%iDecision = closedForm ! use temperature with closed form heat capacity + case('enthalpyForm'); model_decisions(iLookDECISIONS%nrgConserv)%iDecision = enthalpyForm ! use enthalpy with soil temperature-enthalpy lookup tables + case('enthalpyFormAN' ); model_decisions(iLookDECISIONS%nrgConserv)%iDecision = enthalpyFormAN ! use enthalpy with soil temperature-enthalpy analytical solution case default if (trim(model_decisions(iLookDECISIONS%num_method)%cDecision)=='itertive')then model_decisions(iLookDECISIONS%nrgConserv)%iDecision = closedForm ! included for backwards compatibility @@ -702,6 +708,24 @@ subroutine mDecisions(err,message) err=10; message=trim(message)//"unknown option for saturation excess surface runoff method [option="//trim(model_decisions(iLookDECISIONS%surfRun_SE)%cDecision)//"]"; return end select + ! method used to read forcing data (per step or full read) + ! NOTE: use read forcing data per time step as the default + select case(trim(model_decisions(iLookDECISIONS%read_force)%cDecision)) + case('readPerStep','notPopulatedYet'); model_decisions(iLookDECISIONS%read_force)%iDecision = readPerStep ! read forcing data per time step (default) + case('readFullSeries' ); model_decisions(iLookDECISIONS%read_force)%iDecision = readFullSeries ! read full forcing series + case default + err=10; message=trim(message)//"unknown option for method used to read forcing data [option="//trim(model_decisions(iLookDECISIONS%read_force)%cDecision)//"]"; return + end select + + ! method used to write model output (per step or full write) + ! NOTE: use per time step as the default + select case(trim(model_decisions(iLookDECISIONS%write_buff)%cDecision)) + case('writePerStep','notPopulatedYet'); model_decisions(iLookDECISIONS%write_buff)%iDecision = writePerStep ! write model output per time step (default) + case('writeFullSeries' ); model_decisions(iLookDECISIONS%write_buff)%iDecision = writeFullSeries ! write all data for a given output file + case default + err=10; message=trim(message)//"unknown option for method used to write model output [option="//trim(model_decisions(iLookDECISIONS%write_buff)%cDecision)//"]"; return + end select + ! ----------------------------------------------------------------------------------------------------------------------------------------------- ! check for consistency among options ! ----------------------------------------------------------------------------------------------------------------------------------------------- diff --git a/build/source/engine/matrixOper.f90 b/build/source/engine/matrixOper.f90 index 6c09d8c49..d0eabe091 100644 --- a/build/source/engine/matrixOper.f90 +++ b/build/source/engine/matrixOper.f90 @@ -21,7 +21,7 @@ module matrixOper_module ! data types -USE nrtype +USE nr_type ! 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 @@ -37,7 +37,7 @@ module matrixOper_module private public::lapackSolv public::scaleMatrices -public::computeGradient +public::computGradient contains ! ********************************************************************************************************** @@ -100,9 +100,9 @@ end subroutine scaleMatrices ! ********************************************************************************************************* - ! * private subroutine computeGradient: compute the gradient of the function + ! * private subroutine computGradient: compute the gradient of the function ! ********************************************************************************************************* - subroutine computeGradient(ixMatrix,nState,aJac,rVec,grad,err,message) + subroutine computGradient(ixMatrix,nState,aJac,rVec,grad,err,message) implicit none ! input integer(i4b),intent(in) :: ixMatrix ! type of matrix (full Jacobian or band diagonal) @@ -117,7 +117,7 @@ subroutine computeGradient(ixMatrix,nState,aJac,rVec,grad,err,message) integer(i4b) :: iJac ! index of model state variable integer(i4b) :: iState ! index of the residual vector ! initialize error control - err=0; message='computeGradient/' + err=0; message='computGradient/' ! check if full Jacobian or band-diagonal matrix select case(ixMatrix) @@ -144,7 +144,7 @@ subroutine computeGradient(ixMatrix,nState,aJac,rVec,grad,err,message) end select ! (option to solve the linear system A.X=B) - end subroutine computeGradient + end subroutine computGradient ! ********************************************************************************************************* diff --git a/build/source/engine/opSplittin.f90 b/build/source/engine/opSplittin.f90 index 77e5e3e26..f01067830 100644 --- a/build/source/engine/opSplittin.f90 +++ b/build/source/engine/opSplittin.f90 @@ -21,7 +21,7 @@ module opSplittin_module ! data types -USE nrtype +USE nr_type ! access the global print flag USE globalData,only:globalPrintFlag @@ -716,7 +716,7 @@ subroutine finalize_coupling do iVar=1,size(flux_meta) if (neededFlux(iVar) .and. any(fluxCount%var(iVar)%dat==0)) then print*, 'fluxCount%var(iVar)%dat = ', fluxCount%var(iVar)%dat - message=trim(message)//'flux '//trim(flux_meta(iVar)%varname)//' was not computed' + message=trim(message)//'flux '//trim(flux_meta(iVar)%varName)//' was not computed' err=20; return_flag=.true.; return end if end do @@ -1183,33 +1183,38 @@ subroutine update_fluxMask if (ixLayerActive(iLayer)/=integerMissing) then ! get the offset (ixLayerActive=1,2,3,...nLayers, and soil vectors nSnow+1, nSnow+2, ..., nLayers) - iOffset = merge(nSnow, 0, flux_meta(iVar)%vartype==iLookVarType%midSoil .or. flux_meta(iVar)%vartype==iLookVarType%ifcSoil) + iOffset = merge(nSnow, 0, flux_meta(iVar)%varType==iLookVarType%midSoil .or. flux_meta(iVar)%varType==iLookVarType%ifcSoil) jLayer = iLayer-iOffset ! identify the minimum layer - select case(flux_meta(iVar)%vartype) + select case(flux_meta(iVar)%varType) case(iLookVarType%ifcToto, iLookVarType%ifcSnow, iLookVarType%ifcSoil); minLayer=merge(jLayer-1, jLayer, jLayer==1) case(iLookVarType%midToto, iLookVarType%midSnow, iLookVarType%midSoil); minLayer=jLayer case default; minLayer=integerMissing end select ! set desired layers - select case(flux_meta(iVar)%vartype) + select case(flux_meta(iVar)%varType) case(iLookVarType%midToto,iLookVarType%ifcToto); fluxMask%var(iVar)%dat(minLayer:jLayer) = desiredFlux case(iLookVarType%midSnow,iLookVarType%ifcSnow); if (iLayer<=nSnow) fluxMask%var(iVar)%dat(minLayer:jLayer) = desiredFlux case(iLookVarType%midSoil,iLookVarType%ifcSoil); if (iLayer> nSnow) fluxMask%var(iVar)%dat(minLayer:jLayer) = desiredFlux end select ! add hydrology states for scalar variables - if (iStateTypeSplit==massSplit .and. flux_meta(iVar)%vartype==iLookVarType%scalarv) then + if (iStateTypeSplit==massSplit .and. flux_meta(iVar)%varType==iLookVarType%scalarv) then select case(iDomainSplit) - case(snowSplit); if(iLayer==nSnow) fluxMask%var(iVar)%dat = desiredFlux - case(soilSplit); - if(iVar==iLookFLUX%scalarSoilDrainage .or. iVar==iLookFLUX%scalarAquiferRecharge & ! soil drainage, aq recharge changes with the bottom layer - .or. iVar==iLookFLUX%scalarSoilBaseflow) then ! soil baseflow changes with all layers, so compute after bottom layer - if(iLayer==nLayers) fluxMask%var(iVar)%dat = desiredFlux - else ! other scalar variables in the soil domain change with the surface layer - if(iLayer==nSnow+1) fluxMask%var(iVar)%dat = desiredFlux + case(snowSplit) ! snow scalar variables change with the bottom layer + if(nSnow>0 .and. iLayer==nSnow) fluxMask%var(iVar)%dat = desiredFlux + case(soilSplit) + if(nSoil>0)then + if(iLayer==nLayers)then + ! soil drainage, aq recharge, soil baseflow changes with all layers, so compute after bottom layer + if((iVar==iLookFLUX%scalarSoilDrainage .or. iVar==iLookFLUX%scalarAquiferRecharge & + .or. iVar==iLookFLUX%scalarSoilBaseflow)) fluxMask%var(iVar)%dat = desiredFlux + ! other scalar variables in the soil domain change with the surface layer + elseif(iLayer==nSnow+1)then + fluxMask%var(iVar)%dat = desiredFlux + end if end if end select end if ! if hydrology split and scalar @@ -1228,7 +1233,7 @@ subroutine update_fluxMask ! define if the flux is desired if (desiredFlux) neededFlux(iVar)=.true. - if ( globalPrintFlag .and. count(fluxMask%var(iVar)%dat)>0 ) print*,'computing flux', trim(flux_meta(iVar)%varname) + if ( globalPrintFlag .and. count(fluxMask%var(iVar)%dat)>0 ) print*,'computing flux', trim(flux_meta(iVar)%varName) end do ! end looping through fluxes diff --git a/build/source/engine/pOverwrite.f90 b/build/source/engine/pOverwrite.f90 index 726143f5b..bcb9664a2 100644 --- a/build/source/engine/pOverwrite.f90 +++ b/build/source/engine/pOverwrite.f90 @@ -19,7 +19,7 @@ ! along with this program. If not, see . module pOverwrite_module -USE nrtype +USE nr_type implicit none private public::pOverwrite diff --git a/build/source/engine/paramCheck.f90 b/build/source/engine/paramCheck.f90 index c372f2aa0..c2e0bd31b 100644 --- a/build/source/engine/paramCheck.f90 +++ b/build/source/engine/paramCheck.f90 @@ -20,7 +20,7 @@ module paramCheck_module ! define numerical recipes data type -USE nrtype +USE nr_type ! define look-up values for the choice of method to combine and sub-divide snow layers USE mDecisions_module,only:& sameRulesAllLayers, & ! SNTHERM option: same combination/sub-dividion rules applied to all layers @@ -163,15 +163,21 @@ subroutine paramCheck(mpar_data,err,message) ! check transpiration if( critSoilTranspire < critSoilWilting )then - write(message,'(a,i0,a)') trim(message)//'critical point for transpiration is less than the wilting point' + print*, 'critSoilTranspire = ', critSoilTranspire + print*, 'critSoilWilting = ', critSoilWilting + message=trim(message)//'critical point for transpiration is less than the wilting point' // & + '[NOTE: if overwriting Noah-MP soil table values in paramTrial or calibrating, must overwrite all soil parameters]' + err=20; return endif ! check porosity if( any(theta_sat < theta_res) )then - print*, 'theta_res = ', theta_res - print*, 'theta_sat = ', theta_sat - write(message,'(a,i0,a)') trim(message)//'porosity is less than the residual liquid water content' + print*, 'theta_res = ', theta_res + print*, 'theta_sat = ', theta_sat + message=trim(message)//'porosity is less than the residual liquid water content '// & + '[NOTE: if overwriting Noah-MP soil table values in paramTrial or calibrating, must overwrite all soil parameters]' + err=20; return endif diff --git a/build/source/engine/qTimeDelay.f90 b/build/source/engine/qTimeDelay.f90 index cc48f35ef..1cadb8b46 100644 --- a/build/source/engine/qTimeDelay.f90 +++ b/build/source/engine/qTimeDelay.f90 @@ -21,7 +21,7 @@ module qTimeDelay_module ! data types -USE nrtype +USE nr_type USE globalData,only:realMissing ! missing real number ! look-up values for the sub-grid routing method diff --git a/build/source/engine/read_attrb.f90 b/build/source/engine/read_attrb.f90 index f26a79d7f..e6e5a1763 100644 --- a/build/source/engine/read_attrb.f90 +++ b/build/source/engine/read_attrb.f90 @@ -19,7 +19,7 @@ ! along with this program. If not, see . module read_attrb_module -USE nrtype +USE nr_type implicit none private public::read_dimension @@ -33,7 +33,7 @@ subroutine read_dimension(attrFile,fileGRU,fileHRU,nGRU,nHRU,err,message,startGR 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 nr_utility_module ,only:arth + USE nr_utils_module ,only:arth ! use to build vectors with regular increments ! provide access to global data USE globalData,only:gru_struc ! gru->hru mapping structure USE globalData,only:index_map ! hru->gru mapping structure @@ -48,7 +48,6 @@ subroutine read_dimension(attrFile,fileGRU,fileHRU,nGRU,nHRU,err,message,startGR 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 @@ -56,12 +55,10 @@ subroutine read_dimension(attrFile,fileGRU,fileHRU,nGRU,nHRU,err,message,startGR integer(i8b),allocatable :: gru_id(:),hru_id(:)! read gru/hru IDs in from attributes file integer(i8b),allocatable :: hru2gru_id(:) ! read hru->gru mapping in from attributes file integer(i4b),allocatable :: hru_ix(:) ! hru index for search - ! define variables for NetCDF file operation - integer(i4b) :: ncID ! NetCDF file ID + 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 + integer(i4b) :: dimID ! netcdf file dimension id character(len=256) :: cmessage ! error message for downwind routine ! Start procedure here @@ -71,37 +68,37 @@ subroutine read_dimension(attrFile,fileGRU,fileHRU,nGRU,nHRU,err,message,startGR if(present(startGRU).and.present(checkHRU))then; message=trim(message)//'startGRU and checkHRU both exist, which is not supported'; 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 + call nc_file_open(trim(attrFile),nf90_noWrite,ncid,err,cmessage) + if(err/=nf90_noerr)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 + err = nf90_inq_dimid(ncid,"gru",dimID); if(err/=nf90_noerr)then; message=trim(message)//'problem finding gru dimension/'//trim(nf90_strerror(err)); return; end if + err = nf90_inquire_dimension(ncid, dimID, 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 + 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 ! 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 + 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 + nGRU = 1 else - sGRU = 1 - nGRU = fileGRU + sGRU = 1 + nGRU = fileGRU endif ! check dimensions if (present(startGRU)) then - if(startGRU + nGRU - 1 > fileGRU) then; err=20; message=trim(message)//'startGRU + nGRU is larger than then the GRU dimension'; return; end if + if(startGRU + nGRU - 1 > fileGRU) then; err=20; message=trim(message)//'startGRU + nGRU is larger than then the GRU dimension'; return; end if end if if (present(checkHRU)) then - if(checkHRU > fileHRU) then; err=20; message=trim(message)//'checkHRU is larger than then the HRU dimension'; return; end if + if(checkHRU > fileHRU) then; err=20; message=trim(message)//'checkHRU is larger than then the HRU dimension'; return; end if end if ! ********************************************************************************************* @@ -112,16 +109,16 @@ subroutine read_dimension(attrFile,fileGRU,fileHRU,nGRU,nHRU,err,message,startGR 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 + err = nf90_inq_varid(ncid,"gruId",varID); if (err/=nf90_noerr) then; message=trim(message)//'problem finding gruId'; return; end if + err = nf90_get_var(ncid,varID,gru_id); if (err/=nf90_noerr) then; message=trim(message)//'problem reading gruId'; return; end if ! read hru_id 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 + err = nf90_inq_varid(ncid,"hruId",varID); if (err/=nf90_noerr) then; message=trim(message)//'problem finding hruId'; return; end if + err = nf90_get_var(ncid,varID,hru_id); if (err/=nf90_noerr) 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 + err = nf90_inq_varid(ncid,"hru2gruId",varID); if (err/=nf90_noerr) then; message=trim(message)//'problem finding hru2gruId'; return; end if + err = nf90_get_var(ncid,varID,hru2gru_id); if (err/=nf90_noerr) then; message=trim(message)//'problem reading hru2gruId'; return; end if ! array from 1 to total # of HRUs in attributes file hru_ix=arth(1,1,fileHRU) @@ -139,39 +136,34 @@ subroutine read_dimension(attrFile,fileGRU,fileHRU,nGRU,nHRU,err,message,startGR allocate(gru_struc(nGRU)) ! set gru to hru mapping -if (present(checkHRU)) then ! allocate space for single-HRU run - - ! gru to hru mapping - iGRU = 1 - gru_struc(iGRU)%hruCount = 1 ! number of HRUs in each GRU - gru_struc(iGRU)%gru_id = hru2gru_id(checkHRU) ! set gru id - gru_struc(iGRU)%gru_nc = sGRU ! set gru index within the netcdf file - 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 +if (present(checkHRU)) then ! allocate space for single-HRU run + ! gru to hru mapping + iGRU = 1 + gru_struc(iGRU)%hruCount = 1 ! number of HRUs in each GRU + gru_struc(iGRU)%gru_id = hru2gru_id(checkHRU) ! set gru id + gru_struc(iGRU)%gru_nc = sGRU ! set gru index within the netcdf file + 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 + 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 #ifdef NGEN_ACTIVE - if (gru_struc(iGRU)%hruCount > 1) then; err=20; message=trim(message)//'NGEN currently only supports single-HRU per GRU'; return; end if - print *, 'GRU id is ', gru_id(iGRU+sGRU-1) + if (gru_struc(iGRU)%hruCount > 1) then; err=20; message=trim(message)//'NGEN currently only supports single-HRU per GRU'; return; end if + print *, 'GRU id is ', gru_id(iGRU+sGRU-1) #endif - gru_struc(iGRU)%gru_id = gru_id(iGRU+sGRU-1) ! set gru id - gru_struc(iGRU)%gru_nc = iGRU+sGRU-1 ! set gru index in the netcdf file - - 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)%gru_id) ! 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 - + gru_struc(iGRU)%gru_id = gru_id(iGRU+sGRU-1) ! set gru id + gru_struc(iGRU)%gru_nc = iGRU+sGRU-1 ! set gru index in the netcdf file + 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)%gru_id) ! 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 @@ -194,8 +186,8 @@ subroutine read_dimension(attrFile,fileGRU,fileHRU,nGRU,nHRU,err,message,startGR deallocate(gru_id, hru_ix, hru_id, hru2gru_id) ! close netcdf file -call nc_file_close(ncID,err,cmessage) -if (err/=0) then; message=trim(message)//trim(cmessage); return; end if +call nc_file_close(ncid,err,cmessage) +if (err/=nf90_noerr) then; message=trim(message)//trim(cmessage); return; end if end subroutine read_dimension @@ -223,10 +215,9 @@ subroutine read_attrb(attrFile,nGRU,attrStruct,typeStruct,idStruct,err,message) 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 - type(gru_hru_int8),intent(inout) :: idStruct ! local classification of hru and gru IDs + type(gru_hru_int8),intent(inout) :: idStruct ! local values of hru and gru IDs integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message - ! define local variables character(len=256) :: cmessage ! error message for downwind routine integer(i4b) :: iVar ! loop through varibles in the netcdf file @@ -234,15 +225,13 @@ subroutine read_attrb(attrFile,nGRU,attrStruct,typeStruct,idStruct,err,message) integer(i4b) :: iGRU ! index of an GRU integer(i4b) :: varType ! type of variable (categorica, numerical, idrelated) 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 :: checkId(:) ! vector to check if we have all desired IDs logical(lgt),allocatable :: checkAttr(:) ! vector to check if we have all desired local attributes - ! netcdf variables - integer(i4b) :: ncID ! netcdf file id + 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 @@ -270,12 +259,12 @@ subroutine read_attrb(attrFile,nGRU,attrStruct,typeStruct,idStruct,err,message) ! (2) open netcdf file ! ********************************************************************************************** ! open file - call nc_file_open(trim(attrFile),nf90_noWrite,ncID,err,cmessage) - if(err/=0)then; message=trim(message)//trim(cmessage); return; endif + call nc_file_open(trim(attrFile),nf90_noWrite,ncid,err,cmessage) + if(err/=nf90_noerr)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 + err = nf90_inquire(ncid,nvariables=nVar) + call netcdf_err(err,message); if (err/=nf90_noerr) return ! ********************************************************************************************** ! (3) read local attributes @@ -284,83 +273,83 @@ subroutine read_attrb(attrFile,nGRU,attrStruct,typeStruct,idStruct,err,message) 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(varName)) - - ! ** categorical data - case('vegTypeIndex','soilTypeIndex','slopeTypeIndex','downHRUindex') - - ! get the index of the variable - varType = categorical - varIndx = get_ixType(varName) - 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 - - ! ** ID related data - case('hruId') - ! get the index of the variable - varType = idrelated - varIndx = get_ixId(varName) - checkId(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,idrelated_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 - idStruct%gru(iGRU)%hru(iHRU)%var(varIndx) = idrelated_var(1) - end do - end do - - ! ** numerical data - case('latitude','longitude','elevation','tan_slope','contourLength','HRUarea','mHeight','aspect') - - ! 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 in read_dimension) - case('hru2gruId','gruId') - ! get the index of the variable - varType = idrelated - varIndx = get_ixId(varName) - checkId(varIndx) = .true. - - ! check that variables are what we expect - case default; message=trim(message)//'unknown variable ['//trim(varName)//'] in local attributes file'; err=20; return - - end select ! select variable + ! 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(varName)) + + ! ** categorical data + case('vegTypeIndex','soilTypeIndex','slopeTypeIndex','downHRUindex') + + ! get the index of the variable + varType = categorical + varIndx = get_ixType(varName) + 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 + + ! ** ID related data + case('hruId') + ! get the index of the variable + varType = idrelated + varIndx = get_ixId(varName) + checkId(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,idrelated_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 + idStruct%gru(iGRU)%hru(iHRU)%var(varIndx) = idrelated_var(1) + end do + end do + + ! ** numerical data + case('latitude','longitude','elevation','tan_slope','contourLength','HRUarea','mHeight','aspect') + + ! 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 variables, do nothing (information read above in read_dimension) + case('hru2gruId','gruId') + ! get the index of the variable + varType = idrelated + varIndx = get_ixId(varName) + checkId(varIndx) = .true. + + ! check that variables are what we expect + case default; message=trim(message)//'unknown variable ['//trim(varName)//'] in local attributes file'; err=20; return + + end select ! select variable end do ! (looping through netcdf local attribute file) @@ -371,9 +360,9 @@ subroutine read_attrb(attrFile,nGRU,attrStruct,typeStruct,idStruct,err,message) write(*,*) NEW_LINE('A')//'INFO: aspect not found in the input attribute file, continuing ...'//NEW_LINE('A') do iGRU=1,nGRU - do iHRU = 1, gru_struc(iGRU)%hruCount - attrStruct%gru(iGRU)%hru(iHRU)%var(varIndx) = nr_realMissing ! populate variable with out-of-range value, used later - end do + do iHRU = 1, gru_struc(iGRU)%hruCount + attrStruct%gru(iGRU)%hru(iHRU)%var(varIndx) = nr_realMissing ! populate variable with out-of-range value, used later + end do end do checkAttr(varIndx) = .true. endif @@ -383,27 +372,25 @@ subroutine read_attrb(attrFile,nGRU,attrStruct,typeStruct,idStruct,err,message) ! ********************************************************************************************** ! check that we have all desired categorical variables if(any(.not.checkType))then - 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 + 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 ID variables if(any(.not.checkId))then - do iCheck = 1,size(id_meta) - if(.not.checkId(iCheck))then; err=20; message=trim(message)//'missing variable ['//trim(id_meta(iCheck)%varname)//'] in local attributes file'; return; endif - end do + do iCheck = 1,size(id_meta) + if(.not.checkId(iCheck))then; err=20; message=trim(message)//'missing variable ['//trim(id_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 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 + 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 - ! ********************************************************************************************** ! (5) close netcdf file ! ********************************************************************************************** @@ -412,8 +399,8 @@ subroutine read_attrb(attrFile,nGRU,attrStruct,typeStruct,idStruct,err,message) deallocate(checkId) deallocate(checkAttr) - call nc_file_close(ncID,err,cmessage) - if (err/=0)then; message=trim(message)//trim(cmessage); return; end if + call nc_file_close(ncid,err,cmessage) + if (err/=nf90_noerr)then; message=trim(message)//trim(cmessage); return; end if end subroutine read_attrb diff --git a/build/source/engine/read_force.f90 b/build/source/engine/read_force.f90 index db50ac85b..0e021eb94 100644 --- a/build/source/engine/read_force.f90 +++ b/build/source/engine/read_force.f90 @@ -21,10 +21,12 @@ module read_force_module ! data types -USE nrtype ! variable types, etc. +USE nr_type ! variable types, etc. ! derived data types +USE data_types,only:var_ilength ! x%var(:)%dat(:) (i4b) USE data_types,only:gru_hru_double ! x%gru(:)%hru(:)%var(:) (rkind) +USE data_types,only:model_options ! defines the model decisions ! constants USE multiconst,only:secprday ! number of seconds in a day @@ -40,6 +42,7 @@ module read_force_module USE globalData,only:ixHRUfile_min,ixHRUfile_max ! global data on the forcing file +USE globalData,only:numtim ! number time steps USE globalData,only:data_step ! length of the data step (s) USE globalData,only:forcFileInfo ! forcing file info USE globalData,only:dJulianStart ! julian day of start time of simulation @@ -49,11 +52,21 @@ module read_force_module USE globalData,only:yearLength ! number of days in the current year USE globalData,only:nHRUfile ! number of days in the data file +! global data holding the buffered read +USE globalData,only:ixStartRead ! start index of the data read +USE globalData,only:fulltimeVec ! full time vector in an input file (nRead) +USE globalData,only:fullforcingStruct ! full forcing data structure + ! global metadata USE globalData,only:time_meta,forc_meta ! metadata structures USE var_lookup,only:iLookTIME,iLookFORCE ! named variables to define structure elements USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure +! look-up values for option to read input data +USE mDecisions_module,only: & + readPerStep , & ! read forcing data per time step (default) + readFullSeries ! read full forcing series + ! file paths USE summaFileManager,only:FORCING_PATH ! path of the forcing data file @@ -68,44 +81,58 @@ module read_force_module contains - ! ************************************************************************************************ ! public subroutine read_force: read in forcing data ! ************************************************************************************************ - subroutine read_force(istep,iFile,iRead,ncid,time_data,forcStruct,err,message) + subroutine read_force(iStep,model_decisions,iFile,iRead,ncid,time_data,forcStruct,err,message) ! provide access to subroutines - USE netcdf ! netcdf capability - USE time_utils_module,only:compJulDay ! convert calendar date to julian day - USE time_utils_module,only:compcalday ! convert julian day to calendar date - USE time_utils_module,only:elapsedSec ! calculate the elapsed time + USE netcdf ! netcdf capability + USE time_utils_module,only:compJulDay ! convert calendar date to julian day + USE time_utils_module,only:compcalday ! convert julian day to calendar date + USE time_utils_module,only:elapsedSec ! calculate the elapsed time implicit none ! define input variables - integer(i4b),intent(in) :: istep ! time index AFTER the start index + integer(i4b),intent(in) :: iStep ! time index AFTER the start index + type(model_options),intent(in) :: model_decisions(:) ! model decisions ! 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 + 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 - type(gru_hru_double) :: forcStruct ! x%gru(:)%hru(:)%var(:) -- model forcing data - integer(i4b),intent(out) :: err ! error code - character(*),intent(out) :: message ! error message + integer(i4b),intent(out) :: time_data(:) ! vector of time data for a given time step + type(gru_hru_double) :: forcStruct ! x%gru(:)%hru(:)%var(:) -- model forcing data + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message ! define local variables - integer(i4b) :: nHRUlocal ! number of HRUs in the local simulation - integer(i4b) :: iGRU,iHRU ! index of GRU and HRU - character(len=256),save :: infile ! filename - character(len=256) :: cmessage ! error message for downwind routine - real(rkind) :: startJulDay ! julian day at the start of the year - real(rkind) :: currentJulDay ! Julian day of current time step + integer(i4b) :: nRemain ! number of steps remaining in the simulation + integer(i4b) :: nData ! number of steps remaining in the file + integer(i4b) :: nRead ! number of steps in the data read + integer(i4b) :: nHRUlocal ! number of HRUs in the local simulation + integer(i4b) :: iline ! loop through lines in the file + integer(i4b) :: jRead ! index of time in data subset + integer(i4b) :: iGRU,iHRU ! index of GRU and HRU + character(len=256),save :: infile ! filename + real(rkind) :: dsec ! double precision seconds (not used) + real(rkind) :: dataJulDay ! julian day of current forcing data step being read + real(rkind) :: startJulDay ! julian day at the start of the year + real(rkind) :: currentJulDay ! Julian day of current time step + logical(lgt) :: isNewFile ! .true. if reading a new forcing file + logical(lgt) :: isRead ! .true. if reading data logical(lgt),parameter :: checkTime=.false. ! flag to check the time + ! error control + integer(i4b) :: ierr ! local error code + character(len=256) :: cmessage ! error message for downwind routine ! Start procedure here err=0; message="read_force/" + ! initialize new file + isNewFile = .false. + ! get the number of HRUs in the local simulation nHRUlocal = sum(gru_struc(:)%hruCount) - ! determine the julDay of current model step (istep) we need to read - if(istep==1)then + ! 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 @@ -131,12 +158,14 @@ subroutine read_force(istep,iFile,iRead,ncid,time_data,forcStruct,err,message) call getFirstTimestep(currentJulDay,iFile,iRead,ncid,err,cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + ! flag new file + isNewFile=.true. + end if ! if the file is not yet open ! ********************************************************************************************** - ! ***** 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 + ! ***** part 1a: if file open, check to see if we've reached the end of the file, if so close it, + ! ***** and open new file ! ********************************************************************************************** if(ncid>0)then @@ -158,33 +187,116 @@ subroutine read_force(istep,iFile,iRead,ncid,time_data,forcStruct,err,message) infile=trim(FORCING_PATH)//trim(forcFileInfo(iFile)%filenmData) ! open up the forcing file - call openForcingFile(iFile,trim(infile),ncId,err,cmessage) + call openForcingFile(iFile,trim(infile),ncid,err,cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + ! flag new file + isNewFile=.true. + ! reset iRead since we opened a new file iRead=1 end if ! if we've passed the end of the NetCDF file - ! read forcing data - call readForcingData(currentJulDay,ncId,iFile,iRead,nHRUlocal,time_data,forcStruct,err,message) - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if - ! 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 1b: allocate space for data structures and read the data + ! ********************************************************************************************** + + ! re-define data length and arrays if new file + if(isNewFile)then + + ! deallocate space + if(allocated(fulltimeVec)) deallocate(fulltimeVec) + if(allocated(fullforcingStruct)) deallocate(fullforcingStruct) + + ! get the number of time steps to read + select case(model_decisions(iLookDECISIONS%read_force)%iDecision) + case(readPerStep); nRead=1 ! ** read forcing data per time step (default) + case(readFullSeries) ! ** read full forcing series + nRemain = (numtim - iStep) + 1 ! number of remaining time steps in simulation + nData = (forcFileInfo(iFile)%nTimeSteps - iRead) + 1 ! number of remaining data steps in file (starting with iRead) + nRead = min(nRemain,nData) ! number of data steps to read + case default; err=10; message=trim(message)//'unable to identify option to read forcing data'; return + end select + + ! allocate space + allocate(fulltimeVec(nRead), stat=ierr) + if(ierr/=0)then; err=20; message=trim(message)//'problem allocating space for fulltimeVec'; return; endif + allocate(fullforcingStruct(nRead), source=forcStruct, stat=ierr) + if(ierr/=0)then; err=20; message=trim(message)//'problem allocating space for fullforcingStruct'; return; endif + + ! define starting index for the data read + ixStartRead = iRead + + endif ! if new file + + ! update ixStartRead and nRead for readPerStep + if(model_decisions(iLookDECISIONS%read_force)%iDecision == readPerStep)then + ixStartRead = iRead + nRead = 1 + endif + + ! check if we need to read the data + isRead = (isNewFile .or. model_decisions(iLookDECISIONS%read_force)%iDecision == readPerStep) + + ! read forcing data + ! NOTE: reads data into global variables fulltimeVec and fullforcingStruct + if(isRead)then + call readForcingData(ncid,iFile,ixStartRead,nRead,nHRUlocal,err,cmessage) + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + endif ! of reading the forcing data + + ! get the index in the data structures + jRead = (iRead - ixStartRead) + 1 + + ! get forcing structure for the desired time + forcStruct = fullforcingStruct(jRead) + #endif ! ********************************************************************************************** ! ***** part 2: compute time ! ********************************************************************************************** + ! check that the computed julian day matches the time information in the NetCDF file + dataJulDay = fulltimeVec(jRead)/forcFileInfo(iFile)%convTime2Days + refJulDay_data + if(abs(currentJulDay - dataJulDay) > timeDiffTol)then + write(message,'(a,f18.8,a,f18.8)') trim(message)//'date for time step: ',dataJulDay,' differs from the expected date: ',currentJulDay + err=40; return + end if + + ! convert julian day to time vector + ! NOTE: use small offset to force ih=0 at the start of the day + call compcalday(dataJulDay+smallOffset, & ! 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 + if(err/=0)then; message=trim(message)//trim(cmessage); return; end if + + ! check to see if any of the time data is missing -- note that it is OK if ih_tz or imin_tz are missing + if((time_data(iLookTIME%iyyy)==integerMissing) .or. & + (time_data(iLookTIME%im) ==integerMissing) .or. & + (time_data(iLookTIME%id) ==integerMissing) .or. & + (time_data(iLookTIME%ih) ==integerMissing) .or. & + (time_data(iLookTIME%imin)==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 + end if ! if time data is missing + ! compute the julian day at the start of the year - call compjulday(time_data(iLookTIME%iyyy), & ! input = year - 1, 1, 1, 1, 0._rkind, & ! input = month, day, hour, minute, second - startJulDay,err,cmessage) ! output = julian day (fraction of day) + error control + call compjulday(time_data(iLookTIME%iyyy), & ! input = year + 1, 1, 1, 1, 0._rkind, & ! 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; end if ! compute the fractional julian day for the current time step @@ -231,21 +343,16 @@ subroutine read_force(istep,iFile,iRead,ncid,time_data,forcStruct,err,message) end subroutine read_force - ! ******************************************************************************************************************* - ! ******************************************************************************************************************* - ! ******************************************************************************************************************* - ! ******************************************************************************************************************* - ! ******************************************************************************************************************* ! ************************************************************************* ! * private subroutine: find first timestep in any of the forcing files... ! ************************************************************************* subroutine getFirstTimestep(currentJulDay,iFile,iRead,ncid,err,message) USE netcdf ! netcdf capability - USE nr_utility_module,only:arth ! get a sequence of numbers + USE nr_utils_module,only:arth ! use to build vectors with regular increments implicit none ! define input - real(rkind),intent(in) :: currentJulDay ! Julian day of current time step + real(rkind),intent(in) :: currentJulDay ! Julian day of current time step ! define input-output variables integer(i4b),intent(inout) :: iFile ! index of current forcing file in forcing file list integer(i4b),intent(inout) :: iRead ! index of read position in time dimension in current netcdf file @@ -278,7 +385,7 @@ subroutine getFirstTimestep(currentJulDay,iFile,iRead,ncid,err,message) infile=trim(FORCING_PATH)//trim(forcFileInfo(iFile)%filenmData) ! open netCDF file - call openForcingFile(iFile,trim(infile),ncId,err,cmessage) + call openForcingFile(iFile,trim(infile),ncid,err,cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return; end if ! how many time steps in current file? @@ -337,7 +444,7 @@ end subroutine getFirstTimestep ! ************************************************************************* ! * open the NetCDF forcing file and get the time information ! ************************************************************************* - subroutine openForcingFile(iFile,infile,ncId,err,message) + subroutine openForcingFile(iFile,infile,ncid,err,message) USE netcdf ! netcdf capability USE netcdf_util_module,only:nc_file_open ! open netcdf file USE time_utils_module,only:fracDay ! compute fractional day @@ -351,14 +458,14 @@ subroutine openForcingFile(iFile,infile,ncId,err,message) ! dummy variables integer(i4b),intent(in) :: iFile ! index of current forcing file in forcing file list character(*) ,intent(in) :: infile ! input file - integer(i4b) ,intent(out) :: ncId ! NetCDF ID + integer(i4b) ,intent(out) :: ncid ! NetCDF ID integer(i4b) ,intent(out) :: err ! error code character(*) ,intent(out) :: message ! error message ! local variables character(len=256) :: cmessage ! error message for downwind routine integer(i4b) :: iyyy,im,id,ih,imin ! date integer(i4b) :: ih_tz,imin_tz ! time zone information - real(rkind) :: dsec,dsec_tz ! seconds + real(rkind) :: dsec,dsec_tz ! seconds integer(i4b) :: varId ! variable identifier integer(i4b) :: mode ! netcdf file mode integer(i4b) :: attLen ! attribute length @@ -413,74 +520,39 @@ end subroutine openForcingFile ! ************************************************************************* ! * read the NetCDF forcing data ! ************************************************************************* - subroutine readForcingData(currentJulDay,ncId,iFile,iRead,nHRUlocal,time_data,forcStruct,err,message) + subroutine readForcingData(ncid,iFile,ixStartRead,nRead,nHRUlocal,err,message) USE netcdf ! netcdf capability USE time_utils_module,only:compcalday ! convert julian day to calendar date USE time_utils_module,only:compJulDay ! convert calendar date to julian day USE get_ixname_module,only:get_ixForce ! identify index of named variable ! dummy variables - real(rkind),intent(in) :: currentJulDay ! Julian day of current time step - integer(i4b) ,intent(in) :: ncId ! NetCDF ID - integer(i4b) ,intent(in) :: iFile ! index of forcing file - integer(i4b) ,intent(in) :: iRead ! index in data file - integer(i4b) ,intent(in) :: nHRUlocal ! number of HRUs in the local simulation - integer(i4b),intent(out) :: time_data(:) ! vector of time data for a given time step - type(gru_hru_double) :: forcStruct ! x%gru(:)%hru(:)%var(:) -- model forcing data - integer(i4b) ,intent(out) :: err ! error code - character(*) ,intent(out) :: message ! error message + integer(i4b) ,intent(in) :: ncid ! NetCDF ID + integer(i4b) ,intent(in) :: iFile ! index of forcing file + integer(i4b) ,intent(in) :: ixStartRead ! starting index in data file + integer(i4b) ,intent(in) :: nRead ! number of time steps for the local data read + integer(i4b) ,intent(in) :: nHRUlocal ! number of HRUs in the local simulation + integer(i4b) ,intent(out) :: err ! error code + character(*) ,intent(out) :: message ! error message ! local variables - character(len=256) :: cmessage ! error message for downwind routine - integer(i4b) :: varId ! variable identifier - character(len = nf90_max_name) :: varName ! dimenison name - real(rkind) :: varTime(1) ! time variable of current forcing data step being read + integer(i4b) :: varId ! variable identifier + character(len = nf90_max_name) :: varName ! dimenison name ! other local variables - integer(i4b) :: iGRU,iHRU ! index of GRU and HRU - integer(i4b) :: iHRU_global ! index of HRU in the NetCDF file - integer(i4b) :: iHRU_local ! index of HRU in the data subset - integer(i4b) :: iline ! loop through lines in the file - integer(i4b) :: iNC ! loop through variables in forcing file - integer(i4b) :: iVar ! index of forcing variable in forcing data vector - real(rkind) :: dsec ! double precision seconds (not used) - real(rkind) :: dataJulDay ! julian day of current forcing data step being read - real(rkind),dimension(nHRUlocal) :: dataVec ! vector of data - real(rkind),dimension(1) :: dataVal ! single data value - real(rkind),parameter :: dataMin=-1._rkind ! minimum allowable data value (all forcing variables should be positive) - logical(lgt),dimension(size(forc_meta)) :: checkForce ! flags to check forcing data variables exist - logical(lgt),parameter :: simultaneousRead=.true. ! flag to denote reading all HRUs at once + integer(i4b) :: iTime ! time index + integer(i4b) :: iGRU,iHRU ! index of GRU and HRU + integer(i4b) :: iHRU_global ! index of HRU in the NetCDF file + integer(i4b) :: iHRU_local ! index of HRU in the data subset + integer(i4b) :: iline ! loop through lines in the file + integer(i4b) :: iNC ! loop through variables in forcing file + integer(i4b) :: iVar ! index of forcing variable in forcing data vector + real(rkind),dimension(nHRUlocal,nRead) :: dataMatrix ! vector of data + real(rkind),parameter :: dataMin=-1._rkind ! minimum allowable data value (all forcing variables should be positive) + logical(lgt),dimension(size(forc_meta)) :: checkForce ! flags to check forcing data variables exist ! Start procedure here err=0; message="readForcingData/" - ! initialize time and forcing data structures - time_data(:) = integerMissing - - ! 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 computed julian day matches the time information in the NetCDF file - dataJulDay = varTime(1)/forcFileInfo(iFile)%convTime2Days + refJulDay_data - if(abs(currentJulDay - dataJulDay) > timeDiffTol)then - write(message,'(a,f18.8,a,f18.8)') trim(message)//'date for time step: ',dataJulDay,' differs from the expected date: ',currentJulDay - err=40; return - end if - - ! convert julian day to time vector - ! NOTE: use small offset to force ih=0 at the start of the day - call compcalday(dataJulDay+smallOffset, & ! 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 - if(err/=0)then; message=trim(message)//trim(cmessage); return; end if - - ! check to see if any of the time data is missing -- note that it is OK if ih_tz or imin_tz are missing - if((time_data(iLookTIME%iyyy)==integerMissing) .or. (time_data(iLookTIME%im)==integerMissing) .or. (time_data(iLookTIME%id)==integerMissing) .or. (time_data(iLookTIME%ih)==integerMissing) .or. (time_data(iLookTIME%imin)==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 - end if + ! read time data starting 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,fulltimeVec,start=(/ixStartRead/),count=(/nRead/)); if(err/=nf90_noerr)then; message=trim(message)//'trouble reading time variable/'//trim(nf90_strerror(err)); return; endif ! initialize flags for forcing data checkForce(:) = .false. @@ -500,46 +572,40 @@ subroutine readForcingData(currentJulDay,ncId,iFile,iRead,nHRUlocal,time_data,fo err=nf90_inquire_variable(ncid,iNC,name=varName) if(err/=nf90_noerr)then; message=trim(message)//'problem reading forcing variable name from netCDF: '//trim(nf90_strerror(err)); return; endif - ! read forcing data for all HRUs - if(simultaneousRead)then - err=nf90_get_var(ncid,forcFileInfo(iFile)%data_id(ivar),dataVec,start=(/ixHRUfile_min,iRead/),count=(/nHRUlocal,1/)) - if(err/=nf90_noerr)then; message=trim(message)//'problem reading forcing data: '//trim(varName)//'/'//trim(nf90_strerror(err)); return; endif - endif - - ! loop through GRUs and HRUs - do iGRU=1,size(gru_struc) - do iHRU=1,gru_struc(iGRU)%hruCount - - ! define global HRU - iHRU_global = gru_struc(iGRU)%hruInfo(iHRU)%hru_nc - iHRU_local = (iHRU_global - ixHRUfile_min)+1 - - ! read forcing data for a single HRU - if(.not.simultaneousRead)then - err=nf90_get_var(ncid,forcFileInfo(iFile)%data_id(ivar),dataVal,start=(/iHRU_global,iRead/)) - if(err/=nf90_noerr)then; message=trim(message)//'problem reading forcing data: '//trim(varName)//'/'//trim(nf90_strerror(err)); return; endif - endif - - ! check the number of HRUs - if(iHRU_global > nHRUfile)then - message=trim(message)//'HRU index exceeds the number of HRUs in the forcing data file' - err=20; return - endif - - ! get individual data value - if(simultaneousRead) dataVal(1) = dataVec(iHRU_local) - - ! check individual data value - if(dataVal(1) nHRUfile)then + message=trim(message)//'HRU index exceeds the number of HRUs in the forcing data file' + err=20; return + endif + + ! check individual data value + if(dataMatrix(iHRU_local,iTime) < dataMin)then + write(message,'(a,f13.5)') trim(message)//'forcing data for variable '//trim(varName)//' is less than minimum allowable value ', dataMin + err=20; return + endif + + ! put the data into structures + fullforcingStruct(iTime)%gru(iGRU)%hru(iHRU)%var(iVar) = dataMatrix(iHRU_local,iTime) + + end do ! looping through HRUs within a given GRU + end do ! looping through GRUs + + end do ! looping through time end do ! loop through forcing variables @@ -547,7 +613,7 @@ subroutine readForcingData(currentJulDay,ncId,iFile,iRead,nHRUlocal,time_data,fo if(count(checkForce). module read_pinit_module -USE nrtype +USE nr_type ! check for when model decisions are undefined USE mDecisions_module,only: unDefined USE globalData,only:model_decisions @@ -64,10 +64,10 @@ subroutine read_pinit(filenm,isLocal,absEnergyFac,mpar_meta,parFallback,err,mess ! 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 + 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) :: iVar ! index of model variable ! Start procedure here err=0; message="read_pinit/" ! ********************************************************************************************** @@ -109,23 +109,23 @@ subroutine read_pinit(filenm,isLocal,absEnergyFac,mpar_meta,parFallback,err,mess if(iend/=0)exit !end of file 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 + 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; end if ! (identify the index of the variable in the data structure) if(isLocal)then - ivar = get_ixParam(trim(varname)) + iVar = get_ixParam(trim(varName)) else - ivar = get_ixBpar(trim(varname)) + iVar = get_ixBpar(trim(varName)) 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 + if(iVar>0)then + if(iVar>size(parFallback))then + err=35; message=trim(message)//"indexOutOfRange[var="//trim(varName)//"]"; return end if ! (put data in the structure) - parFallback(ivar)=parTemp + parFallback(iVar)=parTemp else - err=40; message=trim(message)//"variable in parameter file not present in data structure [var="//trim(varname)//"]"; return + 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) @@ -147,9 +147,9 @@ subroutine read_pinit(filenm,isLocal,absEnergyFac,mpar_meta,parFallback,err,mess ! 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_rkind*realMissing))then - do ivar=1,size(parFallback) - if(parFallback(ivar)%default_val < 0.99_rkind*realMissing)then - err=40; message=trim(message)//"variableNonexistent[var="//trim(mpar_meta(ivar)%varname)//"]"; return + do iVar=1,size(parFallback) + if(parFallback(iVar)%default_val < 0.99_rkind*realMissing)then + err=40; message=trim(message)//"variableNonexistent[var="//trim(mpar_meta(iVar)%varName)//"]"; return end if end do end if diff --git a/build/source/engine/run_oneGRU.f90 b/build/source/engine/run_oneGRU.f90 index b416ffa94..8c25ac91d 100644 --- a/build/source/engine/run_oneGRU.f90 +++ b/build/source/engine/run_oneGRU.f90 @@ -21,7 +21,7 @@ module run_oneGRU_module ! numerical recipes data types -USE nrtype +USE nr_type ! access integers to define "yes" and "no" USE globalData,only:yes,no ! .true. and .false. @@ -48,6 +48,7 @@ module run_oneGRU_module USE var_lookup,only:iLookATTR ! look-up values for local attributes USE var_lookup,only:iLookINDEX ! look-up values for local column index variables USE var_lookup,only:iLookFLUX ! look-up values for local column model fluxes +USE var_lookup,only:iLookDIAG ! look-up values model diagnostic variables USE var_lookup,only:iLookBVAR ! look-up values for basin-average model variables ! provide access to model decisions @@ -105,7 +106,7 @@ subroutine run_oneGRU(& ! data structures (input) integer(i4b) , intent(in) :: timeVec(:) ! integer vector -- model time data type(hru_int) , intent(in) :: typeHRU ! x%hru(:)%var(:) -- local classification of soil veg etc. for each HRU - type(hru_int8) , intent(in) :: idHRU ! x%hru(:)%var(:) -- local classification of hru and gru IDs + type(hru_int8) , intent(in) :: idHRU ! x%hru(:)%var(:) -- local values of hru and gru IDs type(hru_double) , intent(in) :: attrHRU ! x%hru(:)%var(:) -- local attributes for each HRU type(hru_z_vLookup) , intent(in) :: lookupHRU ! x%hru(:)%z(:)%var(:)%lookup(:) -- lookup values for each HRU ! data structures (input-output) @@ -124,9 +125,6 @@ subroutine run_oneGRU(& character(len=512) :: cmessage ! error message integer(i4b) :: iHRU ! HRU index integer(i4b) :: jHRU,kHRU ! index of the hydrologic response unit - integer(i4b) :: nSnow ! number of snow layers - integer(i4b) :: nSoil ! number of soil layers - integer(i4b) :: nLayers ! total number of layers real(rkind) :: fracHRU ! fractional area of a given HRU (-) logical(lgt) :: computeVegFluxFlag ! flag to indicate if we are computing fluxes over vegetation (.false. means veg is buried with snow) @@ -146,6 +144,9 @@ subroutine run_oneGRU(& bvarData%var(iLookBVAR%basin__AquiferBaseflow)%dat(1) = 0._rkind ! baseflow from the aquifer (m s-1) bvarData%var(iLookBVAR%basin__AquiferTranspire)%dat(1) = 0._rkind ! transpiration loss from the aquifer (m s-1) + ! initialize storage change variable + bvarData%var(iLookBVAR%basin__StorageChange)%dat(1) = 0._rkind ! change in total basin storage (m s-1) + ! initialize total inflow for each layer in a soil column do iHRU=1,gruInfo%hruCount fluxHRU%hru(iHRU)%var(iLookFLUX%mLayerColumnInflow)%dat(:) = 0._rkind @@ -155,16 +156,7 @@ subroutine run_oneGRU(& ! loop through HRUs do iHRU=1,gruInfo%hruCount - ! ----- hru initialization --------------------------------------------------------------------------------------------- - - ! update the number of layers - nSnow = indxHRU%hru(iHRU)%var(iLookINDEX%nSnow)%dat(1) ! number of snow layers - nSoil = indxHRU%hru(iHRU)%var(iLookINDEX%nSoil)%dat(1) ! number of soil layers - nLayers = indxHRU%hru(iHRU)%var(iLookINDEX%nLayers)%dat(1) ! total number of layers - - ! set the flag to compute the vegetation flux - computeVegFluxFlag = (ixComputeVegFlux(iHRU) == yes) - + computeVegFluxFlag = (ixComputeVegFlux(iHRU) == yes) ! set the flag to compute the vegetation flux ! ----- run the model -------------------------------------------------------------------------------------------------- ! simulation for a single HRU @@ -174,7 +166,7 @@ subroutine run_oneGRU(& gruInfo%hruInfo(iHRU)%hru_id, & ! intent(in): hruId dt_init(iHRU), & ! intent(inout): initial time step computeVegFluxFlag, & ! intent(inout): flag to indicate if we are computing fluxes over vegetation (false=no, true=yes) - nSnow,nSoil,nLayers, & ! intent(inout): number of snow and soil layers + gruInfo%hruInfo(iHRU), & ! intent(inout): HRU layer information ! data structures (input) timeVec, & ! intent(in): model time data typeHRU%hru(iHRU), & ! intent(in): local classification of soil veg etc. for each HRU @@ -192,10 +184,6 @@ subroutine run_oneGRU(& err,cmessage) ! intent(out): error control if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif - ! update layer numbers that could be changed in run_oneHRU -- needed for model output - gruInfo%hruInfo(iHRU)%nSnow = nSnow - gruInfo%hruInfo(iHRU)%nSoil = nSoil - ! save the flag for computing the vegetation fluxes if(computeVegFluxFlag) ixComputeVegFlux(iHRU) = yes if(.not. computeVegFluxFlag) ixComputeVegFlux(iHRU) = no @@ -228,11 +216,12 @@ subroutine run_oneGRU(& end if ! ----- calculate weighted basin (GRU) fluxes -------------------------------------------------------------------------------------- + bvarData%var(iLookBVAR%basin__StorageChange)%dat(1) = bvarData%var(iLookBVAR%basin__StorageChange)%dat(1) + diagHRU%hru(iHRU)%var(iLookDIAG%scalarTotalMassChange)%dat(1)*fracHRU ! increment basin surface runoff (m s-1) - bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) = bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) + fluxHRU%hru(iHRU)%var(iLookFLUX%scalarSurfaceRunoff)%dat(1)*fracHRU + bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) = bvarData%var(iLookBVAR%basin__SurfaceRunoff)%dat(1) + fluxHRU%hru(iHRU)%var(iLookFLUX%scalarSurfaceRunoff)%dat(1)*fracHRU ! increment basin soil drainage (m s-1) - bvarData%var(iLookBVAR%basin__SoilDrainage)%dat(1) = bvarData%var(iLookBVAR%basin__SoilDrainage)%dat(1) + fluxHRU%hru(iHRU)%var(iLookFLUX%scalarSoilDrainage)%dat(1) *fracHRU + bvarData%var(iLookBVAR%basin__SoilDrainage)%dat(1) = bvarData%var(iLookBVAR%basin__SoilDrainage)%dat(1) + fluxHRU%hru(iHRU)%var(iLookFLUX%scalarSoilDrainage)%dat(1) *fracHRU ! increment aquifer variables -- ONLY if aquifer baseflow is computed individually for each HRU and aquifer is run ! NOTE: groundwater computed later for singleBasin diff --git a/build/source/engine/run_oneHRU.f90 b/build/source/engine/run_oneHRU.f90 index fe8791b38..3df9f0001 100644 --- a/build/source/engine/run_oneHRU.f90 +++ b/build/source/engine/run_oneHRU.f90 @@ -21,10 +21,11 @@ module run_oneHRU_module ! numerical recipes data types -USE nrtype +USE nr_type ! data types USE data_types,only:& + hru_info, & ! HRU info (i4b) var_i, & ! x%var(:) (i4b) var_d, & ! x%var(:) (rkind) var_ilength, & ! x%var(:)%dat (i4b) @@ -34,7 +35,6 @@ module run_oneHRU_module ! access vegetation data USE globalData,only:greenVegFrac_monthly ! fraction of green vegetation in each month (0-1) USE globalData,only:overwriteRSMIN ! flag to overwrite RSMIN -USE globalData,only:maxSoilLayers ! Maximum Number of Soil Layers ! provide access to Noah-MP constants USE module_sf_noahmplsm,only:isWater ! parameter for water land cover type @@ -90,7 +90,7 @@ subroutine run_oneHRU(& hruId, & ! intent(in): hruId dt_init, & ! intent(inout): used to initialize the length of the sub-step for each HRU computeVegFlux, & ! intent(inout): flag to indicate if we are computing fluxes over vegetation (false=no, true=yes) - nSnow,nSoil,nLayers, & ! intent(inout): number of snow and soil layers + hruInfo, & ! intent(inout): HRU number of snow and soil layers ! data structures (input) timeVec, & ! intent(in): model time data typeData, & ! intent(in): local classification of soil veg etc. for each HRU @@ -121,7 +121,7 @@ subroutine run_oneHRU(& integer(i8b) , intent(in) :: hruId ! hruId real(rkind) , intent(inout) :: dt_init ! used to initialize the length of the sub-step for each HRU logical(lgt) , intent(inout) :: computeVegFlux ! flag to indicate if we are computing fluxes over vegetation (false=no, true=yes) - integer(i4b) , intent(inout) :: nSnow,nSoil,nLayers ! number of snow and soil layers + type(hru_info) , intent(inout) :: hruInfo ! HRU number of snow and soil layers ! data structures (input) integer(i4b) , intent(in) :: timeVec(:) ! int vector -- model time data type(var_i) , intent(in) :: typeData ! x%var(:) -- local classification of soil veg etc. for each HRU @@ -164,7 +164,7 @@ subroutine run_oneHRU(& call REDPRM(typeData%var(iLookTYPE%vegTypeIndex), & ! vegetation type index typeData%var(iLookTYPE%soilTypeIndex), & ! soil type typeData%var(iLookTYPE%slopeTypeIndex), & ! slope type index - maxSoilLayers, & ! number of soil layers + 10000_i4b, & ! number of soil layers urbanVegCategory) ! vegetation category for urban areas ! overwrite the minimum resistance @@ -222,9 +222,8 @@ subroutine run_oneHRU(& if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif ! update the number of layers - nSnow = indxData%var(iLookINDEX%nSnow)%dat(1) ! number of snow layers - nSoil = indxData%var(iLookINDEX%nSoil)%dat(1) ! number of soil layers - nLayers = indxData%var(iLookINDEX%nLayers)%dat(1) ! total number of layers + hruInfo%nSnow = indxData%var(iLookINDEX%nSnow)%dat(1) ! number of snow layers + hruInfo%nSoil = indxData%var(iLookINDEX%nSoil)%dat(1) ! number of soil layers end subroutine run_oneHRU diff --git a/build/source/engine/snowAlbedo.f90 b/build/source/engine/snowAlbedo.f90 index 22651619d..7967434a7 100644 --- a/build/source/engine/snowAlbedo.f90 +++ b/build/source/engine/snowAlbedo.f90 @@ -21,7 +21,7 @@ module snowAlbedo_module ! data types -USE nrtype ! numerical recipes data types +USE nr_type ! numerical recipes data types USE globalData,only:realMissing ! missing real number ! physical constants @@ -166,7 +166,7 @@ subroutine snowAlbedo(& albedoMin = albedoMinWinter end if ! compute average albedo - call computeAlbedo(scalarSnowAlbedo,refreshFactor,decayFactor,albedoMax,albedoMin) + call computAlbedo(scalarSnowAlbedo,refreshFactor,decayFactor,albedoMax,albedoMin) ! assume albedo is the same in visible and near infra-red bands, and for direct and diffuse radiation spectralSnowAlbedoDiffuse(ixVisible) = scalarSnowAlbedo spectralSnowAlbedoDiffuse(ixNearIR) = scalarSnowAlbedo @@ -182,8 +182,8 @@ subroutine snowAlbedo(& age3 = albedoSootLoad ! soot loading decayFactor = dt*(age1 + age2 + age3)/albedoDecayRate ! compute diffuse albedo for the different spectral bands - call computeAlbedo(spectralSnowAlbedoDiffuse(ixVisible),refreshFactor,decayFactor,albedoMaxVisible,albedoMinVisible) - call computeAlbedo(spectralSnowAlbedoDiffuse(ixNearIR), refreshFactor,decayFactor,albedoMaxNearIR, albedoMinNearIR) + call computAlbedo(spectralSnowAlbedoDiffuse(ixVisible),refreshFactor,decayFactor,albedoMaxVisible,albedoMinVisible) + call computAlbedo(spectralSnowAlbedoDiffuse(ixNearIR), refreshFactor,decayFactor,albedoMaxNearIR, albedoMinNearIR) ! compute factor to modify direct albedo at low zenith angles if(cosZenith < 0.5_rkind)then fZen = (1._rkind/bPar)*( ((1._rkind + bPar)/(1._rkind + 2._rkind*bPar*cosZenith)) - 1._rkind) @@ -213,9 +213,9 @@ end subroutine snowAlbedo ! ******************************************************************************************************* - ! private subroutine computeAlbedo: compute change in albedo -- implicit solution + ! private subroutine computAlbedo: compute change in albedo -- implicit solution ! ******************************************************************************************************* - subroutine computeAlbedo(snowAlbedo,refreshFactor,decayFactor,albedoMax,albedoMin) + subroutine computAlbedo(snowAlbedo,refreshFactor,decayFactor,albedoMax,albedoMin) implicit none ! dummy variables real(rkind),intent(inout) :: snowAlbedo ! snow albedo (-) @@ -229,7 +229,7 @@ subroutine computeAlbedo(snowAlbedo,refreshFactor,decayFactor,albedoMax,albedoMi albedoChange = refreshFactor*(albedoMax - snowAlbedo) - (decayFactor*(snowAlbedo - albedoMin)) / (1._rkind + decayFactor) snowAlbedo = snowAlbedo + albedoChange if(snowAlbedo > albedoMax) snowAlbedo = albedoMax - end subroutine computeAlbedo + end subroutine computAlbedo end module snowAlbedo_module diff --git a/build/source/engine/snwCompact.f90 b/build/source/engine/snowDepth.f90 similarity index 56% rename from build/source/engine/snwCompact.f90 rename to build/source/engine/snowDepth.f90 index 5a66f0261..ab0dc9730 100644 --- a/build/source/engine/snwCompact.f90 +++ b/build/source/engine/snowDepth.f90 @@ -1,44 +1,142 @@ -! SUMMA - Structure for Unifying Multiple Modeling Alternatives -! Copyright (C) 2014-2020 NCAR/RAL; University of Saskatchewan; University of Washington -! -! This file is part of SUMMA -! -! For more information see: http://www.ral.ucar.edu/projects/summa -! -! This program is free software: you can redistribute it and/or modify -! it under the terms of the GNU General Public License as published by -! the Free Software Foundation, either version 3 of the License, or -! (at your option) any later version. -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program. If not, see . - -module snwDensify_module +module snowDepth_module ! data types -USE nrtype +USE nr_type +USE data_types,only:& + var_ilength, & ! x%var(:)%dat (i4b) + var_dlength, & ! x%var(:)%dat (rkind) + zLookup ! x%z(:)%var(:)%lookup(:) (rkind) -! model constants +! constants USE multiconst,only:& - Tfreeze, & ! freezing point of pure water (K) - iden_ice, & ! intrinsic density of ice (kg m-3) - iden_air, & ! intrinsic density of air (kg m-3) - iden_water ! intrinsic density of liquid water (kg m-3) + Tfreeze, & ! freezing temperature (K) + iden_ice, & ! intrinsic density of ice (kg m-3) + iden_air, & ! intrinsic density of air (kg m-3) + iden_water ! intrinsic density of liquid water (kg m-3) +USE globalData,only:verySmall ! a small number + +! 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 + ! privacy implicit none private -public::snwDensify +public::snowDepth + contains +! ************************************************************************************************ +! public subroutine snowDepth: compute snow depth for one sub timestep +! ************************************************************************************************ +subroutine snowDepth(& + dt_sub, & ! intent(in): time step (s) + nSnow, & ! intent(in): number of snow layers + scalarSnowSublimation, & ! intent(in): scalar sublimation of snow (kg m-2) + mLayerVolFracLiq, & ! intent(inout): volumetric fraction of liquid water in each layer (-) + mLayerVolFracIce, & ! intent(inout): volumetric fraction of ice in each layer (-) + mLayerTemp, & ! intent(in): temperature of each layer (K) + mLayerMeltFreeze, & ! intent(in): volumetric melt in each layer (kg m-3) + mpar_data, & ! intent(in): model parameters + ! output + tooMuchSublim, & ! intent(out): flag to denote that there was too much sublimation in a given time step + mLayerDepth, & ! intent(inout): depth of each layer (m) + ! error control + err,message) ! intent(out): error control + + ! ----------------------------------------------------------------------------------------------------------------------------------------- + implicit none + real(qp),intent(in) :: dt_sub ! time step (s) + integer(i4b),intent(in) :: nSnow ! number of snow layers + real(rkind),intent(in) :: scalarSnowSublimation ! scalar sublimation of snow (kg m-2) + real(rkind),intent(inout) :: mLayerVolFracLiq(:) ! volumetric fraction of liquid water in each layer (-) + real(rkind),intent(inout) :: mLayerVolFracIce(:) ! volumetric fraction of ice in each layer (-) + real(rkind),intent(in) :: mLayerTemp(:) ! temperature of each layer (K) + real(rkind),intent(in) :: mLayerMeltFreeze(:) ! volumetric melt in each layer (kg m-3) + type(var_dlength),intent(in) :: mpar_data ! model parameters + logical(lgt) :: tooMuchSublim ! flag to denote that there was too much sublimation in a given time step + real(rkind),intent(inout) :: mLayerDepth(:) ! depth of each layer (m) + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! local variables + character(len=256) :: cmessage ! error message + integer(i4b) :: iSnow ! index of snow layers + real(rkind) :: massLiquid ! mass liquid water (kg m-2) + + ! * compute change in ice content of the top snow layer due to sublimation... + ! --------------------------------------------------------------------------- + ! initialize the flags + tooMuchSublim=.false. ! too much sublimation (merge snow layers) + ! NOTE: this is done BEFORE densification + if(nSnow>0)then ! snow layers exist + + ! try to remove ice from the top layer + iSnow=1 + + ! save the mass of liquid water (kg m-2) + massLiquid = mLayerDepth(iSnow)*mLayerVolFracLiq(iSnow)*iden_water + + ! add/remove the depth of snow gained/lost by frost/sublimation (m) + ! NOTE: assume constant density + mLayerDepth(iSnow) = mLayerDepth(iSnow) + dt_sub*scalarSnowSublimation/(mLayerVolFracIce(iSnow)*iden_ice) + + ! check that we did not remove the entire layer + if(mLayerDepth(iSnow) < verySmall)then + tooMuchSublim=.true. + return + endif + + ! update the volumetric fraction of liquid water + mLayerVolFracLiq(iSnow) = massLiquid / (mLayerDepth(iSnow)*iden_water) + + ! no snow + else + + ! no snow: check that sublimation is zero + if(abs(scalarSnowSublimation) > verySmall)then + message=trim(message)//'sublimation of snow has been computed when no snow exists' + err=20; return + end if + + end if ! (if snow layers exist) + + + ! *** account for compaction and cavitation in the snowpack... + ! ------------------------------------------------------------ + if(nSnow>0)then + call snowDensify(& + ! intent(in): variables + dt_sub, & ! intent(in): time step (s) + nSnow, & ! intent(in): number of snow layers + mLayerTemp(1:nSnow), & ! intent(in): temperature of each layer (K) + mLayerMeltFreeze(1:nSnow), & ! intent(in): volumetric melt in each layer (kg m-3) + ! intent(in): parameters + mpar_data%var(iLookPARAM%densScalGrowth)%dat(1), & ! intent(in): density scaling factor for grain growth (kg-1 m3) + mpar_data%var(iLookPARAM%tempScalGrowth)%dat(1), & ! intent(in): temperature scaling factor for grain growth (K-1) + mpar_data%var(iLookPARAM%grainGrowthRate)%dat(1), & ! intent(in): rate of grain growth (s-1) + mpar_data%var(iLookPARAM%densScalOvrbdn)%dat(1), & ! intent(in): density scaling factor for overburden pressure (kg-1 m3) + mpar_data%var(iLookPARAM%tempScalOvrbdn)%dat(1), & ! intent(in): temperature scaling factor for overburden pressure (K-1) + mpar_data%var(iLookPARAM%baseViscosity)%dat(1), & ! intent(in): viscosity coefficient at T=T_frz and snow density=0 (kg m-2 s) + ! intent(inout): state variables + mLayerDepth(1:nSnow), & ! intent(inout): depth of each layer (m) + mLayerVolFracLiq(1:nSnow), & ! intent(inout): volumetric fraction of liquid water after itertations (-) + mLayerVolFracIce(1:nSnow), & ! intent(inout): volumetric fraction of ice after itertations (-) + ! output: error control + err,cmessage) ! intent(out): error control + if(err/=0)then; err=55; message=trim(message)//trim(cmessage); return; end if + end if ! if snow layers exist + +end subroutine snowDepth + + +! ************************************************************************************************ + ! public subroutine snowDensify: compute change in snow density over the time step ! ************************************************************************************************ - ! public subroutine snwDensify: compute change in snow density over the time step - ! ************************************************************************************************ - subroutine snwDensify(& + subroutine snowDensify(& ! intent(in): variables dt, & ! intent(in): time step (s) nSnow, & ! intent(in): number of snow layers @@ -100,7 +198,7 @@ subroutine snwDensify(& real(rkind),parameter :: minLayerDensity=40._rkind ! minimum snow density allowed for any layer (kg m-3) ! ----------------------------------------------------------------------------------------------------------------------------------------- ! initialize error control - err=0; message="snwDensify/" + err=0; message="snowDensify/" ! NOTE: still need to process the case of "snow without a layer" if(nSnow==0)return @@ -159,13 +257,6 @@ subroutine snwDensify(& scalarDepthMin = (massIceOld / iden_ice) + (massLiqOld / iden_water) mLayerDepth(iSnow) = max(scalarDepthMin, scalarDepthNew) - ! check that depth is reasonable - if(mLayerDepth(iSnow) < 0._rkind)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) @@ -192,7 +283,7 @@ subroutine snwDensify(& err=20; return end if - end subroutine snwDensify + end subroutine snowDensify +end module snowDepth_module -end module snwDensify_module diff --git a/build/source/engine/snowLiqFlx.f90 b/build/source/engine/snowLiqFlux.f90 similarity index 80% rename from build/source/engine/snowLiqFlx.f90 rename to build/source/engine/snowLiqFlux.f90 index 6d1aa6951..0d68a59fd 100644 --- a/build/source/engine/snowLiqFlx.f90 +++ b/build/source/engine/snowLiqFlux.f90 @@ -18,10 +18,10 @@ ! You should have received a copy of the GNU General Public License ! along with this program. If not, see . -module snowLiqFlx_module +module snowLiqFlux_module ! access modules -USE nrtype ! numerical recipes data types +USE nr_type ! numerical recipes data types USE multiconst,only:iden_ice,iden_water ! intrinsic density of ice and water (kg m-3) ! access missing values @@ -39,42 +39,42 @@ module snowLiqFlx_module USE data_types,only:var_d ! x%var(:) [rkind] USE data_types,only:var_dlength ! x%var(:)%dat [rkind] USE data_types,only:var_ilength ! x%var(:)%dat [i4b] -USE data_types,only:in_type_snowLiqFlx ! data type for intent(in) arguments -USE data_types,only:io_type_snowLiqFlx ! data type for intent(inout) arguments -USE data_types,only:out_type_snowLiqFlx ! data type for intent(out) arguments +USE data_types,only:in_type_snowLiqFlux ! data type for intent(in) arguments +USE data_types,only:io_type_snowLiqFlux ! data type for intent(inout) arguments +USE data_types,only:out_type_snowLiqFlux ! data type for intent(out) arguments ! privacy implicit none private -public :: snowLiqFlx +public :: snowLiqFlux contains ! ************************************************************************************************ -! public subroutine snowLiqFlx: compute liquid water flux through the snowpack +! public subroutine snowLiqFlux: compute liquid water flux through the snowpack ! ************************************************************************************************ -subroutine snowLiqFlx(& +subroutine snowLiqFlux(& ! input: model control, forcing, and model state vector - in_snowLiqFlx, & ! intent(in): model control, forcing, and model state vector + in_snowLiqFlux, & ! intent(in): model control, forcing, and model state vector ! input-output: data structures indx_data, & ! intent(in): model indices mpar_data, & ! intent(in): model parameters prog_data, & ! intent(in): model prognostic variables for a local HRU diag_data, & ! intent(inout): model diagnostic variables for a local HRU ! input-output: fluxes and derivatives - io_snowLiqFlx, & ! intent(inout): fluxes and derivatives + io_snowLiqFlux, & ! intent(inout): fluxes and derivatives ! output: error control - out_snowLiqFlx) ! intent(out): error control + out_snowLiqFlux) ! intent(out): error control implicit none ! input: model control, forcing, and model state vector - type(in_type_snowLiqFlx) :: in_snowLiqFlx ! model control, forcing, and model state vector + type(in_type_snowLiqFlux) :: in_snowLiqFlux ! model control, forcing, and model state vector ! input-output: data structures type(var_ilength),intent(in) :: indx_data ! model indices type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU ! input-output: fluxes and derivatives - type(io_type_snowLiqFlx) :: io_snowLiqFlx ! fluxes and derivatives + type(io_type_snowLiqFlux) :: io_snowLiqFlux ! fluxes and derivatives ! output: error control - type(out_type_snowLiqFlx) :: out_snowLiqFlx ! error control + type(out_type_snowLiqFlux) :: out_snowLiqFlux ! error control ! ------------------------------ ------------------------------------------------------------------------------------------------------------ ! local variables integer(i4b) :: nSnow ! number of snow layers @@ -89,16 +89,16 @@ subroutine snowLiqFlx(& real(rkind) :: relSaturn ! relative saturation [0,1] (-) ! ------------------------------------------------------------------------------------------------------------------------------------------ ! make association of local variables with information in the data structures - nSnow=in_snowLiqFlx % nSnow ! get number of snow layers + nSnow=in_snowLiqFlux % nSnow ! get number of snow layers associate(& ! input: model control - firstFluxCall => in_snowLiqFlx % firstFluxCall, & ! intent(in): the first flux call - scalarSolution => in_snowLiqFlx % scalarSolution, & ! intent(in): flag to denote if implementing the scalar solution + firstFluxCall => in_snowLiqFlux % firstFluxCall, & ! intent(in): the first flux call + scalarSolution => in_snowLiqFlux % scalarSolution, & ! intent(in): flag to denote if implementing the scalar solution ! input: forcing for the snow domain - scalarThroughfallRain => in_snowLiqFlx % scalarThroughfallRain, & ! intent(in): computed throughfall rate (kg m-2 s-1) - scalarCanopyLiqDrainage => in_snowLiqFlx % scalarCanopyLiqDrainage, & ! intent(in): computed drainage of liquid water (kg m-2 s-1) + scalarThroughfallRain => in_snowLiqFlux % scalarThroughfallRain, & ! intent(in): computed throughfall rate (kg m-2 s-1) + scalarCanopyLiqDrainage => in_snowLiqFlux % scalarCanopyLiqDrainage, & ! intent(in): computed drainage of liquid water (kg m-2 s-1) ! input: model state vector - mLayerVolFracLiqTrial => in_snowLiqFlx % mLayerVolFracLiqTrial, & ! intent(in): trial value of volumetric fraction of liquid water at the current iteration (-) + mLayerVolFracLiqTrial => in_snowLiqFlux % mLayerVolFracLiqTrial, & ! intent(in): trial value of volumetric fraction of liquid water at the current iteration (-) ! input: layer indices ixLayerState => indx_data%var(iLookINDEX%ixLayerState)%dat, & ! intent(in): list of indices for all model layers ixSnowOnlyHyd => indx_data%var(iLookINDEX%ixSnowOnlyHyd)%dat, & ! intent(in): index in the state subset for hydrology state variables in the snow domain @@ -111,15 +111,15 @@ subroutine snowLiqFlx(& mLayerPoreSpace => diag_data%var(iLookDIAG%mLayerPoreSpace)%dat, & ! intent(inout): pore space in each snow layer (-) mLayerThetaResid => diag_data%var(iLookDIAG%mLayerThetaResid)%dat, & ! intent(inout): esidual volumetric liquid water content in each snow layer (-) ! input-output: fluxes and derivatives - iLayerLiqFluxSnow => io_snowLiqFlx % iLayerLiqFluxSnow, & ! intent(inout): vertical liquid water flux at layer interfaces (m s-1) - iLayerLiqFluxSnowDeriv => io_snowLiqFlx % iLayerLiqFluxSnowDeriv, & ! intent(inout): derivative in vertical liquid water flux at layer interfaces (m s-1) + iLayerLiqFluxSnow => io_snowLiqFlux % iLayerLiqFluxSnow, & ! intent(inout): vertical liquid water flux at layer interfaces (m s-1) + iLayerLiqFluxSnowDeriv => io_snowLiqFlux % iLayerLiqFluxSnowDeriv, & ! intent(inout): derivative in vertical liquid water flux at layer interfaces (m s-1) ! output: error control - err => out_snowLiqFlx % err, & ! intent(out): error code - message => out_snowLiqFlx % cmessage & ! intent(out): error message + err => out_snowLiqFlux % err, & ! intent(out): error code + message => out_snowLiqFlux % cmessage & ! intent(out): error message ) ! end association of local variables with information in the data structures ! ------------------------------------------------------------------------------------------------------------------------------------------ ! initialize error control - err=0; message='snowLiqFlx/' + err=0; message='snowLiqFlux/' ! check that the input vectors match nSnow if (size(mLayerVolFracLiqTrial)/=nSnow .or. size(mLayerVolFracIce)/=nSnow .or. & @@ -182,6 +182,6 @@ subroutine snowLiqFlx(& end associate ! end association of local variables with information in the data structures -end subroutine snowLiqFlx +end subroutine snowLiqFlux -end module snowLiqFlx_module +end module snowLiqFlux_module diff --git a/build/source/engine/ssdNrgFlux.f90 b/build/source/engine/snowSoilNrgFlux.f90 similarity index 77% rename from build/source/engine/ssdNrgFlux.f90 rename to build/source/engine/snowSoilNrgFlux.f90 index 1405a78ca..ca3e8a502 100644 --- a/build/source/engine/ssdNrgFlux.f90 +++ b/build/source/engine/snowSoilNrgFlux.f90 @@ -18,18 +18,18 @@ ! You should have received a copy of the GNU General Public License ! along with this program. If not, see . -module ssdNrgFlux_module +module snowSoilNrgFlux_module ! data types -USE nrtype +USE nr_type ! data types USE data_types,only:var_d ! x%var(:) [rkind] USE data_types,only:var_dlength ! x%var(:)%dat [rkind] USE data_types,only:var_ilength ! x%var(:)%dat [i4b] -USE data_types,only:in_type_ssdNrgFlux ! intent(in) arguments for ssdNrgFlux -USE data_types,only:io_type_ssdNrgFlux ! intent(inout) arguments for ssdNrgFlux -USE data_types,only:out_type_ssdNrgFlux ! intent(out) arguments for ssdNrgFlux +USE data_types,only:in_type_snowSoilNrgFlux ! intent(in) arguments for snowSoilNrgFlux +USE data_types,only:io_type_snowSoilNrgFlux ! intent(inout) arguments for snowSoilNrgFlux +USE data_types,only:out_type_snowSoilNrgFlux ! intent(out) arguments for snowSoilNrgFlux ! physical constants USE multiconst,only:& @@ -67,29 +67,28 @@ module ssdNrgFlux_module ! ------------------------------------------------------------------------------------------------- implicit none private -public :: ssdNrgFlux -! global parameters -real(rkind),parameter :: dx=1.e-10_rkind ! finite difference increment (K) +public :: snowSoilNrgFlux + contains ! ********************************************************************************************************** -! public subroutine ssdNrgFlux: compute energy fluxes and derivatives at layer interfaces +! public subroutine snowSoilNrgFlux: compute energy fluxes and derivatives at layer interfaces ! ********************************************************************************************************** -subroutine ssdNrgFlux(& +subroutine snowSoilNrgFlux(& ! input: model control, fluxes, trial variables, and derivatives - in_ssdNrgFlux, & ! intent(in): model control, fluxes, trial variables, and derivatives + in_snowSoilNrgFlux, & ! intent(in): model control, fluxes, trial variables, and derivatives ! input-output: data structures and derivatives mpar_data, & ! intent(in): model parameters indx_data, & ! intent(in): model indices prog_data, & ! intent(in): model prognostic variables for a local HRU diag_data, & ! intent(in): model diagnostic variables for a local HRU flux_data, & ! intent(inout): model fluxes for a local HRU - io_ssdNrgFlux, & ! intent(inout): derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) + io_snowSoilNrgFlux, & ! intent(inout): derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) ! output: fluxes and derivatives at all layer interfaces and error control - out_ssdNrgFlux) ! intent(out): derivatives and error control + out_snowSoilNrgFlux) ! intent(out): derivatives and error control ! ------------------------------------------------------------------------------------------------------------------------------------------------- implicit none ! input: model control, fluxes, trial variables, and derivatives - type(in_type_ssdNrgFlux),intent(in) :: in_ssdNrgFlux ! input ssdNrgFlux arguments + type(in_type_snowSoilNrgFlux),intent(in) :: in_snowSoilNrgFlux ! input snowSoilNrgFlux arguments ! input-output: data structures type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_ilength),intent(in) :: indx_data ! state vector geometry @@ -97,12 +96,11 @@ subroutine ssdNrgFlux(& type(var_dlength),intent(in) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU ! input-output: derivatives - type(io_type_ssdNrgFlux),intent(inout) :: io_ssdNrgFlux ! input-output ssdNrgFlux arguments + type(io_type_snowSoilNrgFlux),intent(inout) :: io_snowSoilNrgFlux ! input-output snowSoilNrgFlux arguments ! output: fluxes and derivatives at all layer interfaces - type(out_type_ssdNrgFlux),intent(inout) :: out_ssdNrgFlux ! output ssdNrgFlux arguments + type(out_type_snowSoilNrgFlux),intent(inout) :: out_snowSoilNrgFlux ! output snowSoilNrgFlux arguments ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! local variables - !character(LEN=256) :: cmessage ! error message of downwind routine integer(i4b) :: nLayers ! number of model layers integer(i4b) :: iLayer ! index of model layers integer(i4b) :: ixLayerDesired(1) ! layer desired (scalar solution) @@ -114,28 +112,28 @@ subroutine ssdNrgFlux(& ! allocate intent(out) data structure components nLayers=indx_data%var(iLookINDEX%nLayers)%dat(1) allocate(& - out_ssdNrgFlux % iLayerNrgFlux(0:nLayers), & ! energy flux at the layer interfaces (W m-2) - out_ssdNrgFlux % dNrgFlux_dTempAbove(0:nLayers), & ! derivatives in the flux w.r.t. temperature in the layer above (J m-2 s-1 K-1) - out_ssdNrgFlux % dNrgFlux_dTempBelow(0:nLayers), & ! derivatives in the flux w.r.t. temperature in the layer below (J m-2 s-1 K-1) - out_ssdNrgFlux % dNrgFlux_dWatAbove(0:nLayers), & ! derivatives in the flux w.r.t. water state in the layer above (J m-2 s-1 K-1) - out_ssdNrgFlux % dNrgFlux_dWatBelow(0:nLayers)) ! derivatives in the flux w.r.t. water state in the layer below (J m-2 s-1 K-1) + out_snowSoilNrgFlux % iLayerNrgFlux(0:nLayers), & ! energy flux at the layer interfaces (W m-2) + out_snowSoilNrgFlux % dNrgFlux_dTempAbove(0:nLayers), & ! derivatives in the flux w.r.t. temperature in the layer above (J m-2 s-1 K-1) + out_snowSoilNrgFlux % dNrgFlux_dTempBelow(0:nLayers), & ! derivatives in the flux w.r.t. temperature in the layer below (J m-2 s-1 K-1) + out_snowSoilNrgFlux % dNrgFlux_dWatAbove(0:nLayers), & ! derivatives in the flux w.r.t. water state in the layer above (J m-2 s-1 K-1) + out_snowSoilNrgFlux % dNrgFlux_dWatBelow(0:nLayers)) ! derivatives in the flux w.r.t. water state in the layer below (J m-2 s-1 K-1) ! make association of local variables with information in the data structures associate(& ! input: model control - scalarSolution => in_ssdNrgFlux % scalarSolution, & ! intent(in): flag to denote if implementing the scalar solution + scalarSolution => in_snowSoilNrgFlux % scalarSolution, & ! intent(in): flag to denote if implementing the scalar solution ! input: fluxes and derivatives at the upper boundary - groundNetFlux => in_ssdNrgFlux % scalarGroundNetNrgFlux, & ! intent(in): net energy flux for the ground surface (W m-2) - dGroundNetFlux_dGroundTemp => io_ssdNrgFlux % dGroundNetFlux_dGroundTemp, & ! intent(inout): derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) + groundNetFlux => in_snowSoilNrgFlux % scalarGroundNetNrgFlux, & ! intent(in): net energy flux for the ground surface (W m-2) + dGroundNetFlux_dGroundTemp => io_snowSoilNrgFlux % dGroundNetFlux_dGroundTemp, & ! intent(inout): derivative in net ground flux w.r.t. ground temperature (W m-2 K-1) ! input: liquid water fluxes - iLayerLiqFluxSnow => in_ssdNrgFlux % iLayerLiqFluxSnow, & ! intent(in): liquid flux at the interface of each snow layer (m s-1) - iLayerLiqFluxSoil => in_ssdNrgFlux % iLayerLiqFluxSoil, & ! intent(in): liquid flux at the interface of each soil layer (m s-1) + iLayerLiqFluxSnow => in_snowSoilNrgFlux % iLayerLiqFluxSnow, & ! intent(in): liquid flux at the interface of each snow layer (m s-1) + iLayerLiqFluxSoil => in_snowSoilNrgFlux % iLayerLiqFluxSoil, & ! intent(in): liquid flux at the interface of each soil layer (m s-1) ! input: trial model state variables - mLayerTempTrial => in_ssdNrgFlux % mLayerTempTrial, & ! intent(in): temperature in each layer at the current iteration (m) + mLayerTempTrial => in_snowSoilNrgFlux % mLayerTempTrial, & ! intent(in): temperature in each layer at the current iteration (m) ! input: derivatives - dThermalC_dWatAbove => in_ssdNrgFlux % dThermalC_dWatAbove, & ! intent(in): derivative in the thermal conductivity w.r.t. water state in the layer above - dThermalC_dWatBelow => in_ssdNrgFlux % dThermalC_dWatBelow, & ! intent(in): derivative in the thermal conductivity w.r.t. water state in the layer above - dThermalC_dTempAbove => in_ssdNrgFlux % dThermalC_dTempAbove, & ! intent(in): derivative in the thermal conductivity w.r.t. energy state in the layer above - dThermalC_dTempBelow => in_ssdNrgFlux % dThermalC_dTempBelow, & ! intent(in): derivative in the thermal conductivity w.r.t. energy state in the layer above + dThermalC_dWatAbove => in_snowSoilNrgFlux % dThermalC_dWatAbove, & ! intent(in): derivative in the thermal conductivity w.r.t. water state in the layer above + dThermalC_dWatBelow => in_snowSoilNrgFlux % dThermalC_dWatBelow, & ! intent(in): derivative in the thermal conductivity w.r.t. water state in the layer above + dThermalC_dTempAbove => in_snowSoilNrgFlux % dThermalC_dTempAbove, & ! intent(in): derivative in the thermal conductivity w.r.t. energy state in the layer above + dThermalC_dTempBelow => in_snowSoilNrgFlux % dThermalC_dTempBelow, & ! intent(in): derivative in the thermal conductivity w.r.t. energy state in the layer above ! input: boundary conditions ix_bcUpprTdyn => model_decisions(iLookDECISIONS%bcUpprTdyn)%iDecision, & ! intent(in): method used to calculate the upper boundary condition for thermodynamics ix_bcLowrTdyn => model_decisions(iLookDECISIONS%bcLowrTdyn)%iDecision, & ! intent(in): method used to calculate the lower boundary condition for thermodynamics @@ -154,18 +152,18 @@ subroutine ssdNrgFlux(& iLayerConductiveFlux => flux_data%var(iLookFLUX%iLayerConductiveFlux)%dat, & ! intent(out): conductive energy flux at layer interfaces at end of time step (W m-2) iLayerAdvectiveFlux => flux_data%var(iLookFLUX%iLayerAdvectiveFlux)%dat, & ! intent(out): advective energy flux at layer interfaces at end of time step (W m-2) ! output: fluxes and derivatives at all layer interfaces - iLayerNrgFlux => out_ssdNrgFlux % iLayerNrgFlux, & ! intent(out): energy flux at the layer interfaces (W m-2) - dFlux_dTempAbove => out_ssdNrgFlux % dNrgFlux_dTempAbove, & ! intent(out): derivatives in the flux w.r.t. temperature in the layer above (J m-2 s-1 K-1) - dFlux_dTempBelow => out_ssdNrgFlux % dNrgFlux_dTempBelow, & ! intent(out): derivatives in the flux w.r.t. temperature in the layer below (J m-2 s-1 K-1) - dFlux_dWatAbove => out_ssdNrgFlux % dNrgFlux_dWatAbove, & ! intent(out): derivatives in the flux w.r.t. water state in the layer above (J m-2 s-1 K-1) - dFlux_dWatBelow => out_ssdNrgFlux % dNrgFlux_dWatBelow, & ! intent(out): derivatives in the flux w.r.t. water state in the layer below (J m-2 s-1 K-1) + iLayerNrgFlux => out_snowSoilNrgFlux % iLayerNrgFlux, & ! intent(out): energy flux at the layer interfaces (W m-2) + dFlux_dTempAbove => out_snowSoilNrgFlux % dNrgFlux_dTempAbove, & ! intent(out): derivatives in the flux w.r.t. temperature in the layer above (J m-2 s-1 K-1) + dFlux_dTempBelow => out_snowSoilNrgFlux % dNrgFlux_dTempBelow, & ! intent(out): derivatives in the flux w.r.t. temperature in the layer below (J m-2 s-1 K-1) + dFlux_dWatAbove => out_snowSoilNrgFlux % dNrgFlux_dWatAbove, & ! intent(out): derivatives in the flux w.r.t. water state in the layer above (J m-2 s-1 K-1) + dFlux_dWatBelow => out_snowSoilNrgFlux % dNrgFlux_dWatBelow, & ! intent(out): derivatives in the flux w.r.t. water state in the layer below (J m-2 s-1 K-1) ! output: error control - err => out_ssdNrgFlux % err, & ! intent(out): error code - message => out_ssdNrgFlux % cmessage & ! intent(out): error message + err => out_snowSoilNrgFlux % err, & ! intent(out): error code + message => out_snowSoilNrgFlux % cmessage & ! intent(out): error message ) ! end association of local variables with information in the data structures ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! initialize error control - err=0; message='ssdNrgFlux/' + err=0; message='snowSoilNrgFlux/' ! set conductive and advective fluxes to missing in the upper boundary iLayerConductiveFlux(0) = realMissing @@ -284,7 +282,7 @@ subroutine ssdNrgFlux(& end associate ! end association of local variables with information in the data structures -end subroutine ssdNrgFlux +end subroutine snowSoilNrgFlux -end module ssdNrgFlux_module +end module snowSoilNrgFlux_module diff --git a/build/source/engine/snow_utils.f90 b/build/source/engine/snow_utils.f90 index 18c633cc2..bf8a65a20 100644 --- a/build/source/engine/snow_utils.f90 +++ b/build/source/engine/snow_utils.f90 @@ -21,7 +21,7 @@ module snow_utils_module ! data types -USE nrtype +USE nr_type ! model constants USE multiconst,only:Tfreeze diff --git a/build/source/engine/soilLiqFlx.f90 b/build/source/engine/soilLiqFlux.f90 similarity index 75% rename from build/source/engine/soilLiqFlx.f90 rename to build/source/engine/soilLiqFlux.f90 index 25a4682c7..2f39a0e4d 100644 --- a/build/source/engine/soilLiqFlx.f90 +++ b/build/source/engine/soilLiqFlux.f90 @@ -18,36 +18,36 @@ ! You should have received a copy of the GNU General Public License ! along with this program. If not, see . -module soilLiqFlx_module +module soilLiqFlux_module ! ----------------------------------------------------------------------------------------------------------- ! data types -USE nrtype -USE data_types,only:var_d ! x%var(:) (rkind) -USE data_types,only:var_ilength ! x%var(:)%dat (i4b) -USE data_types,only:var_dlength ! x%var(:)%dat (rkind) -USE data_types,only:in_type_soilLiqFlx ! derived type for intent(in) arguments -USE data_types,only:io_type_soilLiqFlx ! derived type for intent(inout) arguments -USE data_types,only:out_type_soilLiqFlx ! derived type for intent(out) arguments -USE data_types,only:in_type_diagv_node ! derived type for intent(in) arguments -USE data_types,only:out_type_diagv_node ! derived type for intent(out) arguments -USE data_types,only:in_type_surfaceFlx ! derived type for intent(in) arguments -USE data_types,only:io_type_surfaceFlx ! derived type for intent(inout) arguments -USE data_types,only:out_type_surfaceFlx ! derived type for intent(out) arguments -USE data_types,only:in_type_iLayerFlux ! derived type for intent(in) arguments -USE data_types,only:out_type_iLayerFlux ! derived type for intent(out) arguments -USE data_types,only:in_type_qDrainFlux ! derived type for intent(in) arguments -USE data_types,only:out_type_qDrainFlux ! derived type for intent(out) arguments +USE nr_type +USE data_types,only:& + var_ilength, & ! x%var(:)%dat (i4b) + var_dlength, & ! x%var(:)%dat (rkind) + in_type_soilLiqFlux, & ! derived type for intent(in) arguments + io_type_soilLiqFlux, & ! derived type for intent(inout) arguments + out_type_soilLiqFlux, & ! derived type for intent(out) arguments + in_type_diagv_node, & ! derived type for intent(in) arguments + out_type_diagv_node, & ! derived type for intent(out) arguments + in_type_surfaceFlux, & ! derived type for intent(in) arguments + io_type_surfaceFlux, & ! derived type for intent(inout) arguments + out_type_surfaceFlux, & ! derived type for intent(out) arguments + in_type_iLayerFlux, & ! derived type for intent(in) arguments + out_type_iLayerFlux, & ! derived type for intent(out) arguments + in_type_qDrainFlux, & ! derived type for intent(in) arguments + out_type_qDrainFlux ! derived type for intent(out) arguments ! missing values USE globalData,only:integerMissing ! missing integer USE globalData,only:realMissing ! missing real number -USE globalData,only:veryBig ! a very big number -USE globalData,only:verySmall ! a small number used as an additive constant to check if substantial difference among real numbers -USE globalData,only:verySmaller ! a smaller number used as an additive constant to check if substantial difference among real numbers -! physical constants +! constants USE multiconst,only:iden_water ! intrinsic density of water (kg m-3) +USE globalData,only:veryBig ! a very big number +USE globalData,only:verySmall ! a small number +USE globalData,only:verySmaller ! a smaller number than verySmall ! named variables USE var_lookup,only:iLookPROG ! named variables for structure elements @@ -95,19 +95,18 @@ module soilLiqFlx_module ! ----------------------------------------------------------------------------------------------------------- implicit none private -public::soilLiqFlx +public::soilLiqFlux ! flag to denote if updating infiltration during iterations for testing purposes logical(lgt),parameter :: updateInfil=.true. contains - ! *************************************************************************************************************** -! public subroutine soilLiqFlx: compute liquid water fluxes and their derivatives +! public subroutine soilLiqFlux: compute liquid water fluxes and their derivatives ! *************************************************************************************************************** -subroutine soilLiqFlx(& +subroutine soilLiqFlux(& ! input: model control, trial state variables, derivatives, and fluxes - in_soilLiqFlx, & ! intent(in): model control, trial state variables, derivatives, and fluxes + in_soilLiqFlux, & ! intent(in): model control, trial state variables, derivatives, and fluxes ! input-output: data structures mpar_data, & ! intent(in): model parameters indx_data, & ! intent(in): model indices @@ -115,13 +114,13 @@ subroutine soilLiqFlx(& diag_data, & ! intent(inout): model diagnostic variables for a local HRU flux_data, & ! intent(inout): model fluxes for a local HRU ! input-output: diagnostic variables, fluxes, and derivatives - io_soilLiqFlx, & ! intent(inout): diagnostic variables, fluxes, and derivatives + io_soilLiqFlux, & ! intent(inout): diagnostic variables, fluxes, and derivatives ! output: error control - out_soilLiqFlx) ! intent(out): error control + out_soilLiqFlux) ! intent(out): error control ! ------------------------------------------------------------------------------------------------------------------------------------------------- implicit none ! input: model control, trial state variables, derivatives, and fluxes - type(in_type_soilLiqFlx),intent(in) :: in_soilLiqFlx ! model control, trial state variables, derivatives, and fluxes + type(in_type_soilLiqFlux),intent(in) :: in_soilLiqFlux ! model control, trial state variables, derivatives, and fluxes ! input-output: data structures type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_ilength),intent(in) :: indx_data ! state vector geometry @@ -129,9 +128,9 @@ subroutine soilLiqFlx(& type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU ! input-output: diagnostic variables, fluxes, and derivatives - type(io_type_soilLiqFlx),intent(inout) :: io_soilLiqFlx ! diagnostic variables, fluxes, and derivatives + type(io_type_soilLiqFlux),intent(inout) :: io_soilLiqFlux ! diagnostic variables, fluxes, and derivatives ! output: error control - type(out_type_soilLiqFlx),intent(out) :: out_soilLiqFlx ! error code and error message + type(out_type_soilLiqFlux),intent(out) :: out_soilLiqFlux ! error code and error message ! ----------------------------------------------------------------------------------------------------------------------------------------------------- ! local variables: general character(LEN=256) :: cmessage ! error message of downwind routine @@ -142,43 +141,43 @@ subroutine soilLiqFlx(& integer(i4b) :: ixTop ! top layer in subroutine call integer(i4b) :: ixBot ! bottom layer in subroutine call ! transpiration sink term - real(rkind),dimension(in_soilLiqFlx % nSoil) :: mLayerTranspireFrac ! fraction of transpiration allocated to each soil layer (-) + real(rkind),dimension(in_soilLiqFlux % nSoil) :: mLayerTranspireFrac ! fraction of transpiration allocated to each soil layer (-) ! diagnostic variables - real(rkind),dimension(in_soilLiqFlx % nSoil) :: iceImpedeFac ! ice impedence factor at layer mid-points (-) - real(rkind),dimension(in_soilLiqFlx % nSoil) :: mLayerDiffuse ! diffusivity at layer mid-point (m2 s-1) - real(rkind),dimension(in_soilLiqFlx % nSoil) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) - real(rkind),dimension(in_soilLiqFlx % nSoil) :: dDiffuse_dVolLiq ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) - real(rkind),dimension(in_soilLiqFlx % nSoil) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) - real(rkind),dimension(0:in_soilLiqFlx % nSoil) :: iLayerHydCond ! hydraulic conductivity at layer interface (m s-1) - real(rkind),dimension(0:in_soilLiqFlx % nSoil) :: iLayerDiffuse ! diffusivity at layer interface (m2 s-1) + real(rkind),dimension(in_soilLiqFlux % nSoil) :: iceImpedeFac ! ice impedence factor at layer mid-points (-) + real(rkind),dimension(in_soilLiqFlux % nSoil) :: mLayerDiffuse ! diffusivity at layer mid-point (m2 s-1) + real(rkind),dimension(in_soilLiqFlux % nSoil) :: dHydCond_dVolLiq ! derivative in hydraulic conductivity w.r.t volumetric liquid water content (m s-1) + real(rkind),dimension(in_soilLiqFlux % nSoil) :: dDiffuse_dVolLiq ! derivative in hydraulic diffusivity w.r.t volumetric liquid water content (m2 s-1) + real(rkind),dimension(in_soilLiqFlux % nSoil) :: dHydCond_dTemp ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + real(rkind),dimension(0:in_soilLiqFlux % nSoil) :: iLayerHydCond ! hydraulic conductivity at layer interface (m s-1) + real(rkind),dimension(0:in_soilLiqFlux % nSoil) :: iLayerDiffuse ! diffusivity at layer interface (m2 s-1) ! compute surface flux - integer(i4b) :: nRoots ! number of soil layers with roots - integer(i4b) :: ixIce ! index of the lowest soil layer that contains ice - real(rkind),dimension(0:in_soilLiqFlx % nSoil) :: iLayerHeight ! height of the layer interfaces (m) + integer(i4b) :: nRoots ! number of soil layers with roots + integer(i4b) :: ixIce ! index of the lowest soil layer that contains ice + real(rkind),dimension(0:in_soilLiqFlux % nSoil) :: iLayerHeight ! height of the layer interfaces (m) ! error control - logical(lgt) :: return_flag ! flag for return statements + logical(lgt) :: return_flag ! flag for return statements ! ------------------------------------------------------------------------------------------------------------------------------------------------- ! ** Initialize indices, error control, and get layer information ** - call initialize_soilLiqFlx; if (return_flag) return + call initialize_soilLiqFlux; if (return_flag) return ! ** Compute transpiration, diagnostic variables, infiltration, and interface fluxes ** - call update_soilLiqFlx; if (return_flag) return + call update_soilLiqFlux; if (return_flag) return ! ** Final error control ** - call finalize_soilLiqFlx; if (return_flag) return + call finalize_soilLiqFlux; if (return_flag) return contains - subroutine initialize_soilLiqFlx - ! **** Initial operations for soilLiqFlx module subroutine **** + subroutine initialize_soilLiqFlux + ! **** Initial operations for soilLiqFlux module subroutine **** ! ** assign variables used in main associate block ** - nSoil = in_soilLiqFlx % nSoil ! get number of soil layers from input arguments + nSoil = in_soilLiqFlux % nSoil ! get number of soil layers from input arguments ! get indices for the data structures ibeg = indx_data%var(iLookINDEX%nSnow)%dat(1) + 1 - iend = indx_data%var(iLookINDEX%nSnow)%dat(1) + indx_data%var(iLookINDEX%nSoil)%dat(1) + iend = indx_data%var(iLookINDEX%nSnow)%dat(1) + nSoil ! get a copy of iLayerHeight (for soil layers only) ! NOTE: performance hit, though cannot define the shape (0:) with the associate construct @@ -187,15 +186,15 @@ subroutine initialize_soilLiqFlx ! ** initialize error control ** return_flag=.false. associate(& - err => out_soilLiqFlx % err, & ! intent(out): error code - message => out_soilLiqFlx % cmessage & ! intent(out): error message + err => out_soilLiqFlux % err, & ! intent(out): error code + message => out_soilLiqFlux % cmessage & ! intent(out): error message &) - err=0; message='soilLiqFlx/' ! initialize error control + err=0; message='soilLiqFlux/' ! initialize error control end associate ! ** get the indices for the soil layers ** associate(& - scalarSolution => in_soilLiqFlx % scalarSolution, & ! intent(in): flag to denote if implementing the scalar solution + scalarSolution => in_soilLiqFlux % scalarSolution, & ! intent(in): flag to denote if implementing the scalar solution ixMatricHead => indx_data%var(iLookINDEX%ixMatricHead)%dat, & ! intent(in): indices of soil layers where matric head is the state variable ixSoilOnlyHyd => indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat & ! intent(in): index in the state subset for hydrology state variables in the soil domain &) @@ -211,9 +210,9 @@ subroutine initialize_soilLiqFlx ! ** identify the number of layers that contain roots ** associate(& - rootingDepth => mpar_data%var(iLookPARAM%rootingDepth)%dat(1),& ! intent(in): rooting depth (m) - err => out_soilLiqFlx % err, & ! intent(out): error code - message => out_soilLiqFlx % cmessage & ! intent(out): error message + rootingDepth => mpar_data%var(iLookPARAM%rootingDepth)%dat(1), & ! intent(in): rooting depth (m) + err => out_soilLiqFlux % err, & ! intent(out): error code + message => out_soilLiqFlux % cmessage & ! intent(out): error message &) nRoots = count(iLayerHeight(0:nSoil-1) < rootingDepth-verySmall) if(nRoots==0)then; message=trim(message)//'no layers with roots'; err=20; return_flag=.true.; return; end if @@ -222,19 +221,19 @@ subroutine initialize_soilLiqFlx ! ** identify lowest soil layer with ice ** ! NOTE: cannot use count because there may be an unfrozen wedge associate(& - mLayerVolFracIceTrial => in_soilLiqFlx % mLayerVolFracIceTrial & ! intent(in): volumetric fraction of ice at the current iteration (-) + mLayerVolFracIceTrial => in_soilLiqFlux % mLayerVolFracIceTrial & ! intent(in): volumetric fraction of ice at the current iteration (-) &) ixIce = 0 ! initialize the index of the ice layer (0 means no ice in the soil profile) do iLayer=1,nSoil ! (loop through soil layers) if (mLayerVolFracIceTrial(iLayer) > verySmaller) ixIce = iLayer end do end associate - end subroutine initialize_soilLiqFlx + end subroutine initialize_soilLiqFlux - subroutine update_soilLiqFlx - ! **** Main computations for soilLiqFlx module subroutine **** + subroutine update_soilLiqFlux + ! **** Main computations for soilLiqFlux module subroutine **** - if ( .not. (in_soilLiqFlx % scalarSolution .and. ixTop>1) ) then ! check the need to compute transpiration + if ( .not. (in_soilLiqFlux % scalarSolution .and. ixTop>1) ) then ! check the need to compute transpiration call compute_transpiration_sink; if (return_flag) return end if @@ -244,22 +243,22 @@ subroutine update_soilLiqFlx call compute_interface_fluxes_derivatives; if (return_flag) return - if ( .not. (in_soilLiqFlx % scalarSolution .and. ixTop out_soilLiqFlx % err, & ! intent(out): error code - message => out_soilLiqFlx % cmessage & ! intent(out): error message + err => out_soilLiqFlux % err, & ! intent(out): error code + message => out_soilLiqFlux % cmessage & ! intent(out): error message &) - if(err/=0)then; message=trim(message)//trim("finalize_soilLiqFlx: final error check failed"); return_flag=.true.; return; end if + if(err/=0)then; message=trim(message)//trim("finalize_soilLiqFlux: final error check failed"); return_flag=.true.; return; end if end associate - end subroutine finalize_soilLiqFlx + end subroutine finalize_soilLiqFlux subroutine compute_transpiration_sink ! **** Compute the transpiration sink term **** @@ -289,8 +288,8 @@ end subroutine update_transpiration_loss_fraction subroutine finalize_transpiration_loss_fraction ! **** Finalize operations for the fraction of transpiration loss from each soil layer ***** associate(& - err => out_soilLiqFlx % err, & ! intent(out): error code - message => out_soilLiqFlx % cmessage & ! intent(out): error message + err => out_soilLiqFlux % err, & ! intent(out): error code + message => out_soilLiqFlux % cmessage & ! intent(out): error message &) ! check fractions sum to one if (abs(sum(mLayerTranspireFrac) - 1._rkind) > verySmaller) then @@ -302,18 +301,18 @@ end subroutine finalize_transpiration_loss_fraction subroutine update_transpiration_loss ! **** Update transpiration loss from each soil layer (kg m-2 s-1 --> m s-1)***** associate(& - scalarCanopyTranspiration => in_soilLiqFlx % scalarCanopyTranspiration, & ! canopy transpiration (kg m-2 s-1) - mLayerTranspire => io_soilLiqFlx % mLayerTranspire, & ! transpiration loss from each soil layer (m s-1) + scalarCanopyTranspiration => in_soilLiqFlux % scalarCanopyTranspiration, & ! canopy transpiration (kg m-2 s-1) + mLayerTranspire => io_soilLiqFlux % mLayerTranspire, & ! transpiration loss from each soil layer (m s-1) ! intent(inout): derivatives in the soil layer transpiration flux ... - mLayerdTrans_dCanWat => io_soilLiqFlx % mLayerdTrans_dCanWat, & ! ... w.r.t. canopy total water - mLayerdTrans_dTCanair => io_soilLiqFlx % mLayerdTrans_dTCanair, & ! ... w.r.t. canopy air temperature - mLayerdTrans_dTCanopy => io_soilLiqFlx % mLayerdTrans_dTCanopy, & ! ... w.r.t. canopy temperature - mLayerdTrans_dTGround => io_soilLiqFlx % mLayerdTrans_dTGround, & ! ... w.r.t. ground temperature + mLayerdTrans_dCanWat => io_soilLiqFlux % mLayerdTrans_dCanWat, & ! ... w.r.t. canopy total water + mLayerdTrans_dTCanair => io_soilLiqFlux % mLayerdTrans_dTCanair, & ! ... w.r.t. canopy air temperature + mLayerdTrans_dTCanopy => io_soilLiqFlux % mLayerdTrans_dTCanopy, & ! ... w.r.t. canopy temperature + mLayerdTrans_dTGround => io_soilLiqFlux % mLayerdTrans_dTGround, & ! ... w.r.t. ground temperature ! intent(in): derivative in canopy transpiration ... - dCanopyTrans_dCanWat => in_soilLiqFlx % dCanopyTrans_dCanWat, & ! ... w.r.t. canopy total water content (s-1) - dCanopyTrans_dTCanair => in_soilLiqFlx % dCanopyTrans_dTCanair, & ! ... w.r.t. canopy air temperature (kg m-2 s-1 K-1) - dCanopyTrans_dTCanopy => in_soilLiqFlx % dCanopyTrans_dTCanopy, & ! ... w.r.t. canopy temperature (kg m-2 s-1 K-1) - dCanopyTrans_dTGround => in_soilLiqFlx % dCanopyTrans_dTGround, & ! ... w.r.t. ground temperature (kg m-2 s-1 K-1) + dCanopyTrans_dCanWat => in_soilLiqFlux % dCanopyTrans_dCanWat, & ! ... w.r.t. canopy total water content (s-1) + dCanopyTrans_dTCanair => in_soilLiqFlux % dCanopyTrans_dTCanair, & ! ... w.r.t. canopy air temperature (kg m-2 s-1 K-1) + dCanopyTrans_dTCanopy => in_soilLiqFlux % dCanopyTrans_dTCanopy, & ! ... w.r.t. canopy temperature (kg m-2 s-1 K-1) + dCanopyTrans_dTGround => in_soilLiqFlux % dCanopyTrans_dTGround, & ! ... w.r.t. ground temperature (kg m-2 s-1 K-1) ! intent(in): index of the upper boundary conditions for soil hydrology ixBcUpperSoilHydrology => model_decisions(iLookDECISIONS%bcUpprSoiH)%iDecision & &) @@ -355,7 +354,7 @@ subroutine initialize_compute_diagnostic_variables(in_diagv_node) ! **** Initialize operations for the compute_diagnostic_variables subroutine **** type(in_type_diagv_node),intent(out) :: in_diagv_node ! input data object for diagv_node ! interface local name space to input data object for diagv_node - call in_diagv_node % initialize(iSoil,in_soilLiqFlx,model_decisions,diag_data,mpar_data,flux_data) + call in_diagv_node % initialize(iSoil,in_soilLiqFlux,model_decisions,diag_data,mpar_data,flux_data) end subroutine initialize_compute_diagnostic_variables subroutine update_compute_diagnostic_variables(in_diagv_node,out_diagv_node) @@ -371,10 +370,10 @@ subroutine finalize_compute_diagnostic_variables(out_diagv_node) type(out_type_diagv_node),intent(in) :: out_diagv_node ! output data object for diagv_node ! interface output data object for diagv_node to local name space associate(& - err => out_soilLiqFlx % err, & ! error code - message => out_soilLiqFlx % cmessage & ! error message + err => out_soilLiqFlux % err, & ! error code + message => out_soilLiqFlux % cmessage & ! error message &) - call out_diagv_node % finalize(iSoil,nSoil,io_soilLiqFlx,mLayerDiffuse,iceImpedeFac,& + call out_diagv_node % finalize(iSoil,nSoil,io_soilLiqFlux,mLayerDiffuse,iceImpedeFac,& &dHydCond_dVolLiq,dDiffuse_dVolLiq,dHydCond_dTemp,err,cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if end associate @@ -382,69 +381,69 @@ end subroutine finalize_compute_diagnostic_variables subroutine compute_surface_infiltration ! **** compute infiltration at the surface and its derivative w.r.t. mass in the upper soil layer **** - type(in_type_surfaceFlx) :: in_surfaceFlx - type(io_type_surfaceFlx) :: io_surfaceFlx - type(out_type_surfaceFlx) :: out_surfaceFlx + type(in_type_surfaceFlux) :: in_surfaceFlux + type(io_type_surfaceFlux) :: io_surfaceFlux + type(out_type_surfaceFlux) :: out_surfaceFlux - call initialize_compute_surface_infiltration(in_surfaceFlx,io_surfaceFlx) + call initialize_compute_surface_infiltration(in_surfaceFlux,io_surfaceFlux) - call update_compute_surface_infiltration(in_surfaceFlx,io_surfaceFlx,out_surfaceFlx) + call update_compute_surface_infiltration(in_surfaceFlux,io_surfaceFlux,out_surfaceFlux) - call finalize_compute_surface_infiltration(io_surfaceFlx,out_surfaceFlx); if (return_flag) return + call finalize_compute_surface_infiltration(io_surfaceFlux,out_surfaceFlux); if (return_flag) return end subroutine compute_surface_infiltration - subroutine initialize_compute_surface_infiltration(in_surfaceFlx,io_surfaceFlx) + subroutine initialize_compute_surface_infiltration(in_surfaceFlux,io_surfaceFlux) ! **** Initialize operations for compute_surface_infiltration **** - type(in_type_surfaceFlx),intent(out) :: in_surfaceFlx - type(io_type_surfaceFlx),intent(out) :: io_surfaceFlx + type(in_type_surfaceFlux),intent(out) :: in_surfaceFlux + type(io_type_surfaceFlux),intent(out) :: io_surfaceFlux ! set derivative w.r.t. state above to zero (does not exist) associate(& ! intent(inout): flux derivatives ... - dq_dHydStateAbove => io_soilLiqFlx % dq_dHydStateAbove,& ! ... in layer interfaces w.r.t. state variables in the layer above - dq_dNrgStateAbove => io_soilLiqFlx % dq_dNrgStateAbove & ! ... w.r.t. temperature in the layer above (m s-1 K-1) + dq_dHydStateAbove => io_soilLiqFlux % dq_dHydStateAbove,& ! ... in layer interfaces w.r.t. state variables in the layer above + dq_dNrgStateAbove => io_soilLiqFlux % dq_dNrgStateAbove & ! ... w.r.t. temperature in the layer above (m s-1 K-1) &) dq_dHydStateAbove(0) = 0._rkind dq_dNrgStateAbove(0) = 0._rkind end associate ! compute surface flux and its derivative... - call in_surfaceFlx % initialize(nRoots,ixIce,nSoil,ibeg,iend,in_soilLiqFlx,io_soilLiqFlx,& + call in_surfaceFlux % initialize(nRoots,ixIce,nSoil,ibeg,iend,in_soilLiqFlux,io_soilLiqFlux,& &model_decisions,prog_data,mpar_data,flux_data,diag_data,& &iLayerHeight,dHydCond_dTemp,iceImpedeFac) - call io_surfaceFlx % initialize(nSoil,io_soilLiqFlx,iLayerHydCond,iLayerDiffuse) + call io_surfaceFlux % initialize(nSoil,io_soilLiqFlux,iLayerHydCond,iLayerDiffuse) end subroutine initialize_compute_surface_infiltration - subroutine update_compute_surface_infiltration(in_surfaceFlx,io_surfaceFlx,out_surfaceFlx) + subroutine update_compute_surface_infiltration(in_surfaceFlux,io_surfaceFlux,out_surfaceFlux) ! **** Update operations for compute_surface_infiltration **** - type(in_type_surfaceFlx) ,intent(in) :: in_surfaceFlx - type(io_type_surfaceFlx) ,intent(inout) :: io_surfaceFlx - type(out_type_surfaceFlx),intent(out) :: out_surfaceFlx - call surfaceFlx(io_soilLiqFlx,in_surfaceFlx,io_surfaceFlx,out_surfaceFlx) + type(in_type_surfaceFlux) ,intent(in) :: in_surfaceFlux + type(io_type_surfaceFlux) ,intent(inout) :: io_surfaceFlux + type(out_type_surfaceFlux),intent(out) :: out_surfaceFlux + call surfaceFlux(io_soilLiqFlux,in_surfaceFlux,io_surfaceFlux,out_surfaceFlux) end subroutine update_compute_surface_infiltration - subroutine finalize_compute_surface_infiltration(io_surfaceFlx,out_surfaceFlx) + subroutine finalize_compute_surface_infiltration(io_surfaceFlux,out_surfaceFlux) ! **** Finalize operations for compute_surface_infiltration **** - type(io_type_surfaceFlx) ,intent(in) :: io_surfaceFlx - type(out_type_surfaceFlx),intent(in) :: out_surfaceFlx + type(io_type_surfaceFlux) ,intent(in) :: io_surfaceFlux + type(out_type_surfaceFlux),intent(in) :: out_surfaceFlux ! interface object data components with local name space - call io_surfaceFlx % finalize(nSoil,io_soilLiqFlx,iLayerHydCond,iLayerDiffuse) + call io_surfaceFlux % finalize(nSoil,io_soilLiqFlux,iLayerHydCond,iLayerDiffuse) associate(& - err => out_soilLiqFlx % err, & ! error code - message => out_soilLiqFlx % cmessage & ! error message + err => out_soilLiqFlux % err, & ! error code + message => out_soilLiqFlux % cmessage & ! error message &) - call out_surfaceFlx % finalize(io_soilLiqFlx,err,cmessage) + call out_surfaceFlux % finalize(io_soilLiqFlux,err,cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if end associate ! include base soil evaporation as the upper boundary flux associate(& - iLayerLiqFluxSoil => io_soilLiqFlx % iLayerLiqFluxSoil, & ! liquid flux at soil layer interfaces (m s-1) - scalarGroundEvaporation => in_soilLiqFlx % scalarGroundEvaporation,& ! ground evaporation (kg m-2 s-1) - scalarSurfaceInfiltration => io_soilLiqFlx % scalarInfiltration, & ! surface infiltration rate (m s-1) - dq_dHydStateBelow => io_soilLiqFlx % dq_dHydStateBelow, & ! derivative in the flux in layer interfaces w.r.t. state variables in the layer below - dq_dNrgStateBelow => io_soilLiqFlx % dq_dNrgStateBelow & ! derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) + iLayerLiqFluxSoil => io_soilLiqFlux % iLayerLiqFluxSoil, & ! liquid flux at soil layer interfaces (m s-1) + scalarGroundEvaporation => in_soilLiqFlux % scalarGroundEvaporation,& ! ground evaporation (kg m-2 s-1) + scalarSurfaceInfiltration => io_soilLiqFlux % scalarInfiltration, & ! surface infiltration rate (m s-1) + dq_dHydStateBelow => io_soilLiqFlux % dq_dHydStateBelow, & ! derivative in the flux in layer interfaces w.r.t. state variables in the layer below + dq_dNrgStateBelow => io_soilLiqFlux % dq_dNrgStateBelow & ! derivatives in the flux w.r.t. temperature in the layer below (m s-1 K-1) &) iLayerLiqFluxSoil(0) = scalarGroundEvaporation/iden_water + scalarSurfaceInfiltration @@ -474,7 +473,7 @@ subroutine initialize_compute_interface_fluxes_derivatives(in_iLayerFlux) ! **** Initialize operations for compute_interface_fluxes_derivatives subroutine **** type(in_type_iLayerFlux),intent(out) :: in_iLayerFlux ! input data object for iLayerFlux ! interface local name space to iLayerFlux input object - call in_iLayerFlux % initialize(iLayer,nSoil,ibeg,iend,in_soilLiqFlx,io_soilLiqFlx,model_decisions,& + call in_iLayerFlux % initialize(iLayer,nSoil,ibeg,iend,in_soilLiqFlux,io_soilLiqFlux,model_decisions,& &prog_data,mLayerDiffuse,dHydCond_dTemp,dHydCond_dVolLiq,dDiffuse_dVolLiq) end subroutine initialize_compute_interface_fluxes_derivatives @@ -491,10 +490,10 @@ subroutine finalize_compute_interface_fluxes_derivatives(out_iLayerFlux) type(out_type_iLayerFlux),intent(in) :: out_iLayerFlux ! output data object for iLayerFlux ! interface iLayerFlux output object to local name space associate(& - err => out_soilLiqFlx % err, & ! error code - message => out_soilLiqFlx % cmessage & ! error message + err => out_soilLiqFlux % err, & ! error code + message => out_soilLiqFlux % cmessage & ! error message &) - call out_iLayerFlux % finalize(iLayer,nSoil,io_soilLiqFlx,iLayerHydCond,iLayerDiffuse,err,cmessage) + call out_iLayerFlux % finalize(iLayer,nSoil,io_soilLiqFlux,iLayerHydCond,iLayerDiffuse,err,cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if end associate end subroutine finalize_compute_interface_fluxes_derivatives @@ -515,7 +514,7 @@ end subroutine compute_drainage_flux subroutine initialize_compute_drainage_flux(in_qDrainFlux) ! **** Initialize operations for compute_drainage_flux **** type(in_type_qDrainFlux),intent(out) :: in_qDrainFlux - call in_qDrainFlux % initialize(nSoil,ibeg,iend,in_soilLiqFlx,io_soilLiqFlx,model_decisions,& + call in_qDrainFlux % initialize(nSoil,ibeg,iend,in_soilLiqFlux,io_soilLiqFlux,model_decisions,& &prog_data,mpar_data,flux_data,diag_data,iceImpedeFac,& &dHydCond_dVolLiq,dHydCond_dTemp) end subroutine initialize_compute_drainage_flux @@ -531,24 +530,24 @@ subroutine finalize_compute_drainage_flux(out_qDrainFlux) ! **** finalize operations for compute_drainage_flux **** type(out_type_qDrainFlux),intent(in) :: out_qDrainFlux associate(& - err => out_soilLiqFlx % err, & ! error code - message => out_soilLiqFlx % cmessage & ! error message + err => out_soilLiqFlux % err, & ! error code + message => out_soilLiqFlux % cmessage & ! error message &) - call out_qDrainFlux % finalize(nSoil,io_soilLiqFlx,iLayerHydCond,iLayerDiffuse,err,cmessage) + call out_qDrainFlux % finalize(nSoil,io_soilLiqFlux,iLayerHydCond,iLayerDiffuse,err,cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if end associate ! no dependence on the aquifer for drainage associate(& ! derivatives in flux w.r.t. ... - dq_dHydStateBelow => io_soilLiqFlx % dq_dHydStateBelow,& ! ... hydrology state variables in the layer below - dq_dNrgStateBelow => io_soilLiqFlx % dq_dNrgStateBelow & ! ... temperature in the layer below (m s-1 K-1) + dq_dHydStateBelow => io_soilLiqFlux % dq_dHydStateBelow,& ! ... hydrology state variables in the layer below + dq_dNrgStateBelow => io_soilLiqFlux % dq_dNrgStateBelow & ! ... temperature in the layer below (m s-1 K-1) &) dq_dHydStateBelow(nSoil) = 0._rkind ! keep this here in case we want to couple some day.... dq_dNrgStateBelow(nSoil) = 0._rkind ! keep this here in case we want to couple some day.... end associate end subroutine finalize_compute_drainage_flux -end subroutine soilLiqFlx +end subroutine soilLiqFlux ! *************************************************************************************************************** ! private subroutine diagv_node: compute transmittance and derivatives for model nodes @@ -729,12 +728,12 @@ subroutine update_diagv_node_hydraulic_conductivity_moisture_form scalarDiffuse = scalardPsi_dTheta * scalarHydCond ! compute derivative in hydraulic conductivity (m s-1) and hydraulic diffusivity (m2 s-1) if (scalarVolFracIceTrial > epsilon(iceImpedeFac)) then - dK_dLiq__noIce = dHydCond_dLiq(scalarVolFracLiqTrial,scalarSatHydCond,theta_res,theta_sat,vGn_m,.true.) ! [.true. = analytical] + dK_dLiq__noIce = dHydCond_dLiq(scalarVolFracLiqTrial,scalarSatHydCond,theta_res,theta_sat,vGn_m) dHydCond_dVolLiq = hydCond_noIce*dIceImpede_dLiq + dK_dLiq__noIce*iceImpedeFac else - dHydCond_dVolLiq = dHydCond_dLiq(scalarVolFracLiqTrial,scalarSatHydCond,theta_res,theta_sat,vGn_m,.true.) + dHydCond_dVolLiq = dHydCond_dLiq(scalarVolFracLiqTrial,scalarSatHydCond,theta_res,theta_sat,vGn_m) 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) + dPsi_dTheta2a = dPsi_dTheta2(scalarVolFracLiqTrial,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) dDiffuse_dVolLiq = dHydCond_dVolLiq*scalardPsi_dTheta + scalarHydCond*dPsi_dTheta2a dHydCond_dMatric = realMissing ! not used, so cause problems @@ -795,14 +794,14 @@ subroutine update_diagv_node_hydraulic_conductivity_mixed_form end if ! compute derivatives for micropores if (scalarVolFracIceTrial > verySmaller) then - dK_dPsi__noIce = dHydCond_dPsi(scalarMatricHeadLiqTrial,scalarSatHydCond,vGn_alpha,vGn_n,vGn_m,.true.) ! analytical + dK_dPsi__noIce = dHydCond_dPsi(scalarMatricHeadLiqTrial,scalarSatHydCond,vGn_alpha,vGn_n,vGn_m) dHydCondMicro_dTemp = dPsiLiq_dTemp*dK_dPsi__noIce ! m s-1 K-1 dHydCondMicro_dMatric = hydCond_noIce*dIceImpede_dLiq*scalardTheta_dPsi + dK_dPsi__noIce*iceImpedeFac else dHydCondMicro_dTemp = 0._rkind - dHydCondMicro_dMatric = dHydCond_dPsi(scalarMatricHeadLiqTrial,scalarSatHydCond,vGn_alpha,vGn_n,vGn_m,.true.) + dHydCondMicro_dMatric = dHydCond_dPsi(scalarMatricHeadLiqTrial,scalarSatHydCond,vGn_alpha,vGn_n,vGn_m) end if - ! combine derivatives + ! combine matric derivatives dHydCond_dMatric = dHydCondMicro_dMatric + dHydCondMacro_dMatric ! compute analytical derivative for change in ice impedance factor w.r.t. temperature @@ -832,9 +831,9 @@ end subroutine finalize_diagv_node end subroutine diagv_node ! *************************************************************************************************************** -! private subroutine surfaceFlx: compute the surface flux and its derivative +! private subroutine surfaceFlux: compute the surface flux and its derivative ! *************************************************************************************************************** -subroutine surfaceFlx(io_soilLiqFlx,in_surfaceFlx,io_surfaceFlx,out_surfaceFlx) +subroutine surfaceFlux(io_soilLiqFlux,in_surfaceFlux,io_surfaceFlux,out_surfaceFlux) USE soil_utils_module,only:volFracLiq ! compute volumetric fraction of liquid water as a function of matric head (-) USE soil_utils_module,only:hydCond_psi ! compute hydraulic conductivity as a function of matric head (m s-1) USE soil_utils_module,only:hydCond_liq ! compute hydraulic conductivity as a function of volumetric liquid water content (m s-1) @@ -844,24 +843,24 @@ subroutine surfaceFlx(io_soilLiqFlx,in_surfaceFlx,io_surfaceFlx,out_surfaceFlx) ! compute infiltraton at the surface and its derivative w.r.t. mass in the upper soil layer implicit none ! ----------------------------------------------------------------------------------------------------------------------------- - ! input: use soilLiqFlx object for array dimensions - type(io_type_soilLiqFlx) ,intent(in) :: io_soilLiqFlx ! input-output object for soilLiqFlx + ! input: use soilLiqFlux object for array dimensions + type(io_type_soilLiqFlux) ,intent(in) :: io_soilLiqFlux ! input-output object for soilLiqFlux ! input: model control, variables, derivatives, soil layer depth, boundary conditions, fluxes, and transmittance and soil parameters - type(in_type_surfaceFlx) ,intent(in) :: in_surfaceFlx ! input object for surfaceFlx + type(in_type_surfaceFlux) ,intent(in) :: in_surfaceFlux ! input object for surfaceFlux ! input-output: hydraulic conductivity and diffusivity, and infiltration parameters - type(io_type_surfaceFlx) ,intent(inout) :: io_surfaceFlx ! input object for surfaceFlx + type(io_type_surfaceFlux) ,intent(inout) :: io_surfaceFlux ! input object for surfaceFlux ! output: runoff, infiltration, derivatives, and error control - type(out_type_surfaceFlx),intent(out) :: out_surfaceFlx ! output object for surfaceFlx + type(out_type_surfaceFlux),intent(out) :: out_surfaceFlux ! output object for surfaceFlux ! ----------------------------------------------------------------------------------------------------------------------------- ! local variables ! general integer(i4b) :: iLayer ! index of soil layer real(rkind) :: Tcrit ! temperature where all water is unfrozen (K) real(rkind) :: fPart1,fPart2 ! different parts of a function - real(rkind) :: dPart1(1:in_surfaceFlx % nSoil) ! derivatives for different parts of a function - real(rkind) :: dPart2(1:in_surfaceFlx % nSoil) ! derivatives for different parts of a function - real(rkind) :: dfracCap(1:in_surfaceFlx % nSoil) ! derivatives for different parts of a function - real(rkind) :: dfInfRaw(1:in_surfaceFlx % nSoil) ! derivatives for different parts of a function + real(rkind) :: dPart1(1:in_surfaceFlux % nSoil) ! derivatives for different parts of a function + real(rkind) :: dPart2(1:in_surfaceFlux % nSoil) ! derivatives for different parts of a function + real(rkind) :: dfracCap(1:in_surfaceFlux % nSoil) ! derivatives for different parts of a function + real(rkind) :: dfInfRaw(1:in_surfaceFlux % nSoil) ! derivatives for different parts of a function real(rkind) :: total_soil_depth ! total depth of soil (m) ! head boundary condition real(rkind) :: cFlux ! capillary flux (m s-1) @@ -907,55 +906,55 @@ subroutine surfaceFlx(io_soilLiqFlx,in_surfaceFlx,io_surfaceFlx,out_surfaceFlx) real(rkind) :: n_topmodel ! TOPMODEL exponent exponent (must be sufficiently large to avoid divergence of lambda_n -- n>=3.5 or so) complex(rkind) :: lambda_n ! mean of the power-transformed topographic index ! derivatives - real(rkind) :: dVolFracLiq_dWat(1:in_surfaceFlx % nSoil) ! ... vol fraction of liquid w.r.t. water state variable in root layers - real(rkind) :: dVolFracIce_dWat(1:in_surfaceFlx % nSoil) ! ... vol fraction of ice w.r.t. water state variable in root layers - real(rkind) :: dVolFracLiq_dTk(1:in_surfaceFlx % nSoil) ! ... vol fraction of liquid w.r.t. temperature in root layers - real(rkind) :: dVolFracIce_dTk(1:in_surfaceFlx % nSoil) ! ... vol fraction of ice w.r.t. temperature in root layers - real(rkind) :: dRootZoneLiq_dWat(1:in_surfaceFlx % nSoil) ! ... vol fraction of scalar root zone liquid w.r.t. water state variable in root layers - real(rkind) :: dRootZoneIce_dWat(1:in_surfaceFlx % nSoil) ! ... vol fraction of scalar root zone ice w.r.t. water state variable in root layers - real(rkind) :: dRootZoneLiq_dTk(1:in_surfaceFlx % nSoil) ! ... vol fraction of scalar root zone liquid w.r.t. temperature in root layers - real(rkind) :: dRootZoneIce_dTk(1:in_surfaceFlx % nSoil) ! ... vol fraction of scalar root zone ice w.r.t. temperature in root layers - real(rkind) :: dDepthWettingFront_dWat(1:in_surfaceFlx % nSoil) ! ... scalar depth of wetting front w.r.t. water state variable in root layers - real(rkind) :: dDepthWettingFront_dTk(1:in_surfaceFlx % nSoil) ! ... scalar depth of wetting front w.r.t. temperature in root layers - real(rkind) :: dxMaxInfilRate_dWat(1:in_surfaceFlx % nSoil) ! ... scalar max infiltration rate w.r.t. water state variable in root layers - real(rkind) :: dxMaxInfilRate_dTk(1:in_surfaceFlx % nSoil) ! ... scalar max infiltration rate w.r.t. temperature in root layers - real(rkind) :: dInfilArea_dWat(1:in_surfaceFlx % nSoil) ! ... scalar infiltration rate w.r.t. water state variable in canopy or snow and root layers - real(rkind) :: dInfilArea_dTk(1:in_surfaceFlx % nSoil) ! ... scalar infiltration rate w.r.t. temperature in canopy or snow and root layers - real(rkind) :: dFrozenArea_dWat(1:in_surfaceFlx % nSoil) ! ... scalar frozen area w.r.t. water state variable in canopy or snow and root layers - real(rkind) :: dFrozenArea_dTk(1:in_surfaceFlx % nSoil) ! ... scalar frozen area w.r.t. temperature in canopy or snow and root layers - real(rkind) :: dInfilRate_dWat(1:in_surfaceFlx % nSoil) ! ... scalar infiltration rate w.r.t. water state variable in canopy or snow and root layers - real(rkind) :: dInfilRate_dTk(1:in_surfaceFlx % nSoil) ! ... scalar infiltration rate w.r.t. temperature in canopy or snow and root layers + real(rkind) :: dVolFracLiq_dWat(1:in_surfaceFlux % nSoil) ! ... vol fraction of liquid w.r.t. water state variable in root layers + real(rkind) :: dVolFracIce_dWat(1:in_surfaceFlux % nSoil) ! ... vol fraction of ice w.r.t. water state variable in root layers + real(rkind) :: dVolFracLiq_dTk(1:in_surfaceFlux % nSoil) ! ... vol fraction of liquid w.r.t. temperature in root layers + real(rkind) :: dVolFracIce_dTk(1:in_surfaceFlux % nSoil) ! ... vol fraction of ice w.r.t. temperature in root layers + real(rkind) :: dRootZoneLiq_dWat(1:in_surfaceFlux % nSoil) ! ... vol fraction of scalar root zone liquid w.r.t. water state variable in root layers + real(rkind) :: dRootZoneIce_dWat(1:in_surfaceFlux % nSoil) ! ... vol fraction of scalar root zone ice w.r.t. water state variable in root layers + real(rkind) :: dRootZoneLiq_dTk(1:in_surfaceFlux % nSoil) ! ... vol fraction of scalar root zone liquid w.r.t. temperature in root layers + real(rkind) :: dRootZoneIce_dTk(1:in_surfaceFlux % nSoil) ! ... vol fraction of scalar root zone ice w.r.t. temperature in root layers + real(rkind) :: dDepthWettingFront_dWat(1:in_surfaceFlux % nSoil) ! ... scalar depth of wetting front w.r.t. water state variable in root layers + real(rkind) :: dDepthWettingFront_dTk(1:in_surfaceFlux % nSoil) ! ... scalar depth of wetting front w.r.t. temperature in root layers + real(rkind) :: dxMaxInfilRate_dWat(1:in_surfaceFlux % nSoil) ! ... scalar max infiltration rate w.r.t. water state variable in root layers + real(rkind) :: dxMaxInfilRate_dTk(1:in_surfaceFlux % nSoil) ! ... scalar max infiltration rate w.r.t. temperature in root layers + real(rkind) :: dInfilArea_dWat(1:in_surfaceFlux % nSoil) ! ... scalar infiltration rate w.r.t. water state variable in canopy or snow and root layers + real(rkind) :: dInfilArea_dTk(1:in_surfaceFlux % nSoil) ! ... scalar infiltration rate w.r.t. temperature in canopy or snow and root layers + real(rkind) :: dFrozenArea_dWat(1:in_surfaceFlux % nSoil) ! ... scalar frozen area w.r.t. water state variable in canopy or snow and root layers + real(rkind) :: dFrozenArea_dTk(1:in_surfaceFlux % nSoil) ! ... scalar frozen area w.r.t. temperature in canopy or snow and root layers + real(rkind) :: dInfilRate_dWat(1:in_surfaceFlux % nSoil) ! ... scalar infiltration rate w.r.t. water state variable in canopy or snow and root layers + real(rkind) :: dInfilRate_dTk(1:in_surfaceFlux % nSoil) ! ... scalar infiltration rate w.r.t. temperature in canopy or snow and root layers ! error control logical(lgt) :: return_flag ! logical flag for return statements - call initialize_surfaceFlx + call initialize_surfaceFlux - call update_surfaceFlx; if (return_flag) return + call update_surfaceFlux; if (return_flag) return - call finalize_surfaceFlx; if (return_flag) return + call finalize_surfaceFlux; if (return_flag) return contains - subroutine initialize_surfaceFlx - ! **** Initialize operations for surfaceFlx **** + subroutine initialize_surfaceFlux + ! **** Initialize operations for surfaceFlux **** ! allocate output object array components - out_surfaceFlx % dq_dHydStateVec = io_soilLiqFlx % dq_dHydStateLayerSurfVec - out_surfaceFlx % dq_dNrgStateVec = io_soilLiqFlx % dq_dNrgStateLayerSurfVec + out_surfaceFlux % dq_dHydStateVec = io_soilLiqFlux % dq_dHydStateLayerSurfVec + out_surfaceFlux % dq_dNrgStateVec = io_soilLiqFlux % dq_dNrgStateLayerSurfVec ! initialize error control return_flag=.false. associate(& - err => out_surfaceFlx % err , & ! error code - message => out_surfaceFlx % message & ! error message + err => out_surfaceFlux % err , & ! error code + message => out_surfaceFlux % message & ! error message &) - err=0; message="surfaceFlx/" + err=0; message="surfaceFlux/" end associate ! initialize derivatives associate(& ! output: derivatives in surface infiltration w.r.t. ... - dq_dHydStateVec => out_surfaceFlx % dq_dHydStateVec , & ! ... hydrology state in above soil snow or canopy and every soil layer (m s-1 or s-1) - dq_dNrgStateVec => out_surfaceFlx % dq_dNrgStateVec & ! ... energy state in above soil snow or canopy and every soil layer (m s-1 K-1) + dq_dHydStateVec => out_surfaceFlux % dq_dHydStateVec , & ! ... hydrology state in above soil snow or canopy and every soil layer (m s-1 or s-1) + dq_dNrgStateVec => out_surfaceFlux % dq_dNrgStateVec & ! ... energy state in above soil snow or canopy and every soil layer (m s-1 K-1) &) dVolFracLiq_dWat(:) = 0._rkind dVolFracIce_dWat(:) = 0._rkind @@ -970,15 +969,15 @@ subroutine initialize_surfaceFlx dFrozenArea_dWat(:) = 0._rkind dFrozenArea_dTk(:) = 0._rkind dq_dHydStateVec(:) = 0._rkind - dq_dNrgStateVec(:) = 0._rkind ! energy state variable is temperature (transformed outside soilLiqFlx_module if needed) + dq_dNrgStateVec(:) = 0._rkind ! energy state variable is temperature (transformed outside soilLiqFlux_module if needed) end associate ! initialize runoff and infiltration values associate(& - scalarSurfaceRunoff => out_surfaceFlx % scalarSurfaceRunoff , & ! surface runoff (m s-1) - scalarSurfaceRunoff_IE => out_surfaceFlx % scalarSurfaceRunoff_IE , & ! infiltration excess surface runoff (m s-1) - scalarSurfaceRunoff_SE => out_surfaceFlx % scalarSurfaceRunoff_SE , & ! saturation excess surface runoff (m s-1) - scalarSurfaceInfiltration => out_surfaceFlx % scalarSurfaceInfiltration & ! surface infiltration (m s-1) + scalarSurfaceRunoff => out_surfaceFlux % scalarSurfaceRunoff , & ! surface runoff (m s-1) + scalarSurfaceRunoff_IE => out_surfaceFlux % scalarSurfaceRunoff_IE , & ! infiltration excess surface runoff (m s-1) + scalarSurfaceRunoff_SE => out_surfaceFlux % scalarSurfaceRunoff_SE , & ! saturation excess surface runoff (m s-1) + scalarSurfaceInfiltration => out_surfaceFlux % scalarSurfaceInfiltration & ! surface infiltration (m s-1) &) scalarSurfaceRunoff = 0._rkind scalarSurfaceRunoff_IE = 0._rkind @@ -986,37 +985,37 @@ subroutine initialize_surfaceFlx scalarSurfaceInfiltration = 0._rkind end associate - end subroutine initialize_surfaceFlx + end subroutine initialize_surfaceFlux - subroutine update_surfaceFlx - ! **** Update operations for surfaceFlx **** + subroutine update_surfaceFlux + ! **** Update operations for surfaceFlux **** associate(& ! input: model control - firstSplitOper => in_surfaceFlx % firstSplitOper, & ! flag indicating if desire to compute infiltration - bc_upper => in_surfaceFlx % bc_upper, & ! index defining the type of boundary conditions - ixInfRateMax => in_surfaceFlx % ixInfRateMax, & ! index defining the maximum infiltration rate method - surfRun_SE => in_surfaceFlx % surfRun_SE, & ! index defining the saturation excess surface runoff method + firstSplitOper => in_surfaceFlux % firstSplitOper, & ! flag indicating if desire to compute infiltration + bc_upper => in_surfaceFlux % bc_upper, & ! index defining the type of boundary conditions + ixInfRateMax => in_surfaceFlux % ixInfRateMax, & ! index defining the maximum infiltration rate method + surfRun_SE => in_surfaceFlux % surfRun_SE, & ! index defining the saturation excess surface runoff method ! input to compute infiltration - scalarRainPlusMelt => in_surfaceFlx % scalarRainPlusMelt, & ! rain plus melt (m s-1) + scalarRainPlusMelt => in_surfaceFlux % scalarRainPlusMelt, & ! rain plus melt (m s-1) ! output: infiltration area and saturated area - scalarInfilArea => io_surfaceFlx % scalarInfilArea, & ! fraction of area where water can infiltrate, may be frozen (-) - scalarSaturatedArea => io_surfaceFlx % scalarSaturatedArea, & ! saturated area fraction (-) + scalarInfilArea => io_surfaceFlux % scalarInfilArea, & ! fraction of area where water can infiltrate, may be frozen (-) + scalarSaturatedArea => io_surfaceFlux % scalarSaturatedArea, & ! saturated area fraction (-) ! output: runoff and infiltration - scalarSurfaceRunoff_SE => out_surfaceFlx % scalarSurfaceRunoff_SE, & ! saturation excess surface runoff (m s-1) - scalarSurfaceRunoff => out_surfaceFlx % scalarSurfaceRunoff, & ! surface runoff (m s-1) + scalarSurfaceRunoff_SE => out_surfaceFlux % scalarSurfaceRunoff_SE, & ! saturation excess surface runoff (m s-1) + scalarSurfaceRunoff => out_surfaceFlux % scalarSurfaceRunoff, & ! surface runoff (m s-1) ! output: derivatives in surface infiltration w.r.t. ... - dq_dHydStateVec => out_surfaceFlx % dq_dHydStateVec, & ! ... hydrology state in above soil snow or canopy and every soil layer (m s-1 or s-1) - dq_dNrgStateVec => out_surfaceFlx % dq_dNrgStateVec, & ! ... energy state in above soil snow or canopy and every soil layer (m s-1 K-1) + dq_dHydStateVec => out_surfaceFlux % dq_dHydStateVec, & ! ... hydrology state in above soil snow or canopy and every soil layer (m s-1 or s-1) + dq_dNrgStateVec => out_surfaceFlux % dq_dNrgStateVec, & ! ... energy state in above soil snow or canopy and every soil layer (m s-1 K-1) ! output: error control - err => out_surfaceFlx % err , & ! error code - message => out_surfaceFlx % message & ! error message + err => out_surfaceFlux % err , & ! error code + message => out_surfaceFlux % message & ! error message &) ! compute the surface flux and its derivative if (firstSplitOper .or. updateInfil) then select case(bc_upper) case(prescribedHead) ! head condition, no frozen area and all area infiltrates - call update_surfaceFlx_prescribedHead; if (return_flag) return + call update_surfaceFlux_prescribedHead; if (return_flag) return case(liquidFlux) ! flux condition ! compute volumetric fraction of liquid and ice water in each soil layer and their derivatives @@ -1025,15 +1024,15 @@ subroutine update_surfaceFlx ! Get infiltration area not considering frozen area, based on SE method select case(surfRun_SE) ! saturation excess surface runoff method, sets infiltration area (not considering frozen) and its derivatives case(zero_SE) ! zero saturation excess surface runoff, all area infiltrates if not frozen - io_surfaceFlx % scalarInfilArea = 1._rkind + io_surfaceFlux % scalarInfilArea = 1._rkind case(homegrown_SE) ! homegrown saturation excess surface runoff (original SUMMA method) - call update_surfaceFlx_homegrown_infilArea; if (return_flag) return + call update_surfaceFlux_homegrown_infilArea; if (return_flag) return case(FUSEPRMS) ! FUSE PRMS surface runoff - call update_surfaceFlx_FUSE_PRMS_infilArea; if (return_flag) return + call update_surfaceFlux_FUSE_PRMS_infilArea; if (return_flag) return case(FUSEAVIC) ! FUSE ARNO/VIC surface runoff - call update_surfaceFlx_FUSE_ARNO_VIC_infilArea; if (return_flag) return + call update_surfaceFlux_FUSE_ARNO_VIC_infilArea; if (return_flag) return case(FUSETOPM) ! FUSE TOPMODEL surface runoff - call update_surfaceFlx_FUSE_TOPMODEL_infilArea; if (return_flag) return + call update_surfaceFlux_FUSE_TOPMODEL_infilArea; if (return_flag) return case default; err=20; message=trim(message)//'unknown saturation excess surface runoff method'; return_flag=.true.; return end select @@ -1045,17 +1044,17 @@ subroutine update_surfaceFlx ! Calculate maximum infiltration rate and scalarFrozenArea (and their derivatives if needed) select case(ixInfRateMax) ! maximum infiltration rate method (controls infiltration excess surface runoff) case(noInfiltrationExcess) ! zero infiltration excess surface runoff - call update_surfaceFlx_liquidFlux_noinfratemax + call update_surfaceFlux_liquidFlux_noinfratemax case(GreenAmpt, topmodel_GA) ! infiltration excess runoff possible - call update_surfaceFlx_liquidFlux_calculate_infratemax; if (return_flag) return + call update_surfaceFlux_liquidFlux_calculate_infratemax; if (return_flag) return case default; err=20; message=trim(message)//'unknown infiltration excess surface runoff method'; return_flag=.true.; return end select ! Compute total infiltration, gets infiltration excess surface runoff, modifies saturation excess surface runoff if more rain than can infiltrate - call update_surfaceFlx_liquidFlux_infiltration; if (return_flag) return + call update_surfaceFlux_liquidFlux_infiltration; if (return_flag) return ! update the derivatives for any combination of SE and IE parametrization options - if(updateInfil) call update_surfaceFlx_liquidFlux_derivatives + if(updateInfil) call update_surfaceFlux_liquidFlux_derivatives case default; err=20; message=trim(message)//'unknown upper boundary condition for soil hydrology'; return_flag=.true.; return ! end of select of bc_upper end select @@ -1065,7 +1064,7 @@ subroutine update_surfaceFlx end if end associate - end subroutine update_surfaceFlx + end subroutine update_surfaceFlux subroutine update_volFracLiq_derivatives ! **** Updates the derivatives for volumetric fraction of liquid and ice water in each soil layer **** @@ -1075,21 +1074,21 @@ subroutine update_volFracLiq_derivatives associate(& ! input: model control - ixInfRateMax => in_surfaceFlx % ixInfRateMax , & ! index defining the maximum infiltration rate method - surfRun_SE => in_surfaceFlx % surfRun_SE , & ! index defining the saturation excess surface runoff method - ixRichards => in_surfaceFlx % ixRichards , & ! index defining the option for Richards' equation (moisture or mixdform) - nRoots => in_surfaceFlx % nRoots , & ! number of layers that contain roots - nSoil => in_surfaceFlx % nSoil , & ! total number of soil layers + ixInfRateMax => in_surfaceFlux % ixInfRateMax , & ! index defining the maximum infiltration rate method + surfRun_SE => in_surfaceFlux % surfRun_SE , & ! index defining the saturation excess surface runoff method + ixRichards => in_surfaceFlux % ixRichards , & ! index defining the option for Richards' equation (moisture or mixdform) + nRoots => in_surfaceFlux % nRoots , & ! number of layers that contain roots + nSoil => in_surfaceFlux % nSoil , & ! total number of soil layers ! input: state and diagnostic variables - mLayerTemp => in_surfaceFlx % mLayerTemp , & ! temperature (K) - mLayerMatricHead => in_surfaceFlx % mLayerMatricHead , & ! matric head in each soil layer (m) + mLayerTemp => in_surfaceFlux % mLayerTemp , & ! temperature (K) + mLayerMatricHead => in_surfaceFlux % mLayerMatricHead , & ! matric head in each soil layer (m) ! input: pre-computed derivatives in ... - dTheta_dTk => in_surfaceFlx % dTheta_dTk , & ! ... volumetric liquid water content w.r.t. temperature (K-1) - dTheta_dPsi => in_surfaceFlx % dTheta_dPsi , & ! ... the soil water characteristic w.r.t. psi (m-1) - mLayerdPsi_dTheta => in_surfaceFlx % mLayerdPsi_dTheta , & ! ... the soil water characteristic w.r.t. theta (m) + dTheta_dTk => in_surfaceFlux % dTheta_dTk , & ! ... volumetric liquid water content w.r.t. temperature (K-1) + dTheta_dPsi => in_surfaceFlux % dTheta_dPsi , & ! ... the soil water characteristic w.r.t. psi (m-1) + mLayerdPsi_dTheta => in_surfaceFlux % mLayerdPsi_dTheta , & ! ... the soil water characteristic w.r.t. theta (m) ! output: error control - err => out_surfaceFlx % err , & ! error code - message => out_surfaceFlx % message & ! error message + err => out_surfaceFlux % err , & ! error code + message => out_surfaceFlux % message & ! error message &) ! determine number of layers to process and whether ice derivatives are needed @@ -1141,21 +1140,21 @@ subroutine update_volFracLiq_derivatives end associate end subroutine update_volFracLiq_derivatives - subroutine update_surfaceFlx_liquidFlux_derivatives + subroutine update_surfaceFlux_liquidFlux_derivatives ! **** Updates the derivatives for the liquid flux upper hydrology boundary condition if needed **** associate(& ! input: flux at the upper boundary - scalarRainPlusMelt => in_surfaceFlx % scalarRainPlusMelt , & ! rain plus melt, used as input to the soil zone before computing surface runoff (m s-1) + scalarRainPlusMelt => in_surfaceFlux % scalarRainPlusMelt , & ! rain plus melt, used as input to the soil zone before computing surface runoff (m s-1) ! input: surface runoff and infiltration flux (m s-1) - xMaxInfilRate => io_surfaceFlx % xMaxInfilRate , & ! maximum infiltration rate (m s-1) - scalarInfilArea => io_surfaceFlx % scalarInfilArea , & ! fraction of area where water can infiltrate, may be frozen (-) - scalarFrozenArea => io_surfaceFlx % scalarFrozenArea , & ! fraction of area that is considered impermeable due to soil ice (-) + xMaxInfilRate => io_surfaceFlux % xMaxInfilRate , & ! maximum infiltration rate (m s-1) + scalarInfilArea => io_surfaceFlux % scalarInfilArea , & ! fraction of area where water can infiltrate, may be frozen (-) + scalarFrozenArea => io_surfaceFlux % scalarFrozenArea , & ! fraction of area that is considered impermeable due to soil ice (-) ! output: derivatives in surface infiltration w.r.t. ... - dq_dHydStateVec => out_surfaceFlx % dq_dHydStateVec, & ! ... hydrology state in above soil snow or canopy and every soil layer (m s-1 or s-1) - dq_dNrgStateVec => out_surfaceFlx % dq_dNrgStateVec, & ! ... energy state in above soil snow or canopy and every soil layer (m s-1 K-1) + dq_dHydStateVec => out_surfaceFlux % dq_dHydStateVec, & ! ... hydrology state in above soil snow or canopy and every soil layer (m s-1 or s-1) + dq_dNrgStateVec => out_surfaceFlux % dq_dNrgStateVec, & ! ... energy state in above soil snow or canopy and every soil layer (m s-1 K-1) ! output: error control - err => out_surfaceFlx % err , & ! error code - message => out_surfaceFlx % message & ! error message + err => out_surfaceFlux % err , & ! error code + message => out_surfaceFlux % message & ! error message &) ! Compute total runoff derivatives, do w.r.t. infiltration only, scalarRainPlusMelt accounted for in computJacob* module @@ -1163,39 +1162,39 @@ subroutine update_surfaceFlx_liquidFlux_derivatives dq_dHydStateVec(:) = (1._rkind - scalarFrozenArea)& * ( dInfilArea_dWat(:)*min(scalarRainPlusMelt,xMaxInfilRate) + scalarInfilArea*dInfilRate_dWat(:) )& + (-dFrozenArea_dWat(:))*scalarInfilArea*min(scalarRainPlusMelt,xMaxInfilRate) - ! energy state variable is temperature (transformed outside soilLiqFlx_module if needed) + ! energy state variable is temperature (transformed outside soilLiqFlux_module if needed) dq_dNrgStateVec(:) = (1._rkind - scalarFrozenArea)& * ( dInfilArea_dTk(:) *min(scalarRainPlusMelt,xMaxInfilRate) + scalarInfilArea*dInfilRate_dTk(:) )& + (-dFrozenArea_dTk(:)) *scalarInfilArea*min(scalarRainPlusMelt,xMaxInfilRate) end associate - end subroutine update_surfaceFlx_liquidFlux_derivatives + end subroutine update_surfaceFlux_liquidFlux_derivatives - subroutine update_surfaceFlx_FUSE_PRMS_infilArea - ! **** Update operations for surfaceFlx: surface runoff from Clark et al. (2008, doi:10.1029/2007WR006735) -- PRMS **** + subroutine update_surfaceFlux_FUSE_PRMS_infilArea + ! **** Update operations for surfaceFlux: surface runoff from Clark et al. (2008, doi:10.1029/2007WR006735) -- PRMS **** use soil_utils_module,only:LogSumExp ! smooth max/min use soil_utils_module,only:SoftArgMax ! smooth arg max/min (for derivatives of LogSumExp) ! local variables - real(rkind) :: dS1_dLiq(1:in_surfaceFlx % nSoil) ! derivative of S1 w.r.t. liquid water content + real(rkind) :: dS1_dLiq(1:in_surfaceFlux % nSoil) ! derivative of S1 w.r.t. liquid water content real(rkind) :: S1_T_derivatives(1:2) ! array of derivatives for S1_T real(rkind) :: dS1_T_dS1 ! derivative of S1_T w.r.t S1 - real(rkind) :: dS1_T_dLiq(1:in_surfaceFlx % nSoil) ! derivative of S1_T w.r.t liquid water content + real(rkind) :: dS1_T_dLiq(1:in_surfaceFlux % nSoil) ! derivative of S1_T w.r.t liquid water content associate(& - nSoil => in_surfaceFlx % nSoil, & ! number of soil layers - mLayerVolFracLiq => in_surfaceFlx % mLayerVolFracLiq, & ! volumetric liquid water content in each soil layer (-) - mLayerDepth => in_surfaceFlx % mLayerDepth, & ! depth of soil layers (m) - iLayerHeight => in_surfaceFlx % iLayerHeight, & ! height at the interface of each layer for soil layers only (m) - theta_sat => in_surfaceFlx % theta_sat, & ! soil porosity (-) + nSoil => in_surfaceFlux % nSoil, & ! number of soil layers + mLayerVolFracLiq => in_surfaceFlux % mLayerVolFracLiq, & ! volumetric liquid water content in each soil layer (-) + mLayerDepth => in_surfaceFlux % mLayerDepth, & ! depth of soil layers (m) + iLayerHeight => in_surfaceFlux % iLayerHeight, & ! height at the interface of each layer for soil layers only (m) + theta_sat => in_surfaceFlux % theta_sat, & ! soil porosity (-) ! output: error control - err => out_surfaceFlx % err , & ! error code - message => out_surfaceFlx % message & ! error message + err => out_surfaceFlux % err , & ! error code + message => out_surfaceFlux % message & ! error message &) ! validation of parameters - SatArea_max = in_surfaceFlx % FUSE_Ac_max - phi_tens = in_surfaceFlx % FUSE_phi_tens + SatArea_max = in_surfaceFlux % FUSE_Ac_max + phi_tens = in_surfaceFlux % FUSE_phi_tens ! validate input parameters if ((SatArea_max<0._rkind).or.(SatArea_max>1._rkind)) then err=10; message=trim(message)//"FUSE PRMS surface runoff error: invalid SatArea_max (max saturated area) value"; return_flag=.true.; return @@ -1206,7 +1205,7 @@ subroutine update_surfaceFlx_FUSE_PRMS_infilArea ! compute water content in upper FUSE layer S1 = sum( mLayerDepth(:) * mLayerVolFracLiq(:) ) ! total water content in upper FUSE layer (m) - if (S1 <= 0._rkind) then; io_surfaceFlx % scalarInfilArea = 1._rkind; return; end if ! if no water, unsaturated and all area infiltrates + if (S1 <= 0._rkind) then; io_surfaceFlux % scalarInfilArea = 1._rkind; return; end if ! if no water, unsaturated and all area infiltrates S1_max = iLayerHeight(nSoil) * theta_sat ! max water storage for upper FUSE layer (m) ! compute tension water content @@ -1218,7 +1217,7 @@ subroutine update_surfaceFlx_FUSE_PRMS_infilArea end if ! define the infiltrating area and derivatives for the non-frozen part of the cell/basin - io_surfaceFlx % scalarInfilArea = 1._rkind - (S1_T/S1_T_max)*SatArea_max + io_surfaceFlux % scalarInfilArea = 1._rkind - (S1_T/S1_T_max)*SatArea_max ! define the derivatives if(updateInfil)then dS1_dLiq = mLayerDepth(:) @@ -1230,39 +1229,39 @@ subroutine update_surfaceFlx_FUSE_PRMS_infilArea endif ! else derivatives are zero end associate - end subroutine update_surfaceFlx_FUSE_PRMS_infilArea + end subroutine update_surfaceFlux_FUSE_PRMS_infilArea - subroutine update_surfaceFlx_FUSE_ARNO_VIC_infilArea - ! **** Update operations for surfaceFlx: surface runoff from Clark et al. (2008, doi:10.1029/2007WR006735) -- ARNO/VIC **** + subroutine update_surfaceFlux_FUSE_ARNO_VIC_infilArea + ! **** Update operations for surfaceFlux: surface runoff from Clark et al. (2008, doi:10.1029/2007WR006735) -- ARNO/VIC **** use soil_utils_module,only:LogSumExp ! smooth max/min use soil_utils_module,only:SoftArgMax ! smooth arg max/min (for derivatives of LogSumExp) ! local variables - real(rkind) :: dS1_dLiq(1:in_surfaceFlx % nSoil) ! derivative of S1 w.r.t. liquid water content + real(rkind) :: dS1_dLiq(1:in_surfaceFlux % nSoil) ! derivative of S1 w.r.t. liquid water content real(rkind) :: dS1_star_dS1 ! derivative in S1_star w.r.t S1 real(rkind) :: dbase_dS1 ! derivative of base w.r.t S1 real(rkind) :: S1_star_derivatives(1:2) ! array of derivatives for S1_star from SoftArgMax function associate(& - nSoil => in_surfaceFlx % nSoil, & ! number of soil layers - mLayerVolFracLiq => in_surfaceFlx % mLayerVolFracLiq, & ! volumetric liquid water content in each soil layer (-) - mLayerDepth => in_surfaceFlx % mLayerDepth, & ! depth of soil layers (m) - iLayerHeight => in_surfaceFlx % iLayerHeight, & ! height at the interface of each layer for soil layers only (m) - theta_sat => in_surfaceFlx % theta_sat, & ! soil porosity (-) + nSoil => in_surfaceFlux % nSoil, & ! number of soil layers + mLayerVolFracLiq => in_surfaceFlux % mLayerVolFracLiq, & ! volumetric liquid water content in each soil layer (-) + mLayerDepth => in_surfaceFlux % mLayerDepth, & ! depth of soil layers (m) + iLayerHeight => in_surfaceFlux % iLayerHeight, & ! height at the interface of each layer for soil layers only (m) + theta_sat => in_surfaceFlux % theta_sat, & ! soil porosity (-) ! output: error control - err => out_surfaceFlx % err , & ! error code - message => out_surfaceFlx % message & ! error message + err => out_surfaceFlux % err , & ! error code + message => out_surfaceFlux % message & ! error message &) ! validation of input parameters - b_arnovic = in_surfaceFlx % FUSE_b ! interface ARNO/VIC exponent + b_arnovic = in_surfaceFlux % FUSE_b ! interface ARNO/VIC exponent if ((b_arnovic < 0.001_rkind).or.(b_arnovic > 3._rkind)) then err=10; message=trim(message)//"FUSE ARNO/VIC exponent must be between 0.001 and 3"; return_flag=.true.; return end if ! compute water content in FUSE layers S1 = sum( mLayerDepth(:) * mLayerVolFracLiq(:) ) ! total water content in FUSE layers (m) - if (S1 <= 0._rkind) then; io_surfaceFlx % scalarInfilArea = 1._rkind; return; end if ! if no water, unsaturated and all area infiltrates + if (S1 <= 0._rkind) then; io_surfaceFlux % scalarInfilArea = 1._rkind; return; end if ! if no water, unsaturated and all area infiltrates S1_max = iLayerHeight(nSoil) * theta_sat ! max water storage for FUSE layers (m) ! Original FUSE: SatArea = 1 - (1-S1/S1_max)**b_arnovic @@ -1290,7 +1289,7 @@ subroutine update_surfaceFlx_FUSE_ARNO_VIC_infilArea end if ! define the infiltrating area and derivatives for the non-frozen part of the cell/basin - io_surfaceFlx % scalarInfilArea = base**b_arnovic + io_surfaceFlux % scalarInfilArea = base**b_arnovic ! define the derivatives if(updateInfil)then @@ -1308,14 +1307,14 @@ subroutine update_surfaceFlx_FUSE_ARNO_VIC_infilArea endif ! else derivatives are zero end associate - end subroutine update_surfaceFlx_FUSE_ARNO_VIC_infilArea + end subroutine update_surfaceFlux_FUSE_ARNO_VIC_infilArea - subroutine update_surfaceFlx_FUSE_TOPMODEL_infilArea - ! **** Update operations for surfaceFlx: surface runoff from Clark et al. (2008, doi:10.1029/2007WR006735) -- TOPMODEL **** + subroutine update_surfaceFlux_FUSE_TOPMODEL_infilArea + ! **** Update operations for surfaceFlux: surface runoff from Clark et al. (2008, doi:10.1029/2007WR006735) -- TOPMODEL **** ! local variables complex(rkind) :: F1,F2 ! temporary storage for regularized lower incomplete gamma function values - real(rkind) :: dS1_dLiq(1:in_surfaceFlx % nSoil) ! derivative in S1 w.r.t liquid water content + real(rkind) :: dS1_dLiq(1:in_surfaceFlux % nSoil) ! derivative in S1 w.r.t liquid water content real(rkind) :: dzeta_crit_n_dS1 ! derivative of zeta_crit_n w.r.t S1 real(rkind) :: dzeta_crit_dzeta_crit_n ! derivative of zeta_crit w.r.t zeta_crit_n real(rkind) :: dx_crit_dzeta_crit ! derivative of x_crit w.r.t zeta_crit @@ -1323,25 +1322,25 @@ subroutine update_surfaceFlx_FUSE_TOPMODEL_infilArea real(rkind) :: dgammp_dx_crit ! derivative of gammp function in SatArea w.r.t x_crit associate(& - nSoil => in_surfaceFlx % nSoil, & ! number of soil layers - mLayerVolFracLiq => in_surfaceFlx % mLayerVolFracLiq, & ! volumetric liquid water content in each soil layer (-) - mLayerDepth => in_surfaceFlx % mLayerDepth, & ! depth of soil layers (m) - iLayerHeight => in_surfaceFlx % iLayerHeight, & ! height at the interface of each layer for soil layers only (m) - theta_sat => in_surfaceFlx % theta_sat, & ! soil porosity (-) + nSoil => in_surfaceFlux % nSoil, & ! number of soil layers + mLayerVolFracLiq => in_surfaceFlux % mLayerVolFracLiq, & ! volumetric liquid water content in each soil layer (-) + mLayerDepth => in_surfaceFlux % mLayerDepth, & ! depth of soil layers (m) + iLayerHeight => in_surfaceFlux % iLayerHeight, & ! height at the interface of each layer for soil layers only (m) + theta_sat => in_surfaceFlux % theta_sat, & ! soil porosity (-) ! output: error control - err => out_surfaceFlx % err , & ! error code - message => out_surfaceFlx % message & ! error message + err => out_surfaceFlux % err , & ! error code + message => out_surfaceFlux % message & ! error message &) ! interface FUSE input parameters - lambda = in_surfaceFlx % FUSE_lambda - chi_topmodel = in_surfaceFlx % FUSE_chi - mu = in_surfaceFlx % FUSE_mu - n_topmodel = in_surfaceFlx % FUSE_n + lambda = in_surfaceFlux % FUSE_lambda + chi_topmodel = in_surfaceFlux % FUSE_chi + mu = in_surfaceFlux % FUSE_mu + n_topmodel = in_surfaceFlux % FUSE_n ! compute water content in lower FUSE layer, here the entire soil column is used S1 = sum( mLayerDepth(:) * mLayerVolFracLiq(:) ) ! total water content in lower FUSE layer (m) - if (S1 <= 0._rkind) then; io_surfaceFlx % scalarInfilArea = 1._rkind; return; end if ! if no water, unsaturated and all area infiltrates + if (S1 <= 0._rkind) then; io_surfaceFlux % scalarInfilArea = 1._rkind; return; end if ! if no water, unsaturated and all area infiltrates S1_max = iLayerHeight(nSoil) * theta_sat ! max water storage for lower FUSE layer (m) ! validate of parameters @@ -1395,10 +1394,10 @@ subroutine update_surfaceFlx_FUSE_TOPMODEL_infilArea end if ! define the infiltrating area and derivatives for the non-frozen part of the cell/basin - io_surfaceFlx % scalarInfilArea = gammp(alpha_topmodel,x_crit/chi_topmodel) + io_surfaceFlux % scalarInfilArea = gammp(alpha_topmodel,x_crit/chi_topmodel) else ! if (S1 == 0) no water is stored in lower FUSE layer (based on asymptotic behaviour of integral in eq. 9c of Clark et al. (2008)) - io_surfaceFlx % scalarInfilArea = 1._rkind + io_surfaceFlux % scalarInfilArea = 1._rkind end if ! define the derivatives @@ -1414,47 +1413,47 @@ subroutine update_surfaceFlx_FUSE_TOPMODEL_infilArea endif ! else derivatives are zero end associate - end subroutine update_surfaceFlx_FUSE_TOPMODEL_infilArea + end subroutine update_surfaceFlux_FUSE_TOPMODEL_infilArea - subroutine update_surfaceFlx_prescribedHead - ! **** Update operations for surfaceFlx: prescribed pressure head condition **** + subroutine update_surfaceFlux_prescribedHead + ! **** Update operations for surfaceFlux: prescribed pressure head condition **** associate(& ! input: model control - ixRichards => in_surfaceFlx % ixRichards , & ! index defining the option for Richards' equation (moisture or mixdform) + ixRichards => in_surfaceFlux % ixRichards , & ! index defining the option for Richards' equation (moisture or mixdform) ! input: state and diagnostic variables - scalarMatricHeadLiq => in_surfaceFlx % scalarMatricHeadLiq , & ! liquid matric head in the upper-most soil layer (m) - scalarVolFracLiq => in_surfaceFlx % scalarVolFracLiq , & ! volumetric liquid water content in the upper-most soil layer (-) + scalarMatricHeadLiq => in_surfaceFlux % scalarMatricHeadLiq , & ! liquid matric head in the upper-most soil layer (m) + scalarVolFracLiq => in_surfaceFlux % scalarVolFracLiq , & ! volumetric liquid water content in the upper-most soil layer (-) ! input: depth of each soil layer (m) - mLayerDepth => in_surfaceFlx % mLayerDepth , & ! depth of each soil layer (m) + mLayerDepth => in_surfaceFlux % mLayerDepth , & ! depth of each soil layer (m) ! input: diriclet boundary conditions - upperBoundHead => in_surfaceFlx % upperBoundHead , & ! upper boundary condition for matric head (m) - upperBoundTheta => in_surfaceFlx % upperBoundTheta , & ! upper boundary condition for volumetric liquid water content (-) + upperBoundHead => in_surfaceFlux % upperBoundHead , & ! upper boundary condition for matric head (m) + upperBoundTheta => in_surfaceFlux % upperBoundTheta , & ! upper boundary condition for volumetric liquid water content (-) ! input: transmittance - surfaceSatHydCond => in_surfaceFlx % surfaceSatHydCond , & ! saturated hydraulic conductivity at the surface (m s-1) - dHydCond_dTemp => in_surfaceFlx % dHydCond_dTemp , & ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) - iceImpedeFac => in_surfaceFlx % iceImpedeFac , & ! ice impedence factor in the upper-most soil layer (-) + surfaceSatHydCond => in_surfaceFlux % surfaceSatHydCond , & ! saturated hydraulic conductivity at the surface (m s-1) + dHydCond_dTemp => in_surfaceFlux % dHydCond_dTemp , & ! derivative in hydraulic conductivity w.r.t temperature (m s-1 K-1) + iceImpedeFac => in_surfaceFlux % iceImpedeFac , & ! ice impedence factor in the upper-most soil layer (-) ! input: soil parameters - vGn_alpha => in_surfaceFlx % vGn_alpha , & ! van Genuchten "alpha" parameter (m-1) - vGn_n => in_surfaceFlx % vGn_n , & ! van Genuchten "n" parameter (-) - vGn_m => in_surfaceFlx % vGn_m , & ! van Genuchten "m" parameter (-) - theta_sat => in_surfaceFlx % theta_sat , & ! soil porosity (-) - theta_res => in_surfaceFlx % theta_res , & ! soil residual volumetric water content (-) + vGn_alpha => in_surfaceFlux % vGn_alpha , & ! van Genuchten "alpha" parameter (m-1) + vGn_n => in_surfaceFlux % vGn_n , & ! van Genuchten "n" parameter (-) + vGn_m => in_surfaceFlux % vGn_m , & ! van Genuchten "m" parameter (-) + theta_sat => in_surfaceFlux % theta_sat , & ! soil porosity (-) + theta_res => in_surfaceFlux % theta_res , & ! soil residual volumetric water content (-) ! input-output: hydraulic conductivity and diffusivity at the surface ! NOTE: intent(inout) because infiltration may only be computed for the first iteration - surfaceHydCond => io_surfaceFlx % surfaceHydCond , & ! hydraulic conductivity (m s-1) - surfaceDiffuse => io_surfaceFlx % surfaceDiffuse , & ! hydraulic diffusivity at the surface (m2 s-1) + surfaceHydCond => io_surfaceFlux % surfaceHydCond , & ! hydraulic conductivity (m s-1) + surfaceDiffuse => io_surfaceFlux % surfaceDiffuse , & ! hydraulic diffusivity at the surface (m2 s-1) ! output: runoff and infiltration - scalarSurfaceRunoff => out_surfaceFlx % scalarSurfaceRunoff , & ! surface runoff (m s-1) - scalarSurfaceRunoff_IE => out_surfaceFlx % scalarSurfaceRunoff_IE , & ! infiltration excess surface runoff (m s-1) - scalarSurfaceRunoff_SE => out_surfaceFlx % scalarSurfaceRunoff_SE , & ! saturation excess surface runoff (m s-1) - scalarSurfaceInfiltration => out_surfaceFlx % scalarSurfaceInfiltration , & ! surface infiltration (m s-1) + scalarSurfaceRunoff => out_surfaceFlux % scalarSurfaceRunoff , & ! surface runoff (m s-1) + scalarSurfaceRunoff_IE => out_surfaceFlux % scalarSurfaceRunoff_IE , & ! infiltration excess surface runoff (m s-1) + scalarSurfaceRunoff_SE => out_surfaceFlux % scalarSurfaceRunoff_SE , & ! saturation excess surface runoff (m s-1) + scalarSurfaceInfiltration => out_surfaceFlux % scalarSurfaceInfiltration , & ! surface infiltration (m s-1) ! output: derivatives in surface infiltration w.r.t. ... - scalarSoilControl => io_surfaceFlx % scalarSoilControl , & ! soil control on infiltration for derivative - dq_dHydStateVec => out_surfaceFlx % dq_dHydStateVec , & ! ... hydrology state in above soil snow or canopy and every soil layer (m s-1 or s-1) - dq_dNrgStateVec => out_surfaceFlx % dq_dNrgStateVec , & ! ... energy state in above soil snow or canopy and every soil layer (m s-1 K-1) + scalarSoilControl => io_surfaceFlux % scalarSoilControl , & ! soil control on infiltration for derivative + dq_dHydStateVec => out_surfaceFlux % dq_dHydStateVec , & ! ... hydrology state in above soil snow or canopy and every soil layer (m s-1 or s-1) + dq_dNrgStateVec => out_surfaceFlux % dq_dNrgStateVec , & ! ... energy state in above soil snow or canopy and every soil layer (m s-1 K-1) ! output: error control - err => out_surfaceFlx % err , & ! error code - message => out_surfaceFlx % message & ! error message + err => out_surfaceFlux % err , & ! error code + message => out_surfaceFlux % message & ! error message &) ! surface runoff iz zero for the head condition @@ -1490,72 +1489,72 @@ subroutine update_surfaceFlx_prescribedHead case(mixdform); dq_dHydStateVec(1) = -surfaceHydCond/(mLayerDepth(1)/2._rkind) case default; err=10; message=trim(message)//"unknown form of Richards' equation"; return_flag=.true.; return end select - ! note: energy state variable is temperature (transformed outside soilLiqFlx_module if needed) + ! note: energy state variable is temperature (transformed outside soilLiqFlux_module if needed) dq_dNrgStateVec(1) = -(dHydCond_dTemp/2._rkind)*(scalarMatricHeadLiq - upperBoundHead)/(mLayerDepth(1)*0.5_rkind) + dHydCond_dTemp/2._rkind end if - ! * additional assignment statements for surfaceFlx input-output object based on presribed head values * + ! * additional assignment statements for surfaceFlux input-output object based on presribed head values * ! the infiltration is always constrained by the prescribed head so the maximum infiltration rate is set to missing - io_surfaceFlx % xMaxInfilRate = realMissing ! maximum infiltration rate (m s-1) + io_surfaceFlux % xMaxInfilRate = realMissing ! maximum infiltration rate (m s-1) ! no soil ice assumed for prescribed head condition - io_surfaceFlx % scalarFrozenArea = 0._rkind ! fraction of area that is considered impermeable due to soil ice (-) + io_surfaceFlux % scalarFrozenArea = 0._rkind ! fraction of area that is considered impermeable due to soil ice (-) ! all area is available for infiltration, and to complement this saturated area (i.e., part where saturation excess runoff occurs) is set to zero - io_surfaceFlx % scalarInfilArea = 1._rkind ! fraction of area where water can infiltrate, may be frozen (-) - io_surfaceFlx % scalarSaturatedArea = 0._rkind ! fraction of area that is considered saturated (-) + io_surfaceFlux % scalarInfilArea = 1._rkind ! fraction of area where water can infiltrate, may be frozen (-) + io_surfaceFlux % scalarSaturatedArea = 0._rkind ! fraction of area that is considered saturated (-) end associate - end subroutine update_surfaceFlx_prescribedHead + end subroutine update_surfaceFlux_prescribedHead - subroutine update_surfaceFlx_homegrown_infilArea - ! **** Update operations for surfaceFlx: homegrown saturation excess runoff condition **** - call update_surfaceFlx_liquidFlux_computation_root_layers - call update_surfaceFlx_liquidFlux_computation_available_capacity; if (return_flag) return - call update_surfaceFlx_liquidFlux_computation_homegrown ! this calculates infiltration area ignoring if frozen or not, depends on available capacity (depends on ice and root zone) - end subroutine update_surfaceFlx_homegrown_infilArea + subroutine update_surfaceFlux_homegrown_infilArea + ! **** Update operations for surfaceFlux: homegrown saturation excess runoff condition **** + call update_surfaceFlux_liquidFlux_computation_root_layers + call update_surfaceFlux_liquidFlux_computation_available_capacity; if (return_flag) return + call update_surfaceFlux_liquidFlux_computation_homegrown ! this calculates infiltration area ignoring if frozen or not, depends on available capacity (depends on ice and root zone) + end subroutine update_surfaceFlux_homegrown_infilArea - subroutine update_surfaceFlx_liquidFlux_noinfratemax - ! **** Update operations for surfaceFlx: no infiltration excess**** + subroutine update_surfaceFlux_liquidFlux_noinfratemax + ! **** Update operations for surfaceFlux: no infiltration excess**** associate(& ! input: model control - surfRun_SE => in_surfaceFlx % surfRun_SE & ! index defining the saturation excess surface runoff method + surfRun_SE => in_surfaceFlux % surfRun_SE & ! index defining the saturation excess surface runoff method &) - io_surfaceFlx % xMaxInfilRate = veryBig ! set to a very large number so rainPlusMelt never exceeds this + io_surfaceFlux % xMaxInfilRate = veryBig ! set to a very large number so rainPlusMelt never exceeds this if (surfRun_SE /= homegrown_SE) then ! frozen area (depends on ice and root zone) - call update_surfaceFlx_liquidFlux_computation_root_layers + call update_surfaceFlux_liquidFlux_computation_root_layers end if end associate ! -- main computations - these always need to run - call update_surfaceFlx_liquidFlux_computation_frozen_area - end subroutine update_surfaceFlx_liquidFlux_noinfratemax + call update_surfaceFlux_liquidFlux_computation_frozen_area + end subroutine update_surfaceFlux_liquidFlux_noinfratemax - subroutine update_surfaceFlx_liquidFlux_calculate_infratemax - ! **** Update operations for surfaceFlx: infiltration excess possible - calculate max infiltration rate **** + subroutine update_surfaceFlux_liquidFlux_calculate_infratemax + ! **** Update operations for surfaceFlux: infiltration excess possible - calculate max infiltration rate **** associate(& ! input: model control - surfRun_SE => in_surfaceFlx % surfRun_SE & ! index defining the saturation excess surface runoff method + surfRun_SE => in_surfaceFlux % surfRun_SE & ! index defining the saturation excess surface runoff method &) if (surfRun_SE /= homegrown_SE) then ! infiltration rate max depends on available capacity (depends on ice and root zone) and frozen area (depends on ice and root zone) - call update_surfaceFlx_liquidFlux_computation_root_layers - call update_surfaceFlx_liquidFlux_computation_available_capacity; if (return_flag) return + call update_surfaceFlux_liquidFlux_computation_root_layers + call update_surfaceFlux_liquidFlux_computation_available_capacity; if (return_flag) return end if end associate ! -- main computations - these always need to run - call update_surfaceFlx_liquidFlux_computation_frozen_area - call update_surfaceFlx_liquidFlux_computation_max_infiltration_rate - end subroutine update_surfaceFlx_liquidFlux_calculate_infratemax + call update_surfaceFlux_liquidFlux_computation_frozen_area + call update_surfaceFlux_liquidFlux_computation_max_infiltration_rate + end subroutine update_surfaceFlux_liquidFlux_calculate_infratemax - subroutine update_surfaceFlx_liquidFlux_computation_root_layers - ! **** Update operations for surfaceFlx: root layer water computation **** + subroutine update_surfaceFlux_liquidFlux_computation_root_layers + ! **** Update operations for surfaceFlux: root layer water computation **** associate(& ! input: model control - nRoots => in_surfaceFlx % nRoots , & ! number of soil layers with roots (-) + nRoots => in_surfaceFlux % nRoots , & ! number of soil layers with roots (-) ! input: state and diagnostic variables - mLayerVolFracLiq => in_surfaceFlx % mLayerVolFracLiq , & ! volumetric liquid water content in each soil layer (-) - mLayerVolFracIce => in_surfaceFlx % mLayerVolFracIce , & ! volumetric ice content in each soil layer (-) + mLayerVolFracLiq => in_surfaceFlux % mLayerVolFracLiq , & ! volumetric liquid water content in each soil layer (-) + mLayerVolFracIce => in_surfaceFlux % mLayerVolFracIce , & ! volumetric ice content in each soil layer (-) ! input: depth of soil layers (m) - mLayerDepth => in_surfaceFlx % mLayerDepth , & ! depth of each soil layer (m) - iLayerHeight => in_surfaceFlx % iLayerHeight , & ! height at the interface of each layer for soil layers only (m) - rootingDepth => in_surfaceFlx % rootingDepth & ! rooting depth (m) + mLayerDepth => in_surfaceFlux % mLayerDepth , & ! depth of each soil layer (m) + iLayerHeight => in_surfaceFlux % iLayerHeight , & ! height at the interface of each layer for soil layers only (m) + rootingDepth => in_surfaceFlux % rootingDepth & ! rooting depth (m) &) ! define the storage in the root zone (m) and derivatives, first initialize @@ -1590,17 +1589,17 @@ subroutine update_surfaceFlx_liquidFlux_computation_root_layers endif end associate - end subroutine update_surfaceFlx_liquidFlux_computation_root_layers + end subroutine update_surfaceFlux_liquidFlux_computation_root_layers - subroutine update_surfaceFlx_liquidFlux_computation_available_capacity - ! **** Update operations for surfaceFlx: compute and check available capacity to hold water **** + subroutine update_surfaceFlux_liquidFlux_computation_available_capacity + ! **** Update operations for surfaceFlux: compute and check available capacity to hold water **** associate(& ! input: soil parameters - theta_sat => in_surfaceFlx % theta_sat , & ! soil porosity (-) - rootingDepth => in_surfaceFlx % rootingDepth , & ! rooting depth (m) + theta_sat => in_surfaceFlux % theta_sat , & ! soil porosity (-) + rootingDepth => in_surfaceFlux % rootingDepth , & ! rooting depth (m) ! output: error control - err => out_surfaceFlx % err , & ! error code - message => out_surfaceFlx % message & ! error message + err => out_surfaceFlux % err , & ! error code + message => out_surfaceFlux % message & ! error message &) availCapacity = theta_sat*rootingDepth - rootZoneIce if (rootZoneLiq > availCapacity+verySmaller) then @@ -1608,22 +1607,22 @@ subroutine update_surfaceFlx_liquidFlux_computation_available_capacity end if end associate - end subroutine update_surfaceFlx_liquidFlux_computation_available_capacity + end subroutine update_surfaceFlux_liquidFlux_computation_available_capacity - subroutine update_surfaceFlx_liquidFlux_computation_max_infiltration_rate - ! **** Update operations for surfaceFlx: max infiltration rate and derivatives **** + subroutine update_surfaceFlux_liquidFlux_computation_max_infiltration_rate + ! **** Update operations for surfaceFlux: max infiltration rate and derivatives **** associate(& ! input: model control - ixInfRateMax => in_surfaceFlx % ixInfRateMax , & ! index defining the maximum infiltration rate method (GreenAmpt, topmodel_GA, noInfiltrationExcess) + ixInfRateMax => in_surfaceFlux % ixInfRateMax , & ! index defining the maximum infiltration rate method (GreenAmpt, topmodel_GA, noInfiltrationExcess) ! input: transmittance - surfaceSatHydCond => in_surfaceFlx % surfaceSatHydCond , & ! saturated hydraulic conductivity at the surface (m s-1) + surfaceSatHydCond => in_surfaceFlux % surfaceSatHydCond , & ! saturated hydraulic conductivity at the surface (m s-1) ! input: soil parameters - zScale_TOPMODEL => in_surfaceFlx % zScale_TOPMODEL , & ! scaling factor used to describe decrease in hydraulic conductivity with depth (m) - rootingDepth => in_surfaceFlx % rootingDepth , & ! rooting depth (m) - wettingFrontSuction => in_surfaceFlx % wettingFrontSuction , & ! Green-Ampt wetting front suction (m) - mLayerDepth => in_surfaceFlx % mLayerDepth , & ! depth of each soil layer (m) + zScale_TOPMODEL => in_surfaceFlux % zScale_TOPMODEL , & ! scaling factor used to describe decrease in hydraulic conductivity with depth (m) + rootingDepth => in_surfaceFlux % rootingDepth , & ! rooting depth (m) + wettingFrontSuction => in_surfaceFlux % wettingFrontSuction , & ! Green-Ampt wetting front suction (m) + mLayerDepth => in_surfaceFlux % mLayerDepth , & ! depth of each soil layer (m) ! input-output: surface runoff and infiltration flux (m s-1) - xMaxInfilRate => io_surfaceFlx % xMaxInfilRate & ! maximum infiltration rate (m s-1) + xMaxInfilRate => io_surfaceFlux % xMaxInfilRate & ! maximum infiltration rate (m s-1) &) ! define the depth to the wetting front (m) and derivatives total_soil_depth = sum(mLayerDepth(:)) @@ -1634,7 +1633,7 @@ subroutine update_surfaceFlx_liquidFlux_computation_max_infiltration_rate end if ! process hydraulic conductivity-controlled infiltration rate - select case(ixInfRateMax) ! maximum infiltration rate parameterization (noInfExcess set in update_surfaceFlx) + select case(ixInfRateMax) ! maximum infiltration rate parameterization (noInfExcess set in update_surfaceFlux) case(topmodel_GA) ! define the hydraulic conductivity at depth=depthWettingFront (m s-1) hydCondWettingFront = surfaceSatHydCond * ( (1._rkind - depthWettingFront/total_soil_depth)**(zScale_TOPMODEL - 1._rkind) ) @@ -1663,22 +1662,22 @@ subroutine update_surfaceFlx_liquidFlux_computation_max_infiltration_rate endif end select end associate - end subroutine update_surfaceFlx_liquidFlux_computation_max_infiltration_rate + end subroutine update_surfaceFlux_liquidFlux_computation_max_infiltration_rate - subroutine update_surfaceFlx_liquidFlux_computation_homegrown - ! **** Update operations for surfaceFlx: infiltrating area (ignoring frozen area) for homegrown saturation excess condition **** + subroutine update_surfaceFlux_liquidFlux_computation_homegrown + ! **** Update operations for surfaceFlux: infiltrating area (ignoring frozen area) for homegrown saturation excess condition **** associate(& ! input: model control - nSoil => in_surfaceFlx % nSoil , & ! number of soil layers - nRoots => in_surfaceFlx % nRoots , & ! number of layers that contain roots - ixIce => in_surfaceFlx % ixIce , & ! index of lowest ice layer - mLayerVolFracLiq => in_surfaceFlx % mLayerVolFracLiq , & ! volumetric liquid water content in each soil layer (-) - mLayerDepth => in_surfaceFlx % mLayerDepth , & ! depth of each soil layer (m) + nSoil => in_surfaceFlux % nSoil , & ! number of soil layers + nRoots => in_surfaceFlux % nRoots , & ! number of layers that contain roots + ixIce => in_surfaceFlux % ixIce , & ! index of lowest ice layer + mLayerVolFracLiq => in_surfaceFlux % mLayerVolFracLiq , & ! volumetric liquid water content in each soil layer (-) + mLayerDepth => in_surfaceFlux % mLayerDepth , & ! depth of each soil layer (m) ! input: soil parameters - theta_sat => in_surfaceFlx % theta_sat , & ! soil porosity (-) - qSurfScale => in_surfaceFlx % qSurfScale , & ! scaling factor in the surface runoff parameterization (-) + theta_sat => in_surfaceFlux % theta_sat , & ! soil porosity (-) + qSurfScale => in_surfaceFlux % qSurfScale , & ! scaling factor in the surface runoff parameterization (-) ! input-output: surface runoff and infiltration flux (m s-1) - scalarInfilArea => io_surfaceFlx % scalarInfilArea & ! fraction of area where water can infiltrate, may be frozen (-) + scalarInfilArea => io_surfaceFlux % scalarInfilArea & ! fraction of area where water can infiltrate, may be frozen (-) &) ! define the infiltrating area and derivatives for the ignoring if frozen or not if (qSurfScale < qSurfScaleMax) then @@ -1709,16 +1708,16 @@ subroutine update_surfaceFlx_liquidFlux_computation_homegrown end if end if end associate - end subroutine update_surfaceFlx_liquidFlux_computation_homegrown + end subroutine update_surfaceFlux_liquidFlux_computation_homegrown - subroutine update_surfaceFlx_liquidFlux_computation_frozen_area - ! **** Update operations for surfaceFlx: get impermeable area due to soil freezing **** + subroutine update_surfaceFlux_liquidFlux_computation_frozen_area + ! **** Update operations for surfaceFlux: get impermeable area due to soil freezing **** associate(& ! input: soil parameters - soilIceScale => in_surfaceFlx % soilIceScale , & ! soil ice scaling factor in Gamma distribution used to define frozen area (m) - soilIceCV => in_surfaceFlx % soilIceCV , & ! soil ice CV in Gamma distribution used to define frozen area (-) + soilIceScale => in_surfaceFlux % soilIceScale , & ! soil ice scaling factor in Gamma distribution used to define frozen area (m) + soilIceCV => in_surfaceFlux % soilIceCV , & ! soil ice CV in Gamma distribution used to define frozen area (-) ! output: frozen area - scalarFrozenArea => io_surfaceFlx % scalarFrozenArea & ! fraction of area that is considered impermeable due to soil ice (-) + scalarFrozenArea => io_surfaceFlux % scalarFrozenArea & ! fraction of area that is considered impermeable due to soil ice (-) &) ! define the impermeable area and derivatives due to frozen ground if (rootZoneIce > tiny(rootZoneIce)) then ! (avoid divide by zero) @@ -1736,28 +1735,28 @@ subroutine update_surfaceFlx_liquidFlux_computation_frozen_area scalarFrozenArea = 0._rkind end if end associate - end subroutine update_surfaceFlx_liquidFlux_computation_frozen_area + end subroutine update_surfaceFlux_liquidFlux_computation_frozen_area - subroutine update_surfaceFlx_liquidFlux_infiltration - ! **** Update operations for surfaceFlx: final infiltration and runoff calculations **** + subroutine update_surfaceFlux_liquidFlux_infiltration + ! **** Update operations for surfaceFlux: final infiltration and runoff calculations **** ! local variables real(rkind) :: scalarInfilArea_unfrozen ! infiltration area that is not frozen ! compute infiltration and runoff associate(& ! input: flux at the upper boundary - scalarRainPlusMelt => in_surfaceFlx % scalarRainPlusMelt, & ! rain plus melt, used as input to the soil zone before computing surface runoff (m s-1) + scalarRainPlusMelt => in_surfaceFlux % scalarRainPlusMelt, & ! rain plus melt, used as input to the soil zone before computing surface runoff (m s-1) ! input-output: surface runoff and infiltration flux (m s-1) - xMaxInfilRate => io_surfaceFlx % xMaxInfilRate , & ! maximum infiltration rate (m s-1) - scalarInfilArea => io_surfaceFlx % scalarInfilArea , & ! fraction of area where water can infiltrate, may be frozen (-) - scalarSaturatedArea => io_surfaceFlx % scalarSaturatedArea, & ! fraction of area that is saturated (-) - scalarSoilControl => io_surfaceFlx % scalarSoilControl, & ! soil control on infiltration for derivative - scalarFrozenArea => io_surfaceFlx % scalarFrozenArea, & ! fraction of area that is considered impermeable due to soil ice (-) + xMaxInfilRate => io_surfaceFlux % xMaxInfilRate , & ! maximum infiltration rate (m s-1) + scalarInfilArea => io_surfaceFlux % scalarInfilArea , & ! fraction of area where water can infiltrate, may be frozen (-) + scalarSaturatedArea => io_surfaceFlux % scalarSaturatedArea, & ! fraction of area that is saturated (-) + scalarSoilControl => io_surfaceFlux % scalarSoilControl, & ! soil control on infiltration for derivative + scalarFrozenArea => io_surfaceFlux % scalarFrozenArea, & ! fraction of area that is considered impermeable due to soil ice (-) ! output: runoff and infiltration - scalarSurfaceRunoff_IE => out_surfaceFlx % scalarSurfaceRunoff_IE, & ! infiltration excess surface runoff (m s-1) - scalarSurfaceRunoff_SE => out_surfaceFlx % scalarSurfaceRunoff_SE, & ! saturation excess surface runoff (m s-1) - scalarSurfaceRunoff => out_surfaceFlx % scalarSurfaceRunoff, & ! surface runoff (m s-1) - scalarSurfaceInfiltration => out_surfaceFlx % scalarSurfaceInfiltration & ! surface infiltration (m s-1) + scalarSurfaceRunoff_IE => out_surfaceFlux % scalarSurfaceRunoff_IE, & ! infiltration excess surface runoff (m s-1) + scalarSurfaceRunoff_SE => out_surfaceFlux % scalarSurfaceRunoff_SE, & ! saturation excess surface runoff (m s-1) + scalarSurfaceRunoff => out_surfaceFlux % scalarSurfaceRunoff, & ! surface runoff (m s-1) + scalarSurfaceInfiltration => out_surfaceFlux % scalarSurfaceInfiltration & ! surface infiltration (m s-1) &) ! unfrozen infiltration area scalarInfilArea_unfrozen=(1._rkind - scalarFrozenArea)*scalarInfilArea @@ -1793,27 +1792,27 @@ subroutine update_surfaceFlx_liquidFlux_infiltration associate(& ! input-output: hydraulic conductivity and diffusivity at the surface ! NOTE: intent(inout) because infiltration may only be computed for the first iteration - surfaceHydCond => io_surfaceFlx % surfaceHydCond , & ! hydraulic conductivity (m s-1) - surfaceDiffuse => io_surfaceFlx % surfaceDiffuse & ! hydraulic diffusivity at the surface (m2 s-1) + surfaceHydCond => io_surfaceFlux % surfaceHydCond , & ! hydraulic conductivity (m s-1) + surfaceDiffuse => io_surfaceFlux % surfaceDiffuse & ! hydraulic diffusivity at the surface (m2 s-1) &) surfaceHydCond = realMissing surfaceDiffuse = realMissing end associate - end subroutine update_surfaceFlx_liquidFlux_infiltration + end subroutine update_surfaceFlux_liquidFlux_infiltration - subroutine finalize_surfaceFlx - ! **** Finalize operations for surfaceFlx **** + subroutine finalize_surfaceFlux + ! **** Finalize operations for surfaceFlux **** ! final error check associate(& - err => out_surfaceFlx % err , & ! error code - message => out_surfaceFlx % message & ! error message + err => out_surfaceFlux % err , & ! error code + message => out_surfaceFlux % message & ! error message &) - if(err/=0)then; message=trim(message)//'unanticipated error in surfaceFlx subroutine'; return_flag=.true.; return; end if + if(err/=0)then; message=trim(message)//'unanticipated error in surfaceFlux subroutine'; return_flag=.true.; return; end if end associate - end subroutine finalize_surfaceFlx + end subroutine finalize_surfaceFlux -end subroutine surfaceFlx +end subroutine surfaceFlux ! *************************************************************************************************************** ! private subroutine iLayerFlux: compute the fluxes and derivatives at layer interfaces @@ -2266,4 +2265,4 @@ end subroutine finalize_qDrainFlux end subroutine qDrainFlux -end module soilLiqFlx_module +end module soilLiqFlux_module diff --git a/build/source/engine/soil_utils.f90 b/build/source/engine/soil_utils.f90 index 5ef922bd8..5a1120b5e 100644 --- a/build/source/engine/soil_utils.f90 +++ b/build/source/engine/soil_utils.f90 @@ -21,18 +21,18 @@ module soil_utils_module ! data types -USE nrtype +USE nr_type +! constants +USE globalData,only: verySmall ! a small number 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) + Tfreeze, & ! temperature at freezing (K) + LH_fus, & ! latent heat of fusion (J kg-1, or m2 s-2) R_wv ! gas constant for water vapor (J kg-1 K-1; [J = Pa m3]) ! privacy implicit none private - -! routines to make public public::iceImpede public::dIceImpede_dTemp public::hydCond_psi @@ -52,18 +52,13 @@ module soil_utils_module public::gammp,gammp_complex public::LogSumExp public::SoftArgMax - -! constant parameters -real(rkind),parameter :: dx=-1.e-12_rkind ! finite difference increment contains - ! ****************************************************************************************************************************** ! public subroutine iceImpede: compute the ice impedence factor ! ****************************************************************************************************************************** subroutine iceImpede(volFracIce,f_impede, & ! input iceImpedeFactor,dIceImpede_dLiq) ! output - ! computes the ice impedence factor (separate function, as used multiple times) implicit none ! input variables real(rkind),intent(in) :: volFracIce ! volumetric fraction of ice (-) @@ -71,6 +66,7 @@ subroutine iceImpede(volFracIce,f_impede, & ! input ! output variables real(rkind) :: iceImpedeFactor ! ice impedence factor (-) real(rkind) :: dIceImpede_dLiq ! derivative in ice impedence factor w.r.t. volumetric liquid water content (-) + ! compute ice impedance factor as a function of volumetric ice content iceImpedeFactor = 10._rkind**(-f_impede*volFracIce) dIceImpede_dLiq = 0._rkind @@ -82,7 +78,6 @@ end subroutine iceImpede ! public subroutine dIceImpede_dTemp: compute the derivative in the ice impedence factor w.r.t. temperature ! ****************************************************************************************************************************** subroutine dIceImpede_dTemp(volFracIce,dTheta_dT,f_impede,dIceImpede_dT) - ! computes the derivative in the ice impedance factor w.r.t. temperature implicit none ! input variables real(rkind),intent(in) :: volFracIce ! volumetric fraction of ice (-) @@ -90,7 +85,7 @@ subroutine dIceImpede_dTemp(volFracIce,dTheta_dT,f_impede,dIceImpede_dT) real(rkind),intent(in) :: f_impede ! ice impedence parameter (-) ! output variables real(rkind) :: dIceImpede_dT ! derivative in the ice impedance factor w.r.t. temperature (K-1) - ! -- + dIceImpede_dT = log(10._rkind)*f_impede*(10._rkind**(-f_impede*volFracIce))*dTheta_dT end subroutine dIceImpede_dTemp @@ -111,7 +106,6 @@ subroutine liquidHead(& dPsiLiq_dPsi0 ,& ! intent(out) : derivative in the liquid water matric potential w.r.t. the total water matric potential (-) dPsiLiq_dTemp ,& ! intent(out) : derivative in the liquid water matric potential w.r.t. temperature (m K-1) err,message) ! intent(out) : error control - ! computes the liquid water matric potential (and the derivatives w.r.t. total matric potential and temperature) implicit none ! input real(rkind),intent(in) :: matricHeadTotal ! total water matric potential (m) @@ -198,6 +192,7 @@ subroutine liquidHead(& end subroutine liquidHead + ! ****************************************************************************************************************************** ! public function hydCondMP_liq: compute the hydraulic conductivity of macropores as a function of liquid water content (m s-1) ! ****************************************************************************************************************************** @@ -215,11 +210,12 @@ function hydCondMP_liq(volFracLiq,theta_sat,theta_mp,mpExp,satHydCond_ma,satHydC real(rkind) :: hydCondMP_liq ! hydraulic conductivity (m s-1) ! locals real(rkind) :: theta_e ! effective soil moisture + if(volFracLiq > theta_mp)then - theta_e = (volFracLiq - theta_mp) / (theta_sat - theta_mp) - hydCondMP_liq = (satHydCond_ma - satHydCond_mi) * (theta_e**mpExp) + theta_e = (volFracLiq - theta_mp) / (theta_sat - theta_mp) + hydCondMP_liq = (satHydCond_ma - satHydCond_mi) * (theta_e**mpExp) else - hydCondMP_liq = 0._rkind + hydCondMP_liq = 0._rkind end if end function hydCondMP_liq @@ -228,7 +224,6 @@ end function hydCondMP_liq ! public function hydCond_psi: compute the hydraulic conductivity as a function of matric head (m s-1) ! ****************************************************************************************************************************** function hydCond_psi(psi,k_sat,alpha,n,m) - ! computes hydraulic conductivity given psi and soil hydraulic parameters k_sat, alpha, n, and m implicit none ! dummies real(rkind),intent(in) :: psi ! soil water suction (m) @@ -237,12 +232,22 @@ function hydCond_psi(psi,k_sat,alpha,n,m) real(rkind),intent(in) :: n ! vGn "n" parameter (-) real(rkind),intent(in) :: m ! vGn "m" parameter (-) real(rkind) :: hydCond_psi ! hydraulic conductivity (m s-1) - if(psi<0._rkind)then - hydCond_psi = k_sat * & - ( ( (1._rkind - (psi*alpha)**(n-1._rkind) * (1._rkind + (psi*alpha)**n)**(-m))**2_i4b ) & - / ( (1._rkind + (psi*alpha)**n)**(m/2._rkind) ) ) + ! Smooth transition to k_sat as psi -> 0 from below. + ! Blend over the interval [-delta,0] using a cubic smoothstep so that value + ! and first derivative are continuous at the join. + real(rkind) :: t, s, orig_val + + if (psi >= 0._rkind) then + hydCond_psi = k_sat else - hydCond_psi = k_sat + orig_val = k_sat * ( ( (1._rkind - (psi*alpha)**(n-1._rkind) * (1._rkind + (psi*alpha)**n)**(-m))**2_i4b ) / ( (1._rkind + (psi*alpha)**n)**(m/2._rkind) ) ) + if (psi < -verySmall) then + hydCond_psi = orig_val + else ! compute original formula and blend to k_sat using a cubic smoothstep + t = (psi + verySmall) / verySmall + s = 3._rkind*t*t - 2._rkind*t*t*t ! cubic smoothstep: s(0)=0, s(1)=1, continuous first derivative + hydCond_psi = orig_val*(1._rkind - s) + k_sat*s + end if end if end function hydCond_psi @@ -251,7 +256,6 @@ end function hydCond_psi ! public function hydCond_liq: compute the hydraulic conductivity as a function of volumetric liquid water content (m s-1) ! ****************************************************************************************************************************** function hydCond_liq(volFracLiq,k_sat,theta_res,theta_sat,m) - ! computes hydraulic conductivity given volFracLiq and soil hydraulic parameters k_sat, theta_sat, theta_res, and m implicit none ! dummies real(rkind),intent(in) :: volFracLiq ! volumetric liquid water content (-) @@ -262,20 +266,20 @@ function hydCond_liq(volFracLiq,k_sat,theta_res,theta_sat,m) real(rkind) :: hydCond_liq ! hydraulic conductivity (m s-1) ! locals real(rkind) :: theta_e ! effective soil moisture + if(volFracLiq < theta_sat)then - theta_e = (volFracLiq - theta_res) / (theta_sat - theta_res) - hydCond_liq = k_sat*theta_e**(1._rkind/2._rkind) * (1._rkind - (1._rkind - theta_e**(1._rkind/m) )**m)**2_i4b + theta_e = (volFracLiq - theta_res) / (theta_sat - theta_res) + hydCond_liq = k_sat*theta_e**(1._rkind/2._rkind) * (1._rkind - (1._rkind - theta_e**(1._rkind/m) )**m)**2_i4b else - hydCond_liq = k_sat + hydCond_liq = k_sat end if end function hydCond_liq ! ****************************************************************************************************************************** -! public function volFracLiq: compute the volumetric liquid water content (-) +! public function volFracLiq: compute the volumetric liquid water content as a function of matric head (-) ! ****************************************************************************************************************************** function volFracLiq(psi,alpha,theta_res,theta_sat,n,m) - ! computes the volumetric liquid water content given psi and soil hydraulic parameters theta_res, theta_sat, alpha, n, and m implicit none real(rkind),intent(in) :: psi ! soil water suction (m) real(rkind),intent(in) :: alpha ! scaling parameter (m-1) @@ -284,10 +288,11 @@ function volFracLiq(psi,alpha,theta_res,theta_sat,n,m) real(rkind),intent(in) :: n ! vGn "n" parameter (-) real(rkind),intent(in) :: m ! vGn "m" parameter (-) real(rkind) :: volFracLiq ! volumetric liquid water content (-) + if(psi<0._rkind)then volFracLiq = theta_res + (theta_sat - theta_res)*(1._rkind + (alpha*psi)**n)**(-m) else - volFracLiq = theta_sat + volFracLiq = theta_sat end if end function volFracLiq @@ -296,7 +301,6 @@ end function volFracLiq ! public function matricHead: compute the matric head (m) based on the volumetric liquid water content ! ****************************************************************************************************************************** function matricHead(theta,alpha,theta_res,theta_sat,n,m) - ! computes the volumetric liquid water content given psi and soil hydraulic parameters theta_res, theta_sat, alpha, n, and m implicit none ! dummy variables real(rkind),intent(in) :: theta ! volumetric liquid water content (-) @@ -309,13 +313,14 @@ function matricHead(theta,alpha,theta_res,theta_sat,n,m) ! local variables real(rkind) :: effSat ! effective saturation (-) real(rkind),parameter :: eps=epsilon(1._rkind) ! a very small number (avoid effective saturation of zero) + ! compute effective saturation effSat = max(eps, (theta - theta_res) / (theta_sat - theta_res)) ! compute matric head if (effSat < 1._rkind .and. effSat > 0._rkind)then - matricHead = (1._rkind/alpha)*( effSat**(-1._rkind/m) - 1._rkind)**(1._rkind/n) + matricHead = (1._rkind/alpha)*( effSat**(-1._rkind/m) - 1._rkind)**(1._rkind/n) else - matricHead = 0._rkind + matricHead = 0._rkind end if end function matricHead @@ -332,12 +337,13 @@ function dTheta_dPsi(psi,alpha,theta_res,theta_sat,n,m) real(rkind),intent(in) :: n ! vGn "n" parameter (-) real(rkind),intent(in) :: m ! vGn "m" parameter (-) real(rkind) :: dTheta_dPsi ! derivative of the soil water characteristic (m-1) + if(psi<=0._rkind)then dTheta_dPsi = (theta_sat-theta_res) * & (-m*(1._rkind + (psi*alpha)**n)**(-m-1._rkind)) * n*(psi*alpha)**(n-1._rkind) * alpha - if(abs(dTheta_dPsi) < epsilon(psi)) dTheta_dPsi = epsilon(psi) + if(abs(dTheta_dPsi) < epsilon(psi)) dTheta_dPsi = epsilon(psi) ! use to avoid division by zero if divide by dTheta_dPsi else - dTheta_dPsi = epsilon(psi) + dTheta_dPsi = epsilon(psi) ! use to avoid division by zero if divide by dTheta_dPsi end if end function dTheta_dPsi @@ -386,7 +392,7 @@ end function dPsi_dTheta ! ****************************************************************************************************************************** ! public function dPsi_dTheta2: compute the derivative of dPsi_dTheta (m-1) ! ****************************************************************************************************************************** -function dPsi_dTheta2(volFracLiq,alpha,theta_res,theta_sat,n,m,lTangent) +function dPsi_dTheta2(volFracLiq,alpha,theta_res,theta_sat,n,m) implicit none ! dummies real(rkind),intent(in) :: volFracLiq ! volumetric liquid water content (-) @@ -395,19 +401,14 @@ function dPsi_dTheta2(volFracLiq,alpha,theta_res,theta_sat,n,m,lTangent) real(rkind),intent(in) :: theta_sat ! porosity (-) real(rkind),intent(in) :: n ! vGn "n" parameter (-) real(rkind),intent(in) :: m ! vGn "m" parameter (-) - logical(lgt),intent(in) :: lTangent ! method used to compute derivative (.true. = analytical) real(rkind) :: dPsi_dTheta2 ! derivative of the soil water characteristic (m) ! locals for analytical derivatives real(rkind) :: xx ! temporary variable real(rkind) :: y1,d1 ! 1st function and derivative real(rkind) :: y2,d2 ! 2nd function and derivative real(rkind) :: theta_e ! effective soil moisture - ! locals for numerical derivative - real(rkind) :: func0,func1 ! function evaluations - ! check if less than saturation + if(volFracLiq < theta_sat)then - ! ***** compute analytical derivatives - if(lTangent)then ! compute the effective saturation theta_e = (volFracLiq - theta_res) / (theta_sat - theta_res) ! get the first function and derivative @@ -419,14 +420,8 @@ function dPsi_dTheta2(volFracLiq,alpha,theta_res,theta_sat,n,m,lTangent) d2 = ( -(1._rkind - n)/((theta_sat - theta_res)*m*n**2_i4b) ) * xx**(1._rkind/n - 2._rkind) * theta_e**(-1._rkind/m - 1._rkind) ! return the derivative dPsi_dTheta2 = (d1*y2 + y1*d2)/alpha - ! ***** compute numerical derivatives - else - func0 = dPsi_dTheta(volFracLiq, alpha,theta_res,theta_sat,n,m) - func1 = dPsi_dTheta(volFracLiq+dx,alpha,theta_res,theta_sat,n,m) - dPsi_dTheta2 = (func1 - func0)/dx - end if ! (case where volumetric liquid water content exceeds porosity) - else + else ! derivative is zero if super-saturated dPsi_dTheta2 = 0._rkind end if end function dPsi_dTheta2 @@ -435,17 +430,14 @@ end function dPsi_dTheta2 ! ****************************************************************************************************************************** ! public function dHydCond_dPsi: compute the derivative in hydraulic conductivity w.r.t. matric head (s-1) ! ****************************************************************************************************************************** -function dHydCond_dPsi(psi,k_sat,alpha,n,m,lTangent) - ! computes the derivative in hydraulic conductivity w.r.t matric head, - ! given psi and soil hydraulic parameters k_sat, alpha, n, and m +function dHydCond_dPsi(psi,k_sat,alpha,n,m) implicit none ! dummies - real(rkind),intent(in) :: psi ! soil water suction (m) - real(rkind),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) - real(rkind),intent(in) :: alpha ! scaling parameter (m-1) - real(rkind),intent(in) :: n ! vGn "n" parameter (-) - real(rkind),intent(in) :: m ! vGn "m" parameter (-) - logical(lgt),intent(in) :: lTangent ! method used to compute derivative (.true. = analytical) + real(rkind),intent(in) :: psi ! soil water suction (m) + real(rkind),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) + real(rkind),intent(in) :: alpha ! scaling parameter (m-1) + real(rkind),intent(in) :: n ! vGn "n" parameter (-) + real(rkind),intent(in) :: m ! vGn "m" parameter (-) real(rkind) :: dHydCond_dPsi ! derivative in hydraulic conductivity w.r.t. matric head (s-1) ! locals for analytical derivatives real(rkind) :: f_x1 ! f(x) for part of the numerator @@ -456,14 +448,12 @@ function dHydCond_dPsi(psi,k_sat,alpha,n,m,lTangent) real(rkind) :: d_x2 ! df(x)/dpsi for part of the numerator real(rkind) :: d_nm ! df(x)/dpsi for the numerator real(rkind) :: d_dm ! df(x)/dpsi for the denominator - ! locals for numerical derivatives - real(rkind) :: hydCond0 ! hydraulic condictivity value for base case - real(rkind) :: hydCond1 ! hydraulic condictivity value for perturbed case - ! derivative is zero if saturated - if(psi<0._rkind)then - ! ***** compute analytical derivatives - if(lTangent)then - ! compute the derivative for the numerator + real(rkind) :: t,s,orig_val,orig_d,ds_dpsi + + if (psi >= 0._rkind) then + dHydCond_dPsi = 0._rkind + else + ! compute the derivative for the numerator (original Van Genuchten form) f_x1 = (psi*alpha)**(n - 1._rkind) f_x2 = (1._rkind + (psi*alpha)**n)**(-m) d_x1 = alpha * (n - 1._rkind)*(psi*alpha)**(n - 2._rkind) @@ -473,16 +463,18 @@ function dHydCond_dPsi(psi,k_sat,alpha,n,m,lTangent) ! compute the derivative for the denominator f_dm = (1._rkind + (psi*alpha)**n)**(m/2._rkind) d_dm = alpha * n*(psi*alpha)**(n - 1._rkind) * (m/2._rkind)*(1._rkind + (psi*alpha)**n)**(m/2._rkind - 1._rkind) - ! and combine - dHydCond_dPsi = k_sat*(d_nm*f_dm - d_dm*f_nm) / (f_dm**2_i4b) - else - ! ***** compute numerical derivatives - hydcond0 = hydCond_psi(psi, k_sat,alpha,n,m) - hydcond1 = hydCond_psi(psi+dx,k_sat,alpha,n,m) - dHydCond_dPsi = (hydcond1 - hydcond0)/dx - end if - else - dHydCond_dPsi = 0._rkind + ! and combine to get the original derivative + orig_val = k_sat * (f_nm / f_dm) + orig_d = k_sat*(d_nm*f_dm - d_dm*f_nm) / (f_dm**2_i4b) + if(psi < -verySmall) then + dHydCond_dPsi = orig_d + else ! compute original formula and blend to k_sat using a cubic smoothstep + t = (psi + verySmall) / verySmall + t = max(0._rkind, min(1._rkind, t)) + s = 3._rkind*t*t - 2._rkind*t*t*t + ds_dpsi = (6._rkind*t*(1._rkind - t)) / verySmall + dHydCond_dPsi = orig_d*(1._rkind - s) + (k_sat - orig_val)*ds_dpsi + end if end if end function dHydCond_dPsi @@ -490,18 +482,14 @@ end function dHydCond_dPsi ! ****************************************************************************************************************************** ! public function dHydCond_dLiq: compute the derivative in hydraulic conductivity w.r.t. volumetric liquid water content (m s-1) ! ****************************************************************************************************************************** -! computes the derivative in hydraulic conductivity w.r.t the volumetric fraction of liquid water, -! given volFracLiq and soil hydraulic parameters k_sat, theta_sat, theta_res, and m -! ****************************************************************************************************************************** -function dHydCond_dLiq(volFracLiq,k_sat,theta_res,theta_sat,m,lTangent) +function dHydCond_dLiq(volFracLiq,k_sat,theta_res,theta_sat,m) implicit none ! dummies - real(rkind),intent(in) :: volFracLiq ! volumetric fraction of liquid water (-) - real(rkind),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) - real(rkind),intent(in) :: theta_res ! soil residual volumetric water content (-) - real(rkind),intent(in) :: theta_sat ! soil porosity (-) - real(rkind),intent(in) :: m ! vGn "m" parameter (-) - logical(lgt),intent(in) :: lTangent ! method used to compute derivative (.true. = analytical) + real(rkind),intent(in) :: volFracLiq ! volumetric fraction of liquid water (-) + real(rkind),intent(in) :: k_sat ! saturated hydraulic conductivity (m s-1) + real(rkind),intent(in) :: theta_res ! soil residual volumetric water content (-) + real(rkind),intent(in) :: theta_sat ! soil porosity (-) + real(rkind),intent(in) :: m ! vGn "m" parameter (-) real(rkind) :: dHydCond_dLiq ! derivative in hydraulic conductivity w.r.t. matric head (s-1) ! locals for analytical derivatives real(rkind) :: theta_e ! effective soil moisture @@ -511,13 +499,8 @@ function dHydCond_dLiq(volFracLiq,k_sat,theta_res,theta_sat,m,lTangent) real(rkind) :: p1,p2,p3 ! df(x)/dLiq for different parts of the second function real(rkind) :: f2 ! f(x) for the second function real(rkind) :: d2 ! df(x)/dLiq for the second function - ! locals for numerical derivatives - real(rkind) :: hydCond0 ! hydraulic condictivity value for base case - real(rkind) :: hydCond1 ! hydraulic condictivity value for perturbed case - ! derivative is zero if super-saturated + if(volFracLiq < theta_sat)then - ! ***** compute analytical derivatives - if(lTangent)then ! compute the effective saturation theta_e = (volFracLiq - theta_res) / (theta_sat - theta_res) ! compute the function and derivative of the first fuction @@ -537,14 +520,8 @@ function dHydCond_dLiq(volFracLiq,k_sat,theta_res,theta_sat,m,lTangent) d2 = p1*p2*p3 ! pull it all together dHydCond_dLiq = (d1*f2 + d2*f1) - else - ! ***** compute numerical derivatives - hydcond0 = hydCond_liq(volFracLiq, k_sat,theta_res,theta_sat,m) - hydcond1 = hydCond_liq(volFracLiq+dx,k_sat,theta_res,theta_sat,m) - dHydCond_dLiq = (hydcond1 - hydcond0)/dx - end if - else - dHydCond_dLiq = 0._rkind + else ! derivative is zero if super-saturated + dHydCond_dLiq = 0._rkind end if end function dHydCond_dLiq @@ -807,6 +784,7 @@ function gser_complex(a,x,gln) end if end function gser_complex + ! ****************************************************************************************************************************** ! public function LogSumExp: LSE (or RealSoftMax) function used for smooth approximations of max or min functions ! ****************************************************************************************************************************** @@ -860,6 +838,7 @@ function LogSumExp(alpha,x,err) result(LSE) end function LogSumExp + ! ****************************************************************************************************************************** ! public function SoftArgMax: SoftArgMax (aliases: softmax, normalized exponential) function for smooth approximations to argument max or min ! ****************************************************************************************************************************** @@ -904,6 +883,6 @@ function SoftArgMax(alpha,x) result(SAM) SAM(maxloc(x)) = 1._rkind end if end if -end function +end function SoftArgMax end module soil_utils_module diff --git a/build/source/engine/soil_utilsAddPrime.f90 b/build/source/engine/soil_utilsAddPrime.f90 index bf7d8b0b4..09480a114 100644 --- a/build/source/engine/soil_utilsAddPrime.f90 +++ b/build/source/engine/soil_utilsAddPrime.f90 @@ -21,7 +21,7 @@ module soil_utilsAddPrime_module ! data types -USE nrtype +USE nr_type USE multiconst,only: gravity, & ! acceleration of gravity (m s-2) Tfreeze, & ! temperature at freezing (K) @@ -140,6 +140,7 @@ subroutine liquidHeadPrime(& end subroutine liquidHeadPrime + ! ****************************************************************************************************************************** ! public function d2Theta_dPsi2: compute the second derivative of the soil water characteristic (m-1) ! ****************************************************************************************************************************** @@ -165,6 +166,7 @@ function d2Theta_dPsi2(psi,alpha,theta_res,theta_sat,n,m) end if end function d2Theta_dPsi2 + ! ****************************************************************************************************************************** ! public function d2Theta_dTk2: differentiate the freezing curve w.r.t. temperature ! ****************************************************************************************************************************** diff --git a/build/source/engine/stomResist.f90 b/build/source/engine/stomResist.f90 index 65ae98e18..70419cad4 100644 --- a/build/source/engine/stomResist.f90 +++ b/build/source/engine/stomResist.f90 @@ -21,21 +21,20 @@ module stomResist_module ! data types -USE nrtype -USE globalData,only:realMissing ! missing real number - -! physical constants -USE multiconst, only: Rgas ! universal gas constant (J mol-1 K-1) -USE multiconst, only: Tfreeze ! freezing point of pure water (K) -USE multiconst, only: ave_slp ! standard pressure (Pa) - -! derived types to define the data structures +USE nr_type USE data_types,only:& var_i, & ! data vector (i4b) var_d, & ! data vector (rkind) var_dlength, & ! data vector with variable length dimension (rkind) model_options ! defines the model decisions +! constants +USE multiconst,only:& + Rgas, & ! universal gas constant (J mol-1 K-1) + Tfreeze, & ! freezing point of pure water (K) + ave_slp ! standard pressure (Pa) +USE globalData,only:realMissing ! missing real number + ! 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 @@ -95,7 +94,6 @@ module stomResist_module real(rkind),parameter :: joule2umolConv=4.6_rkind ! conversion factor from joules to umol photons (umol J-1) ! algorithmic parameters real(rkind),parameter :: mpe=1.e-6_rkind ! prevents overflow error if division by zero, from NOAH mpe value -real(rkind),parameter :: dx=1.e-6_rkind ! finite difference increment contains @@ -121,29 +119,29 @@ subroutine stomResist(& ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! conversion functions - USE conv_funcs_module,only:satVapPress ! function to compute the saturated vapor pressure (Pa) + USE convert_funcs_module,only:satVapPress ! function to compute the saturated vapor pressure (Pa) ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! input: state and diagnostic variables real(rkind),intent(in) :: scalarVegetationTemp ! vegetation temperature (K) real(rkind),intent(in) :: scalarSatVP_VegTemp ! saturation vapor pressure at vegetation temperature (Pa) real(rkind),intent(in) :: scalarVP_CanopyAir ! canopy air vapor pressure (Pa) ! 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 + 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 + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message ! ----------------------------------------------------------------------------------------------------------------------------------------------------- ! local variables - character(LEN=256) :: cmessage ! error message of downwind routine - integer(i4b),parameter :: ixSunlit=1 ! named variable for sunlit leaves - integer(i4b),parameter :: ixShaded=2 ! named variable for shaded leaves - integer(i4b) :: iSunShade ! index defining sunlit or shaded leaves + character(LEN=256) :: cmessage ! error message of downwind routine + integer(i4b),parameter :: ixSunlit=1 ! named variable for sunlit leaves + integer(i4b),parameter :: ixShaded=2 ! named variable for shaded leaves + integer(i4b) :: iSunShade ! index defining sunlit or shaded leaves real(rkind) :: absorbedPAR ! absorbed PAR (W m-2) real(rkind) :: scalarStomResist ! stomatal resistance (s m-1) real(rkind) :: scalarPhotosynthesis ! photosynthesis (umol CO2 m-2 s-1) @@ -361,7 +359,6 @@ subroutine stomResist_flex(& character(*),intent(out) :: message ! error message ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! general local variables - logical(lgt),parameter :: testDerivs=.false. ! flag to test the derivatives real(rkind) :: unitConv ! unit conversion factor (mol m-3, convert m s-1 --> mol H20 m-2 s-1) real(rkind) :: rlb ! leaf boundary layer rersistance (umol-1 m2 s) real(rkind) :: x0,x1,x2 ! temporary variables @@ -413,7 +410,6 @@ subroutine stomResist_flex(& real(rkind) :: dci_dc ! final derivative (-) ! ------------------------------------------------------------------------------------------------------------------------------------------------------ ! iterative solution - real(rkind) :: func1,func2 ! functions for numerical derivative calculation real(rkind) :: cMin,cMax ! solution brackets real(rkind) :: xInc ! iteration increment (Pa) integer(i4b) :: iter ! iteration index @@ -652,14 +648,6 @@ subroutine stomResist_flex(& dci_dc = 0._rkind 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... ! *********************** @@ -706,43 +694,6 @@ subroutine stomResist_flex(& end associate - contains - - ! ****************************************************** - ! internal function used to test derivatives - function testFunc(ci, cond2photo_slope, airpres, scalarCO2air, ix_bbHumdFunc, ix_bbCO2point, ix_bbAssimFnc) - real(rkind),intent(in) :: ci, cond2photo_slope, airpres, scalarCO2air - integer(i4b),intent(in) :: ix_bbHumdFunc, ix_bbCO2point, ix_bbAssimFnc - real(rkind) :: testFunc - real(rkind),parameter :: unUsedInput=0._rkind - real(rkind) :: 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._rkind) ! Pa - - end function testFunc - end subroutine stomResist_flex ! ******************************************************************************************************* @@ -1149,38 +1100,38 @@ subroutine stomResist_NoahMP(& ! 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) - 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) + 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) + 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) + 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) ! check identified an option case default; err=20; message=trim(message)//'unable to identify case for stomatal resistance'; return diff --git a/build/source/engine/summaSolve4homegrown.f90 b/build/source/engine/summaSolv4homegrown.f90 similarity index 94% rename from build/source/engine/summaSolve4homegrown.f90 rename to build/source/engine/summaSolv4homegrown.f90 index 4d602f590..9cd304e86 100644 --- a/build/source/engine/summaSolve4homegrown.f90 +++ b/build/source/engine/summaSolv4homegrown.f90 @@ -18,10 +18,10 @@ ! You should have received a copy of the GNU General Public License ! along with this program. If not, see . -module summaSolve4homegrown_module +module summaSolv4homegrown_module ! data types -USE nrtype +USE nr_type ! access the global print flag USE globalData,only:globalPrintFlag @@ -62,9 +62,9 @@ module summaSolve4homegrown_module out_type_computJacob, & ! class for computJacob arguments in_type_lineSearchRefinement, & ! class for lineSearchRefinement arguments out_type_lineSearchRefinement,& ! class for lineSearchRefinement arguments - in_type_summaSolve4homegrown, & ! class for summaSolve4homegrown arguments - io_type_summaSolve4homegrown, & ! class for summaSolve4homegrown arguments - out_type_summaSolve4homegrown ! class for summaSolve4homegrown arguments + in_type_summaSolv4homegrown, & ! class for summaSolv4homegrown arguments + io_type_summaSolv4homegrown, & ! class for summaSolv4homegrown arguments + out_type_summaSolv4homegrown ! class for summaSolv4homegrown arguments ! look-up values for the choice of groundwater parameterization @@ -80,15 +80,15 @@ module summaSolve4homegrown_module implicit none private -public :: summaSolve4homegrown +public :: summaSolv4homegrown public :: refine_Newton_step public :: checkConv contains ! ************************************************************************************************************************** - ! public subroutine summaSolve4homegrown: calculate the iteration increment, evaluate the new state, and refine if necessary + ! public subroutine summaSolv4homegrown: calculate the iteration increment, evaluate the new state, and refine if necessary ! ************************************************************************************************************************** - subroutine summaSolve4homegrown(& + subroutine summaSolv4homegrown(& ! input: model control in_SS4HG, & ! intent(in): model control and previous function value ! input: state vectors @@ -126,8 +126,8 @@ subroutine summaSolve4homegrown(& USE matrixOper_module, only: scaleMatrices implicit none ! -------------------------------------------------------------------------------------------------------------------------------- - type(in_type_summaSolve4homegrown),intent(in) :: in_SS4HG ! model control variables and previous function evaluation - type(io_type_summaSolve4homegrown),intent(inout) :: io_SS4HG ! first flux call flag and baseflow variables + type(in_type_summaSolv4homegrown),intent(in) :: in_SS4HG ! model control variables and previous function evaluation + type(io_type_summaSolv4homegrown),intent(inout) :: io_SS4HG ! first flux call flag and baseflow variables ! input: state vectors real(rkind),intent(in) :: stateVecTrial(:) ! trial state vector real(rkind),intent(in) :: fScale(:) ! characteristic scale of the function evaluations @@ -156,7 +156,7 @@ subroutine summaSolve4homegrown(& real(rkind),intent(out) :: fluxVecNew(:) ! new flux vector real(rkind),intent(out) :: resSinkNew(:) ! sink terms on the RHS of the flux equation real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector - type(out_type_summaSolve4homegrown),intent(out) :: out_SS4HG ! new function evaluation, convergence flag, and error control + type(out_type_summaSolv4homegrown),intent(out) :: out_SS4HG ! new function evaluation, convergence flag, and error control ! -------------------------------------------------------------------------------------------------------------------------------- ! local variables ! -------------------------------------------------------------------------------------------------------------------------------- @@ -183,23 +183,23 @@ subroutine summaSolve4homegrown(& ! ***** Compute the Newton Step ***** ! initial setup including computing the Jacobian -- return if error - call initialize_summaSolve4homegrown; if (return_flag) return + call initialize_summaSolv4homegrown; if (return_flag) return ! compute the Newton step -- return if error - call update_summaSolve4homegrown; if (return_flag) return + call update_summaSolv4homegrown; if (return_flag) return ! final check for errors - call finalize_summaSolve4homegrown; if (return_flag) return + call finalize_summaSolv4homegrown; if (return_flag) return contains - subroutine initialize_summaSolve4homegrown - ! *** Initial steps for the summaSolve4homegrown algorithm (computing the Newton step) *** + subroutine initialize_summaSolv4homegrown + ! *** Initial steps for the summaSolv4homegrown algorithm (computing the Newton step) *** associate(& err => out_SS4HG % err ,& message => out_SS4HG % message & &) ! initialize error control - err=0; message='summaSolve4homegrown/' + err=0; message='summaSolv4homegrown/' return_flag=.false. ! initialize return flag ! choose Jacobian type @@ -220,10 +220,10 @@ subroutine initialize_summaSolve4homegrown ! compute the Jacobian call update_Jacobian; if (return_flag) return ! compute Jacobian for Newton step -- return if error - end subroutine initialize_summaSolve4homegrown + end subroutine initialize_summaSolv4homegrown - subroutine update_summaSolve4homegrown - ! *** Update steps for the summaSolve4homegrown algorithm (computing the Newton step) *** + subroutine update_summaSolv4homegrown + ! *** Update steps for the summaSolv4homegrown algorithm (computing the Newton step) *** call solve_linear_system; if (return_flag) return ! solve the linear system for the Newton step -- return if error ! refine Newton step if needed @@ -232,14 +232,14 @@ subroutine update_summaSolve4homegrown &sMul,io_SS4HG,indx_data,diag_data,flux_data,deriv_data,dBaseflow_dMatric,& ! input-output &stateVecNew,fluxVecNew,resSinkNew,resVecNew,out_SS4HG,return_flag) ! output if (return_flag) return ! return if error - end subroutine update_summaSolve4homegrown + end subroutine update_summaSolv4homegrown - subroutine finalize_summaSolve4homegrown - ! *** Final steps for the summaSolve4homegrown algorithm (computing the Newton step) *** + subroutine finalize_summaSolv4homegrown + ! *** Final steps for the summaSolv4homegrown algorithm (computing the Newton step) *** associate(err => out_SS4HG % err,message => out_SS4HG % message) if (err/=0) then; message=trim(message)//trim(cmessage); return; end if ! check for errors end associate - end subroutine finalize_summaSolve4homegrown + end subroutine finalize_summaSolv4homegrown subroutine update_Jacobian ! *** Update Jacobian used for Newton step *** @@ -252,9 +252,9 @@ subroutine update_Jacobian err => out_SS4HG % err ,& message => out_SS4HG % message & &) - call initialize_computJacob_summaSolve4homegrown + call initialize_computJacob_summaSolv4homegrown call computJacob(in_computJacob,indx_data,prog_data,diag_data,deriv_data,dBaseflow_dMatric,dMat,aJac,out_computJacob) - call finalize_computJacob_summaSolve4homegrown + call finalize_computJacob_summaSolv4homegrown if (err/=0) then; message=trim(message)//trim(cmessage); return_flag=.true.; return; end if ! (check for errors) end associate @@ -299,8 +299,8 @@ subroutine solve_linear_system end associate end subroutine solve_linear_system - subroutine initialize_computJacob_summaSolve4homegrown - ! *** Transfer data to in_computJacob class object from local variables in summaSolve4homegrown *** + subroutine initialize_computJacob_summaSolv4homegrown + ! *** Transfer data to in_computJacob class object from local variables in summaSolv4homegrown *** associate(& ixGroundwater => model_decisions(iLookDECISIONS%groundwatr)%iDecision,& ! intent(in): [i4b] groundwater parameterization dt_cur => in_SS4HG % dt_cur ,& ! intent(in): current stepsize @@ -312,16 +312,16 @@ subroutine initialize_computJacob_summaSolve4homegrown &) call in_computJacob % initialize(dt_cur,nSnow,nSoil,nLayers,computeVegFlux,(ixGroundwater==qbaseTopmodel),ixMatrix) end associate - end subroutine initialize_computJacob_summaSolve4homegrown + end subroutine initialize_computJacob_summaSolv4homegrown - subroutine finalize_computJacob_summaSolve4homegrown - ! *** Transfer data from out_computJacob class object to local variables in summaSolve4homegrown *** + subroutine finalize_computJacob_summaSolv4homegrown + ! *** Transfer data from out_computJacob class object to local variables in summaSolv4homegrown *** associate(err => out_SS4HG % err) call out_computJacob % finalize(err,cmessage) end associate - end subroutine finalize_computJacob_summaSolve4homegrown + end subroutine finalize_computJacob_summaSolv4homegrown - end subroutine summaSolve4homegrown + end subroutine summaSolv4homegrown ! ********************************************************************************************************* ! * module subroutine refine_Newton_step: refine the Newton step if necessary @@ -331,11 +331,11 @@ subroutine refine_Newton_step(in_SS4HG,mSoil,stateVecTrial,newtStepScaled,aJacSc &sMul,io_SS4HG,indx_data,diag_data,flux_data,deriv_data,dBaseflow_dMatric,& ! input-output &stateVecNew,fluxVecNew,resSinkNew,resVecNew,out_SS4HG,return_flag) ! output ! provide access to the external procedures - USE matrixOper_module, only: computeGradient + USE matrixOper_module, only: computGradient USE eval8summa_module, only: imposeConstraints implicit none ! input - type(in_type_summaSolve4homegrown),intent(in) :: in_SS4HG ! model control variables and previous function evaluation + type(in_type_summaSolv4homegrown),intent(in) :: in_SS4HG ! model control variables and previous function evaluation integer(i4b),intent(in) :: mSoil ! number of soil layers in solution vector real(rkind),intent(in) :: stateVecTrial(:) ! trial state vector real(rkind),intent(in) :: newtStepScaled(:) ! scaled newton step @@ -353,7 +353,7 @@ subroutine refine_Newton_step(in_SS4HG,mSoil,stateVecTrial,newtStepScaled,aJacSc type(var_dlength), intent(in) :: prog_data ! prognostic variables for a local HRU ! input-output real(qp),intent(inout) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) - type(io_type_summaSolve4homegrown),intent(inout) :: io_SS4HG ! first flux call flag and baseflow variables + type(io_type_summaSolv4homegrown),intent(inout) :: io_SS4HG ! first flux call flag and baseflow variables type(var_ilength),intent(inout) :: indx_data ! indices defining model states and layers type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU @@ -364,7 +364,7 @@ subroutine refine_Newton_step(in_SS4HG,mSoil,stateVecTrial,newtStepScaled,aJacSc real(rkind),intent(out) :: fluxVecNew(:) ! new flux vector real(rkind),intent(out) :: resSinkNew(:) ! sink terms on the RHS of the flux equation real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector - type(out_type_summaSolve4homegrown),intent(out) :: out_SS4HG ! new function evaluation, convergence flag, and error control + type(out_type_summaSolv4homegrown),intent(out) :: out_SS4HG ! new function evaluation, convergence flag, and error control logical(lgt),intent(out) :: return_flag ! flag that controls execution of return statements ! local logical(lgt) :: doRefine ! flag for step refinement @@ -455,12 +455,12 @@ subroutine lineSearchRefinement(in_LSR,in_SS4HG,mSoil,stateVecTrial,newtStepScal &sMul,io_SS4HG,indx_data,diag_data,flux_data,deriv_data,dBaseflow_dMatric,& &stateVecNew,fluxVecNew,resSinkNew,resVecNew,out_SS4HG,out_LSR) ! provide access to the external procedures - USE matrixOper_module, only: computeGradient + USE matrixOper_module, only: computGradient USE eval8summa_module, only: imposeConstraints implicit none ! input type(in_type_lineSearchRefinement),intent(in) :: in_LSR ! class object for intent(in) arguments - type(in_type_summaSolve4homegrown),intent(in) :: in_SS4HG ! model control variables and previous function evaluation + type(in_type_summaSolv4homegrown),intent(in) :: in_SS4HG ! model control variables and previous function evaluation integer(i4b),intent(in) :: mSoil ! number of soil layers in solution vector real(rkind),intent(in) :: stateVecTrial(:) ! trial state vector real(rkind),intent(in) :: newtStepScaled(:) ! scaled newton step @@ -478,7 +478,7 @@ subroutine lineSearchRefinement(in_LSR,in_SS4HG,mSoil,stateVecTrial,newtStepScal type(var_dlength), intent(in) :: prog_data ! prognostic variables for a local HRU ! input-output real(qp),intent(inout) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) - type(io_type_summaSolve4homegrown),intent(inout) :: io_SS4HG ! first flux call flag and baseflow variables + type(io_type_summaSolv4homegrown),intent(inout) :: io_SS4HG ! first flux call flag and baseflow variables type(var_ilength),intent(inout) :: indx_data ! indices defining model states and layers type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU @@ -489,7 +489,7 @@ subroutine lineSearchRefinement(in_LSR,in_SS4HG,mSoil,stateVecTrial,newtStepScal real(rkind),intent(out) :: fluxVecNew(:) ! new flux vector real(rkind),intent(out) :: resSinkNew(:) ! sink terms on the RHS of the flux equation real(qp),intent(out) :: resVecNew(:) ! NOTE: qp ! new residual vector - type(out_type_summaSolve4homegrown),intent(out) :: out_SS4HG ! new function evaluation, convergence flag, and error control + type(out_type_summaSolv4homegrown),intent(out) :: out_SS4HG ! new function evaluation, convergence flag, and error control type(out_type_lineSearchRefinement),intent(out) :: out_LSR ! class object for intent(out) arguments ! -------------------------------------------------------------------------------------------------------- ! local @@ -532,7 +532,7 @@ subroutine lineSearchRefinement(in_LSR,in_SS4HG,mSoil,stateVecTrial,newtStepScal if (doLineSearch) then ! compute the gradient of the function vector - call computeGradient(ixMatrix,nState,aJacScaled,rVecScaled,gradScaled,err,cmessage) + call computGradient(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 @@ -656,11 +656,11 @@ end subroutine lineSearchRefinement subroutine trustRegionRefinement(in_TRR,in_SS4HG,stateVecTrial,newtStepScaled,aJacScaled,rVecScaled,stateVecNew,fluxVecNew,resVecNew,out_TRR) ! provide access to the matrix routines USE matrixOper_module, only: lapackSolv - USE matrixOper_module, only: computeGradient + USE matrixOper_module, only: computGradient implicit none ! input type(in_type_lineSearchRefinement),intent(in) :: in_TRR ! object for scalar intent(in) arguments -- reusing line search class - type(in_type_summaSolve4homegrown),intent(in) :: in_SS4HG ! model control variables and previous function evaluation + type(in_type_summaSolv4homegrown),intent(in) :: in_SS4HG ! model control variables and previous function evaluation real(rkind),intent(in) :: stateVecTrial(:) ! trial state vector real(rkind),intent(in) :: newtStepScaled(:) ! scaled newton step real(rkind),intent(in) :: aJacScaled(:,:) ! scaled jacobian matrix @@ -745,7 +745,7 @@ subroutine safeRootfinder(mSoil,stateVecTrial,rVecscaled,newtStepScaled,fScale,x real(rkind),intent(in) :: newtStepScaled(:) ! scaled newton step real(rkind),intent(in) :: fScale(:) ! characteristic scale of the function evaluations real(rkind),intent(in) :: xScale(:) ! characteristic scale of the state vector - type(in_type_summaSolve4homegrown),intent(in) :: in_SS4HG ! model control variables and previous function evaluation + type(in_type_summaSolv4homegrown),intent(in) :: in_SS4HG ! model control variables and previous function evaluation type(model_options),intent(in) :: model_decisions(:) ! model decisions type(zLookup), intent(in) :: lookup_data ! lookup tables type(var_i), intent(in) :: type_data ! type of vegetation and soil @@ -756,14 +756,14 @@ subroutine safeRootfinder(mSoil,stateVecTrial,rVecscaled,newtStepScaled,fScale,x type(var_dlength), intent(in) :: prog_data ! prognostic variables for a local HRU ! input-output real(qp),intent(inout) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) - type(io_type_summaSolve4homegrown),intent(inout) :: io_SS4HG ! first flux call flag and baseflow variables + type(io_type_summaSolv4homegrown),intent(inout) :: io_SS4HG ! first flux call flag and baseflow variables type(var_ilength),intent(inout) :: indx_data ! indices defining model states and layers type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU type(var_dlength),intent(inout) :: deriv_data ! derivatives in model fluxes w.r.t. relevant state variables real(rkind),intent(inout) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) ! output - type(out_type_summaSolve4homegrown),intent(out) :: out_SS4HG ! new function evaluation, convergence flag, and error control + type(out_type_summaSolv4homegrown),intent(out) :: out_SS4HG ! new function evaluation, convergence flag, and error control real(rkind),intent(out) :: stateVecNew(:) ! new state vector real(rkind),intent(out) :: fluxVecNew(:) ! new flux vector real(rkind),intent(out) :: resSinkNew(:) ! sink terms on the RHS of the flux equation @@ -892,7 +892,7 @@ subroutine getBrackets(stateVecTrial,rVec,fScale,in_SS4HG,model_decisions,lookup real(rkind),intent(in) :: stateVecTrial(:) ! trial state vector real(qp),intent(in) :: rVec(:) ! NOTE: qp ! residual vector real(rkind),intent(in) :: fScale(:) ! characteristic scale of the function evaluations - type(in_type_summaSolve4homegrown),intent(in) :: in_SS4HG ! model control variables and previous function evaluation + type(in_type_summaSolv4homegrown),intent(in) :: in_SS4HG ! model control variables and previous function evaluation type(model_options),intent(in) :: model_decisions(:) ! model decisions type(zLookup), intent(in) :: lookup_data ! lookup tables type(var_i), intent(in) :: type_data ! type of vegetation and soil @@ -903,7 +903,7 @@ subroutine getBrackets(stateVecTrial,rVec,fScale,in_SS4HG,model_decisions,lookup type(var_dlength), intent(in) :: prog_data ! prognostic variables for a local HRU ! input-output real(qp),intent(inout) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) - type(io_type_summaSolve4homegrown),intent(inout) :: io_SS4HG ! first flux call flag and baseflow variables + type(io_type_summaSolv4homegrown),intent(inout) :: io_SS4HG ! first flux call flag and baseflow variables type(var_ilength),intent(inout) :: indx_data ! indices defining model states and layers type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU @@ -911,7 +911,7 @@ subroutine getBrackets(stateVecTrial,rVec,fScale,in_SS4HG,model_decisions,lookup real(rkind),intent(inout) :: dBaseflow_dMatric(:,:) ! derivative in baseflow w.r.t. matric head (s-1) integer(i4b),intent(inout) :: err ! error code ! output - type(out_type_summaSolve4homegrown),intent(out) :: out_SS4HG ! new function evaluation, convergence flag, and error control + type(out_type_summaSolv4homegrown),intent(out) :: out_SS4HG ! new function evaluation, convergence flag, and error control real(rkind),intent(out) :: stateVecNew(:) ! new state vector real(rkind),intent(out) :: fluxVecNew(:) ! updated flux vector real(rkind),intent(out) :: resSinkNew(:) ! sink terms on the RHS of the flux equation @@ -1001,7 +1001,7 @@ subroutine eval8summa_wrapper(stateVecNew,fScale,in_SS4HG,model_decisions,& ! input real(rkind),intent(in) :: stateVecNew(:) ! updated state vector real(rkind),intent(in) :: fScale(:) ! characteristic scale of the function evaluations - type(in_type_summaSolve4homegrown),intent(in) :: in_SS4HG ! model control variables and previous function evaluation + type(in_type_summaSolv4homegrown),intent(in) :: in_SS4HG ! model control variables and previous function evaluation type(model_options),intent(in) :: model_decisions(:) ! model decisions type(zLookup), intent(in) :: lookup_data ! lookup tables type(var_i), intent(in) :: type_data ! type of vegetation and soil @@ -1012,7 +1012,7 @@ subroutine eval8summa_wrapper(stateVecNew,fScale,in_SS4HG,model_decisions,& type(var_dlength), intent(in) :: prog_data ! prognostic variables for a local HRU ! input-output real(qp),intent(inout) :: sMul(:) ! NOTE: qp ! state vector multiplier (used in the residual calculations) - type(io_type_summaSolve4homegrown),intent(inout) :: io_SS4HG ! first flux call flag and baseflow variables + type(io_type_summaSolv4homegrown),intent(inout) :: io_SS4HG ! first flux call flag and baseflow variables type(var_ilength),intent(inout) :: indx_data ! indices defining model states and layers type(var_dlength),intent(inout) :: diag_data ! diagnostic variables for a local HRU type(var_dlength),intent(inout) :: flux_data ! model fluxes for a local HRU @@ -1106,14 +1106,14 @@ function checkConv(mSoil,in_SS4HG,mpar_data,indx_data,prog_data,rVec,xInc,xVec,o logical(lgt) :: checkConv ! flag to denote convergence ! dummies integer(i4b),intent(in) :: mSoil ! number of soil layers in solution vector - type(in_type_summaSolve4homegrown),intent(in) :: in_SS4HG ! model control variables and previous function evaluation + type(in_type_summaSolv4homegrown),intent(in) :: in_SS4HG ! model control variables and previous function evaluation type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_ilength),intent(in) :: indx_data ! indices defining model states and layers type(var_dlength),intent(in) :: prog_data ! prognostic variables for a local HRU real(rkind),intent(in) :: rVec(:) ! residual vector (mixed units) real(rkind),intent(in) :: xInc(:) ! iteration increment (mixed units) real(rkind),intent(in) :: xVec(:) ! state vector (mixed units) - type(out_type_summaSolve4homegrown),intent(in) :: out_SS4HG ! new function evaluation, convergence flag, and error control + type(out_type_summaSolv4homegrown),intent(in) :: out_SS4HG ! new function evaluation, convergence flag, and error control ! locals real(rkind),dimension(mSoil) :: psiScale ! scaling factor for matric head real(rkind),parameter :: xSmall=1.e-0_rkind ! a small offset @@ -1220,12 +1220,12 @@ function checkConv(mSoil,in_SS4HG,mpar_data,indx_data,prog_data,rVec,xInc,xVec,o ! print progress towards solution if (globalPrintFlag) then - write(*,'(a,1x,i4,1x,6(e15.5,1x),7(L1,1x))') 'check convergence: ', iter, & - matric_max(1), liquid_max(1), energy_max(1), canopy_max, aquifer_max, soilWatBalErr, matricConv, liquidConv, energyConv, watbalConv, canopyConv, aquiferConv, watbalConv + write(*,'(a,1x,i4,1x,6(e15.5,1x),6(L1,1x))') 'check convergence: ', iter, & + matric_max(1), liquid_max(1), energy_max(1), canopy_max, aquifer_max, soilWatBalErr, matricConv, liquidConv, energyConv, canopyConv, aquiferConv, watbalConv end if end associate ! end associations with variables in the data structures end function checkConv -end module summaSolve4homegrown_module +end module summaSolv4homegrown_module diff --git a/build/source/engine/summaSolve4ida.f90 b/build/source/engine/summaSolv4ida.f90 similarity index 93% rename from build/source/engine/summaSolve4ida.f90 rename to build/source/engine/summaSolv4ida.f90 index a8beb510a..cfac75213 100644 --- a/build/source/engine/summaSolve4ida.f90 +++ b/build/source/engine/summaSolv4ida.f90 @@ -18,18 +18,23 @@ ! You should have received a copy of the GNU General Public License ! along with this program. If not, see . -module summaSolve4ida_module +module summaSolv4ida_module !======= Inclusions =========== USE, intrinsic :: iso_c_binding -USE nrtype +USE nr_type USE type4ida +USE data_types,only:& + var_i, & ! data vector (i4b) + var_d, & ! data vector (rkind) + var_ilength, & ! data vector with variable length dimension (i4b) + var_dlength, & ! data vector with variable length dimension (rkind) + model_options ! defines the model decisions ! access missing values USE globalData,only:integerMissing ! missing integer USE globalData,only:realMissing ! missing real number -USE globalData,only:verySmaller ! a smaller number used as an additive constant to check if substantial difference among real numbers ! access matrix information USE globalData,only: ixFullMatrix ! named variable for the full Jacobian matrix @@ -41,7 +46,9 @@ module summaSolve4ida_module USE globalData,only:flux_meta ! metadata on the model fluxes ! constants -USE multiconst,only: Tfreeze ! temperature at freezing (K) +USE multiconst,only:Tfreeze ! temperature at freezing (K) +USE globalData,only:verySmall ! a small number +USE globalData,only:verySmaller ! a smaller number than verySmall ! provide access to indices that define elements of the data structures USE var_lookup,only:iLookPROG ! named variables for structure elements @@ -52,14 +59,6 @@ module summaSolve4ida_module USE var_lookup,only:iLookPARAM ! named variables for structure elements USE var_lookup,only:iLookINDEX ! named variables for structure elements -! provide access to the derived types to define the data structures -USE data_types,only:& - var_i, & ! data vector (i4b) - var_d, & ! data vector (rkind) - var_ilength, & ! data vector with variable length dimension (i4b) - var_dlength, & ! data vector with variable length dimension (rkind) - model_options ! defines the model decisions - ! look-up values for the choice of groundwater parameterization USE mDecisions_module,only: & qbaseTopmodel, & ! TOPMODEL-ish baseflow parameterization @@ -69,8 +68,8 @@ module summaSolve4ida_module ! look-up values for the choice of variable in energy equations (BE residual or IDA state variable) USE mDecisions_module,only: & closedForm, & ! use temperature with closed form heat capacity - enthalpyFormLU, & ! use enthalpy with soil temperature-enthalpy lookup tables - enthalpyForm ! use enthalpy with soil temperature-enthalpy analytical solution + enthalpyForm, & ! use enthalpy with soil temperature-enthalpy lookup tables + enthalpyFormAN ! use enthalpy with soil temperature-enthalpy analytical solution ! look-up values for method used to compute derivative USE mDecisions_module,only: & @@ -84,15 +83,15 @@ module summaSolve4ida_module private::find_rootdir public::layerDisCont4ida private::getErrMessage - public::summaSolve4ida + public::summaSolv4ida contains ! ************************************************************************************ -! * public subroutine summaSolve4ida: solve F(y,y') = 0 by IDA (y is the state vector) +! * public subroutine summaSolv4ida: solve F(y,y') = 0 by IDA (y is the state vector) ! ************************************************************************************ -subroutine summaSolve4ida(& +subroutine summaSolv4ida(& dt_cur, & ! intent(in): current stepsize dt, & ! intent(in): data time step atol, & ! intent(in): absolute tolerance @@ -270,7 +269,7 @@ subroutine summaSolve4ida(& ) ! association to necessary variables for the residual computations ! initialize error control - err=0; message="summaSolve4ida/" + err=0; message="summaSolv4ida/" ! choose Jacobian type select case(model_decisions(iLookDECISIONS%fDerivMeth)%iDecision) @@ -389,17 +388,13 @@ subroutine summaSolve4ida(& if(detect_events)then nRoot = 0 if(ixVegNrg/=integerMissing) nRoot = nRoot+1 - if(nSnow>0)then - do i = 1,nSnow - if(ixSnowOnlyNrg(i)/=integerMissing) nRoot = nRoot+1 - enddo - endif - if(nSoil>0)then - do i = 1,nSoil - if(ixSoilOnlyHyd(i)/=integerMissing) nRoot = nRoot+1 - if(ixSoilOnlyNrg(i)/=integerMissing) nRoot = nRoot+1 - enddo - endif + do i = 1,nSnow + if(ixSnowOnlyNrg(i)/=integerMissing) nRoot = nRoot+1 + enddo + do i = 1,nSoil + if(ixSoilOnlyHyd(i)/=integerMissing) nRoot = nRoot+1 + if(ixSoilOnlyNrg(i)/=integerMissing) nRoot = nRoot+1 + enddo allocate( rootsfound(nRoot) ) allocate( rootdir(nRoot) ) rootdir = 0 @@ -488,7 +483,7 @@ subroutine summaSolve4ida(& if (eqns_data%err/=0)then; message=trim(message)//trim(eqns_data%message); return; endif ! fail from summa problem call getErrMessage(retvalr,cmessage) ! fail from solver problem message=trim(message)//trim(cmessage) - !if(retvalr==-1) err = -20 ! max iterations failure, exit and reduce the data window time in varSubStep + !if(retvalr==-1) err = -20 ! max iterations failure, exit and reduce the data window time in varSubstep exit end if @@ -530,7 +525,7 @@ subroutine summaSolve4ida(& ! early return for non-feasible solutions, right now will just fail if goes infeasible if(.not.feasible)then idaSucceeds = .false. - message=trim(message)//trim(cmessage)//'non-feasible' ! err=0 is already set, could make this a warning and reduce the data window time in varSubStep + message=trim(message)//trim(cmessage)//'non-feasible' ! err=0 is already set, could make this a warning and reduce the data window time in varSubstep exit end if @@ -597,7 +592,7 @@ subroutine summaSolve4ida(& retval = FIDAReInit(ida_mem, tret(1), sunvec_y, sunvec_yp) if (retval /= 0) then; err=20; message=trim(message)//'error in FIDAReInit'; return; endif ! don't keep calling if step is small, or took many steps already (prevents root bouncing) - if(dt_last(1) < 1.e-6_rkind .or. abs(dt_diff) < 1.e-6_rkind & + if(dt_last(1) < verySmall .or. abs(dt_diff) < verySmall & .or. (mpar_data%var(iLookPARAM%idaMaxDataWindowSteps)%dat(1)<1.e10_rkind & .and. nSteps>=mpar_data%var(iLookPARAM%idaMaxDataWindowSteps)%dat(1)))then ! treat 1e10 as no limit on steps retval = FIDARootInit(ida_mem, 0, c_funloc(layerDisCont4ida)) @@ -669,7 +664,7 @@ subroutine summaSolve4ida(& end associate -end subroutine summaSolve4ida +end subroutine summaSolv4ida ! ---------------------------------------------------------------- ! SetInitialCondition: routine to initialize u and up vectors. @@ -820,35 +815,31 @@ subroutine find_rootdir(eqns_data,rootdir) if(eqns_data%scalarCanopyTempPrev > Tfreeze) rootdir(ind) = -1 endif - if(nSnow>0)then - do i = 1,nSnow - ! identify the critical point when the snow layer begins to freeze - if(eqns_data%indx_data%var(iLookINDEX%ixSnowOnlyNrg)%dat(i)/=integerMissing)then - ind = ind+1 - rootdir(ind) = 1 - if(eqns_data%mLayerTempPrev(i) > Tfreeze) rootdir(ind) = -1 - endif - end do - endif - - if(nSoil>0)then - do i = 1,nSoil - xPsi = eqns_data%mLayerMatricHeadPrev(i) - ! identify the critical point when soil matrix potential goes below 0 and Tfreeze depends only on temp - if (eqns_data%indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat(i)/=integerMissing)then - ind = ind+1 - rootdir(ind) = 1 - if(xPsi > 0._rkind ) rootdir(ind) = -1 - endif - ! identify the critical point when the soil layer begins to freeze - if(eqns_data%indx_data%var(iLookINDEX%ixSoilOnlyNrg)%dat(i)/=integerMissing)then - ind = ind+1 - TcSoil = crit_soilT(xPsi) - rootdir(ind) = 1 - if(eqns_data%mLayerTempPrev(i+nSnow) > TcSoil) rootdir(ind) = -1 - endif - end do - endif + do i = 1,nSnow + ! identify the critical point when the snow layer begins to freeze + if(eqns_data%indx_data%var(iLookINDEX%ixSnowOnlyNrg)%dat(i)/=integerMissing)then + ind = ind+1 + rootdir(ind) = 1 + if(eqns_data%mLayerTempPrev(i) > Tfreeze) rootdir(ind) = -1 + endif + end do + + do i = 1,nSoil + xPsi = eqns_data%mLayerMatricHeadPrev(i) + ! identify the critical point when soil matrix potential goes below 0 and Tfreeze depends only on temp + if (eqns_data%indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat(i)/=integerMissing)then + ind = ind+1 + rootdir(ind) = 1 + if(xPsi > 0._rkind ) rootdir(ind) = -1 + endif + ! identify the critical point when the soil layer begins to freeze + if(eqns_data%indx_data%var(iLookINDEX%ixSoilOnlyNrg)%dat(i)/=integerMissing)then + ind = ind+1 + TcSoil = crit_soilT(xPsi) + rootdir(ind) = 1 + if(eqns_data%mLayerTempPrev(i+nSnow) > TcSoil) rootdir(ind) = -1 + endif + end do end subroutine find_rootdir @@ -921,42 +912,38 @@ integer(c_int) function layerDisCont4ida(t, sunvec_u, sunvec_up, gout, user_data end if endif - if(nSnow>0)then - do i = 1,nSnow - ! identify the critical point when the snow layer begins to freeze - if(eqns_data%indx_data%var(iLookINDEX%ixSnowOnlyNrg)%dat(i)/=integerMissing)then - ind = ind+1 - if(enthalpyStateVec)then - gout(ind) = uu(eqns_data%indx_data%var(iLookINDEX%ixSnowOnlyNrg)%dat(i)) - else - gout(ind) = uu(eqns_data%indx_data%var(iLookINDEX%ixSnowOnlyNrg)%dat(i)) - Tfreeze - end if - endif - end do - endif - - if(nSoil>0)then - do i = 1,nSoil - ! identify the critical point when soil matrix potential goes below 0 and Tfreeze depends only on temp - if (eqns_data%indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat(i)/=integerMissing)then - ind = ind+1 - xPsi = uu(eqns_data%indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat(i)) - gout(ind) = uu(eqns_data%indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat(i)) + do i = 1,nSnow + ! identify the critical point when the snow layer begins to freeze + if(eqns_data%indx_data%var(iLookINDEX%ixSnowOnlyNrg)%dat(i)/=integerMissing)then + ind = ind+1 + if(enthalpyStateVec)then + gout(ind) = uu(eqns_data%indx_data%var(iLookINDEX%ixSnowOnlyNrg)%dat(i)) else - xPsi = eqns_data%prog_data%var(iLookPROG%mLayerMatricHead)%dat(i) - endif - ! identify the critical point when the soil layer begins to freeze - if(eqns_data%indx_data%var(iLookINDEX%ixSoilOnlyNrg)%dat(i)/=integerMissing)then - ind = ind+1 - if(enthalpyStateVec)then - gout(ind) = uu(eqns_data%indx_data%var(iLookINDEX%ixSoilOnlyNrg)%dat(i)) - else - TcSoil = crit_soilT(xPsi) - gout(ind) = uu(eqns_data%indx_data%var(iLookINDEX%ixSoilOnlyNrg)%dat(i)) - TcSoil - end if - endif - end do - endif + gout(ind) = uu(eqns_data%indx_data%var(iLookINDEX%ixSnowOnlyNrg)%dat(i)) - Tfreeze + end if + endif + end do + + do i = 1,nSoil + ! identify the critical point when soil matrix potential goes below 0 and Tfreeze depends only on temp + if (eqns_data%indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat(i)/=integerMissing)then + ind = ind+1 + xPsi = uu(eqns_data%indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat(i)) + gout(ind) = uu(eqns_data%indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat(i)) + else + xPsi = eqns_data%prog_data%var(iLookPROG%mLayerMatricHead)%dat(i) + endif + ! identify the critical point when the soil layer begins to freeze + if(eqns_data%indx_data%var(iLookINDEX%ixSoilOnlyNrg)%dat(i)/=integerMissing)then + ind = ind+1 + if(enthalpyStateVec)then + gout(ind) = uu(eqns_data%indx_data%var(iLookINDEX%ixSoilOnlyNrg)%dat(i)) + else + TcSoil = crit_soilT(xPsi) + gout(ind) = uu(eqns_data%indx_data%var(iLookINDEX%ixSoilOnlyNrg)%dat(i)) - TcSoil + end if + endif + end do ! return success ierr = 0 @@ -1005,4 +992,4 @@ subroutine getErrMessage(retval,message) end subroutine getErrMessage -end module summaSolve4ida_module +end module summaSolv4ida_module diff --git a/build/source/engine/summaSolve4kinsol.f90 b/build/source/engine/summaSolv4kinsol.f90 similarity index 98% rename from build/source/engine/summaSolve4kinsol.f90 rename to build/source/engine/summaSolv4kinsol.f90 index 0e694876f..76c985161 100644 --- a/build/source/engine/summaSolve4kinsol.f90 +++ b/build/source/engine/summaSolv4kinsol.f90 @@ -18,11 +18,11 @@ ! You should have received a copy of the GNU General Public License ! along with this program. If not, see . -module summaSolve4kinsol_module +module summaSolv4kinsol_module !======= Inclusions =========== USE, intrinsic :: iso_c_binding -USE nrtype +USE nr_type USE type4kinsol ! access missing values @@ -75,15 +75,15 @@ module summaSolve4kinsol_module private::setInitialCondition private::setSolverParams private::getErrMessage - public::summaSolve4kinsol + public::summaSolv4kinsol contains ! *************************************************************************************** -! * public subroutine summaSolve4kinsol: solve F(y) = 0 by KINSOL (y is the state vector) +! * public subroutine summaSolv4kinsol: solve F(y) = 0 by KINSOL (y is the state vector) ! *************************************************************************************** -subroutine summaSolve4kinsol(& +subroutine summaSolv4kinsol(& dt_cur, & ! intent(in): current stepsize dt, & ! intent(in): data time step fScale, & ! intent(in): characteristic scale of the function evaluations (mixed units) @@ -208,7 +208,7 @@ subroutine summaSolve4kinsol(& ! ----------------------------------------------------------------------------------------------------- ! initialize error control - err=0; message="summaSolve4kinsol/" + err=0; message="summaSolv4kinsol/" ! choose Jacobian type select case(model_decisions(iLookDECISIONS%fDerivMeth)%iDecision) @@ -349,7 +349,7 @@ subroutine summaSolve4kinsol(& if (eqns_data%err/=0)then; message=trim(message)//trim(eqns_data%message); return; endif !fail from summa problem call getErrMessage(retvalr,cmessage) ! fail from solver problem message=trim(message)//trim(cmessage) - if(retvalr==-6) err = -20 ! max iterations failure, exit and reduce the data window time in varSubStep + if(retvalr==-6) err = -20 ! max iterations failure, exit and reduce the data window time in varSubstep else ! check the feasibility of the solution, imposeConstraints should keep it from going infeasible feasible=.true. @@ -367,7 +367,7 @@ subroutine summaSolve4kinsol(& if(.not. feasible)then kinsolSucceeds = .false. - message=trim(message)//trim(cmessage)//'non-feasible' ! err=0 is already set, could make this a warning and reduce the data window time in varSubStep + message=trim(message)//trim(cmessage)//'non-feasible' ! err=0 is already set, could make this a warning and reduce the data window time in varSubstep endif endif !****************************** End of Main Solver *************************************** @@ -410,7 +410,7 @@ subroutine summaSolve4kinsol(& retval = FSUNContext_Free(sunctx) if(retval /= 0)then; err=20; message=trim(message)//'unable to free the SUNDIALS context'; return; endif -end subroutine summaSolve4kinsol +end subroutine summaSolv4kinsol ! ---------------------------------------------------------------- ! SetInitialCondition: routine to initialize u vector. @@ -530,4 +530,4 @@ subroutine getErrMessage(retval,message) end subroutine getErrMessage -end module summaSolve4kinsol_module +end module summaSolv4kinsol_module diff --git a/build/source/engine/sunGeomtry.f90 b/build/source/engine/sunGeomtry.f90 index e03eedf11..3a3b58ebe 100644 --- a/build/source/engine/sunGeomtry.f90 +++ b/build/source/engine/sunGeomtry.f90 @@ -19,7 +19,7 @@ ! along with this program. If not, see . MODULE sunGeomtry_module -USE nrtype +USE nr_type implicit none private public::clrsky_rad @@ -184,7 +184,7 @@ SUBROUTINE CLRSKY_RAD(MONTH,DAY,HOUR,DT,SLOPE,AZI,LAT,HRI,COSZEN) ! internal function JULIAN: calculate day of year ! ************************************************************************************************* FUNCTION JULIAN(MONTH,DAY) - USE nrtype + USE nr_type IMPLICIT NONE ! input INTEGER(I4B) :: MONTH,DAY ! month and day diff --git a/build/source/engine/systemSolv.f90 b/build/source/engine/systemSolv.f90 index 023875dcf..fce047885 100644 --- a/build/source/engine/systemSolv.f90 +++ b/build/source/engine/systemSolv.f90 @@ -21,7 +21,7 @@ module systemSolv_module ! data types -USE nrtype +USE nr_type ! access missing values USE globalData,only:integerMissing ! missing integer @@ -72,9 +72,9 @@ module systemSolv_module var_dlength, & ! data vector with variable length dimension (rkind) zLookup, & ! lookup tables model_options, & ! defines the model decisions - in_type_summaSolve4homegrown, & ! class for summaSolve4homegrown arguments - io_type_summaSolve4homegrown, & ! class for summaSolve4homegrown arguments - out_type_summaSolve4homegrown ! class for summaSolve4homegrown arguments + in_type_summaSolv4homegrown, & ! class for summaSolv4homegrown arguments + io_type_summaSolv4homegrown, & ! class for summaSolv4homegrown arguments + out_type_summaSolv4homegrown ! class for summaSolv4homegrown arguments ! look-up values for the choice of groundwater representation (local-column, or single-basin) USE mDecisions_module,only:& @@ -151,16 +151,16 @@ subroutine systemSolv(& ! structure allocations USE allocspace_module,only:allocLocal ! allocate local data structures ! state vector and solver - USE getVectorz_module,only:getScaling ! get the scaling vectors - USE enthalpyTemp_module,only:T2enthalpy_snwWat ! convert temperature to liq+ice enthalpy for a snow layer + USE getVectorz_module,only:getScaling ! get the scaling vectors and state multipliers + USE convertEnthalpyTemp_module,only:T2enthalpy_snwWat ! convert temperature to liq+ice enthalpy for a snow layer #ifdef SUNDIALS_ACTIVE USE tol4ida_module,only:popTol4ida ! populate tolerances USE eval8summaWithPrime_module,only:eval8summaWithPrime ! get the fluxes and residuals - USE summaSolve4ida_module,only:summaSolve4ida ! solve DAE by IDA - USE summaSolve4kinsol_module,only:summaSolve4kinsol ! solve DAE by KINSOL + USE summaSolv4ida_module,only:summaSolv4ida ! solve DAE by IDA + USE summaSolv4kinsol_module,only:summaSolv4kinsol ! solve DAE by KINSOL #endif USE eval8summa_module,only:eval8summa ! get the fluxes and residuals - USE summaSolve4homegrown_module,only:summaSolve4homegrown ! solve DAE using homegrown solver + USE summaSolv4homegrown_module,only:summaSolv4homegrown ! solve DAE using homegrown solver implicit none ! --------------------------------------------------------------------------------------- @@ -260,10 +260,10 @@ subroutine systemSolv(& integer(i4b), parameter :: scalarMaxIter=100 ! maximum number of iterations for the scalar solution homegrown solver logical(lgt) :: converged ! convergence flag homegrown solver logical(lgt), parameter :: post_massCons=.false. ! “perfectly” conserve mass by pushing the errors into the states, turn off for now to agree with SUNDIALS - ! class objects for call to summaSolve4homegrown - type(in_type_summaSolve4homegrown) :: in_SS4HG ! object for intent(in) summaSolve4homegrown arguments - type(io_type_summaSolve4homegrown) :: io_SS4HG ! object for intent(io) summaSolve4homegrown arguments - type(out_type_summaSolve4homegrown) :: out_SS4HG ! object for intent(out) summaSolve4homegrown arguments + ! class objects for call to summaSolv4homegrown + type(in_type_summaSolv4homegrown) :: in_SS4HG ! object for intent(in) summaSolv4homegrown arguments + type(io_type_summaSolv4homegrown) :: io_SS4HG ! object for intent(io) summaSolv4homegrown arguments + type(out_type_summaSolv4homegrown) :: out_SS4HG ! object for intent(out) summaSolv4homegrown arguments ! flags logical(lgt) :: return_flag ! flag for handling systemSolv returns trigerred from internal subroutines logical(lgt) :: exit_flag ! flag for handling loop exit statements trigerred from internal subroutines @@ -560,7 +560,7 @@ subroutine Newton_step ) call in_SS4HG % initialize(dt_cur,dt,iter,nSnow,nSoil,nLayers,nLeadDim,nState,ixMatrix,firstSubStep,computeVegFlux,scalarSolution,fOld) call io_SS4HG % initialize(firstFluxCall,xMin,xMax,ixSaturation) - call summaSolve4homegrown(in_SS4HG,& ! input: model control + call summaSolv4homegrown(in_SS4HG,& ! input: model control &stateVecTrial,fScale,xScale,resVec,sMul,dMat,& ! input: state vectors &model_decisions,lookup_data,type_data,attr_data,mpar_data,forc_data,bvar_data,prog_data,& ! input: data structures &indx_data,diag_data,flux_temp,deriv_data,& ! input-output: data structures @@ -663,7 +663,7 @@ subroutine solve_with_IDA ! * solving F(y,y') = 0 by IDA, y is the state vector and y' is the time derivative vector dy/dt !--------------------------- ! iterations and updates to trial state vector, fluxes, and derivatives are done inside IDA solver - call summaSolve4ida(& + call summaSolv4ida(& dt_cur, & ! intent(in): current stepsize dt, & ! intent(in): entire time step for drainage pond rate atol, & ! intent(in): absolute tolerance @@ -750,7 +750,7 @@ subroutine solve_with_KINSOL !--------------------------- stateVecNew(:) = 0._rkind ! iterations and updates to trial state vector, fluxes, and derivatives are done inside IDA solver - call summaSolve4kinsol(& + call summaSolv4kinsol(& dt_cur, & ! intent(in): data time step dt, & ! intent(in): length of the entire time step (seconds) for drainage pond rate fScale, & ! intent(in): characteristic scale of the function evaluations diff --git a/build/source/engine/tempAdjust.f90 b/build/source/engine/tempAdjust.f90 index 9fe8acd3c..3b638b55a 100644 --- a/build/source/engine/tempAdjust.f90 +++ b/build/source/engine/tempAdjust.f90 @@ -21,7 +21,7 @@ module tempAdjust_module ! data types -USE nrtype +USE nr_type ! derived types to define the data structures USE data_types,only:& diff --git a/build/source/engine/computThermConduct.f90 b/build/source/engine/thermConductivity.f90 similarity index 53% rename from build/source/engine/computThermConduct.f90 rename to build/source/engine/thermConductivity.f90 index 028969fe0..18cb23a2f 100644 --- a/build/source/engine/computThermConduct.f90 +++ b/build/source/engine/thermConductivity.f90 @@ -1,8 +1,8 @@ -module computThermConduct_module +module thermConductivity_module ! data types -USE nrtype +USE nr_type ! derived types to define the data structures USE data_types,only:& @@ -57,35 +57,236 @@ module computThermConduct_module ! privacy implicit none private -public::computThermConduct +public::init_thermConductivity +public::thermConductivity contains +! ********************************************************************************************************** + ! public subroutine init_thermConductivity: compute start-of-step thermal conductivity + ! ********************************************************************************************************** + subroutine init_thermConductivity(& + ! input/output: data structures + mpar_data, & ! intent(in): model parameters + indx_data, & ! intent(in): model layer indices + prog_data, & ! intent(in): model prognostic variables for a local HRU + diag_data, & ! intent(inout): model diagnostic variables for a local HRU + ! output: error control + err,message) ! intent(out): error control + ! -------------------------------------------------------------------------------------------------------------------------------------- + ! provide access to external subroutines + USE snow_utils_module,only:tcond_snow ! compute thermal conductivity of snow + ! -------------------------------------------------------------------------------------------------------------------------------------- + ! input/output: data structures + type(var_dlength),intent(in) :: mpar_data ! model parameters + type(var_ilength),intent(in) :: indx_data ! model layer indices + type(var_dlength),intent(in) :: prog_data ! model prognostic variables for a local HRU + type(var_dlength),intent(inout) :: diag_data ! model diagnostic variables for a local HRU + ! output: error control + integer(i4b),intent(out) :: err ! error code + character(*),intent(out) :: message ! error message + ! -------------------------------------------------------------------------------------------------------------------------------- + ! local variables + character(LEN=256) :: cmessage ! error message of downwind routine + integer(i4b) :: iLayer ! index of model layer + integer(i4b) :: iSoil ! index of soil layer + real(rkind) :: TCn ! thermal conductivity below the layer interface (W m-1 K-1) + real(rkind) :: TCp ! thermal conductivity above the layer interface (W m-1 K-1) + real(rkind) :: zdn ! height difference between interface and lower value (m) + real(rkind) :: zdp ! height difference between interface and upper value (m) + real(rkind) :: bulkden_soil ! bulk density of soil (kg m-3) + real(rkind) :: lambda_drysoil ! thermal conductivity of dry soil (W m-1) + real(rkind) :: lambda_wetsoil ! thermal conductivity of wet soil (W m-1) + real(rkind) :: lambda_wet ! thermal conductivity of the wet material + real(rkind) :: relativeSat ! relative saturation (-) + real(rkind) :: kerstenNum ! the Kersten number (-), defining weight applied to conductivity of the wet medium + real(rkind) :: den ! denominator in the thermal conductivity calculations + ! local variables to reproduce the thermal conductivity of Hansson et al. VZJ 2005 + real(rkind),parameter :: c1=0.55_rkind ! optimized parameter from Hansson et al. VZJ 2005 (W m-1 K-1) + real(rkind),parameter :: c2=0.8_rkind ! optimized parameter from Hansson et al. VZJ 2005 (W m-1 K-1) + real(rkind),parameter :: c3=3.07_rkind ! optimized parameter from Hansson et al. VZJ 2005 (-) + real(rkind),parameter :: c4=0.13_rkind ! optimized parameter from Hansson et al. VZJ 2005 (W m-1 K-1) + real(rkind),parameter :: c5=4._rkind ! optimized parameter from Hansson et al. VZJ 2005 (-) + real(rkind),parameter :: f1=13.05_rkind ! optimized parameter from Hansson et al. VZJ 2005 (-) + real(rkind),parameter :: f2=1.06_rkind ! optimized parameter from Hansson et al. VZJ 2005 (-) + real(rkind) :: fArg,xArg ! temporary variables (see Hansson et al. VZJ 2005 for details) + ! -------------------------------------------------------------------------------------------------------------------------------- + ! 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 + 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 + 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) + 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: thermal conductivity + 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 + 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="init_thermConductivity/" + + ! initialize the soil layer + iSoil=integerMissing + + ! loop through layers + do iLayer=1,nLayers + + ! get the soil layer + if(iLayer>nSnow) iSoil = iLayer-nSnow + + ! compute the thermal conductivity of dry and wet soils (W m-1) + ! NOTE: this is actually constant over the simulation, and included here for clarity + if(ixThCondSoil == funcSoilWet .and. layerType(iLayer)==iname_soil)then + bulkden_soil = iden_soil(iSoil)*( 1._rkind - theta_sat(iSoil) ) + lambda_drysoil = (0.135_rkind*bulkden_soil + 64.7_rkind) / (iden_soil(iSoil) - 0.947_rkind*bulkden_soil) + lambda_wetsoil = (8.80_rkind*frac_sand(iSoil) + 2.92_rkind*frac_clay(iSoil)) / (frac_sand(iSoil) + frac_clay(iSoil)) + end if + + ! * compute the volumetric fraction of air in each layer... + select case(layerType(iLayer)) + case(iname_soil); mLayerVolFracAir(iLayer) = theta_sat(iSoil) - (mLayerVolFracIce(iLayer) + mLayerVolFracLiq(iLayer)) + case(iname_snow); mLayerVolFracAir(iLayer) = 1._rkind - (mLayerVolFracIce(iLayer) + mLayerVolFracLiq(iLayer)) + case default; err=20; message=trim(message)//'unable to identify type of layer (snow or soil) to compute volumetric fraction of air'; return + end select + + ! ***** + ! * compute the thermal conductivity of snow and soil at the mid-point of each layer... + ! ************************************************************************************* + select case(layerType(iLayer)) + + case(iname_soil) + + ! select option for thermal conductivity of soil + select case(ixThCondSoil) + + ! ** function of soil wetness + case(funcSoilWet) + ! compute the thermal conductivity of the wet material (W m-1) + lambda_wet = lambda_wetsoil**( 1._rkind - theta_sat(iSoil) ) * lambda_water**theta_sat(iSoil) * lambda_ice**(theta_sat(iSoil) - mLayerVolFracLiq(iLayer)) + relativeSat = (mLayerVolFracIce(iLayer) + mLayerVolFracLiq(iLayer))/theta_sat(iSoil) ! relative saturation + ! compute the Kersten number (-) + if(relativeSat > 0.1_rkind)then ! log10(0.1) = -1 + kerstenNum = log10(relativeSat) + 1._rkind + else + kerstenNum = 0._rkind ! dry thermal conductivity + endif + ! ...and, compute the thermal conductivity + mLayerThermalC(iLayer) = kerstenNum*lambda_wet + (1._rkind - kerstenNum)*lambda_drysoil + + ! ** mixture of constituents + case(mixConstit) + mLayerThermalC(iLayer) = thCond_soil(iSoil) * ( 1._rkind - theta_sat(iSoil) ) + & ! soil component + lambda_ice * mLayerVolFracIce(iLayer) + & ! ice component + lambda_water * mLayerVolFracLiq(iLayer) + & ! liquid water component + lambda_air * mLayerVolFracAir(iLayer) ! air component + + ! ** test case for the mizoguchi lab experiment, Hansson et al. VZJ 2004 + case(hanssonVZJ) + fArg = 1._rkind + f1*mLayerVolFracIce(iLayer)**f2 + xArg = mLayerVolFracLiq(iLayer) + fArg*mLayerVolFracIce(iLayer) + mLayerThermalC(iLayer) = c1 + c2*xArg + (c1 - c4)*exp(-(c3*xArg)**c5) + + ! ** check + case default; err=20; message=trim(message)//'unable to identify option for thermal conductivity of soil'; return + end select ! option for the thermal conductivity of soil + + 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 + + end do ! looping through layers + + ! ***** + ! * compute the thermal conductivity of snow at the interface of each layer... + ! **************************************************************************** + ! loop through INTERFACES... + do iLayer=1,nLayers + ! ***** the lower boundary + if (iLayer==nLayers) then ! assume the thermal conductivity at the domain boundaries is equal to the thermal conductivity of the layer + iLayerThermalC(nLayers) = mLayerThermalC(nLayers) + ! ***** internal layers + else + ! get temporary variables + TCn = mLayerThermalC(iLayer) ! thermal conductivity below the layer interface (W m-1 K-1) + TCp = mLayerThermalC(iLayer+1) ! thermal conductivity above the layer interface (W m-1 K-1) + zdn = iLayerHeight(iLayer) - mLayerHeight(iLayer) ! height difference between interface and lower value (m) + zdp = mLayerHeight(iLayer+1) - iLayerHeight(iLayer) ! height difference between interface and upper value (m) + den = TCn*zdp + TCp*zdn ! denominator + ! compute thermal conductivity + if(TCn+TCp > epsilon(TCn))then + iLayerThermalC(iLayer) = (TCn*TCp*(zdn + zdp)) / den + else + iLayerThermalC(iLayer) = (TCn*zdn + TCp*zdp) / (zdn + zdp) + endif + end if ! type of layer (internal or lower) + end do ! end looping through layers + ! ***** the upper boundary + if(ixThCondSoil==hanssonVZJ)then ! special case of hansson + iLayerThermalC(0) = 28._rkind*(0.5_rkind*(iLayerHeight(1) - iLayerHeight(0))) + else + iLayerThermalC(0) = mLayerThermalC(1) + end if + + ! end association to variables in the data structure + end associate + + end subroutine init_thermConductivity ! ********************************************************************************************************** -! public subroutine computThermConduct: recompute diagnostic energy variables (thermal conductivity) +! public subroutine thermConductivity: recompute diagnostic energy variables (thermal conductivity) ! NOTE: does every layer regardless if layer or layer+1 is in state subset, could fix for speedup ! ********************************************************************************************************** -subroutine computThermConduct(& - ! input: control variables - nLayers, & ! intent(in): total number of layers +subroutine thermConductivity(& ! input: state variables - mLayerTemp, & ! intent(in): temperature at the current iteration (K) - mLayerMatricHead, & ! intent(in): matric head at the current iteration(m) + nLayers, & ! intent(in): total number of layers + scalarSolution, & ! intent(in): flag to indicate the scalar solution mLayerVolFracIce, & ! intent(in): volumetric fraction of ice at the start of the sub-step (-) mLayerVolFracLiq, & ! intent(in): volumetric fraction of liquid water at the start of the sub-step (-) - ! input: pre-computed derivatives - mLayerdTheta_dTk, & ! intent(in): derivative in volumetric liquid water content w.r.t. temperature (K-1) - mLayerFracLiqSnow, & ! intent(in): fraction of liquid water (-) ! input/output: data structures mpar_data, & ! intent(in): model parameters indx_data, & ! intent(in): model layer indices prog_data, & ! intent(in): model prognostic variables for a local HRU diag_data, & ! intent(inout): model diagnostic variables for a local HRU - ! output: derivatives - dThermalC_dWatAbove, & ! intent(out): derivative in the thermal conductivity w.r.t. water state in the layer above - dThermalC_dWatBelow, & ! intent(out): derivative in the thermal conductivity w.r.t. water state in the layer above - dThermalC_dTempAbove, & ! intent(out): derivative in the thermal conductivity w.r.t. energy state in the layer above - dThermalC_dTempBelow, & ! intent(out): derivative in the thermal conductivity w.r.t. energy state in the layer above + ! input: pre-computed derivatives + mLayerTemp, & ! intent(in): temperature at the current iteration (K) + mLayerMatricHead, & ! intent(in): matric head at the current iteration(m) + mLayerdTheta_dTk, & ! intent(in): derivative in volumetric liquid water content w.r.t. temperature (K-1) + mLayerFracLiqSnow, & ! intent(in): fraction of liquid water (-) + ! input/output: derivatives + dThermalC_dWatAbove, & ! intent(inout): derivative in the thermal conductivity w.r.t. water state in the layer above + dThermalC_dWatBelow, & ! intent(inout): derivative in the thermal conductivity w.r.t. water state in the layer above + dThermalC_dTempAbove, & ! intent(inout): derivative in the thermal conductivity w.r.t. energy state in the layer above + dThermalC_dTempBelow, & ! intent(inout): derivative in the thermal conductivity w.r.t. energy state in the layer above ! output: error control err,message) ! intent(out): error control @@ -97,33 +298,37 @@ subroutine computThermConduct(& implicit none ! -------------------------------------------------------------------------------------------------------------------------------------- - ! input: model control + ! input: model state variables integer(i4b),intent(in) :: nLayers ! total number of layers in the snow+soil domain - ! input: trial model state variables - real(rkind),intent(in) :: mLayerTemp(:) ! temperature in each layer at the current iteration (m) - real(rkind),intent(in) :: mLayerMatricHead(:) ! matric head in each layer at the current iteration (m) + logical,intent(in) :: scalarSolution ! flag to indicate the scalar solution real(rkind),intent(in) :: mLayerVolFracIce(:) ! volumetric fraction of ice at the current iteration (-) real(rkind),intent(in) :: mLayerVolFracLiq(:) ! volumetric fraction of liquid at the current iteration (-) - ! input: pre-computed derivatives - real(rkind),intent(in) :: mLayerdTheta_dTk(:) ! derivative in volumetric liquid water content w.r.t. temperature (K-1) - real(rkind),intent(in) :: mLayerFracLiqSnow(:) ! fraction of liquid water (-) ! input/output: data structures type(var_dlength),intent(in) :: mpar_data ! model parameters type(var_ilength),intent(in) :: indx_data ! model layer indices type(var_dlength),intent(in) :: prog_data ! model prognostic variables for a local HRU type(var_dlength),intent(inout) :: diag_data ! model diagnostic variables for a local HRU - ! output: derivatives - real(rkind),intent(out) :: dThermalC_dWatAbove(0:) ! derivative in the thermal conductivity w.r.t. water state in the layer above - real(rkind),intent(out) :: dThermalC_dWatBelow(0:) ! derivative in the thermal conductivity w.r.t. water state in the layer above - real(rkind),intent(out) :: dThermalC_dTempAbove(0:) ! derivative in the thermal conductivity w.r.t. energy state in the layer above - real(rkind),intent(out) :: dThermalC_dTempBelow(0:) ! derivative in the thermal conductivity w.r.t. energy state in the layer above + ! input: pre-computed derivatives + real(rkind),intent(in) :: mLayerTemp(:) ! temperature in each layer at the current iteration (m) + real(rkind),intent(in) :: mLayerMatricHead(:) ! matric head in each layer at the current iteration (m) + real(rkind),intent(in) :: mLayerdTheta_dTk(:) ! derivative in volumetric liquid water content w.r.t. temperature (K-1) + real(rkind),intent(in) :: mLayerFracLiqSnow(:) ! fraction of liquid water (-) + ! input/output: derivatives + real(rkind),intent(inout) :: dThermalC_dWatAbove(0:) ! derivative in the thermal conductivity w.r.t. water state in the layer above + real(rkind),intent(inout) :: dThermalC_dWatBelow(0:) ! derivative in the thermal conductivity w.r.t. water state in the layer above + real(rkind),intent(inout) :: dThermalC_dTempAbove(0:) ! derivative in the thermal conductivity w.r.t. energy state in the layer above + real(rkind),intent(inout) :: dThermalC_dTempBelow(0:) ! derivative in the thermal conductivity w.r.t. energy state in the layer above ! output: error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! -------------------------------------------------------------------------------------------------------------------------------- ! local variables character(LEN=256) :: cmessage ! error message of downwind routine - integer(i4b) :: iLayer ! index of model layer + logical(lgt) :: doVegNrgFlux ! flag to compute the energy flux over vegetation + integer(i4b) :: iLayer ! index of model layers + integer(i4b) :: ixLayerDesired(1) ! layer desired (scalar solution) + integer(i4b) :: ixTop ! top layer in subroutine call + integer(i4b) :: ixBot ! bottom layer in subroutine call integer(i4b) :: iSoil ! index of soil layer real(rkind) :: TCn ! thermal conductivity below the layer interface (W m-1 K-1) real(rkind) :: TCp ! thermal conductivity above the layer interface (W m-1 K-1) @@ -165,9 +370,14 @@ subroutine computThermConduct(& ixThCondSnow => model_decisions(iLookDECISIONS%thCondSnow)%iDecision, & ! intent(in): [i4b] choice of method for thermal conductivity of snow ixThCondSoil => model_decisions(iLookDECISIONS%thCondSoil)%iDecision, & ! intent(in): [i4b] choice of method for thermal conductivity of soil ! input: coordinate variables + ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1), & ! intent(in): [i4b] index of canopy air space energy state variable + ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1), & ! intent(in): [i4b] index of canopy energy state variable + ixTopNrg => indx_data%var(iLookINDEX%ixTopNrg)%dat(1), & ! intent(in): [i4b] index of upper-most energy state in the snow+soil subdomain nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1), & ! intent(in): [dp] number of snow layers - nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1), & ! intent(in): [dp] number of soil layers + nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg)%dat(1), & ! intent(in): [i4b] number of energy state variables in the snow+soil domain layerType => indx_data%var(iLookINDEX%layerType)%dat, & ! intent(in): [dp(:)] layer type (iname_soil or iname_snow) + ixLayerState => indx_data%var(iLookINDEX%ixLayerState)%dat, & ! intent(in): [i4b(:)]list of indices for all model layers + ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat, & ! intent(in): [i4b] index in the state subset for energy state variables in the snow+soil domain mLayerHeight => prog_data%var(iLookPROG%mLayerHeight)%dat, & ! intent(in): [dp(:)] height at the mid-point of each layer (m) iLayerHeight => prog_data%var(iLookPROG%iLayerHeight)%dat, & ! intent(in): [dp(:)] height at the interface of each layer (m) ! input: heat capacity and thermal conductivity @@ -185,20 +395,38 @@ subroutine computThermConduct(& theta_res => mpar_data%var(iLookPARAM%theta_res)%dat, & ! intent(in): [dp(:)] soil residual volumetric water content (-) ! input: snow parameters snowfrz_scale => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1), & ! intent(in): [dp] scaling parameter for the snow freezing curve (K-1) - ! output: diagnostic variables and derivatives (diagnostic as may be treated as constant) - mLayerThermalC => diag_data%var(iLookDIAG%mLayerThermalC)%dat, & ! intent(out): [dp(:)] thermal conductivity at the mid-point of each layer (W m-1 K-1) - iLayerThermalC => diag_data%var(iLookDIAG%iLayerThermalC)%dat, & ! intent(out): [dp(:)] thermal conductivity at the interface of each layer (W m-1 K-1) - mLayerVolFracAir => diag_data%var(iLookDIAG%mLayerVolFracAir)%dat & ! intent(out): [dp(:)] volumetric fraction of air in each layer (-) + ! input/output: diagnostic variables and derivatives (diagnostic as may be treated as constant) + mLayerThermalC => diag_data%var(iLookDIAG%mLayerThermalC)%dat, & ! intent(inout): [dp(:)] thermal conductivity at the mid-point of each layer (W m-1 K-1) + iLayerThermalC => diag_data%var(iLookDIAG%iLayerThermalC)%dat, & ! intent(inout): [dp(:)] thermal conductivity at the interface of each layer (W m-1 K-1) + mLayerVolFracAir => diag_data%var(iLookDIAG%mLayerVolFracAir)%dat & ! intent(inout): [dp(:)] volumetric fraction of air in each layer (-) ) ! association of local variables with information in the data structures ! -------------------------------------------------------------------------------------------------------------------------------- ! initialize error control - err=0; message="computThermConduct/" + err=0; message="thermConductivity/" + + ! get the indices for the snow+soil layers + doVegNrgFlux = (ixCasNrg/=integerMissing .or. ixVegNrg/=integerMissing .or. ixTopNrg/=integerMissing) + if (nSnowSoilNrg>0) then + if (scalarSolution) then + ixLayerDesired = pack(ixLayerState, ixSnowSoilNrg/=integerMissing) + ixTop = ixLayerDesired(1) + ixBot = ixLayerDesired(1) + else + ixTop = 1 + ixBot = nLayers + end if + elseif (doVegNrgFlux) then ! need top interface, potentially from top layer + ixTop = 1 + ixBot = 1 + else ! if not computing fluxes over vegetation and no energy state variables in the snow+soil domain, then we don't need to compute thermal conductivity + return + endif ! initialize the soil layer iSoil=integerMissing ! loop through layers - do iLayer=1,nLayers + do iLayer=ixTop,ixBot ! get the soil layer if(iLayer>nSnow) iSoil = iLayer-nSnow @@ -211,9 +439,8 @@ subroutine computThermConduct(& lambda_wetsoil = (8.80_rkind*frac_sand(iSoil) + 2.92_rkind*frac_clay(iSoil)) / (frac_sand(iSoil) + frac_clay(iSoil)) end if - ! ***** ! * compute the volumetric fraction of air in each layer... - ! ********************************************************* + select case(layerType(iLayer)) case(iname_soil); mLayerVolFracAir(iLayer) = theta_sat(iSoil) - (mLayerVolFracIce(iLayer) + mLayerVolFracLiq(iLayer)) case(iname_snow); mLayerVolFracAir(iLayer) = 1._rkind - (mLayerVolFracIce(iLayer) + mLayerVolFracLiq(iLayer)) @@ -228,9 +455,7 @@ subroutine computThermConduct(& select case(layerType(iLayer)) - ! ***** soil case(iname_soil) - select case(ixRichards) ! (form of Richards' equation) case(moisture) dVolFracLiq_dWat = 1._rkind @@ -253,7 +478,6 @@ subroutine computThermConduct(& ! ** function of soil wetness case(funcSoilWet) - ! compute the thermal conductivity of the wet material (W m-1) lambda_wet = lambda_wetsoil**( 1._rkind - theta_sat(iSoil) ) * lambda_water**theta_sat(iSoil) * lambda_ice**(theta_sat(iSoil) - mLayerVolFracLiq(iLayer)) dlambda_wet_dWat = -lambda_wet * log(lambda_ice) * dVolFracLiq_dWat @@ -271,17 +495,16 @@ subroutine computThermConduct(& endif ! ...and, compute the thermal conductivity mLayerThermalC(iLayer) = kerstenNum*lambda_wet + (1._rkind - kerstenNum)*lambda_drysoil - ! compute derivatives dThermalC_dWat(iLayer) = dkerstenNum_dWat * ( lambda_wet - lambda_drysoil ) + kerstenNum*dlambda_wet_dWat dThermalC_dNrg(iLayer) = kerstenNum*dlambda_wet_dTk ! ** mixture of constituents case(mixConstit) - mLayerThermalC(iLayer) = thCond_soil(iSoil) * ( 1._rkind - theta_sat(iSoil) ) + & ! soil component - lambda_ice * mLayerVolFracIce(iLayer) + & ! ice component - lambda_water * mLayerVolFracLiq(iLayer) + & ! liquid water component - lambda_air * mLayerVolFracAir(iLayer) ! air component + mLayerThermalC(iLayer) = thCond_soil(iSoil) * ( 1._rkind - theta_sat(iSoil) ) + & ! soil component + lambda_ice * mLayerVolFracIce(iLayer) + & ! ice component + lambda_water * mLayerVolFracLiq(iLayer) + & ! liquid water component + lambda_air * mLayerVolFracAir(iLayer) ! air component ! compute derivatives dThermalC_dWat(iLayer) = lambda_ice*dVolFracIce_dWat + lambda_water*dVolFracLiq_dWat + lambda_air*(-dVolFracIce_dWat - dVolFracLiq_dWat) dThermalC_dNrg(iLayer) = (lambda_ice - lambda_water) * dVolFracIce_dTk @@ -292,28 +515,24 @@ subroutine computThermConduct(& xArg = mLayerVolFracLiq(iLayer) + fArg*mLayerVolFracIce(iLayer) dxArg_dWat = dVolFracLiq_dWat + dVolFracIce_dWat * (1._rkind + f1*(f2+1)*mLayerVolFracIce(iLayer)**f2) dxArg_dTk = dVolFracIce_dTk * f1*(f2+1)*mLayerVolFracIce(iLayer)**f2 + ! ...and, compute the thermal conductivity mLayerThermalC(iLayer) = c1 + c2*xArg + (c1 - c4)*exp(-(c3*xArg)**c5) - ! compute derivatives dThermalC_dWat(iLayer) = ( c2 - c5*c3*(c3*xArg)**(c5-1)*(c1 - c4)*exp(-(c3*xArg)**c5) ) * dxArg_dWat dThermalC_dNrg(iLayer) = ( c2 - c5*c3*(c3*xArg)**(c5-1)*(c1 - c4)*exp(-(c3*xArg)**c5) ) * dxArg_dTk ! ** check case default; err=20; message=trim(message)//'unable to identify option for thermal conductivity of soil'; return - end select ! option for the thermal conductivity of soil - ! ***** snow case(iname_snow) dVolFracIce_dWat = ( 1._rkind - mLayerFracLiqSnow(iLayer) )*(iden_water/iden_ice) dVolFracIce_dTk = -mLayerdTheta_dTk(iLayer)*(iden_water/iden_ice) - ! temporally constant thermal conductivity + ! temporally constant thermal conductivity, derivatives are zero if(ixThCondSnow==Smirnova2000)then mLayerThermalC(iLayer) = fixedThermalCond_snow - dThermalC_dWat(iLayer) = 0._rkind - dThermalC_dNrg(iLayer) = 0._rkind ! thermal conductivity as a function of snow density else call tcond_snow(mLayerVolFracIce(iLayer)*iden_ice, & ! input: snow density (kg m-3) @@ -335,7 +554,6 @@ subroutine computThermConduct(& ! * error check case default; err=20; message=trim(message)//'unable to identify type of layer (snow or soil) to compute thermal conductivity'; return - end select end do ! looping through layers @@ -343,31 +561,41 @@ subroutine computThermConduct(& ! ***** ! * compute the thermal conductivity of snow at the interface of each layer... ! **************************************************************************** - do iLayer=1,nLayers-1 ! (loop through layers) - ! get temporary variables - TCn = mLayerThermalC(iLayer) ! thermal conductivity below the layer interface (W m-1 K-1) - TCp = mLayerThermalC(iLayer+1) ! thermal conductivity above the layer interface (W m-1 K-1) - zdn = iLayerHeight(iLayer) - mLayerHeight(iLayer) ! height difference between interface and lower value (m) - zdp = mLayerHeight(iLayer+1) - iLayerHeight(iLayer) ! height difference between interface and upper value (m) - den = TCn*zdp + TCp*zdn ! denominator - ! compute thermal conductivity - if(TCn+TCp > epsilon(TCn))then - iLayerThermalC(iLayer) = (TCn*TCp*(zdn + zdp)) / den - dThermalC_dWatBelow(iLayer) = ( TCn*(zdn + zdp) - iLayerThermalC(iLayer)*zdn ) / den * dThermalC_dWat(iLayer+1) - dThermalC_dWatAbove(iLayer) = ( TCp*(zdn + zdp) - iLayerThermalC(iLayer)*zdp ) / den * dThermalC_dWat(iLayer) - dThermalC_dTempBelow(iLayer) = ( TCn*(zdn + zdp) - iLayerThermalC(iLayer)*zdn ) / den * dThermalC_dNrg(iLayer+1) - dThermalC_dTempAbove(iLayer) = ( TCp*(zdn + zdp) - iLayerThermalC(iLayer)*zdp ) / den * dThermalC_dNrg(iLayer) + ! loop through INTERFACES... + do iLayer=ixTop,ixBot + ! ***** the lower boundary + if (iLayer==nLayers) then ! assume the thermal conductivity at the domain boundaries is equal to the thermal conductivity of the layer + iLayerThermalC(nLayers) = mLayerThermalC(nLayers) + dThermalC_dWatBelow(iLayer) = dThermalC_dWat(iLayer) + dThermalC_dTempBelow(iLayer) = dThermalC_dNrg(iLayer) + dThermalC_dWatAbove(iLayer) = realMissing + dThermalC_dTempAbove(iLayer) = realMissing + ! ***** internal layers else - iLayerThermalC(iLayer) = (TCn*zdn + TCp*zdp) / (zdn + zdp) - dThermalC_dWatBelow(iLayer) = zdp / (zdn + zdp) * dThermalC_dWat(iLayer+1) - dThermalC_dWatAbove(iLayer) = zdn / (zdn + zdp) * dThermalC_dWat(iLayer) - dThermalC_dTempBelow(iLayer) = zdp / (zdn + zdp) * dThermalC_dNrg(iLayer+1) - dThermalC_dTempAbove(iLayer) = zdn / (zdn + zdp) * dThermalC_dNrg(iLayer) - endif - end do ! looping through layers - - ! special case of hansson - if(ixThCondSoil==hanssonVZJ)then + ! get temporary variables + TCn = mLayerThermalC(iLayer) ! thermal conductivity below the layer interface (W m-1 K-1) + TCp = mLayerThermalC(iLayer+1) ! thermal conductivity above the layer interface (W m-1 K-1) + zdn = iLayerHeight(iLayer) - mLayerHeight(iLayer) ! height difference between interface and lower value (m) + zdp = mLayerHeight(iLayer+1) - iLayerHeight(iLayer) ! height difference between interface and upper value (m) + den = TCn*zdp + TCp*zdn ! denominator + ! compute thermal conductivity + if(TCn+TCp > epsilon(TCn))then + iLayerThermalC(iLayer) = (TCn*TCp*(zdn + zdp)) / den + dThermalC_dWatBelow(iLayer) = ( TCn*(zdn + zdp) - iLayerThermalC(iLayer)*zdn ) / den * dThermalC_dWat(iLayer+1) + dThermalC_dWatAbove(iLayer) = ( TCp*(zdn + zdp) - iLayerThermalC(iLayer)*zdp ) / den * dThermalC_dWat(iLayer) + dThermalC_dTempBelow(iLayer) = ( TCn*(zdn + zdp) - iLayerThermalC(iLayer)*zdn ) / den * dThermalC_dNrg(iLayer+1) + dThermalC_dTempAbove(iLayer) = ( TCp*(zdn + zdp) - iLayerThermalC(iLayer)*zdp ) / den * dThermalC_dNrg(iLayer) + else + iLayerThermalC(iLayer) = (TCn*zdn + TCp*zdp) / (zdn + zdp) + dThermalC_dWatBelow(iLayer) = zdp / (zdn + zdp) * dThermalC_dWat(iLayer+1) + dThermalC_dWatAbove(iLayer) = zdn / (zdn + zdp) * dThermalC_dWat(iLayer) + dThermalC_dTempBelow(iLayer) = zdp / (zdn + zdp) * dThermalC_dNrg(iLayer+1) + dThermalC_dTempAbove(iLayer) = zdn / (zdn + zdp) * dThermalC_dNrg(iLayer) + endif + end if ! type of layer (internal or lower) + end do ! end looping through layers + ! ***** the upper boundary + if(ixThCondSoil==hanssonVZJ)then ! special case of hansson iLayerThermalC(0) = 28._rkind*(0.5_rkind*(iLayerHeight(1) - iLayerHeight(0))) dThermalC_dWatBelow(0) = 0._rkind dThermalC_dTempBelow(0) = 0._rkind @@ -379,17 +607,10 @@ subroutine computThermConduct(& dThermalC_dWatAbove(0) = realMissing dThermalC_dTempAbove(0) = realMissing - ! assume the thermal conductivity at the domain boundaries is equal to the thermal conductivity of the layer - iLayerThermalC(nLayers) = mLayerThermalC(nLayers) - dThermalC_dWatAbove(nLayers) = dThermalC_dWat(nLayers) - dThermalC_dTempAbove(nLayers) = dThermalC_dNrg(nLayers) - dThermalC_dWatBelow(nLayers) = realMissing - dThermalC_dTempBelow(nLayers) = realMissing - ! end association to variables in the data structure end associate -end subroutine computThermConduct +end subroutine thermConductivity -end module computThermConduct_module +end module thermConductivity_module diff --git a/build/source/engine/time_utils.f90 b/build/source/engine/time_utils.f90 index 2d56110cf..d13e0bb7f 100644 --- a/build/source/engine/time_utils.f90 +++ b/build/source/engine/time_utils.f90 @@ -21,7 +21,7 @@ module time_utils_module ! data types -USE nrtype +USE nr_type ! model constants USE multiconst,only:secprday,secprhour,secprmin ! seconds in an (day, hour, minute) diff --git a/build/source/engine/tol4ida.f90 b/build/source/engine/tol4ida.f90 index 4d890894e..e431cc61a 100644 --- a/build/source/engine/tol4ida.f90 +++ b/build/source/engine/tol4ida.f90 @@ -2,7 +2,7 @@ module tol4ida_module !======= Inclusions =========== use, intrinsic :: iso_c_binding -use nrtype +use nr_type use type4ida ! missing values @@ -62,7 +62,7 @@ integer(c_int) function computWeight4ida(sunvec_y, sunvec_ewt, user_data) & use, intrinsic :: iso_c_binding use fsundials_core_mod use fnvector_serial_mod - use nrtype + use nr_type use type4ida !======= Declarations ========= diff --git a/build/source/engine/updateVars.f90 b/build/source/engine/updatDiagn.f90 similarity index 96% rename from build/source/engine/updateVars.f90 rename to build/source/engine/updatDiagn.f90 index 4204d9a86..8128f3e9e 100644 --- a/build/source/engine/updateVars.f90 +++ b/build/source/engine/updatDiagn.f90 @@ -18,10 +18,10 @@ ! You should have received a copy of the GNU General Public License ! along with this program. If not, see . -module updateVars_module +module updatDiagn_module ! data types -USE nrtype +USE nr_type ! missing values USE globalData,only:integerMissing ! missing integer @@ -74,36 +74,36 @@ module updateVars_module 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 +USE updatState_module,only:updatSnow ! update snow states +USE updatState_module,only:updatSoil ! 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:matricHead ! compute the matric head based on volumetric water content -USE soil_utils_module,only:volFracLiq ! compute volumetric fraction of liquid water -USE soil_utils_module,only:crit_soilT ! compute critical temperature below which ice exists -USE soil_utils_module,only:liquidHead ! compute the liquid water matric potential -USE enthalpyTemp_module,only:T2enthTemp_cas ! convert temperature to enthalpy for canopy air space -USE enthalpyTemp_module,only:T2enthTemp_veg ! convert temperature to enthalpy for vegetation -USE enthalpyTemp_module,only:T2enthTemp_snow ! convert temperature to enthalpy for snow -USE enthalpyTemp_module,only:T2enthTemp_soil ! convert temperature to enthalpy for soil +USE snow_utils_module,only:fracliquid ! compute the fraction of liquid water (snow) +USE snow_utils_module,only:dFracLiq_dTk ! differentiate the freezing curve w.r.t. temperature (snow) +USE soil_utils_module,only:dTheta_dTk ! differentiate the freezing curve w.r.t. temperature (soil) +USE soil_utils_module,only:dTheta_dPsi ! derivative in the soil water characteristic (soil) +USE soil_utils_module,only:matricHead ! compute the matric head based on volumetric water content +USE soil_utils_module,only:volFracLiq ! compute volumetric fraction of liquid water +USE soil_utils_module,only:crit_soilT ! compute critical temperature below which ice exists +USE soil_utils_module,only:liquidHead ! compute the liquid water matric potential +USE convertEnthalpyTemp_module,only:T2enthTemp_cas ! convert temperature to enthalpy for canopy air space +USE convertEnthalpyTemp_module,only:T2enthTemp_veg ! convert temperature to enthalpy for vegetation +USE convertEnthalpyTemp_module,only:T2enthTemp_snow ! convert temperature to enthalpy for snow +USE convertEnthalpyTemp_module,only:T2enthTemp_soil ! convert temperature to enthalpy for soil ! IEEE check USE, intrinsic :: ieee_arithmetic ! check values (NaN, etc.) implicit none private -public::updateVars +public::updatDiagn contains ! ********************************************************************************************************** -! public subroutine updateVars: compute diagnostic variables and derivatives +! public subroutine updatDiagn: compute diagnostic variables and derivatives ! ********************************************************************************************************** -subroutine updateVars(& +subroutine updatDiagn(& ! input computeEnthTemp, & ! intent(in): flag if computing temperature compoment of enthalpy use_lookup, & ! intent(in): flag to use the lookup table for soil enthalpy @@ -256,7 +256,7 @@ subroutine updateVars(& dPsiLiq_dTemp => deriv_data%var(iLookDERIV%dPsiLiq_dTemp )%dat ,& ! intent(out): [dp(:)] derivative in the liquid water matric potential w.r.t. temperature mLayerdTheta_dTk => deriv_data%var(iLookDERIV%mLayerdTheta_dTk)%dat ,& ! intent(out): [dp(:)] derivative of volumetric liquid water content w.r.t. temperature dTheta_dTkCanopy => deriv_data%var(iLookDERIV%dTheta_dTkCanopy)%dat(1) ,& ! intent(out): [dp] derivative of volumetric liquid water content w.r.t. temperature - dFracLiqWat_dTk => deriv_data%var(iLookDERIV%dFracLiqWat_dTk)%dat ,& ! intent(out): [dp(:)] derivative in fraction of liquid water w.r.t. temperature + dFracLiqWat_dTk => deriv_data%var(iLookDERIV%dFracLiqWat_dTk)%dat ,& ! intent(out): [dp(:)] derivative in fraction of liquid water w.r.t. temperature dFracLiqVeg_dTkCanopy => deriv_data%var(iLookDERIV%dFracLiqVeg_dTkCanopy)%dat(1),& ! intent(out): [dp ] derivative in fraction of (throughfall + drainage) w.r.t. temperature ! derivatives inside solver for Jacobian only mLayerdTemp_dt => deriv_data%var(iLookDERIV%mLayerdTemp_dt )%dat ,& ! intent(out): [dp(:)] timestep change in layer temperature @@ -269,7 +269,7 @@ subroutine updateVars(& ! -------------------------------------------------------------------------------------------------------------------------------- ! initialize error control - err=0; message='updateVars/' + err=0; message='updatDiagn/' ! 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 @@ -492,7 +492,7 @@ subroutine updateVars(& case(iname_veg) ! compute volumetric fraction of liquid water and ice - call updateSnow(xTemp, & ! intent(in): temperature (K) + call updatSnow(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 (-) @@ -510,7 +510,7 @@ subroutine updateVars(& case(iname_snow) ! compute volumetric fraction of liquid water and ice - call updateSnow(xTemp, & ! intent(in): temperature (K) + call updatSnow(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 (-) @@ -523,7 +523,7 @@ subroutine updateVars(& case(iname_soil) ! compute volumetric fraction of liquid water and ice - call updateSoil(xTemp, & ! intent(in): temperature (K) + call updatSoil(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 (-) @@ -768,7 +768,7 @@ subroutine updateVars(& end associate - end subroutine updateVars + end subroutine updatDiagn ! ********************************************************************************************************** @@ -805,4 +805,4 @@ subroutine xTempSolve(& derivative = heatCap + LH_fus*iden_water*dLiq_dT ! J m-3 K-1 end subroutine xTempSolve -end module updateVars_module +end module updatDiagn_module diff --git a/build/source/engine/updateVarsWithPrime.f90 b/build/source/engine/updatDiagnWithPrime.f90 similarity index 96% rename from build/source/engine/updateVarsWithPrime.f90 rename to build/source/engine/updatDiagnWithPrime.f90 index ae5be7ab0..9a27fbe28 100644 --- a/build/source/engine/updateVarsWithPrime.f90 +++ b/build/source/engine/updatDiagnWithPrime.f90 @@ -18,10 +18,10 @@ ! You should have received a copy of the GNU General Public License ! along with this program. If not, see . -module updateVarsWithPrime_module +module updatDiagnWithPrime_module ! data types -USE nrtype +USE nr_type ! missing values USE globalData,only:integerMissing ! missing integer @@ -74,39 +74,39 @@ module updateVarsWithPrime_module USE var_lookup,only:iLookINDEX ! named variables for structure elements ! provide access to routines to update states -USE updatStateWithPrime_module,only:updateSnowPrime ! update snow states -USE updatStateWithPrime_module,only:updateSoilPrime ! update soil states +USE updatStateWithPrime_module,only:updatSnowPrime ! update snow states +USE updatStateWithPrime_module,only:updatSoilPrime ! update soil states ! provide access to functions for the constitutive functions and derivatives -USE snow_utils_module,only:fracliquid ! compute the fraction of liquid water (snow) -USE snow_utils_module,only:dFracLiq_dTk ! differentiate the freezing curve w.r.t. temperature (snow) -USE soil_utils_module,only:dTheta_dTk ! differentiate the freezing curve w.r.t. temperature (soil) -USE soil_utils_module,only:dTheta_dPsi ! derivative in the soil water characteristic (soil) -USE soil_utils_module,only:dPsi_dTheta ! derivative in the soil water characteristic (soil) -USE soil_utils_module,only:matricHead ! compute the matric head based on volumetric water content -USE soil_utils_module,only:volFracLiq ! compute volumetric fraction of liquid water -USE soil_utils_module,only:crit_soilT ! compute critical temperature below which ice exists -USE soil_utilsAddPrime_module,only:liquidHeadPrime ! compute the liquid water matric potential -USE soil_utilsAddPrime_module,only:d2Theta_dPsi2 ! second derivative in the soil water characteristic (soil) -USE soil_utilsAddPrime_module,only:d2Theta_dTk2 ! second derivative in the freezing curve w.r.t. temperature (soil) -USE enthalpyTemp_module,only:enthalpy2T_cas ! compute canopy air space temperature from enthalpy -USE enthalpyTemp_module,only:enthalpy2T_veg ! compute canopy temperature from enthalpy and water content -USE enthalpyTemp_module,only:enthalpy2T_snow ! compute snow layer temperature from enthalpy and water content -USE enthalpyTemp_module,only:enthalpy2T_soil ! compute soil layer temperature from enthalpy and matric potential +USE snow_utils_module,only:fracliquid ! compute the fraction of liquid water (snow) +USE snow_utils_module,only:dFracLiq_dTk ! differentiate the freezing curve w.r.t. temperature (snow) +USE soil_utils_module,only:dTheta_dTk ! differentiate the freezing curve w.r.t. temperature (soil) +USE soil_utils_module,only:dTheta_dPsi ! derivative in the soil water characteristic (soil) +USE soil_utils_module,only:dPsi_dTheta ! derivative in the soil water characteristic (soil) +USE soil_utils_module,only:matricHead ! compute the matric head based on volumetric water content +USE soil_utils_module,only:volFracLiq ! compute volumetric fraction of liquid water +USE soil_utils_module,only:crit_soilT ! compute critical temperature below which ice exists +USE soil_utilsAddPrime_module,only:liquidHeadPrime ! compute the liquid water matric potential +USE soil_utilsAddPrime_module,only:d2Theta_dPsi2 ! second derivative in the soil water characteristic (soil) +USE soil_utilsAddPrime_module,only:d2Theta_dTk2 ! second derivative in the freezing curve w.r.t. temperature (soil) +USE convertEnthalpyTemp_module,only:enthalpy2T_cas ! compute canopy air space temperature from enthalpy +USE convertEnthalpyTemp_module,only:enthalpy2T_veg ! compute canopy temperature from enthalpy and water content +USE convertEnthalpyTemp_module,only:enthalpy2T_snow ! compute snow layer temperature from enthalpy and water content +USE convertEnthalpyTemp_module,only:enthalpy2T_soil ! compute soil layer temperature from enthalpy and matric potential ! IEEE checks USE, intrinsic :: ieee_arithmetic ! check values (NaN, etc.) implicit none private -public::updateVarsWithPrime +public::updatDiagnWithPrime contains ! ********************************************************************************************************** -! public subroutine updateVarsWithPrime: compute diagnostic variables and derivatives for Prime Jacobian +! public subroutine updatDiagnWithPrime: compute diagnostic variables and derivatives for Prime Jacobian ! ********************************************************************************************************** -subroutine updateVarsWithPrime(& +subroutine updatDiagnWithPrime(& ! input enthalpyStateVec, & ! intent(in): flag if enthalpy is the state variable use_lookup, & ! intent(in): flag to use the lookup table for soil enthalpy @@ -301,7 +301,7 @@ subroutine updateVarsWithPrime(& ! -------------------------------------------------------------------------------------------------------------------------------- ! initialize error control - err=0; message='updateVarsWithPrime/' + err=0; message='updatDiagnWithPrime/' ! 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 @@ -614,7 +614,7 @@ subroutine updateVarsWithPrime(& case(iname_veg) ! compute volumetric fraction of liquid water and ice - call updateSnowPrime(& + call updatSnowPrime(& 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) @@ -639,7 +639,7 @@ subroutine updateVarsWithPrime(& case(iname_snow) ! compute volumetric fraction of liquid water and ice - call updateSnowPrime(& + call updatSnowPrime(& 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) @@ -657,7 +657,7 @@ subroutine updateVarsWithPrime(& case(iname_soil) ! compute volumetric fraction of liquid water and ice - call updateSoilPrime(& + call updatSoilPrime(& xTemp, & ! intent(in): temperature (K) mLayerMatricHeadTrial(ixControlIndex), & ! intent(in): total water matric potential (m) mLayerTempPrime(iLayer), & ! intent(in): temperature time derivative (K/s) @@ -860,7 +860,7 @@ subroutine updateVarsWithPrime(& ! end association to the variables in the data structures end associate -end subroutine updateVarsWithPrime +end subroutine updatDiagnWithPrime ! ********************************************************************************************************** @@ -897,4 +897,4 @@ subroutine xTempSolve(& derivative = heatCap + LH_fus*iden_water*dLiq_dT ! J m-3 K-1 end subroutine xTempSolve -end module updateVarsWithPrime_module +end module updatDiagnWithPrime_module diff --git a/build/source/engine/updatState.f90 b/build/source/engine/updatState.f90 index 31b1bfb58..d6d537bcc 100644 --- a/build/source/engine/updatState.f90 +++ b/build/source/engine/updatState.f90 @@ -19,7 +19,7 @@ ! along with this program. If not, see . module updatState_module -USE nrtype +USE nr_type ! physical constants USE multiconst,only:& Tfreeze, & ! freezing point of pure water (K) @@ -29,15 +29,15 @@ module updatState_module LH_fus ! latent heat of fusion (J kg-1) implicit none private -public::updateSnow -public::updateSoil +public::updatSnow +public::updatSoil contains ! ************************************************************************************************************* -! public subroutine updateSnow: compute phase change impacts on volumetric liquid water and ice (veg or soil) +! public subroutine updatSnow: compute phase change impacts on volumetric liquid water and ice (veg or soil) ! ************************************************************************************************************* -subroutine updateSnow(& +subroutine updatSnow(& ! input mLayerTemp ,& ! intent(in): temperature (K) mLayerTheta ,& ! intent(in): volume fraction of total water (-) @@ -62,18 +62,18 @@ subroutine updateSnow(& integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! initialize error control - err=0; message="updateSnow/" + err=0; message="updatSnow/" ! compute the volumetric fraction of liquid water and ice (-) fLiq = fracliquid(mLayerTemp,snowfrz_scale) mLayerVolFracLiq = fLiq*mLayerTheta mLayerVolFracIce = (1._rkind - fLiq)*mLayerTheta*(iden_water/iden_ice) -end subroutine updateSnow +end subroutine updatSnow ! ************************************************************************************************************* -! public subroutine updateSoil: compute phase change impacts on matric head and volumetric liquid water and ice +! public subroutine updatSoil: compute phase change impacts on matric head and volumetric liquid water and ice ! ************************************************************************************************************* -subroutine updateSoil(& +subroutine updatSoil(& ! input mLayerTemp ,& ! intent(in): temperature vector (K) mLayerMatricHead ,& ! intent(in): matric head (m) @@ -110,7 +110,7 @@ subroutine updateSoil(& real(rkind) :: xConst ! constant in the freezing curve function (m K-1) real(rkind) :: mLayerPsiLiq ! liquid water matric potential (m) ! initialize error control - err=0; message="updateSoil/" + err=0; message="updatSoil/" ! compute fractional **volume** of total water (liquid plus ice) mLayerVolFracWat = volFracLiq(mLayerMatricHead,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) @@ -137,6 +137,6 @@ subroutine updateSoil(& ! - volumetric ice content (-) mLayerVolFracIce = mLayerVolFracWat - mLayerVolFracLiq -end subroutine updateSoil +end subroutine updatSoil end module updatState_module \ No newline at end of file diff --git a/build/source/engine/updatStateWithPrime.f90 b/build/source/engine/updatStateWithPrime.f90 index 68091c4c3..e7258b148 100644 --- a/build/source/engine/updatStateWithPrime.f90 +++ b/build/source/engine/updatStateWithPrime.f90 @@ -1,5 +1,5 @@ module updatStateWithPrime_module -USE nrtype +USE nr_type ! physical constants USE multiconst,only:& Tfreeze, & ! freezing point of pure water (K) @@ -13,15 +13,15 @@ module updatStateWithPrime_module implicit none private -public::updateSnowPrime -public::updateSoilPrime +public::updatSnowPrime +public::updatSoilPrime contains ! ************************************************************************************************************* -! public subroutine updateSnowPrime: compute phase change impacts on volumetric liquid water and ice +! public subroutine updatSnowPrime: compute phase change impacts on volumetric liquid water and ice ! ************************************************************************************************************* -subroutine updateSnowPrime(& +subroutine updatSnowPrime(& ! input mLayerTemp ,& ! intent(in): temperature (K) mLayerTheta ,& ! intent(in): volume fraction of total water (-) @@ -55,7 +55,7 @@ subroutine updateSnowPrime(& integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! initialize error control - err=0; message="updateSnowPrime/" + err=0; message="updatSnowPrime/" ! compute the volumetric fraction of liquid water and ice (-) fLiq = fracliquid(mLayerTemp,snowfrz_scale) @@ -70,12 +70,12 @@ subroutine updateSnowPrime(& mLayerVolFracIcePrime=realMissing end if -end subroutine updateSnowPrime +end subroutine updatSnowPrime ! *********************************************************************************************************************************** -! public subroutine updateSoilPrime: compute phase change impacts on matric head and volumetric liquid water and ice (veg or soil) +! public subroutine updatSoilPrime: compute phase change impacts on matric head and volumetric liquid water and ice (veg or soil) ! *********************************************************************************************************************************** -subroutine updateSoilPrime(& +subroutine updatSoilPrime(& ! input mLayerTemp ,& ! intent(in): temperature (K) mLayerMatricHead ,& ! intent(in): total water matric potential (m) @@ -123,7 +123,7 @@ subroutine updateSoilPrime(& real(rkind) :: xConst ! constant in the freezing curve function (m K-1) real(rkind) :: mLayerPsiLiq ! liquid water matric potential (m) ! initialize error control - err=0; message="updateSoilPrime/" + err=0; message="updatSoilPrime/" ! compute fractional **volume** of total water (liquid plus ice) mLayerVolFracWat = volFracLiq(mLayerMatricHead,vGn_alpha,theta_res,theta_sat,vGn_n,vGn_m) @@ -161,6 +161,6 @@ subroutine updateSoilPrime(& mLayerVolFracIcePrime=realMissing end if -end subroutine updateSoilPrime +end subroutine updatSoilPrime end module updatStateWithPrime_module diff --git a/build/source/engine/varSubstep.f90 b/build/source/engine/varSubstep.f90 index 8127da249..d58374397 100644 --- a/build/source/engine/varSubstep.f90 +++ b/build/source/engine/varSubstep.f90 @@ -21,8 +21,18 @@ module varSubstep_module ! data types -USE nrtype -USE globalData,only: verySmall ! a very small number used as an additive constant to check if substantial difference among real numbers +USE nr_type +USE data_types,only:& + var_i, & ! data vector (i4b) + var_d, & ! data vector (rkind) + var_flagVec, & ! data vector with variable length dimension (i4b) + var_ilength, & ! data vector with variable length dimension (i4b) + var_dlength, & ! data vector with variable length dimension (rkind) + zLookup, & ! lookup tables + model_options, & ! defines the model decisions + in_type_varSubstep, & ! class for intent(in) arguments + io_type_varSubstep, & ! class for intent(inout) arguments + out_type_varSubstep ! class for intent(out) arguments ! access missing values USE globalData,only:integerMissing ! missing integer @@ -41,19 +51,6 @@ module varSubstep_module ! global metadata USE globalData,only:flux_meta ! metadata on the model fluxes -! derived types to define the data structures -USE data_types,only:& - var_i, & ! data vector (i4b) - var_d, & ! data vector (rkind) - var_flagVec, & ! data vector with variable length dimension (i4b) - var_ilength, & ! data vector with variable length dimension (i4b) - var_dlength, & ! data vector with variable length dimension (rkind) - zLookup, & ! lookup tables - model_options, & ! defines the model decisions - in_type_varSubstep, & ! class for intent(in) arguments - io_type_varSubstep, & ! class for intent(inout) arguments - out_type_varSubstep ! class for intent(out) arguments - ! provide access to indices that define elements of the data structures USE var_lookup,only:iLookFLUX ! named variables for structure elements USE var_lookup,only:iLookPROG ! named variables for structure elements @@ -63,9 +60,6 @@ module varSubstep_module USE var_lookup,only:iLookDERIV ! named variables for structure elements USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure -! look up structure for variable types -USE var_lookup,only:iLookVarType - ! constants USE multiconst,only:& Tfreeze, & ! freezing temperature (K) @@ -73,18 +67,19 @@ module varSubstep_module 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) +USE globalData,only:verySmall ! a small number ! look-up values for the numerical method USE mDecisions_module,only: & - homegrown ,& ! homegrown backward Euler solution using concepts from numerical recipes - kinsol ,& ! SUNDIALS backward Euler solution using Kinsol + homegrown, & ! homegrown backward Euler solution using concepts from numerical recipes + kinsol, & ! SUNDIALS backward Euler solution using Kinsol ida ! SUNDIALS solution using IDA ! look-up values for the choice of variable in energy equations (BE residual or IDA state variable) USE mDecisions_module,only: & closedForm, & ! use temperature with closed form heat capacity - enthalpyFormLU, & ! use enthalpy with soil temperature-enthalpy lookup tables - enthalpyForm ! use enthalpy with soil temperature-enthalpy analytical solution + enthalpyForm, & ! use enthalpy with soil temperature-enthalpy lookup tables + enthalpyFormAN ! use enthalpy with soil temperature-enthalpy analytical solution ! safety: set private unless specified otherwise implicit none @@ -154,6 +149,9 @@ subroutine varSubstep(& ! error control character(LEN=256) :: cmessage ! error message of downwind routine ! general local variables + integer(i4b) :: nSnow_in ! number of snow layers for input to subroutines + integer(i4b) :: nSoil_in ! number of soil layers for input to subroutines + integer(i4b) :: nLayers_in ! number of layers for input to subroutines integer(i4b) :: iVar ! index of variables in data structures integer(i4b) :: iSoil ! index of soil layers integer(i4b) :: ixLayer ! index in a given domain @@ -222,43 +220,8 @@ subroutine varSubstep(& fluxCount => io_varSubstep % fluxCount, & ! intent(inout): number of times that the flux is updated (should equal nSubsteps) ixSaturation => io_varSubstep % ixSaturation, & ! intent(inout): index of the lowest saturated layer (NOTE: only computed on the first iteration) ! model decisions - ixNumericalMethod => model_decisions(iLookDECISIONS%num_method)%iDecision ,& ! intent(in): [i4b] choice of numerical solver - ixNrgConserv => model_decisions(iLookDECISIONS%nrgConserv)%iDecision ,& ! intent(in): [i4b] choice of variable in either energy backward Euler residual or IDA state variable - ! number of layers - nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in): [i4b] number of snow layers - nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1) ,& ! intent(in): [i4b] number of soil layers - nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1) ,& ! intent(in): [i4b] total number of layers - nSoilOnlyHyd => indx_data%var(iLookINDEX%nSoilOnlyHyd )%dat(1) ,& ! intent(in): [i4b] number of hydrology variables in the soil domain - mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat ,& ! intent(in): [dp(:)] depth of each layer in the snow-soil sub-domain (m) - ! get indices for balances - ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy air space energy state variable - ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable - ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) - ixTopNrg => indx_data%var(iLookINDEX%ixTopNrg)%dat(1) ,& ! intent(in): [i4b] index of upper-most energy state in the snow+soil subdomain - ixTopHyd => indx_data%var(iLookINDEX%ixTopHyd)%dat(1) ,& ! intent(in): [i4b] index of upper-most hydrology state in the snow+soil subdomain - ixAqWat => indx_data%var(iLookINDEX%ixAqWat)%dat(1) ,& ! intent(in): [i4b] index of water storage in the aquifer - ixSoilOnlyHyd => indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the soil domain - ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the snow+soil domain - ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the snow+soil domain - nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg)%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow+soil domain - nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd)%dat(1) ,& ! intent(in): [i4b] number of hydrology state variables in the snow+soil domain - ! mapping between state vectors and control volumes - ixLayerActive => indx_data%var(iLookINDEX%ixLayerActive)%dat ,& ! intent(in): [i4b(:)] list of indices for all active layers (inactive=integerMissing) - ixMapFull2Subset => indx_data%var(iLookINDEX%ixMapFull2Subset)%dat ,& ! intent(in): [i4b(:)] mapping of full state vector to the state subset - ixControlVolume => indx_data%var(iLookINDEX%ixControlVolume)%dat ,& ! intent(in): [i4b(:)] index of control volume for different domains (veg, snow, soil) - ! model state variables (vegetation canopy) - scalarCanairTemp => prog_data%var(iLookPROG%scalarCanairTemp)%dat(1) ,& ! intent(inout): [dp] temperature of the canopy air space (K) - scalarCanopyTemp => prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1) ,& ! intent(inout): [dp] temperature of the vegetation canopy (K) - scalarCanopyIce => prog_data%var(iLookPROG%scalarCanopyIce)%dat(1) ,& ! intent(inout): [dp] mass of ice on the vegetation canopy (kg m-2) - scalarCanopyLiq => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1) ,& ! intent(inout): [dp] mass of liquid water on the vegetation canopy (kg m-2) - scalarCanopyWat => prog_data%var(iLookPROG%scalarCanopyWat)%dat(1) ,& ! intent(inout): [dp] mass of total water on the vegetation canopy (kg m-2) - ! model state variables (snow and soil domains) - mLayerTemp => prog_data%var(iLookPROG%mLayerTemp)%dat ,& ! intent(inout): [dp(:)] temperature of each snow/soil layer (K) - mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat ,& ! intent(inout): [dp(:)] volumetric fraction of ice (-) - mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat ,& ! intent(inout): [dp(:)] volumetric fraction of liquid water (-) - mLayerVolFracWat => prog_data%var(iLookPROG%mLayerVolFracWat)%dat ,& ! intent(inout): [dp(:)] volumetric fraction of total water (-) - mLayerMatricHead => prog_data%var(iLookPROG%mLayerMatricHead)%dat ,& ! intent(inout): [dp(:)] matric head (m) - mLayerMatricHeadLiq => diag_data%var(iLookDIAG%mLayerMatricHeadLiq)%dat ,& ! intent(inout): [dp(:)] matric potential of liquid water (m) + ixNumericalMethod => model_decisions(iLookDECISIONS%num_method)%iDecision ,& ! intent(in): [i4b] choice of numerical solver + ixNrgConserv => model_decisions(iLookDECISIONS%nrgConserv)%iDecision ,& ! intent(in): [i4b] choice of variable in either energy backward Euler residual or IDA state variable ! model control dtMultiplier => out_varSubstep % dtMultiplier ,& ! intent(out): substep multiplier (-) nSubsteps => out_varSubstep % nSubsteps ,& ! intent(out): number of substeps taken for a given split @@ -270,6 +233,7 @@ subroutine varSubstep(& ) ! end association with variables in the data structures ! ********************************************************************************************************************************************************* + ! initialize flag for the success of the substepping failedMinimumStep=.false. @@ -279,7 +243,7 @@ subroutine varSubstep(& use_lookup = .false. if((ixNrgConserv .ne. closedForm .or. computNrgBalance) .and. ixNumericalMethod .ne. ida) computeEnthTemp = .true. ! use enthTemp to conserve energy or compute energy balance if(ixNrgConserv .ne. closedForm .and. ixNumericalMethod==ida) enthalpyStateVec = .true. ! enthalpy as state variable - if(ixNrgConserv==enthalpyFormLU) use_lookup = .true. ! use lookup tables for soil enthalpy instead of analytical solution + if(ixNrgConserv==enthalpyForm) use_lookup = .true. ! use lookup tables for soil enthalpy instead of analytical solution ! initialize the length of the substep dtSubstep = dtInit @@ -288,21 +252,28 @@ subroutine varSubstep(& ! NOTE: this may just be amplifying the splitting error if maxstep is smaller than the full possible step maxstep = mpar_data%var(iLookPARAM%maxstep)%dat(1) ! maximum time step (s). - ! allocate space for the temporary model flux structure - call allocLocal(flux_meta(:),flux_temp,nSnow,nSoil,err,cmessage) - if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif - - ! initialize the model fluxes (some model fluxes are not computed in the iterations) - do iVar=1,size(flux_data%var) - flux_temp%var(iVar)%dat(:) = flux_data%var(iVar)%dat(:) - end do + ! associate block for indx_data components + ! note: using local associate blocks for indx_data components to permit reallocation in systemSolv + associate(& + nSnow => indx_data%var(iLookINDEX%nSnow)%dat(1) ,& ! intent(in): [i4b] number of snow layers + nSoil => indx_data%var(iLookINDEX%nSoil)%dat(1) & ! intent(in): [i4b] number of soil layers + &) + ! allocate space for the temporary model flux structure + call allocLocal(flux_meta(:),flux_temp,nSnow,nSoil,err,cmessage) + if(err/=0)then; err=20; message=trim(message)//trim(cmessage); return; endif + + ! initialize the model fluxes (some model fluxes are not computed in the iterations) + do iVar=1,size(flux_data%var) + flux_temp%var(iVar)%dat(:) = flux_data%var(iVar)%dat(:) + end do - ! initialize the total energy fluxes (modified in updateProg) - sumCanopyEvaporation = 0._rkind ! canopy evaporation/condensation (kg m-2 s-1) - sumLatHeatCanopyEvap = 0._rkind ! latent heat flux for evaporation from the canopy to the canopy air space (W m-2) - sumSenHeatCanopy = 0._rkind ! sensible heat flux from the canopy to the canopy air space (W m-2) - sumSoilCompress = 0._rkind ! total soil compression - allocate(sumLayerCompress(nSoil)); sumLayerCompress = 0._rkind ! soil compression by layer + ! initialize the total energy fluxes (modified in updatProg) + sumCanopyEvaporation = 0._rkind ! canopy evaporation/condensation (kg m-2 s-1) + sumLatHeatCanopyEvap = 0._rkind ! latent heat flux for evaporation from the canopy to the canopy air space (W m-2) + sumSenHeatCanopy = 0._rkind ! sensible heat flux from the canopy to the canopy air space (W m-2) + sumSoilCompress = 0._rkind ! total soil compression + allocate(sumLayerCompress(nSoil)); sumLayerCompress = 0._rkind ! soil compression by layer + end associate ! initialize balances sumBalance = 0._rkind @@ -314,6 +285,7 @@ subroutine varSubstep(& dtSum = 0._rkind ! keep track of the portion of the time step that is completed nSubsteps = 0 + ! loop through substeps ! NOTE: continuous do statement with exit clause substeps: do @@ -336,6 +308,9 @@ subroutine varSubstep(& err,cmessage) ! intent(out): error control if(err/=0)then; message=trim(message)//trim(cmessage); return; endif ! (check for errors) + ! # of layers to be used as input to systemSolv + ! note: using a separate variable rather than an association to resolve conflicting intent attributes for indx_data + nLayers_in=indx_data%var(iLookINDEX%nLayers)%dat(1) ! ----- ! * iterative solution... ! ----------------------- @@ -345,7 +320,7 @@ subroutine varSubstep(& dtSubstep, & ! intent(in): time step (s) whole_step, & ! intent(in): entire time step (s) nState, & ! intent(in): total number of state variables - nLayers, & ! intent(in): total number of layers + nLayers_in, & ! intent(in): total number of layers firstSubStep, & ! intent(in): flag to denote first sub-step firstFluxCall, & ! intent(inout): flag to indicate if we are processing the first flux call firstSplitOper, & ! intent(in): flag to indicate if we are processing the first flux call in a splitting operation @@ -383,6 +358,7 @@ subroutine varSubstep(& reduceCoupledStep, & ! intent(out): flag to reduce the length of the coupled step tooMuchMelt, & ! intent(out): flag to denote that ice is insufficient to support melt err,cmessage) ! intent(out): error code and error message + if(err/=0)then ! (check for errors, but do not fail yet) message=trim(message)//trim(cmessage) if(err>0) return @@ -446,7 +422,11 @@ subroutine varSubstep(& endif ! update prognostic variables, update balances, and check them for possible step reduction if homegrown or kinsol solver - call updateProg(dtSubstep,nSnow,nSoil,nLayers,untappedMelt,stateVecTrial,stateVecPrime, & ! input: states + ! note: using separate variables rather than associations to resolve conflicting intent attributes for indx_data + nSnow_in = indx_data%var(iLookINDEX%nSnow)%dat(1) ! intent(in): [i4b] number of snow layers + nSoil_in = indx_data%var(iLookINDEX%nSoil)%dat(1) ! intent(in): [i4b] number of soil layers + nLayers_in = indx_data%var(iLookINDEX%nLayers)%dat(1) ! intent(in): [i4b] total number of layers + call updatProg(dtSubstep,nSnow_in,nSoil_in,nLayers_in,untappedMelt,stateVecTrial,stateVecPrime, & ! input: states doAdjustTemp,computeVegFlux,computMassBalance,computNrgBalance,computeEnthTemp,enthalpyStateVec,use_lookup,& ! input: model control model_decisions,lookup_data,mpar_data,indx_data,flux_temp,prog_data,diag_data,deriv_data, & ! input-output: data structures fluxVec,resVec,balance,waterBalanceError,nrgFluxModified,err,message) ! input-output: balances, flags, and error control @@ -483,77 +463,100 @@ subroutine varSubstep(& endif endif ! if errors in prognostic update - - ! add balances to the total balances - if(ixCasNrg/=integerMissing) sumBalance(ixCasNrg) = sumBalance(ixCasNrg) + dtSubstep*balance(ixCasNrg) - if(ixVegNrg/=integerMissing) sumBalance(ixVegNrg) = sumBalance(ixVegNrg) + dtSubstep*balance(ixVegNrg) - if(nSnowSoilNrg>0) then - do concurrent (ixLayer=1:nLayers,ixSnowSoilNrg(ixLayer)/=integerMissing) - if(ixSnowSoilNrg(ixLayer)/=integerMissing) sumBalance(ixSnowSoilNrg(ixLayer)) = sumBalance(ixSnowSoilNrg(ixLayer)) + dtSubstep*balance(ixSnowSoilNrg(ixLayer)) - end do - endif - if(ixVegHyd/=integerMissing) sumBalance(ixVegHyd) = sumBalance(ixVegHyd) + dtSubstep*balance(ixVegHyd) - if(nSnowSoilHyd>0) then - do concurrent (ixLayer=1:nLayers,ixSnowSoilHyd(ixLayer)/=integerMissing) - if(ixSnowSoilHyd(ixLayer)/=integerMissing) sumBalance(ixSnowSoilHyd(ixLayer)) = sumBalance(ixSnowSoilHyd(ixLayer)) + dtSubstep*balance(ixSnowSoilHyd(ixLayer)) - end do - endif - if(ixAqWat/=integerMissing) sumBalance(ixAqWat) = sumBalance(ixAqWat) + dtSubstep*balance(ixAqWat) - ! get the total energy fluxes (modified in updateProg), have to do differently - if(nrgFluxModified .or. ixVegNrg/=integerMissing)then - sumCanopyEvaporation = sumCanopyEvaporation + dtSubstep*flux_temp%var(iLookFLUX%scalarCanopyEvaporation)%dat(1) ! canopy evaporation/condensation (kg m-2 s-1) - sumLatHeatCanopyEvap = sumLatHeatCanopyEvap + dtSubstep*flux_temp%var(iLookFLUX%scalarLatHeatCanopyEvap)%dat(1) ! latent heat flux for evaporation from the canopy to the canopy air space (W m-2) - sumSenHeatCanopy = sumSenHeatCanopy + dtSubstep*flux_temp%var(iLookFLUX%scalarSenHeatCanopy)%dat(1) ! sensible heat flux from the canopy to the canopy air space (W m-2) - else - sumCanopyEvaporation = sumCanopyEvaporation + dtSubstep*flux_data%var(iLookFLUX%scalarCanopyEvaporation)%dat(1) ! canopy evaporation/condensation (kg m-2 s-1) - sumLatHeatCanopyEvap = sumLatHeatCanopyEvap + dtSubstep*flux_data%var(iLookFLUX%scalarLatHeatCanopyEvap)%dat(1) ! latent heat flux for evaporation from the canopy to the canopy air space (W m-2) - sumSenHeatCanopy = sumSenHeatCanopy + dtSubstep*flux_data%var(iLookFLUX%scalarSenHeatCanopy)%dat(1) ! sensible heat flux from the canopy to the canopy air space (W m-2) - endif ! if energy fluxes were modified - - ! get the total soil compression - if (count(ixSoilOnlyHyd/=integerMissing)>0) then - ! scalar compression - if(.not.scalarSolution .or. iStateSplit==nSoil)& - sumSoilCompress = sumSoilCompress + dtSubstep*diag_data%var(iLookDIAG%scalarSoilCompress)%dat(1) ! total soil compression - ! vector compression - do iSoil=1,nSoil - if(ixSoilOnlyHyd(iSoil)/=integerMissing)& - sumLayerCompress(iSoil) = sumLayerCompress(iSoil) + dtSubstep*diag_data%var(iLookDIAG%mLayerCompress)%dat(iSoil) ! soil compression in layers - end do - endif + ! associate block for indx_data components + ! note: using local associate blocks for indx_data components to permit reallocation in systemSolv + associate(& + 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 + ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy air space energy state variable + ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable + ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) + ixAqWat => indx_data%var(iLookINDEX%ixAqWat)%dat(1) ,& ! intent(in): [i4b] index of water storage in the aquifer + ixSoilOnlyHyd => indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the soil domain + ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the snow+soil domain + ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the snow+soil domain + nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg)%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow+soil domain + nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd)%dat(1) & ! intent(in): [i4b] number of hydrology state variables in the snow+soil domain + &) + ! add balances to the total balances + if(ixCasNrg/=integerMissing) sumBalance(ixCasNrg) = sumBalance(ixCasNrg) + dtSubstep*balance(ixCasNrg) + if(ixVegNrg/=integerMissing) sumBalance(ixVegNrg) = sumBalance(ixVegNrg) + dtSubstep*balance(ixVegNrg) + if(nSnowSoilNrg>0) then + do concurrent (ixLayer=1:nLayers,ixSnowSoilNrg(ixLayer)/=integerMissing) + if(ixSnowSoilNrg(ixLayer)/=integerMissing) sumBalance(ixSnowSoilNrg(ixLayer)) = sumBalance(ixSnowSoilNrg(ixLayer)) + dtSubstep*balance(ixSnowSoilNrg(ixLayer)) + end do + endif + if(ixVegHyd/=integerMissing) sumBalance(ixVegHyd) = sumBalance(ixVegHyd) + dtSubstep*balance(ixVegHyd) + if(nSnowSoilHyd>0) then + do concurrent (ixLayer=1:nLayers,ixSnowSoilHyd(ixLayer)/=integerMissing) + if(ixSnowSoilHyd(ixLayer)/=integerMissing) sumBalance(ixSnowSoilHyd(ixLayer)) = sumBalance(ixSnowSoilHyd(ixLayer)) + dtSubstep*balance(ixSnowSoilHyd(ixLayer)) + end do + endif + if(ixAqWat/=integerMissing) sumBalance(ixAqWat) = sumBalance(ixAqWat) + dtSubstep*balance(ixAqWat) + + ! get the total energy fluxes (modified in updatProg), have to do differently + if(nrgFluxModified .or. ixVegNrg/=integerMissing)then + sumCanopyEvaporation = sumCanopyEvaporation + dtSubstep*flux_temp%var(iLookFLUX%scalarCanopyEvaporation)%dat(1) ! canopy evaporation/condensation (kg m-2 s-1) + sumLatHeatCanopyEvap = sumLatHeatCanopyEvap + dtSubstep*flux_temp%var(iLookFLUX%scalarLatHeatCanopyEvap)%dat(1) ! latent heat flux for evaporation from the canopy to the canopy air space (W m-2) + sumSenHeatCanopy = sumSenHeatCanopy + dtSubstep*flux_temp%var(iLookFLUX%scalarSenHeatCanopy)%dat(1) ! sensible heat flux from the canopy to the canopy air space (W m-2) + else + sumCanopyEvaporation = sumCanopyEvaporation + dtSubstep*flux_data%var(iLookFLUX%scalarCanopyEvaporation)%dat(1) ! canopy evaporation/condensation (kg m-2 s-1) + sumLatHeatCanopyEvap = sumLatHeatCanopyEvap + dtSubstep*flux_data%var(iLookFLUX%scalarLatHeatCanopyEvap)%dat(1) ! latent heat flux for evaporation from the canopy to the canopy air space (W m-2) + sumSenHeatCanopy = sumSenHeatCanopy + dtSubstep*flux_data%var(iLookFLUX%scalarSenHeatCanopy)%dat(1) ! sensible heat flux from the canopy to the canopy air space (W m-2) + endif ! if energy fluxes were modified + + ! get the total soil compression + if (count(ixSoilOnlyHyd/=integerMissing)>0) then + ! scalar compression + if(.not.scalarSolution .or. iStateSplit==nSoil)& + sumSoilCompress = sumSoilCompress + dtSubstep*diag_data%var(iLookDIAG%scalarSoilCompress)%dat(1) ! total soil compression + ! vector compression + do iSoil=1,nSoil + if(ixSoilOnlyHyd(iSoil)/=integerMissing)& + sumLayerCompress(iSoil) = sumLayerCompress(iSoil) + dtSubstep*diag_data%var(iLookDIAG%mLayerCompress)%dat(iSoil) ! soil compression in layers + end do + end if + end associate ! print progress if(globalPrintFlag)& write(*,'(a,1x,3(f13.2,1x))') 'updating: dtSubstep, dtSum, dt = ', dtSubstep, dtSum, dt - ! increment fluxes + ! increment fluxes dt_wght = dtSubstep/dt ! define weight applied to each sub-step do iVar=1,size(flux_meta) if(count(fluxMask%var(iVar)%dat)>0) then - ! ** no domain splitting - if(count(ixLayerActive/=integerMissing)==nLayers)then - flux_mean%var(iVar)%dat(:) = flux_mean%var(iVar)%dat(:) + flux_temp%var(iVar)%dat(:)*dt_wght - fluxCount%var(iVar)%dat(:) = fluxCount%var(iVar)%dat(:) + 1 - - ! ** domain splitting - else - ixMin=lbound(flux_data%var(iVar)%dat) - ixMax=ubound(flux_data%var(iVar)%dat) - do ixLayer=ixMin(1),ixMax(1) - if(fluxMask%var(iVar)%dat(ixLayer)) then - ! special case of the transpiration sink from soil layers: only computed for the top soil layer - if(iVar==iLookFLUX%mLayerTranspire)then - if(ixLayer==1) flux_mean%var(iVar)%dat(:) = flux_mean%var(iVar)%dat(:) + flux_temp%var(iVar)%dat(:)*dt_wght - ! standard case - else - flux_mean%var(iVar)%dat(ixLayer) = flux_mean%var(iVar)%dat(ixLayer) + flux_temp%var(iVar)%dat(ixLayer)*dt_wght + ! associate block for indx_data components + ! note: using local associate blocks for indx_data components to permit reallocation in systemSolv + associate(& + nLayers => indx_data%var(iLookINDEX%nLayers)%dat(1) ,& ! intent(in): [i4b] total number of layers + ixLayerActive => indx_data%var(iLookINDEX%ixLayerActive)%dat & ! intent(in): [i4b(:)] list of indices for all active layers (inactive=integerMissing) + &) + ! ** no domain splitting + if(count(ixLayerActive/=integerMissing)==nLayers)then + flux_mean%var(iVar)%dat(:) = flux_mean%var(iVar)%dat(:) + flux_temp%var(iVar)%dat(:)*dt_wght + fluxCount%var(iVar)%dat(:) = fluxCount%var(iVar)%dat(:) + 1 + + ! ** domain splitting + else + ixMin=lbound(flux_data%var(iVar)%dat) + ixMax=ubound(flux_data%var(iVar)%dat) + do ixLayer=ixMin(1),ixMax(1) + if(fluxMask%var(iVar)%dat(ixLayer)) then + ! special case of the transpiration sink from soil layers: only computed for the top soil layer + if(iVar==iLookFLUX%mLayerTranspire)then + if(ixLayer==1) flux_mean%var(iVar)%dat(:) = flux_mean%var(iVar)%dat(:) + flux_temp%var(iVar)%dat(:)*dt_wght + ! standard case + else + flux_mean%var(iVar)%dat(ixLayer) = flux_mean%var(iVar)%dat(ixLayer) + flux_temp%var(iVar)%dat(ixLayer)*dt_wght + endif + fluxCount%var(iVar)%dat(ixLayer) = fluxCount%var(iVar)%dat(ixLayer) + 1 endif - fluxCount%var(iVar)%dat(ixLayer) = fluxCount%var(iVar)%dat(ixLayer) + 1 - endif - end do - endif ! (domain splitting) + end do + endif ! (domain splitting) + end associate endif ! (if the flux is desired) end do ! (loop through fluxes) @@ -586,53 +589,69 @@ subroutine varSubstep(& flux_data%var(iLookFLUX%scalarLatHeatCanopyEvap)%dat(1) = sumLatHeatCanopyEvap /dt ! latent heat flux for evaporation from the canopy to the canopy air space (W m-2) flux_data%var(iLookFLUX%scalarSenHeatCanopy)%dat(1) = sumSenHeatCanopy /dt ! sensible heat flux from the canopy to the canopy air space (W m-2) - ! save the soil compression diagnostics as averages - diag_data%var(iLookDIAG%scalarSoilCompress)%dat(1) = sumSoilCompress/dt - do iSoil=1,nSoil - if(ixSoilOnlyHyd(iSoil)/=integerMissing)& - diag_data%var(iLookDIAG%mLayerCompress)%dat(iSoil) = sumLayerCompress(iSoil)/dt - end do - deallocate(sumLayerCompress) - - ! save the balance diagnostics as averages - if(ixCasNrg/=integerMissing) diag_data%var(iLookDIAG%balanceCasNrg)%dat(1) = sumBalance(ixCasNrg)/dt - if(ixVegNrg/=integerMissing) diag_data%var(iLookDIAG%balanceVegNrg)%dat(1) = sumBalance(ixVegNrg)/dt - if(nSnowSoilNrg>0) then - do concurrent (ixLayer=1:nLayers,ixSnowSoilNrg(ixLayer)/=integerMissing) - diag_data%var(iLookDIAG%balanceLayerNrg)%dat(ixLayer) = sumBalance(ixSnowSoilNrg(ixLayer))/dt + ! associate block for indx_data components + ! note: using local associate blocks for indx_data components to permit reallocation in systemSolv + associate(& + 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 + ixCasNrg => indx_data%var(iLookINDEX%ixCasNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy air space energy state variable + ixVegNrg => indx_data%var(iLookINDEX%ixVegNrg)%dat(1) ,& ! intent(in): [i4b] index of canopy energy state variable + ixVegHyd => indx_data%var(iLookINDEX%ixVegHyd)%dat(1) ,& ! intent(in): [i4b] index of canopy hydrology state variable (mass) + ixAqWat => indx_data%var(iLookINDEX%ixAqWat)%dat(1) ,& ! intent(in): [i4b] index of water storage in the aquifer + ixSoilOnlyHyd => indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the soil domain + ixSnowSoilHyd => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat ,& ! intent(in): [i4b(:)] index in the state subset for hydrology state variables in the snow+soil domain + ixSnowSoilNrg => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat ,& ! intent(in): [i4b(:)] index in the state subset for energy state variables in the snow+soil domain + nSnowSoilNrg => indx_data%var(iLookINDEX%nSnowSoilNrg)%dat(1) ,& ! intent(in): [i4b] number of energy state variables in the snow+soil domain + nSnowSoilHyd => indx_data%var(iLookINDEX%nSnowSoilHyd)%dat(1) & ! intent(in): [i4b] number of hydrology state variables in the snow+soil domain + &) + ! save the soil compression diagnostics as averages + diag_data%var(iLookDIAG%scalarSoilCompress)%dat(1) = sumSoilCompress/dt + do iSoil=1,nSoil + if(ixSoilOnlyHyd(iSoil)/=integerMissing)& + diag_data%var(iLookDIAG%mLayerCompress)%dat(iSoil) = sumLayerCompress(iSoil)/dt end do - endif - if(ixVegHyd/=integerMissing) diag_data%var(iLookDIAG%balanceVegMass)%dat(1) = sumBalance(ixVegHyd)/dt - if(nSnowSoilHyd>0) then - do concurrent (ixLayer=1:nLayers,ixSnowSoilHyd(ixLayer)/=integerMissing) - diag_data%var(iLookDIAG%balanceLayerMass)%dat(ixLayer) = sumBalance(ixSnowSoilHyd(ixLayer))/dt - end do - endif - if(ixAqWat/=integerMissing) diag_data%var(iLookDIAG%balanceAqMass)%dat(1) = sumBalance(ixAqWat)/dt + deallocate(sumLayerCompress) + + ! save the balance diagnostics as averages + if(ixCasNrg/=integerMissing) diag_data%var(iLookDIAG%balanceCasNrg)%dat(1) = sumBalance(ixCasNrg)/dt + if(ixVegNrg/=integerMissing) diag_data%var(iLookDIAG%balanceVegNrg)%dat(1) = sumBalance(ixVegNrg)/dt + if(nSnowSoilNrg>0) then + do concurrent (ixLayer=1:nLayers,ixSnowSoilNrg(ixLayer)/=integerMissing) + diag_data%var(iLookDIAG%balanceLayerNrg)%dat(ixLayer) = sumBalance(ixSnowSoilNrg(ixLayer))/dt + end do + endif + if(ixVegHyd/=integerMissing) diag_data%var(iLookDIAG%balanceVegMass)%dat(1) = sumBalance(ixVegHyd)/dt + if(nSnowSoilHyd>0) then + do concurrent (ixLayer=1:nLayers,ixSnowSoilHyd(ixLayer)/=integerMissing) + diag_data%var(iLookDIAG%balanceLayerMass)%dat(ixLayer) = sumBalance(ixSnowSoilHyd(ixLayer))/dt + end do + endif + if(ixAqWat/=integerMissing) diag_data%var(iLookDIAG%balanceAqMass)%dat(1) = sumBalance(ixAqWat)/dt + end associate ! update error codes if (failedMinimumStep) then err=-20 ! negative = recoverable error message=trim(message)//'failed minimum step' end if - ! end associate statements - end associate globalVars + + end associate globalVars ! end global associate block end subroutine varSubstep ! ********************************************************************************************************** -! private subroutine updateProg: update prognostic variables +! private subroutine updatProg: update prognostic variables ! ********************************************************************************************************** -subroutine updateProg(dt,nSnow,nSoil,nLayers,untappedMelt,stateVecTrial,stateVecPrime, & ! input: states +subroutine updatProg(dt,nSnow,nSoil,nLayers,untappedMelt,stateVecTrial,stateVecPrime, & ! input: states doAdjustTemp,computeVegFlux,computMassBalance,computNrgBalance,computeEnthTemp,enthalpyStateVec,use_lookup,& ! input: model control model_decisions,lookup_data,mpar_data,indx_data,flux_data,prog_data,diag_data,deriv_data, & ! input-output: data structures fluxVec,resVec,balance,waterBalanceError,nrgFluxModified,err,message) ! input-output: balances, flags, and error control USE getVectorz_module,only:varExtract ! extract variables from the state vector #ifdef SUNDIALS_ACTIVE - USE updateVarsWithPrime_module,only:updateVarsWithPrime ! update prognostic variables + USE updatDiagnWithPrime_module,only:updatDiagnWithPrime ! update diagnostic variables #endif - USE updateVars_module,only:updateVars ! update prognostic variables - USE enthalpyTemp_module,only:enthTemp_or_enthalpy ! add phase change terms to delta temperature component of enthalpy + USE updatDiagn_module,only:updatDiagn ! update diagnostic variables + USE convertEnthalpyTemp_module,only:enthTemp_or_enthalpy ! add phase change terms to delta temperature component of enthalpy implicit none ! model control real(rkind) ,intent(in) :: dt ! time step (s) @@ -798,7 +817,7 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,untappedMelt,stateVecTrial,stateVec ) ! associating flux variables in the data structure ! ------------------------------------------------------------------------------------------------------------------- ! initialize error control - err=0; message='updateProg/' + err=0; message='updatProg/' ! initialize flags for water balance error and energy flux modification waterBalanceError=.false. @@ -932,7 +951,7 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,untappedMelt,stateVecTrial,stateVec endif !(choice of how conservation of energy is implemented) ! update diagnostic variables - call updateVarsWithPrime(& + call updatDiagnWithPrime(& ! input enthalpyStateVec, & ! intent(in): flag if enthalpy is used as state variable use_lookup, & ! intent(in): flag to use the lookup table for soil enthalpy @@ -976,7 +995,7 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,untappedMelt,stateVecTrial,stateVec #endif case(kinsol, homegrown) ! update diagnostic variables - call updateVars(& + call updatDiagn(& ! input computeEnthTemp, & ! intent(in): flag if computing temperature component of enthalpy use_lookup, & ! intent(in): flag to use the lookup table for soil enthalpy @@ -1369,6 +1388,6 @@ subroutine updateProg(dt,nSnow,nSoil,nLayers,untappedMelt,stateVecTrial,stateVec ! end associations to info in the data structures end associate -end subroutine updateProg +end subroutine updatProg end module varSubstep_module diff --git a/build/source/engine/var_derive.f90 b/build/source/engine/var_derive.f90 index e3808d992..84afb7bdb 100644 --- a/build/source/engine/var_derive.f90 +++ b/build/source/engine/var_derive.f90 @@ -21,7 +21,7 @@ module var_derive_module ! data types -USE nrtype +USE nr_type ! derived types to define the data structures USE data_types,only:var_ilength ! x%var(:)%dat (i4b) diff --git a/build/source/engine/vegLiqFlux.f90 b/build/source/engine/vegLiqFlux.f90 index a8d58dbf5..c3a0a6aea 100644 --- a/build/source/engine/vegLiqFlux.f90 +++ b/build/source/engine/vegLiqFlux.f90 @@ -21,7 +21,7 @@ module vegLiqFlux_module ! data types -USE nrtype +USE nr_type ! data types USE data_types,only:var_d ! x%var(:) (rkind) diff --git a/build/source/engine/vegNrgFlux.f90 b/build/source/engine/vegNrgFlux.f90 index c0b891c52..2f6ae67b3 100644 --- a/build/source/engine/vegNrgFlux.f90 +++ b/build/source/engine/vegNrgFlux.f90 @@ -21,15 +21,7 @@ module vegNrgFlux_module ! data types -USE nrtype - -! global variables -USE globalData,only:& - verySmall, & ! a very small number used as an additive constant to check if substantial difference among real numbers - realMissing, & ! missing value for real numbers - minExpLogHgtFac ! factor for minimum height of transition from the exponential to the logarithmic wind profile - -! derived types to define the data structures +USE nr_type USE data_types,only:& var_i, & ! data vector (i4b) var_d, & ! data vector (rkind) @@ -39,6 +31,9 @@ module vegNrgFlux_module in_type_vegNrgFlux, & ! intent(in) arguments for vegNrgFlux call out_type_vegNrgFlux ! intent(out) arguments for vegNrgFlux call +! access missing values +USE globalData,only:realMissing ! missing real number + ! indices that define elements of the data structures USE var_lookup,only:iLookTYPE ! named variables for structure elements USE var_lookup,only:iLookPROG ! named variables for structure elements @@ -52,18 +47,20 @@ module vegNrgFlux_module ! constants USE multiconst,only:& - gravity, & ! acceleration of gravity (m s-2) - vkc, & ! von Karman's constant (-) - w_ratio, & ! molecular ratio water to dry air (-) - R_wv, & ! gas constant for water vapor (Pa K-1 m3 kg-1; J kg-1 K-1) - Cp_air, & ! specific heat of air (J kg-1 K-1) - Cp_ice, & ! specific heat of ice (J kg-1 K-1) - Cp_water, & ! specific heat of liquid water (J kg-1 K-1) - Tfreeze, & ! temperature at freezing (K) - LH_vap, & ! latent heat of vaporization (J kg-1) - LH_sub, & ! latent heat of sublimation (J kg-1) - sb, & ! Stefan Boltzman constant (W m-2 K-4) - iden_air ! intrinsic density of air (kg m-3) + gravity, & ! acceleration of gravity (m s-2) + vkc, & ! von Karman's constant (-) + w_ratio, & ! molecular ratio water to dry air (-) + R_wv, & ! gas constant for water vapor (Pa K-1 m3 kg-1; J kg-1 K-1) + Cp_air, & ! specific heat of air (J kg-1 K-1) + Cp_ice, & ! specific heat of ice (J kg-1 K-1) + Cp_water, & ! specific heat of liquid water (J kg-1 K-1) + Tfreeze, & ! temperature at freezing (K) + LH_vap, & ! latent heat of vaporization (J kg-1) + LH_sub, & ! latent heat of sublimation (J kg-1) + sb, & ! Stefan Boltzman constant (W m-2 K-4) + iden_air ! intrinsic density of air (kg m-3) +USE globalData,only:verySmall ! a small number +USE globalData,only: minExpLogHgtFac ! factor for minimum height of transition from the exponential to the logarithmic wind profile ! look-up values for method used to compute derivative USE mDecisions_module,only: & @@ -102,16 +99,8 @@ module vegNrgFlux_module private public :: vegNrgFlux public :: wettedFrac -! named variables -integer(i4b),parameter :: ist = 1 ! Surface type: IST=1 => soil; IST=2 => lake -integer(i4b),parameter :: isc = 4 ! Soil color type -integer(i4b),parameter :: ice = 0 ! Surface type: ICE=0 => soil; ICE=1 => sea-ice -! spatial indices -integer(i4b),parameter :: iLoc = 1 ! i-location -integer(i4b),parameter :: jLoc = 1 ! j-location ! algorithmic parameters real(rkind),parameter :: mpe=1.e-6_rkind ! prevents overflow error if division by zero, from NOAH mpe value -real(rkind),parameter :: dx=1.e-11_rkind ! finite difference increment contains @@ -137,8 +126,8 @@ subroutine vegNrgFlux(& ! 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) + USE convert_funcs_module,only:satVapPress ! function to compute the saturated vapor pressure (Pa) + USE convert_funcs_module,only:getLatentHeatValue ! function to identify latent heat of vaporization/sublimation (J kg-1) ! stomatal resistance USE stomResist_module,only:stomResist ! subroutine to calculate stomatal resistance ! phase changes @@ -516,8 +505,6 @@ subroutine vegNrgFlux(& groundNetFlux = -diag_data%var(iLookDIAG%iLayerThermalC)%dat(0)*(groundTempTrial - upperBoundTemp)/(prog_data%var(iLookPROG%mLayerDepth)%dat(1)*0.5_rkind) elseif (ix_bcUpprTdyn == zeroFlux) then groundNetFlux = 0._rkind - else - err=20; message=trim(message)//'unable to identify upper boundary condition for thermodynamics: expect the case to be prescribedTemp or zeroFlux'; return end if ! ***** @@ -552,16 +539,24 @@ subroutine vegNrgFlux(& ! NOTE: variables are constant over the substep, to simplify relating energy and mass fluxes if (firstFluxCall) then scalarLatHeatSubVapCanopy = getLatentHeatValue(canopyTempTrial) - if (nSnow > 0) then ! case when there is snow on the ground (EXCLUDE "snow without a layer" -- in this case, evaporate from the soil) + if (nSnow>0) then ! case when there is snow on the ground (EXCLUDE "snow without a layer" -- in this case, evaporate from the soil) if (groundTempTrial > Tfreeze) then; err=20; message=trim(message)//'do not expect ground temperature > 0 when snow is on the ground'; return; end if scalarLatHeatSubVapGround = LH_sub ! sublimation from snow else ! case when the ground is less than a layer of snow (e.g., bare soil or snow without a layer) - scalarLatHeatSubVapGround = LH_vap ! evaporation of water in the soil pores: this occurs even if frozen because of super-cooled water - end if ! (there is snow enough for a layer on the ground) + if (nSoil>0)then + scalarLatHeatSubVapGround = LH_vap ! evaporation of water in the soil pores: this occurs even if frozen because of super-cooled water + else + err=20; message=trim(message)//'unable to identify snow-free ground surface'; return + end if + end if ! end if there is snow on the ground end if ! (first flux call) - ! compute the roughness length of the ground (ground below the canopy or non-vegetated surface) - z0Ground = z0Soil*(1._rkind - scalarGroundSnowFraction) + z0Snow*scalarGroundSnowFraction ! roughness length (m) + ! compute the roughness length (m) of the ground (ground below the canopy or non-vegetated surface) + if (nSoil>0)then + z0Ground = z0Soil*(1._rkind - scalarGroundSnowFraction) + z0Snow*scalarGroundSnowFraction + else + err=20; message=trim(message)//'unable to identify ground surface under potential snow'; return + end if ! compute the total vegetation area index (leaf plus stem) VAI = scalarLAI + scalarSAI ! vegetation area index @@ -586,7 +581,9 @@ subroutine vegNrgFlux(& if (.not.computeVegFlux) scalarCanopyEmissivity=0._rkind ! compute emissivity of the ground surface (-) - groundEmissivity = scalarGroundSnowFraction*snowEmissivity + (1._rkind - scalarGroundSnowFraction)*soilEmissivity ! emissivity of the ground surface (-) + if (nSoil>0)then + groundEmissivity = scalarGroundSnowFraction*snowEmissivity + (1._rkind - scalarGroundSnowFraction)*soilEmissivity + end if ! compute the fraction of canopy that is wet ! NOTE: we either sublimate or evaporate over the entire substep @@ -691,31 +688,36 @@ subroutine vegNrgFlux(& ! (2) derivative calculations are rather complex (iterations within the Ball-Berry routine); and ! (3) stomatal resistance does not change rapidly if (firstFluxCall) then - ! compute soil moisture factor controlling stomatal resistance - call soilResist(& - ! input (model decisions) - ix_soilStress, & ! intent(in): choice of function for the soil moisture control on stomatal resistance - ix_groundwatr, & ! intent(in): groundwater parameterization - ! input (state variables) - mLayerMatricHead(1:nSoil), & ! intent(in): matric head in each soil layer (m) - mLayerVolFracLiq(nSnow+1:nLayers), & ! intent(in): volumetric fraction of liquid water in each soil layer (-) - scalarAquiferStorage, & ! intent(in): aquifer storage (m) - ! input (diagnostic variables) - mLayerRootDensity(1:nSoil), & ! intent(in): root density in each layer (-) - scalarAquiferRootFrac, & ! intent(in): fraction of roots below the lowest soil layer (-) - ! input (parameters) - plantWiltPsi, & ! intent(in): matric head at wilting point (m) - soilStressParam, & ! intent(in): parameter in the exponential soil stress function (-) - critSoilWilting, & ! intent(in): critical vol. liq. water content when plants are wilting (-) - critSoilTranspire, & ! intent(in): critical vol. liq. water content when transpiration is limited (-) - critAquiferTranspire, & ! intent(in): critical aquifer storage value when transpiration is limited (m) - ! output - scalarTranspireLim, & ! intent(out): weighted average of the transpiration limiting factor (-) - mLayerTranspireLim(1:nSoil), & ! intent(out): transpiration limiting factor in each layer (-) - scalarTranspireLimAqfr, & ! intent(out): transpiration limiting factor for the aquifer (-) - err,cmessage ) ! intent(out): error control - if (err/=0) then; message=trim(message)//trim(cmessage); return; end if - + if (nSoil>0) then ! need values for aquifer + ! compute soil moisture factor controlling stomatal resistance, and for transpiration limiting factor in aquifer and soil + call soilResist(& + ! input (model decisions) + ix_soilStress, & ! intent(in): choice of function for the soil moisture control on stomatal resistance + ix_groundwatr, & ! intent(in): groundwater parameterization + ! input (state variables) + mLayerMatricHead(1:nSoil), & ! intent(in): matric head in each soil layer (m) + mLayerVolFracLiq(nSnow+1:nLayers), & ! intent(in): volumetric fraction of liquid water in each soil layer (-) + scalarAquiferStorage, & ! intent(in): aquifer storage (m) + ! input (diagnostic variables) + mLayerRootDensity(1:nSoil), & ! intent(in): root density in each layer (-) + scalarAquiferRootFrac, & ! intent(in): fraction of roots below the lowest soil layer (-) + ! input (parameters) + plantWiltPsi, & ! intent(in): matric head at wilting point (m) + soilStressParam, & ! intent(in): parameter in the exponential soil stress function (-) + critSoilWilting, & ! intent(in): critical vol. liq. water content when plants are wilting (-) + critSoilTranspire, & ! intent(in): critical vol. liq. water content when transpiration is limited (-) + critAquiferTranspire, & ! intent(in): critical aquifer storage value when transpiration is limited (m) + ! output + scalarTranspireLim, & ! intent(out): weighted average of the transpiration limiting factor (-) + mLayerTranspireLim(1:nSoil), & ! intent(out): transpiration limiting factor in each layer (-) + scalarTranspireLimAqfr, & ! intent(out): transpiration limiting factor for the aquifer (-) + err,cmessage ) ! intent(out): error control + if (err/=0) then; message=trim(message)//trim(cmessage); return; end if + else + ! set transpiration limiting factor in the case of aquifer with no soil + scalarTranspireLim = 1._rkind ! no soil + scalarTranspireLimAqfr = 0._rkind ! no roots in aquifer + endif ! compute the saturation vapor pressure for vegetation temperature TV_celcius = canopyTempTrial - Tfreeze call satVapPress(TV_celcius, scalarSatVP_CanopyTemp, dSVPCanopy_dCanopyTemp) @@ -791,11 +793,14 @@ subroutine vegNrgFlux(& ! compute the relative humidity in the top soil layer and the resistance at the ground surface ! NOTE: computations are based on start-of-step values, so only compute for the first flux call if (firstFluxCall) then - ! soil water evaporation factor [0-1] - soilEvapFactor = mLayerVolFracLiq(nSnow+1)/(theta_sat - theta_res) - ! resistance from the soil [s m-1] - scalarSoilResistance = scalarGroundSnowFraction*1._rkind + (1._rkind - scalarGroundSnowFraction)*EXP(8.25_rkind - 4.225_rkind*soilEvapFactor) ! Sellers (1992) + if (nSoil>0)then + ! soil water evaporation factor [0-1] + soilEvapFactor = mLayerVolFracLiq(nSnow+1)/(theta_sat - theta_res) + ! resistance from the soil [s m-1] + scalarSoilResistance = scalarGroundSnowFraction*1._rkind + (1._rkind - scalarGroundSnowFraction)*EXP(8.25_rkind - 4.225_rkind*soilEvapFactor) ! Sellers (1992) !scalarSoilResistance = scalarGroundSnowFraction*0._rkind + (1._rkind - scalarGroundSnowFraction)*exp(8.25_rkind - 6.0_rkind*soilEvapFactor) ! Niu adjustment to decrease resitance for wet soil + end if + ! relative humidity in the soil pores [0-1] if (mLayerMatricHead(1) > -1.e+6_rkind) then ! avoid problems with numerical precision when soil is very dry if (groundTempTrial < 0._rkind) then @@ -943,7 +948,7 @@ subroutine vegNrgFlux(& scalarSnowSublimation = scalarLatHeatGround/LH_sub else ! NOTE: this should only occur when we have no snow layers, so check - if (nSnow > 0) then; err=20; message=trim(message)//'only expect ground evaporation when there are no snow layers'; return; end if + if (nSnow>0) then; err=20; message=trim(message)//'only expect ground evaporation when there are no snow layers'; return; end if scalarGroundEvaporation = scalarLatHeatGround/LH_vap scalarSnowSublimation = 0._rkind ! no sublimation from snow if no snow layers have formed end if @@ -972,7 +977,7 @@ subroutine vegNrgFlux(& ! check if evaporation or sublimation if (scalarLatHeatSubVapCanopy < LH_vap+verySmall) then ! evaporation - ! compute the liquid water derivarives + ! compute the liquid water derivatives dCanopyEvaporation_dCanWat = dLatHeatCanopyEvap_dCanWat/LH_vap ! (s-1) dCanopyEvaporation_dTCanair = dLatHeatCanopyEvap_dTCanair/LH_vap ! (kg m-2 s-1 K-1) dCanopyEvaporation_dTCanopy = dLatHeatCanopyEvap_dTCanopy/LH_vap ! (kg m-2 s-1 K-1) @@ -997,7 +1002,7 @@ subroutine vegNrgFlux(& dCanopyTrans_dTGround= dLatHeatCanopyTrans_dTGround/LH_vap end if - ! compute the liquid water derivarives (ground evap) + ! compute the liquid water derivatives (ground evap) dGroundEvaporation_dCanWat = dLatHeatGroundEvap_dCanWat/LH_vap ! (s-1) dGroundEvaporation_dTCanair = dLatHeatGroundEvap_dTCanair/LH_vap ! (kg m-2 s-1 K-1) dGroundEvaporation_dTCanopy = dLatHeatGroundEvap_dTCanopy/LH_vap ! (kg m-2 s-1 K-1) @@ -1577,7 +1582,14 @@ subroutine aeroResist(& referenceHeight = z0Canopy+zeroPlaneDisplacement windConvFactor = exp(-windReductionFactor*(1._rkind - (referenceHeight/heightCanopyTopAboveSnow))) windspdRefHeight = windspdCanopyTop*windConvFactor - if(heightCanopyTopAboveSnow < referenceHeight)then; err=20; message=trim(message)//'canopy top height above snow < reference height'; return; end if + if(heightCanopyTopAboveSnow < referenceHeight)then + if(snowDepth>0 .and. ixVegTraits==vegTypeTable)then + message=trim(message)//'canopy top height above snow < reference height, decision veg_traits==vegTypeTable is inappropriate for snowy conditions' + else + message=trim(message)//'canopy top height above snow < reference height, check for parameter interdependency' + end if + err=20; return + end if ! compute windspeed at the bottom of the canopy relative to the snow depth (m s-1) windConvFactor = exp(-windReductionFactor*(1._rkind - (heightCanopyBottomAboveSnow/heightCanopyTopAboveSnow))) diff --git a/build/source/engine/vegPhenlgy.f90 b/build/source/engine/vegPhenlgy.f90 index 5a187c075..cb884a8ed 100644 --- a/build/source/engine/vegPhenlgy.f90 +++ b/build/source/engine/vegPhenlgy.f90 @@ -21,7 +21,7 @@ module vegPhenlgy_module ! data types -USE nrtype +USE nr_type ! global variables USE globalData,only:& @@ -142,7 +142,7 @@ subroutine vegPhenlgy(& ) ! associate variables in data structure ! ---------------------------------------------------------------------------------------------------------------------------------- - if (nSnow > 0) then ! case when there is snow on the ground (EXCLUDE "snow without a layer" -- in this case, evaporate from the soil) + if (nSnow>0) then ! case when there is snow on the ground (EXCLUDE "snow without a layer" -- in this case, evaporate from the soil) scalarGroundSnowFraction = 1._rkind else ! case when the ground is less than a layer of snow (e.g., bare soil or snow without a layer) scalarGroundSnowFraction = 0._rkind diff --git a/build/source/engine/vegSWavRad.f90 b/build/source/engine/vegSWavRad.f90 index 23848dd31..c5d98be76 100644 --- a/build/source/engine/vegSWavRad.f90 +++ b/build/source/engine/vegSWavRad.f90 @@ -21,12 +21,14 @@ module vegSWavRad_module ! data types -USE nrtype +USE nr_type USE data_types,only:var_i ! x%var(:) (i4b) USE data_types,only:var_dlength ! x%var(:)%dat (rkind) -! physical constants +! constants USE multiconst,only:Tfreeze ! temperature at freezing (K) +USE globalData,only:nSpecBand ! number of spectral bands +USE globalData,only:verySmall ! a very small number used as an additive constant to check if substantial difference among real numbers ! named variables for structure elements USE var_lookup,only:iLookTYPE,iLookPROG,iLookDIAG,iLookFLUX @@ -34,8 +36,6 @@ module vegSWavRad_module ! model decisions USE globalData,only:model_decisions ! model decision structure USE var_lookup,only:iLookDECISIONS ! named variables for elements of the decision structure -USE globalData,only:nSpecBand ! number of spectral bands -USE globalData,only:verySmall ! a very small number used as an additive constant to check if substantial difference among real numbers ! look-up values for the choice of canopy shortwave radiation method USE mDecisions_module,only: & diff --git a/build/source/engine/volicePack.f90 b/build/source/engine/volicePack.f90 index 310f9e84b..bbbe5640b 100644 --- a/build/source/engine/volicePack.f90 +++ b/build/source/engine/volicePack.f90 @@ -21,7 +21,7 @@ module volicePack_module ! data types -USE nrtype +USE nr_type ! derived types to define the data structures USE data_types,only:& diff --git a/build/source/hookup/ascii_util.f90 b/build/source/hookup/ascii_util.f90 index b28768526..16790fa2d 100644 --- a/build/source/hookup/ascii_util.f90 +++ b/build/source/hookup/ascii_util.f90 @@ -19,7 +19,7 @@ ! along with this program. If not, see . module ascii_util_module -USE nrtype +USE nr_type implicit none integer(i4b),parameter,public :: linewidth=4096 ! max character number for one line private diff --git a/build/source/hookup/summaFileManager.f90 b/build/source/hookup/summaFileManager.f90 index afb27405b..0685b511a 100644 --- a/build/source/hookup/summaFileManager.f90 +++ b/build/source/hookup/summaFileManager.f90 @@ -23,7 +23,7 @@ ! (C) Copyright 2009-2010 --- Dmitri Kavetski and Martyn Clark --- All rights reserved !****************************************************************** MODULE summaFileManager -use nrtype +use nr_type implicit none public ! summa-wide pathlength diff --git a/build/source/netcdf/def_output.f90 b/build/source/netcdf/def_output.f90 index 264642261..4d11dd9a3 100644 --- a/build/source/netcdf/def_output.f90 +++ b/build/source/netcdf/def_output.f90 @@ -23,10 +23,12 @@ module def_output_module USE netcdf_util_module,only:netcdf_err ! netcdf error handling function USE netcdf_util_module,only:nc_file_close ! close NetCDF files USE f2008funcs_module,only:cloneStruc ! used to "clone" data structures -- temporary replacement of the intrinsic allocate(a, source=b) -USE nrtype, integerMissing=>nr_integerMissing ! top-level data types +USE nr_type, integerMissing=>nr_integerMissing ! top-level data types +USE globalData, only: numtim ! number of model time steps USE globalData, only: outputPrecision ! data structure for output precision USE globalData, only: chunkSize ! size of chunks to write USE globalData, only: outputCompressionLevel ! netcdf deflate level + implicit none private public :: def_output @@ -36,10 +38,10 @@ module def_output_module character(len=32),parameter :: gru_DimName = 'gru' ! dimension name for the GRUs 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 :: scalar_DimName = 'scalarv' ! dimension name for scalar variables +character(len=32),parameter :: wLength_dimName = 'spectral' ! 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 the time delay routing vectors +character(len=32),parameter :: routing_DimName = 'tdh' ! dimension name for the time delay routing vectors character(len=32),parameter :: midSnow_DimName = 'midSnow' ! dimension name for midSnow character(len=32),parameter :: midSoil_DimName = 'midSoil' ! dimension name for midSoil character(len=32),parameter :: midToto_DimName = 'midToto' ! dimension name for midToto @@ -72,30 +74,29 @@ module def_output_module ! ********************************************************************************************************** ! public subroutine def_output: define model output file ! ********************************************************************************************************** - subroutine def_output(summaVersion,buildTime,gitBranch,gitHash,nGRU,nHRU,nSoil,infile,err,message) + subroutine def_output(using_buffer,summaVersion,buildTime,gitBranch,gitHash,nGRU,nHRU,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:time_meta,forc_meta,attr_meta,type_meta ! metadata structures + USE globalData,only:prog_meta,diag_meta,flux_meta,mpar_meta ! metadata structures + USE globalData,only:indx_meta,bpar_meta,bvar_meta ! metadata structures USE globalData,only:model_decisions ! model decisions USE globalData,only:ncid USE globalData,only:outFreq ! output frequencies - USE var_lookup,only:maxVarFreq ! # of available output frequencies + USE var_lookup,only:maxvarFreq ! # of available output frequencies USE get_ixname_module,only:get_freqName ! get name of frequency from frequency index ! declare dummy variables + logical(lgt),intent(in) :: using_buffer ! flag for will do buffered write character(*),intent(in) :: summaVersion ! SUMMA version character(*),intent(in) :: buildTime ! build time character(*),intent(in) :: gitBranch ! git branch character(*),intent(in) :: gitHash ! git hash integer(i4b),intent(in) :: nGRU ! number of GRUs 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 decisions + integer(i4b) :: iVar ! loop through model decisions integer(i4b) :: iFreq ! loop through output frequencies integer(i4b) :: iStruct ! loop through structure types character(len=32) :: fstring ! string to hold model output freuqnecy @@ -122,13 +123,17 @@ subroutine def_output(summaVersion,buildTime,gitBranch,gitHash,nGRU,nHRU,nSoil,i ! e.g., xxxxxxxxx_monthly.nc (for monthly model output) do iFreq=1,maxvarFreq - ! skip frequencies that are not needed + ! skip frequencies that are not needed, buffered write only write timestep data if(.not.outFreq(iFreq)) cycle + fstring = get_freqName(iFreq) + if(using_buffer .and. trim(fstring)/='timestep') then + write(*,*)'WARNING: can only output timestep data when using the buffered write option (writeFullSeries), skipping frequency '//trim(fstring) + cycle + endif ! create file - fstring = get_freqName(iFreq) fname = trim(infile)//'_'//trim(fstring)//'.nc' - call ini_create(nGRU,nHRU,nSoil,trim(fname),ncid(iFreq),err,cmessage) + call ini_create(nGRU,nHRU,trim(fname),ncid(iFreq),err,cmessage) if(err/=0)then; message=trim(message)//trim(cmessage); return; end if print*,'Created output file: '//trim(fname) @@ -155,19 +160,19 @@ subroutine def_output(summaVersion,buildTime,gitBranch,gitHash,nGRU,nHRU,nSoil,i do iStruct = 1,size(structInfo) select case (trim(structInfo(iStruct)%structName)) case('attr' ); call def_variab(ncid(iFreq),iFreq,needHRU, noTime,attr_meta, outputPrecision, err,cmessage) ! local attributes HRU - case('type' ); call def_variab(ncid(iFreq),iFreq,needHRU, noTime,type_meta, nf90_int, err,cmessage) ! local classification + case('type' ); call def_variab(ncid(iFreq),iFreq,needHRU, noTime,type_meta, nf90_int, err,cmessage) ! local classification case('mpar' ); call def_variab(ncid(iFreq),iFreq,needHRU, noTime,mpar_meta, outputPrecision, err,cmessage) ! model parameters case('bpar' ); call def_variab(ncid(iFreq),iFreq,needGRU, noTime,bpar_meta, outputPrecision, err,cmessage) ! basin-average param - case('indx' ); call def_variab(ncid(iFreq),iFreq,needHRU,needTime,indx_meta, nf90_int, err,cmessage) ! model variables - case('deriv' ); call def_variab(ncid(iFreq),iFreq,needHRU,needTime,deriv_meta,outputPrecision, err,cmessage) ! model derivatives - case('time' ); call def_variab(ncid(iFreq),iFreq, noHRU,needTime,time_meta, nf90_int, err,cmessage) ! model derivatives + case('indx' ); call def_variab(ncid(iFreq),iFreq,needHRU,needTime,indx_meta, nf90_int, err,cmessage) ! model variables + case('deriv' ); cycle ! model derivatives -- for internal use only, not written to output files + case('time' ); call def_variab(ncid(iFreq),iFreq, noHRU,needTime,time_meta, nf90_int, err,cmessage) ! model derivatives case('forc' ); call def_variab(ncid(iFreq),iFreq,needHRU,needTime,forc_meta, outputPrecision, err,cmessage) ! model forcing data case('prog' ); call def_variab(ncid(iFreq),iFreq,needHRU,needTime,prog_meta, outputPrecision, err,cmessage) ! model prognostics case('diag' ); call def_variab(ncid(iFreq),iFreq,needHRU,needTime,diag_meta, outputPrecision, err,cmessage) ! model diagnostic variables case('flux' ); call def_variab(ncid(iFreq),iFreq,needHRU,needTime,flux_meta, outputPrecision, err,cmessage) ! model fluxes case('bvar' ); call def_variab(ncid(iFreq),iFreq,needGRU,needTime,bvar_meta, outputPrecision, err,cmessage) ! basin-average variables case('id' ); cycle ! ids -- see write_hru_info() - case('lookup'); cycle ! ids -- see write_hru_info() + case('lookup'); cycle ! lookup structures -- for internal use only, not written to output files case default; err=20; message=trim(message)//'unable to identify lookup structure'; end select ! error handling @@ -175,7 +180,7 @@ subroutine def_output(summaVersion,buildTime,gitBranch,gitHash,nGRU,nHRU,nSoil,i end do ! iStruct ! write HRU dimension and ID for each output file - call write_hru_info(ncid(iFreq), err, cmessage); if(err/=0) then; message=trim(message)//trim(cmessage); return; end if + call write_hru_info(ncid(iFreq), gru_DimID, hru_DimID, err, cmessage); if(err/=0) then; message=trim(message)//trim(cmessage); return; end if end do ! iFreq @@ -184,37 +189,28 @@ end subroutine def_output ! ********************************************************************************************************** ! private subroutine ini_create: initial create ! ********************************************************************************************************** - subroutine ini_create(nGRU,nHRU,nSoil,infile,ncid,err,message) + subroutine ini_create(nGRU,nHRU,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 - ! model decisions - 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 - rulesDependLayerIndex ! CLM option: combination/sub-dividion rules depend on layer index + ! vector lengths + USE globalData,only:maxLayers ! maximum number of layers + USE globalData,only:nSpecBand ! number of spectral bands + USE globalData,only:nTimeDelay ! number of timesteps in the time delay histogram + USE globalData,only:maxSoilLayers ! maximum number of soil layers + USE globalData,only:maxSnowLayers ! maximum number of snow layers + USE globalData,only:allowRoutingOutput ! flag to allow routing variable output implicit none ! declare dummy variables - integer(i4b),intent(in) :: nGRU ! number of GRUs - 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 + integer(i4b),intent(in) :: nGRU ! number of GRUs + integer(i4b),intent(in) :: nHRU ! number of HRUs + 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) :: 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) :: maxSnowLayers ! maximum number of snow layers + integer(i4b),parameter :: scalarLength=1 ! length of scalar variable ! initialize error control - err=0;message="f-iniCreate/" - ! identify length of the variable vector - select case(model_decisions(iLookDECISIONS%snowLayers)%iDecision) - case(sameRulesAllLayers); maxSnowLayers = 100 - case(rulesDependLayerIndex); maxSnowLayers = 5 - 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) + err=0;message="ini_create/" ! create output file !err = nf90_create(trim(infile),NF90_64BIT_OFFSET,ncid) @@ -222,19 +218,19 @@ subroutine ini_create(nGRU,nHRU,nSoil,infile,ncid,err,message) message='iCreate[create]'; call netcdf_err(err,message); if (err/=0) return ! create dimensions - err = nf90_def_dim(ncid, trim( gru_DimName), nGRU, gru_DimID); message='iCreate[gru]'; call netcdf_err(err,message); if (err/=0) return - err = nf90_def_dim(ncid, trim( hru_DimName), nHRU, hru_DimID); message='iCreate[hru]'; call netcdf_err(err,message); if (err/=0) return - err = nf90_def_dim(ncid, trim(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( midSnow_DimName), maxSnowLayers, midSnow_DimID); message='iCreate[midSnow]'; call netcdf_err(err,message); if (err/=0) return - err = nf90_def_dim(ncid, trim( midSoil_DimName), nSoil, midSoil_DimID); message='iCreate[midSoil]'; call netcdf_err(err,message); if (err/=0) return - err = nf90_def_dim(ncid, trim( midToto_DimName), nSoil+maxSnowLayers, midToto_DimID); message='iCreate[midToto]'; call netcdf_err(err,message); if (err/=0) return - err = nf90_def_dim(ncid, trim( ifcSnow_DimName), maxSnowLayers+1, ifcSnow_DimID); message='iCreate[ifcSnow]'; call netcdf_err(err,message); if (err/=0) return - err = nf90_def_dim(ncid, trim( ifcSoil_DimName), nSoil+1, ifcSoil_DimID); message='iCreate[ifcSoil]'; call netcdf_err(err,message); if (err/=0) return - err = nf90_def_dim(ncid, trim( ifcToto_DimName), nSoil+maxSnowLayers+1, ifcToto_DimID); message='iCreate[ifcToto]'; call netcdf_err(err,message); if (err/=0) return + err = nf90_def_dim(ncid, trim( gru_DimName), nGRU, gru_DimID); message='iCreate[gru]'; call netcdf_err(err,message); if (err/=0) return + err = nf90_def_dim(ncid, trim( hru_DimName), nHRU, hru_DimID); message='iCreate[hru]'; call netcdf_err(err,message); if (err/=0) return + err = nf90_def_dim(ncid, trim(timestep_DimName), nf90_unlimited, timestep_DimID); message='iCreate[time]'; call netcdf_err(err,message); if (err/=0) return + if(maxSoilLayers>0) err = nf90_def_dim(ncid, trim( depth_DimName), maxSoilLayers, 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), nSpecBand, wLength_DimID); message='iCreate[spectral]'; call netcdf_err(err,message); if (err/=0) return + if(allowRoutingOutput) err = nf90_def_dim(ncid, trim( routing_DimName), nTimeDelay, routing_DimID); message='iCreate[routing]'; call netcdf_err(err,message); if (err/=0) return + if(maxSnowLayers>0) err = nf90_def_dim(ncid, trim( midSnow_DimName), maxSnowLayers, midSnow_DimID); message='iCreate[midSnow]'; call netcdf_err(err,message); if (err/=0) return + if(maxSoilLayers>0) err = nf90_def_dim(ncid, trim( midSoil_DimName), maxSoilLayers, midSoil_DimID); message='iCreate[midSoil]'; call netcdf_err(err,message); if (err/=0) return + err = nf90_def_dim(ncid, trim( midToto_DimName), maxLayers, midToto_DimID); message='iCreate[midToto]'; call netcdf_err(err,message); if (err/=0) return + if(maxSnowLayers>0) err = nf90_def_dim(ncid, trim( ifcSnow_DimName), maxSnowLayers+1, ifcSnow_DimID); message='iCreate[ifcSnow]'; call netcdf_err(err,message); if (err/=0) return + if(maxSoilLayers>0) err = nf90_def_dim(ncid, trim( ifcSoil_DimName), maxSoilLayers+1, ifcSoil_DimID); message='iCreate[ifcSoil]'; call netcdf_err(err,message); if (err/=0) return + err = nf90_def_dim(ncid, trim( ifcToto_DimName), maxLayers+1, ifcToto_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 @@ -268,14 +264,18 @@ end subroutine put_attrib ! private subroutine def_variab: define variables ! ********************************************************************************************************** subroutine def_variab(ncid,iFreq,spatialDesire,timeDesire,metaData,ivtype,err,message) - USE var_lookup,only:iLookvarType ! look up structure for variable typed + 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:maxVarFreq ! # of available output frequencies + USE var_lookup,only:maxvarFreq ! # of available output frequencies USE get_ixName_module,only:get_varTypeName ! to access type strings for error messages USE get_ixname_module,only:get_statName ! statistics names for variable defs in output file USE globalData,only:nHRUrun ! number of HRUs in the current run USE globalData,only:nGRUrun ! number of GRUs in the current run + USE globalData,only:maxSnowLayers ! maximum number of snow layers + USE globalData,only:maxSoilLayers ! maximum number of soil layers + USE globalData,only:allowRoutingOutput ! flag to allow routing variable output + implicit none ! input integer(i4b) ,intent(in) :: ncid ! netcdf file id @@ -310,15 +310,18 @@ subroutine def_variab(ncid,iFreq,spatialDesire,timeDesire,metaData,ivtype,err,me do iVar = 1,size(metaData) ! check that the variable is desired - if (metaData(iVar)%varType==iLookvarType%unknown) cycle - if (metaData(iVar)%statIndex(iFreq)==integerMissing .and. metaData(iVar)%varName/='time') cycle + if (metaData(iVar)%varType==iLookVarType%unknown) cycle + if (metaData(iVar)%statIndex(iFreq)==integerMissing .and. trim(metaData(iVar)%varName)/='time') cycle ! ---------- get the dimension IDs (use cloneStruc, given source) ---------- - gruChunk = min(nGRUrun, chunkSize) - hruChunk = min(nHRUrun, chunkSize) + gruChunk = min(nGRUrun, chunkSize) + hruChunk = min(nHRUrun, chunkSize) timeChunk = chunkSize layerChunk = 1 + ! set the chunk size to the number of time steps for single basin runs + if(nGRUrun == 1) timeChunk = numtim + ! special case of the time variable if(metaData(iVar)%varName == 'time')then call cloneStruc(dimensionIDs, lowerBound=1, source=(/Timestep_DimID/),err=err,message=cmessage); writechunk=(/ timeChunk /) @@ -329,7 +332,7 @@ subroutine def_variab(ncid,iFreq,spatialDesire,timeDesire,metaData,ivtype,err,me select case(metaData(iVar)%varType) ! (scalar variable -- many different types) - case(iLookvarType%scalarv) + case(iLookVarType%scalarv) if(spatialDesire==needGRU .and. timeDesire==needTime) then; call cloneStruc(dimensionIDs, lowerBound=1, source=(/ gru_DimID,Timestep_DimID/), err=err, message=cmessage); writechunk=(/ gruChunk, int(timeChunk/gruChunk)+1 /); endif if(spatialDesire==needGRU .and. timeDesire== noTime) then; call cloneStruc(dimensionIDs, lowerBound=1, source=(/ gru_DimID/), err=err, message=cmessage); writechunk=(/ gruChunk /); endif if(spatialDesire==needHRU .and. timeDesire==needTime) then; call cloneStruc(dimensionIDs, lowerBound=1, source=(/ hru_DimID,Timestep_DimID/), err=err, message=cmessage); writechunk=(/ hruChunk, int(timeChunk/hruChunk)+1 /); endif @@ -338,15 +341,20 @@ subroutine def_variab(ncid,iFreq,spatialDesire,timeDesire,metaData,ivtype,err,me if(spatialDesire== noHRU .and. timeDesire== noTime) then; call cloneStruc(dimensionIDs, lowerBound=1, source=(/ scalar_DimID/) , err=err, message=cmessage); writechunk=(/ hruChunk, int(timeChunk/hruChunk)+1 /); endif ! (other variables) - case(iLookvarType%wLength); call cloneStruc(dimensionIDs, lowerBound=1, source=(/hru_DimID, wLength_DimID, Timestep_DimID/), err=err, message=cmessage); writechunk=(/ hruChunk, layerChunk, int(timeChunk/hruChunk)+1 /) - case(iLookvarType%midSnow); call cloneStruc(dimensionIDs, lowerBound=1, source=(/hru_DimID, midSnow_DimID, Timestep_DimID/), err=err, message=cmessage); writechunk=(/ hruChunk, layerChunk, int(timeChunk/hruChunk)+1 /) - case(iLookvarType%midSoil); call cloneStruc(dimensionIDs, lowerBound=1, source=(/hru_DimID, midSoil_DimID, Timestep_DimID/), err=err, message=cmessage); writechunk=(/ hruChunk, layerChunk, int(timeChunk/hruChunk)+1 /) - case(iLookvarType%midToto); call cloneStruc(dimensionIDs, lowerBound=1, source=(/hru_DimID, midToto_DimID, Timestep_DimID/), err=err, message=cmessage); writechunk=(/ hruChunk, layerChunk, int(timeChunk/hruChunk)+1 /) - case(iLookvarType%ifcSnow); call cloneStruc(dimensionIDs, lowerBound=1, source=(/hru_DimID, ifcSnow_DimID, Timestep_DimID/), err=err, message=cmessage); writechunk=(/ hruChunk, layerChunk, int(timeChunk/hruChunk)+1 /) - case(iLookvarType%ifcSoil); call cloneStruc(dimensionIDs, lowerBound=1, source=(/hru_DimID, ifcSoil_DimID, Timestep_DimID/), err=err, message=cmessage); writechunk=(/ hruChunk, layerChunk, int(timeChunk/hruChunk)+1 /) - case(iLookvarType%ifcToto); call cloneStruc(dimensionIDs, lowerBound=1, source=(/hru_DimID, ifcToto_DimID, Timestep_DimID/), err=err, message=cmessage); writechunk=(/ hruChunk, layerChunk, int(timeChunk/hruChunk)+1 /) - case(iLookvarType%parSoil); call cloneStruc(dimensionIDs, lowerBound=1, source=(/hru_DimID, depth_DimID /), err=err, message=cmessage); writechunk=(/ hruChunk, layerChunk/) - case(iLookvarType%routing); call cloneStruc(dimensionIDs, lowerBound=1, source=(/routing_DimID /), err=err, message=cmessage); writechunk=(/ layerChunk /) + case(iLookVarType%wLength); call cloneStruc(dimensionIDs, lowerBound=1, source=(/hru_DimID, wLength_DimID, Timestep_DimID/), err=err, message=cmessage); writechunk=(/ hruChunk, layerChunk, int(timeChunk/hruChunk)+1 /) + case(iLookVarType%midSnow) + if( maxSnowLayers>0)then; call cloneStruc(dimensionIDs, lowerBound=1, source=(/hru_DimID, midSnow_DimID, Timestep_DimID/), err=err, message=cmessage); writechunk=(/ hruChunk, layerChunk, int(timeChunk/hruChunk)+1 /); else; cycle; endif + case(iLookVarType%midSoil) + if( maxSoilLayers>0)then; call cloneStruc(dimensionIDs, lowerBound=1, source=(/hru_DimID, midSoil_DimID, Timestep_DimID/), err=err, message=cmessage); writechunk=(/ hruChunk, layerChunk, int(timeChunk/hruChunk)+1 /); else; cycle; endif + case(iLookVarType%midToto); call cloneStruc(dimensionIDs, lowerBound=1, source=(/hru_DimID, midToto_DimID, Timestep_DimID/), err=err, message=cmessage); writechunk=(/ hruChunk, layerChunk, int(timeChunk/hruChunk)+1 /) + case(iLookVarType%ifcSnow) + if( maxSnowLayers>0)then; call cloneStruc(dimensionIDs, lowerBound=1, source=(/hru_DimID, ifcSnow_DimID, Timestep_DimID/), err=err, message=cmessage); writechunk=(/ hruChunk, layerChunk, int(timeChunk/hruChunk)+1 /); else; cycle; endif + case(iLookVarType%ifcSoil) + if( maxSoilLayers>0)then; call cloneStruc(dimensionIDs, lowerBound=1, source=(/hru_DimID, ifcSoil_DimID, Timestep_DimID/), err=err, message=cmessage); writechunk=(/ hruChunk, layerChunk, int(timeChunk/hruChunk)+1 /); else; cycle; endif + case(iLookVarType%ifcToto); call cloneStruc(dimensionIDs, lowerBound=1, source=(/hru_DimID, ifcToto_DimID, Timestep_DimID/), err=err, message=cmessage); writechunk=(/ hruChunk, layerChunk, int(timeChunk/hruChunk)+1 /) + case(iLookVarType%parSoil); call cloneStruc(dimensionIDs, lowerBound=1, source=(/hru_DimID, depth_DimID /), err=err, message=cmessage); writechunk=(/ hruChunk, layerChunk/) ! soil parameters have no time dimension + case(iLookVarType%routing) + if(allowRoutingOutput)then; call cloneStruc(dimensionIDs, lowerBound=1, source=(/gru_DimID, routing_DimID, Timestep_DimID/), err=err, message=cmessage); writechunk=(/ gruChunk, layerChunk, int(timeChunk/gruChunk)+1 /); else; cycle; endif end select ! check errors if(err/=0)then @@ -414,7 +422,7 @@ subroutine def_variab(ncid,iFreq,spatialDesire,timeDesire,metaData,ivtype,err,me call netcdf_err(err,message); if (err/=0) return ! add NetCDF variable ID to metadata structure - metaData(iVar)%ncVarID(iFreq) = iVarID + metaData(iVar)%ncVarID(iFreq) = iVarId end do ! looping through variables @@ -426,10 +434,12 @@ end subroutine def_variab ! ********************************************************************************************************** ! public subroutine write_hru_info: write HRU dimension and IDs ! ********************************************************************************************************** - subroutine write_hru_info(ncid, err, message) + subroutine write_hru_info(ncid, gruDimID, hruDimID, err, message) use globalData,only:gru_struc ! gru-hru mapping structures ! input integer(i4b),intent(in) :: ncid ! netcdf file id + integer(i4b),intent(in) :: gruDimID ! GRU dimension ID + integer(i4b),intent(in) :: hruDimID ! HRU dimension ID ! output integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -448,22 +458,22 @@ subroutine write_hru_info(ncid, err, message) err = nf90_redef(ncid); call netcdf_err(err, message); if (err/=nf90_NoErr) return ! define HRU var - err = nf90_def_var(ncid, trim(hru_DimName), nf90_int, (/hru_DimID/), hruVarID, deflate_level=outputCompressionLevel); if (err/=nf90_NoErr) then; message=trim(message)//'nf90_define_hruVar' ; call netcdf_err(err,message); return; end if + err = nf90_def_var(ncid, trim(hru_DimName), nf90_int, (/hruDimID/), hruVarID, deflate_level=outputCompressionLevel); if (err/=nf90_NoErr) then; message=trim(message)//'nf90_define_hruVar' ; call netcdf_err(err,message); return; end if err = nf90_put_att(ncid, hruVarID, 'long_name', 'hruId in the input file'); if (err/=nf90_NoErr) then; message=trim(message)//'write_hruVar_longname'; call netcdf_err(err,message); return; end if err = nf90_put_att(ncid, hruVarID, 'units', '-' ); if (err/=nf90_NoErr) then; message=trim(message)//'write_hruVar_unit'; call netcdf_err(err,message); return; end if ! define GRU var - err = nf90_def_var(ncid, trim(gru_DimName), nf90_int, (/gru_DimID/), gruVarID, deflate_level=outputCompressionLevel); if (err/=nf90_NoErr) then; message=trim(message)//'nf90_define_gruVar' ; call netcdf_err(err,message); return; end if + err = nf90_def_var(ncid, trim(gru_DimName), nf90_int, (/gruDimID/), gruVarID, deflate_level=outputCompressionLevel); if (err/=nf90_NoErr) then; message=trim(message)//'nf90_define_gruVar' ; call netcdf_err(err,message); return; end if err = nf90_put_att(ncid, gruVarID, 'long_name', 'gruId in the input file'); if (err/=nf90_NoErr) then; message=trim(message)//'write_gruVar_longname'; call netcdf_err(err,message); return; end if err = nf90_put_att(ncid, gruVarID, 'units', '-' ); if (err/=nf90_NoErr) then; message=trim(message)//'write_gruVar_unit'; call netcdf_err(err,message); return; end if ! define hruId var - err = nf90_def_var(ncid, 'hruId', nf90_int64, (/hru_DimID/), hruIdVarID, deflate_level=outputCompressionLevel); if (err/=nf90_NoErr) then; message=trim(message)//'nf90_define_hruIdVar' ; call netcdf_err(err,message); return; end if + err = nf90_def_var(ncid, 'hruId', nf90_int64, (/hruDimID/), hruIdVarID, deflate_level=outputCompressionLevel); if (err/=nf90_NoErr) then; message=trim(message)//'nf90_define_hruIdVar' ; call netcdf_err(err,message); return; end if err = nf90_put_att(ncid, hruIdVarID, 'long_name', 'ID defining the hydrologic response unit'); if (err/=nf90_NoErr) then; message=trim(message)//'write_hruIdVar_longname'; call netcdf_err(err,message); return; end if err = nf90_put_att(ncid, hruIdVarID, 'units', '-' ); if (err/=nf90_NoErr) then; message=trim(message)//'write_hruIdVar_unit'; call netcdf_err(err,message); return; end if ! define gruId var - err = nf90_def_var(ncid, 'gruId', nf90_int64, (/gru_DimID/), gruIdVarID, deflate_level=outputCompressionLevel); if (err/=nf90_NoErr) then; message=trim(message)//'nf90_define_gruIdVar' ; call netcdf_err(err,message); return; end if + err = nf90_def_var(ncid, 'gruId', nf90_int64, (/gruDimID/), gruIdVarID, deflate_level=outputCompressionLevel); if (err/=nf90_NoErr) then; message=trim(message)//'nf90_define_gruIdVar' ; call netcdf_err(err,message); return; end if err = nf90_put_att(ncid, gruIdVarID, 'long_name', 'ID defining the grouped (basin) response unit'); if (err/=nf90_NoErr) then; message=trim(message)//'write_gruIdVar_longname'; call netcdf_err(err,message); return; end if err = nf90_put_att(ncid, gruIdVarID, 'units', '-' ); if (err/=nf90_NoErr) then; message=trim(message)//'write_gruIdVar_unit'; call netcdf_err(err,message); return; end if diff --git a/build/source/netcdf/modelwrite.f90 b/build/source/netcdf/modelwrite.f90 index b59f9fb3a..a66313b07 100644 --- a/build/source/netcdf/modelwrite.f90 +++ b/build/source/netcdf/modelwrite.f90 @@ -22,16 +22,26 @@ module modelwrite_module ! NetCDF types USE netcdf -USE netcdf_util_module,only:netcdf_err ! netcdf error handling function +USE netcdf_util_module,only:netcdf_err ! netcdf error handling function ! top-level data types -USE nrtype +USE nr_type ! missing values USE globalData,only: integerMissing, realMissing +! output constraints +USE globalData,only:maxSnowLayers ! maximum number of snow layers +USE globalData,only:maxSoilLayers ! maximum number of soil layers +USE globalData,only:maxLayers ! maximum number of layers +USE globalData,only:nTimeDelay ! number of timesteps in the time delay histogram +USE globalData,only:nSpecBand ! maximum number of spectral bands +USE globalData,only:allowRoutingOutput ! flag to allow routing variable output + ! provide access to global data -USE globalData,only:gru_struc ! gru->hru mapping structure +USE globalData,only:nGRUrun ! number of GRUs in the run +USE globalData,only:nHRUrun ! number of HRUs in the run +USE globalData,only:gru_struc ! gru->hru mapping structure ! provide access to the derived types to define the data structures USE data_types,only:& @@ -39,48 +49,40 @@ module modelwrite_module dlength, & ! var%dat ilength, & ! var%dat ! no spatial dimension - var_i, & ! x%var(:) (i4b) - var_i8, & ! x%var(:) (i8b) - var_d, & ! x%var(:) (dp) - var_ilength, & ! x%var(:)%dat (i4b) - var_dlength, & ! x%var(:)%dat (dp) - ! no variable dimension - hru_i, & ! x%hru(:) (i4b) - hru_d, & ! x%hru(:) (dp) + var_i, & ! x%var(:) (i4b) + var_i8, & ! x%var(:) (i8b) + var_d, & ! x%var(:) (rkind) + var_ilength, & ! x%var(:)%dat (i4b) + var_dlength, & ! x%var(:)%dat (rkind) ! 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_int, & ! x%gru(:)%var(:) (i4b) + gru_double, & ! x%gru(:)%var(:) (rkind) + gru_intVec, & ! x%gru(:)%var(:)%dat (i4b) + gru_doubleVec, & ! x%gru(:)%var(:)%dat (rkind) ! gru+hru dimension gru_hru_int, & ! x%gru(:)%hru(:)%var(:) (i4b) - gru_hru_int8, & ! x%gru(:)%hru(:)%var(:) (i8b) - gru_hru_double, & ! x%gru(:)%hru(:)%var(:) (dp) + gru_hru_double, & ! x%gru(:)%hru(:)%var(:) (rkind) gru_hru_intVec, & ! x%gru(:)%hru(:)%var(:)%dat (i4b) - gru_hru_doubleVec ! x%gru(:)%hru(:)%var(:)%dat (dp) + gru_hru_doubleVec ! x%gru(:)%hru(:)%var(:)%dat (rkind) ! vector lengths USE var_lookup, only: maxvarFreq ! number of output frequencies -USE var_lookup, only: maxvarStat ! number of statistics - +USE var_lookup, only: maxvarStat ! number of statistics implicit none private -public::writeParm -public::writeData -public::writeBasin +public::writeParam +public::writeData_fullSeries +public::writeData_perStep public::writeTime public::writeRestart -! define dimension lengths -integer(i4b),parameter :: maxSpectral=2 ! maximum number of spectral bands - contains ! ********************************************************************************************************** - ! public subroutine writeParm: write model parameters + ! public subroutine writeParam: write model parameters ! ********************************************************************************************************** - subroutine writeParm(ispatial,struct,meta,err,message) + subroutine writeParam(iSpatial,struct,meta,err,message) USE globalData,only:ncid ! netcdf file ids USE data_types,only:var_info ! metadata info USE var_lookup,only:iLookSTAT ! index in statistics vector @@ -88,7 +90,7 @@ subroutine writeParm(ispatial,struct,meta,err,message) implicit none ! declare input variables - integer(i4b) ,intent(in) :: iSpatial ! hydrologic response unit + integer(i4b) ,intent(in) :: iSpatial ! HRU index or GRU index class(*) ,intent(in) :: struct ! data structure type(var_info),intent(in) :: meta(:) ! metadata structure integer(i4b) ,intent(out) :: err ! error code @@ -97,7 +99,7 @@ subroutine writeParm(ispatial,struct,meta,err,message) integer(i4b) :: iVar ! loop through variables ! initialize error control - err=0;message="writeParm/" + err=0;message="writeParam/" ! loop through local column model parameters do iVar = 1,size(meta) @@ -106,87 +108,65 @@ subroutine writeParm(ispatial,struct,meta,err,message) if (meta(iVar)%statIndex(iLookFREQ%timestep)==integerMissing) cycle ! initialize message - message=trim(message)//trim(meta(iVar)%varName)//'/' - - ! HRU data - if (iSpatial/=integerMissing) then - select type (struct) - class is (var_i) - err = nf90_put_var(ncid(iLookFREQ%timestep),meta(iVar)%ncVarID(iLookFREQ%timestep),(/struct%var(iVar)/),start=(/iSpatial/),count=(/1/)) - class is (var_i8) - err = nf90_put_var(ncid(iLookFREQ%timestep),meta(iVar)%ncVarID(iLookFREQ%timestep),(/struct%var(iVar)/),start=(/iSpatial/),count=(/1/)) - class is (var_d) - err = nf90_put_var(ncid(iLookFREQ%timestep),meta(iVar)%ncVarID(iLookFREQ%timestep),(/struct%var(iVar)/),start=(/iSpatial/),count=(/1/)) - class is (var_dlength) - err = nf90_put_var(ncid(iLookFREQ%timestep),meta(iVar)%ncVarID(iLookFREQ%timestep),(/struct%var(iVar)%dat/),start=(/iSpatial,1/),count=(/1,size(struct%var(iVar)%dat)/)) - class default; err=20; message=trim(message)//'unknown variable type (with HRU)'; return - end select - call netcdf_err(err,message); if (err/=0) return - - ! GRU data - else - select type (struct) - class is (var_d) - err = nf90_put_var(ncid(iLookFREQ%timestep),meta(iVar)%ncVarID(iLookFREQ%timestep),(/struct%var(iVar)/),start=(/1/),count=(/1/)) - class is (var_i8) - err = nf90_put_var(ncid(iLookFREQ%timestep),meta(iVar)%ncVarID(iLookFREQ%timestep),(/struct%var(iVar)/),start=(/1/),count=(/1/)) - class default; err=20; message=trim(message)//'unknown variable type (no HRU)'; return - end select - end if + message=trim(message)//trim(meta(iVar)%varName)//':' + + select type (struct) + class is (var_i) + err = nf90_put_var(ncid(iLookFREQ%timestep),meta(iVar)%ncVarID(iLookFREQ%timestep),(/struct%var(iVar)/),start=(/iSpatial/),count=(/1/)) + class is (var_i8) + err = nf90_put_var(ncid(iLookFREQ%timestep),meta(iVar)%ncVarID(iLookFREQ%timestep),(/struct%var(iVar)/),start=(/iSpatial/),count=(/1/)) + class is (var_d) + err = nf90_put_var(ncid(iLookFREQ%timestep),meta(iVar)%ncVarID(iLookFREQ%timestep),(/struct%var(iVar)/),start=(/iSpatial/),count=(/1/)) + class is (var_dlength) + err = nf90_put_var(ncid(iLookFREQ%timestep),meta(iVar)%ncVarID(iLookFREQ%timestep),(/struct%var(iVar)%dat/),start=(/iSpatial,1/),count=(/1,size(struct%var(iVar)%dat)/)) + class default; err=20; message=trim(message)//'parameter type must be var_i, var_i8, var_d, or var_dlength'; return + end select call netcdf_err(err,message); if (err/=0) return ! re-initialize message - message="writeParm/" + message="writeParam/" end do ! looping through local column model parameters - end subroutine writeParm + end subroutine writeParam ! ************************************************************************************** - ! public subroutine writeData: write model time-dependent data + ! public subroutine writeData_fullSeries: write buffered model time-dependent data for each HRU ! ************************************************************************************** - subroutine writeData(finalizeStats,outputTimestep,nHRUrun,maxLayers,meta,stat,dat,map,indx,err,message) + subroutine writeData_fullSeries(finalizeStats,maxWrite,meta,datt,map,indx,err,message) USE data_types,only:var_info ! metadata type - USE var_lookup,only:maxVarStat ! index into stats structure USE var_lookup,only:iLookVarType ! index into type structure - USE var_lookup,only:iLookINDEX ! index into index structure - USE var_lookup,only:iLookSTAT ! index into stat structure + USE var_lookup,only:iLookFREQ ! index into freq structure USE globalData,only:outFreq,ncid ! output file information USE get_ixName_module,only:get_varTypeName ! to access type strings for error messages USE get_ixName_module,only:get_statName ! to access type strings for error messages implicit none ! declare dummy variables - logical(lgt) ,intent(in) :: finalizeStats(:) ! flags to finalize statistics - integer(i4b) ,intent(in) :: outputTimestep(:) ! output time step - integer(i4b) ,intent(in) :: nHRUrun ! number of HRUs in the run domain - integer(i4b) ,intent(in) :: maxLayers ! maximum number of layers - type(var_info),intent(in) :: meta(:) ! meta data - class(*) ,intent(in) :: stat ! stats data - class(*) ,intent(in) :: dat ! timestep data - integer(i4b) ,intent(in) :: map(:) ! map into stats child struct - type(gru_hru_intVec) ,intent(in) :: indx ! index data - integer(i4b) ,intent(out) :: err ! error code - character(*) ,intent(out) :: message ! error message + logical(lgt) ,intent(in) :: finalizeStats(:) ! flags to finalize statistics + integer(i4b) ,intent(in) :: maxWrite ! maximum number of steps written + type(var_info),intent(in) :: meta(:) ! meta data + class(*) ,intent(in) :: datt(:) ! timestep or buffer data + integer(i4b) ,intent(in) :: map(:) ! map into stats child struct + type(gru_hru_intVec),intent(in):: indx ! index data + integer(i4b) ,intent(out) :: err ! error code + character(*) ,intent(out) :: message ! error message ! local variables - integer(i4b) :: iGRU ! grouped response unit counter - integer(i4b) :: iHRU ! hydrologic response unit counter - 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) :: iGRU ! grouped response unit counter + integer(i4b) :: iHRU ! hydrologic response unit counter + integer(i4b) :: iVar ! variable index + integer(i4b) :: iStat ! statistics index + integer(i4b) :: iFreq ! frequency index + integer(i4b) :: iTime ! time index + integer(i4b) :: ncVarID ! used only for time + integer(i4b) :: nSpace ! number of spatial data elements ! output arrays - integer(i4b) :: datLength ! length of each data vector - integer(i4b) :: maxLength ! maximum length of each data vector - real(rkind) :: realVec(nHRUrun) ! real vector for all HRUs in the run domain - real(rkind) :: realArray(nHRUrun,maxLayers+1) ! real array for all HRUs in the run domain - integer(i4b) :: intArray(nHRUrun,maxLayers+1) ! integer array for all HRUs in the run domain - integer(i4b) :: dataType ! type of data - integer(i4b),parameter :: ixInteger=1001 ! named variable for integer - integer(i4b),parameter :: ixReal=1002 ! named variable for real + real(rkind) :: timeBuffer(maxWrite) ! buffer for all time steps + real(rkind) :: realBuffer(nHRUrun,maxWrite) ! buffer for all HRUs in the run domain + time steps + integer(i4b) :: dataType ! type of data + integer(i4b),parameter :: ixInteger=1001 ! named variable for integer + integer(i4b),parameter :: ixReal=1002 ! named variable for real + ! initialize error control - err=0;message="writeData/" + err=0 ! loop through output frequencies do iFreq=1,maxvarFreq @@ -194,152 +174,154 @@ subroutine writeData(finalizeStats,outputTimestep,nHRUrun,maxLayers,meta,stat,da ! skip frequencies that are not needed if(.not.outFreq(iFreq)) cycle + ! restrict attention to the timestep data if buffered write + if(iFreq/=iLookFREQ%timestep) cycle + ! check that we have finalized statistics for a given frequency if(.not.finalizeStats(iFreq)) cycle ! loop through model variables - do iVar = 1,size(meta) + iVarLoop: do iVar = 1,size(meta) + + ! initialize message + message="writeData_fullSeries/"//trim(meta(iVar)%varName) + + ! **************************************************************************** + ! *** write time information -- instantaneous + ! **************************************************************************** ! handle time first - if (meta(iVar)%varName=='time')then + if(trim(meta(iVar)%varName)=='time')then + message=trim(message)//':' ! add statistic (none) to message + ! get variable index err = nf90_inq_varid(ncid(iFreq),trim(meta(iVar)%varName),ncVarID) call netcdf_err(err,message); if (err/=0) return + ! define HRUs and GRUs (only write once) iGRU=1; iHRU=1 - ! data bound write - select type(dat) ! forcStruc - class is (gru_hru_double) ! x%gru(:)%hru(:)%var(:) - err = nf90_put_var(ncid(iFreq),ncVarID,(/dat%gru(iGRU)%hru(iHRU)%var(iVar)/),start=(/outputTimestep(iFreq)/),count=(/1/)) - call netcdf_err(err,message); if (err/=0) return - cycle ! move onto the next variable + + ! data bound array access + select type (datt) ! forcStruc + class is (gru_hru_double) ! x%gru(:)%hru(:)%var(:) + do iTime=1,maxWrite + timeBuffer(iTime) = datt(iTime)%gru(iGRU)%hru(iHRU)%var(iVar) + end do class default; err=20; message=trim(message)//'time variable must be of type gru_hru_double (forcing data structure)'; return - end select - end if ! id time + end select ! type of data structure - ! define the statistics index - iStat = meta(iVar)%statIndex(iFreq) + ! write time + err = nf90_put_var(ncid(iFreq),ncVarID,(/timeBuffer/),start=(/1/),count=(/maxWrite/)) + call netcdf_err(err,message); if (err/=0) return + cycle ! move onto the next variable - ! check that the variable is desired - if (iStat==integerMissing.or.trim(meta(iVar)%varName)=='unknown') cycle + end if ! if time - ! stats output: only scalar variable type - if(meta(iVar)%varType==iLookVarType%scalarv) then - select type(stat) - class is (gru_hru_doubleVec) - - ! loop through HRUs and GRUs, and place data in the single vector - do iGRU=1,size(gru_struc) - do iHRU=1,gru_struc(iGRU)%hruCount - realVec(gru_struc(iGRU)%hruInfo(iHRU)%hru_ix) = stat%gru(iGRU)%hru(iHRU)%var(map(iVar))%dat(iFreq) - end do - end do + ! **************************************************************************** + ! *** write scalar variables + ! **************************************************************************** - ! write data - err = nf90_put_var(ncid(iFreq),meta(iVar)%ncVarID(iFreq),realVec,start=(/1,outputTimestep(iFreq)/),count=(/nHRUrun,1/)) + ! define the statistics index + iStat = meta(iVar)%statIndex(iFreq) + message=trim(message)//'_'//trim(get_statName(iStat))//':' ! add statistic to message - class default; err=20; message=trim(message)//'stats must be scalarv and of type gru_hru_doubleVec'; return - end select ! stat + ! check that the variable is desired, currently do not write large variables (unknown and routing) as they are large and slow things down a lot + if (iStat==integerMissing .or. meta(iVar)%varType==iLookVarType%unknown .or. meta(iVar)%varType==integerMissing) cycle + if (meta(iVar)%varType==iLookVarType%routing .and. .not.allowRoutingOutput) cycle ! routing variable write can be turned on with the allowRoutingOutput flag - ! non-scalar variables: regular data structures - else + ! buffered output: only scalar variable type + if(meta(iVar)%varType==iLookVarType%scalarv) then ! initialize the data vectors - select type (dat) - class is (gru_hru_doubleVec); realArray(:,:) = realMissing; dataType=ixReal - class is (gru_hru_intVec); intArray(:,:) = integerMissing; dataType=ixInteger - class default; err=20; message=trim(message)//'data must not be scalarv and either of type gru_hru_doubleVec or gru_hru_intVec'; return + select type (datt) + class is (gru_hru_double); nSpace = nHRUrun; realBuffer(:,:) = realMissing; dataType=ixReal + class is (gru_hru_int); nSpace = nHRUrun; realBuffer(:,:) = realMissing; dataType=ixReal + class is (gru_double); nSpace = nGRUrun; realBuffer(:,:) = realMissing; dataType=ixReal + class is (gru_int); nSpace = nGRUrun; realBuffer(:,:) = realMissing; dataType=ixReal + class default; err=20; message=trim(message)//'data is not scalarv so should be either of type gru_hru_[double or int] or gru_[double or int]'; return end select - ! loop thru GRUs and HRUs - do iGRU=1,size(gru_struc) - do iHRU=1,gru_struc(iGRU)%hruCount - - ! get the model layers - nSoil = indx%gru(iGRU)%hru(iHRU)%var(iLookINDEX%nSoil)%dat(1) - nSnow = indx%gru(iGRU)%hru(iHRU)%var(iLookINDEX%nSnow)%dat(1) - nLayers = indx%gru(iGRU)%hru(iHRU)%var(iLookINDEX%nLayers)%dat(1) - - ! get the length of each data vector - select case (meta(iVar)%varType) - case(iLookVarType%wLength); datLength = maxSpectral - case(iLookVarType%midToto); datLength = nLayers - case(iLookVarType%midSnow); datLength = nSnow - case(iLookVarType%midSoil); datLength = nSoil - case(iLookVarType%ifcToto); datLength = nLayers+1 - case(iLookVarType%ifcSnow); datLength = nSnow+1 - case(iLookVarType%ifcSoil); datLength = nSoil+1 - case default; cycle - end select ! vartype - - ! get the data vectors - select type (dat) - class is (gru_hru_doubleVec); realArray(gru_struc(iGRU)%hruInfo(iHRU)%hru_ix,1:datLength) = dat%gru(iGRU)%hru(iHRU)%var(iVar)%dat(:) - class is (gru_hru_intVec); intArray(gru_struc(iGRU)%hruInfo(iHRU)%hru_ix,1:datLength) = dat%gru(iGRU)%hru(iHRU)%var(iVar)%dat(:) - class default; err=20; message=trim(message)//'data must not be scalarv and either of type gru_hru_doubleVec or gru_hru_intVec'; return - end select + ! loop through time, HRUs and GRU + do iTime=1,maxWrite + do iGRU=1,size(gru_struc) + do iHRU=1,gru_struc(iGRU)%hruCount - end do ! HRU loop - end do ! GRU loop + ! get the data vectors + select type (datt) + class is (gru_hru_double); realBuffer(gru_struc(iGRU)%hruInfo(iHRU)%hru_ix,iTime) = datt(iTime)%gru(iGRU)%hru(iHRU)%var(map(iVar)) + class is (gru_hru_int); realBuffer(gru_struc(iGRU)%hruInfo(iHRU)%hru_ix,iTime) = datt(iTime)%gru(iGRU)%hru(iHRU)%var(map(iVar)) + class is (gru_double); realBuffer(iGRU,iTime) = datt(iTime)%gru(iGRU)%var(map(iVar)); exit ! only need to get the GRU-level data once + class is (gru_int); realBuffer(iGRU,iTime) = datt(iTime)%gru(iGRU)%var(map(iVar)); exit ! only need to get the GRU-level data once + end select ! time step data structure - ! get the maximum length of each data vector - select case (meta(iVar)%varType) - case(iLookVarType%wLength); maxLength = maxSpectral - case(iLookVarType%midToto); maxLength = maxLayers - case(iLookVarType%midSnow); maxLength = maxLayers-nSoil - case(iLookVarType%midSoil); maxLength = nSoil - case(iLookVarType%ifcToto); maxLength = maxLayers+1 - case(iLookVarType%ifcSnow); maxLength = (maxLayers-nSoil)+1 - case(iLookVarType%ifcSoil); maxLength = nSoil+1 - case default; cycle - end select ! vartype + end do ! HRU loop + end do ! GRU loop + end do ! time loop ! write the data vectors - select case(dataType) - case(ixReal); err = nf90_put_var(ncid(iFreq),meta(iVar)%ncVarID(iFreq),realArray(1:nHRUrun,1:maxLength),start=(/1,1,outputTimestep(iFreq)/),count=(/nHRUrun,maxLength,1/)) - case(ixInteger); err = nf90_put_var(ncid(iFreq),meta(iVar)%ncVarID(iFreq),intArray(1:nHRUrun,1:maxLength),start=(/1,1,outputTimestep(iFreq)/),count=(/nHRUrun,maxLength,1/)) - case default; err=20; message=trim(message)//'data must be of type integer or real'; return - end select ! data type + select case (dataType) + case(ixReal); err = nf90_put_var(ncid(iFreq),meta(iVar)%ncVarID(iFreq),realBuffer(1:nSpace,1:maxWrite),start=(/1,1/),count=(/nSpace,maxWrite/)) + end select + call netcdf_err(err,message); if (err/=0) return - end if ! not scalarv + else ! cannot write non-scalar variables in buffered write -- too complicated and slow, so not currently supported + write(*,*)'WARNING: cannot output non-scalar type data when using the buffered write option (writeFullSeries), skipping variable '//trim(meta(iVar)%varName); cycle - ! process error code - if (err/=0) message=trim(message)//trim(meta(iVar)%varName)//'_'//trim(get_statName(iStat)) - call netcdf_err(err,message); if (err/=0) return + end if ! not scalarv - end do ! iVar + end do iVarLoop ! iVar end do ! iFreq - end subroutine writeData + end subroutine writeData_fullSeries ! ************************************************************************************** - ! public subroutine writeBasin: write basin-average variables + ! public subroutine writeData_perStep: write per-step model time-dependent data for each HRU ! ************************************************************************************** - subroutine writeBasin(iGRU,finalizeStats,outputTimestep,meta,stat,dat,map,err,message) + subroutine writeData_perStep(finalizeStats,outputTimestep,maxLengthAll,meta,stat,datt,map,indx,err,message) USE data_types,only:var_info ! metadata type - USE var_lookup,only:maxVarStat ! index into stats structure + 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:iLookFREQ ! index into freq structure USE globalData,only:outFreq,ncid ! output file information USE get_ixName_module,only:get_varTypeName ! to access type strings for error messages USE get_ixName_module,only:get_statName ! to access type strings for error messages implicit none - ! declare dummy variables - integer(i4b) ,intent(in) :: iGRU ! GRU index - logical(lgt) ,intent(in) :: finalizeStats(:) ! flags to finalize statistics - integer(i4b) ,intent(in) :: outputTimestep(:) ! output time step - 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(out) :: err ! error code - character(*) ,intent(out) :: message ! error message + logical(lgt) ,intent(in) :: finalizeStats(:) ! flags to finalize statistics + integer(i4b) ,intent(in) :: outputTimestep(:) ! output time step + integer(i4b) ,intent(in) :: maxLengthAll ! maxLength all data + type(var_info),intent(in) :: meta(:) ! meta data + class(*) ,intent(in) :: stat ! stats data + class(*) ,intent(in) :: datt ! timestep data + integer(i4b) ,intent(in) :: map(:) ! map into stats child struct + type(gru_hru_intVec),intent(in):: indx ! index data + 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) :: iGRU ! grouped response unit counter + integer(i4b) :: iHRU ! hydrologic response unit counter + 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) :: nSpace ! number of spatial data elements + ! output arrays + integer(i4b) :: datLength ! length of each data vector + integer(i4b) :: maxLength ! maximum length of each data vector + real(rkind) :: timeStep ! timestep value written to file + real(rkind) :: realBuffer(nHRUrun) ! buffer for all HRUs in the run domain + time steps + real(rkind) :: realArray(nHRUrun,maxLengthAll)! real array for all HRUs in the run domain + integer(i4b) :: intArray(nHRUrun,maxLengthAll) ! integer array for all HRUs in the run domain + integer(i4b) :: dataType ! type of data + integer(i4b),parameter :: ixInteger=1001 ! named variable for integer + integer(i4b),parameter :: ixReal=1002 ! named variable for real + ! initialize error control - err=0;message="f-writeBasin/" + err=0 ! loop through output frequencies do iFreq=1,maxvarFreq @@ -351,42 +333,164 @@ subroutine writeBasin(iGRU,finalizeStats,outputTimestep,meta,stat,dat,map,err,me if(.not.finalizeStats(iFreq)) cycle ! loop through model variables - do iVar = 1,size(meta) + iVarLoop: do iVar = 1,size(meta) + + ! initialize message + message="writeData_perStep/"//trim(meta(iVar)%varName) + + ! **************************************************************************** + ! *** write time information -- instantaneous + ! **************************************************************************** + + ! handle time first + if(trim(meta(iVar)%varName)=='time')then + message=trim(message)//':' ! add statistic (none) to message + + ! get variable index + err = nf90_inq_varid(ncid(iFreq),trim(meta(iVar)%varName),ncVarID) + call netcdf_err(err,message); if (err/=0) return + + ! define HRUs and GRUs (only write once) + iGRU=1; iHRU=1 + + ! data bound array access + select type (datt) ! forcStruc + class is (gru_hru_double) ! x%gru(:)%hru(:)%var(:) + timeStep = datt%gru(iGRU)%hru(iHRU)%var(iVar) + class default; err=20; message=trim(message)//'time variable must be of type gru_hru_double (forcing data structure)'; return + end select ! type of data structure + + ! write time + err = nf90_put_var(ncid(iFreq),ncVarID,(/timeStep/),start=(/outputTimestep(iFreq)/),count=(/1/)) + call netcdf_err(err,message); if (err/=0) return + cycle ! move onto the next variable + + end if ! if time + + ! **************************************************************************** + ! *** write scalar variables + ! **************************************************************************** ! define the statistics index iStat = meta(iVar)%statIndex(iFreq) + message=trim(message)//'_'//trim(get_statName(iStat))//':' ! add statistic to message - ! check that the variable is desired - if (iStat==integerMissing.or.trim(meta(iVar)%varName)=='unknown') cycle + ! check that the variable is desired, currently do not write large variables (unknown and routing) as they are large and slow things down a lot + if (iStat==integerMissing .or. meta(iVar)%varType==iLookVarType%unknown .or. meta(iVar)%varType==integerMissing) cycle + if (meta(iVar)%varType==iLookVarType%routing .and. .not.allowRoutingOutput) cycle ! routing variable write can be turned on with the allowRoutingOutput flag - ! stats/data output - select data type - select case (meta(iVar)%varType) + ! stats output: only scalar variable type + if(meta(iVar)%varType==iLookVarType%scalarv) then - case (iLookVarType%scalarv) - err = nf90_put_var(ncid(iFreq),meta(iVar)%ncVarID(iFreq),(/stat(map(iVar))%dat(iFreq)/),start=(/iGRU,outputTimestep(iFreq)/),count=(/1,1/)) + ! initialize the data vectors + select type (stat) + class is (gru_hru_doubleVec); nSpace = nHRUrun; realBuffer(:) = realMissing; dataType=ixReal + class is (gru_doubleVec); nSpace = nGRUrun; realBuffer(:) = realMissing; dataType=ixReal + class default; message=trim(message)//'stats must be scalarv and of type gru_hru_doubleVec or gru_doubleVec'; err=20; return;err=20; return + end select - case (iLookVarType%routing) - if (iFreq==1 .and. outputTimestep(iFreq)==1) then - err = nf90_put_var(ncid(iFreq),meta(iVar)%ncVarID(iFreq),(/dat(iVar)%dat/),start=(/1/),count=(/1000/)) - end if + ! loop thru GRUs and HRUs + do iGRU=1,size(gru_struc) + do iHRU=1,gru_struc(iGRU)%hruCount - 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 + ! get the data vectors + select type (stat) + class is (gru_hru_doubleVec); realBuffer(gru_struc(iGRU)%hruInfo(iHRU)%hru_ix) = stat%gru(iGRU)%hru(iHRU)%var(map(iVar))%dat(iFreq) + class is (gru_doubleVec); realBuffer(iGRU) = stat%gru(iGRU)%var(map(iVar))%dat(iFreq); exit ! only need to get the GRU-level data once + end select ! stat data structure - ! 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 ! HRU loop + end do ! GRU loop - end do ! iVar + ! write the data vectors + select case (dataType) + case(ixReal); err = nf90_put_var(ncid(iFreq),meta(iVar)%ncVarID(iFreq),realBuffer(1:nSpace),start=(/1,outputTimestep(iFreq)/),count=(/nSpace,1/)) + end select + call netcdf_err(err,message); if (err/=0) return + + ! **************************************************************************** + ! *** write non-scalar variables (regular data structures -- instantaneous) + ! **************************************************************************** + + ! non-scalar variables: regular data structures + else + + ! initialize the data vectors + select type (datt) + class is (gru_hru_doubleVec); nSpace = nHRUrun; realArray(:,:) = realMissing; dataType=ixReal + class is (gru_hru_intVec); nSpace = nHRUrun; intArray(:,:) = integerMissing; dataType=ixInteger + class is (gru_doubleVec); nSpace = nGRUrun; realArray(:,:) = realMissing; dataType=ixReal + class is (gru_intVec); nSpace = nGRUrun; intArray(:,:) = integerMissing; dataType=ixInteger + class default; message=trim(message)//'data is not scalarv so should be either of type gru_hru_[double or int]Vec or gru_[double or int]Vec';err=20; return + end select + + ! loop thru GRUs and HRUs + do iGRU=1,size(gru_struc) + do iHRU=1,gru_struc(iGRU)%hruCount + + ! get the model layers + nSoil = indx%gru(iGRU)%hru(iHRU)%var(iLookINDEX%nSoil)%dat(1) + nSnow = indx%gru(iGRU)%hru(iHRU)%var(iLookINDEX%nSnow)%dat(1) + nLayers = indx%gru(iGRU)%hru(iHRU)%var(iLookINDEX%nLayers)%dat(1) + + ! get the length of each data vector + select case (meta(iVar)%varType) + case(iLookVarType%wLength); datLength = nSpecBand + case(iLookVarType%midToto); datLength = nLayers + case(iLookVarType%midSnow); datLength = nSnow + case(iLookVarType%midSoil); datLength = nSoil + case(iLookVarType%ifcToto); datLength = nLayers+1 + case(iLookVarType%ifcSnow); datLength = nSnow+1 + case(iLookVarType%ifcSoil); datLength = nSoil+1 + case(iLookVarType%routing); datLength = nTimeDelay + case default; cycle iVarLoop + ! case parSoil only in parameters (mpar, not written here) + ! case unknown skipped above + end select ! varType + + ! get the data vectors + select type (datt) + class is (gru_hru_doubleVec); realArray(gru_struc(iGRU)%hruInfo(iHRU)%hru_ix,1:datLength) = datt%gru(iGRU)%hru(iHRU)%var(iVar)%dat(:) + class is (gru_hru_intVec); intArray(gru_struc(iGRU)%hruInfo(iHRU)%hru_ix,1:datLength) = datt%gru(iGRU)%hru(iHRU)%var(iVar)%dat(:) + class is (gru_doubleVec); realArray(iGRU,1:datLength) = datt%gru(iGRU)%var(iVar)%dat(:); exit ! only need to get the GRU-level data once + class is (gru_intVec); intArray(iGRU,1:datLength) = datt%gru(iGRU)%var(iVar)%dat(:); exit ! only need to get the GRU-level data once + end select + + end do ! HRU loop + end do ! GRU loop + + ! get the maximum length of each data vector + select case (meta(iVar)%varType) + case(iLookVarType%wLength); maxLength = nSpecBand + case(iLookVarType%midToto); maxLength = maxLayers + case(iLookVarType%midSnow); maxLength = maxSnowLayers + case(iLookVarType%midSoil); maxLength = maxSoilLayers + case(iLookVarType%ifcToto); maxLength = maxLayers+1 + case(iLookVarType%ifcSnow); maxLength = maxSnowLayers+1 + case(iLookVarType%ifcSoil); maxLength = maxSoilLayers+1 + case(iLookVarType%routing); maxLength = nTimeDelay + case default; cycle iVarLoop ! move onto the next variable + end select ! varType + + ! write the data vectors + if(maxLength==0) cycle iVarLoop ! skip if there is no length + select case (dataType) + case(ixReal); err = nf90_put_var(ncid(iFreq),meta(iVar)%ncVarID(iFreq),realArray(1:nSpace,1:maxLength),start=(/1,1,outputTimestep(iFreq)/),count=(/nSpace,maxLength,1/)) + case(ixInteger); err = nf90_put_var(ncid(iFreq),meta(iVar)%ncVarID(iFreq),intArray(1:nSpace,1:maxLength),start=(/1,1,outputTimestep(iFreq)/),count=(/nSpace,maxLength,1/)) + end select ! data type + call netcdf_err(err,message); if (err/=0) return + + end if ! not scalarv + + end do iVarLoop ! iVar end do ! iFreq - end subroutine writeBasin + end subroutine writeData_perStep ! ************************************************************************************** ! public subroutine writeTime: write current time to all files ! ************************************************************************************** - subroutine writeTime(finalizeStats,outputTimestep,meta,dat,err,message) + subroutine writeTime(finalizeStats,outputTimestep,meta,datt,err,message) USE data_types,only:var_info ! metadata type USE globalData,only:ncid ! output file IDs USE var_lookup,only:iLookSTAT ! index into stat structure @@ -396,7 +500,7 @@ subroutine writeTime(finalizeStats,outputTimestep,meta,dat,err,message) logical(lgt) ,intent(in) :: finalizeStats(:) ! flags to finalize statistics integer(i4b) ,intent(in) :: outputTimestep(:) ! output time step type(var_info),intent(in) :: meta(:) ! meta data - integer ,intent(in) :: dat(:) ! timestep data + integer ,intent(in) :: datt(:) ! timestep data integer(i4b) ,intent(out) :: err ! error code character(*) ,intent(out) :: message ! error message ! local variables @@ -404,7 +508,7 @@ subroutine writeTime(finalizeStats,outputTimestep,meta,dat,err,message) integer(i4b) :: iFreq ! frequency index integer(i4b) :: ncVarID ! used only for time ! initialize error control - err=0;message="f-writeTime/" + err=0;message="writeTime/" ! loop through output frequencies do iFreq=1,maxvarFreq @@ -425,7 +529,7 @@ subroutine writeTime(finalizeStats,outputTimestep,meta,dat,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/)) + err = nf90_put_var(ncid(iFreq),ncVarID,(/datt(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 @@ -436,7 +540,7 @@ subroutine writeTime(finalizeStats,outputTimestep,meta,dat,err,message) end subroutine writeTime ! ********************************************************************************************************* - ! public subroutine printRestartFile: print a re-start file + ! public subroutine writeRestart: print a re-start file ! ********************************************************************************************************* subroutine writeRestart(filename, & ! intent(in): name of restart file nGRU, & ! intent(in): number of GRUs @@ -445,8 +549,6 @@ subroutine writeRestart(filename, & ! intent(in): name of restart file prog_data, & ! intent(in): prognostics data bvar_meta, & ! intent(in): basin (gru) variable metadata bvar_data, & ! intent(in): basin (gru) variable data - maxLayers, & ! intent(in): maximum number of layers - maxSnowLayers, & ! intent(in): maximum number of snow layers indx_meta, & ! intent(in): index metadata indx_data, & ! intent(in): index data err,message) ! intent(out): error control @@ -463,7 +565,6 @@ subroutine writeRestart(filename, & ! intent(in): name of restart file ! external routines USE netcdf_util_module,only:nc_file_close ! close netcdf file USE netcdf_util_module,only:nc_file_open ! open netcdf file - USE globalData,only:nTimeDelay ! number of timesteps in the time delay histogram USE def_output_module,only: write_hru_info ! write HRU information to netcdf file implicit none @@ -482,10 +583,6 @@ subroutine writeRestart(filename, & ! intent(in): name of restart file integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message ! -------------------------------------------------------------------------------------------------------- - ! dummy variables - integer(i4b), intent(in) :: maxLayers ! maximum number of total layers - integer(i4b), intent(in) :: maxSnowLayers ! maximum number of snow layers - ! local variables integer(i4b) :: ncid ! netcdf file id integer(i4b),allocatable :: ncVarID(:) ! netcdf variable id @@ -493,10 +590,7 @@ subroutine writeRestart(filename, & ! intent(in): name of restart file 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),parameter :: nSpectral=2 ! number of spectal bands integer(i4b),parameter :: nScalar=1 ! size of a scalar integer(i4b) :: nProgVars ! number of prognostic variables written to state file integer(i4b) :: hruDimID ! variable dimension ID @@ -536,45 +630,39 @@ subroutine writeRestart(filename, & ! intent(in): name of restart file nProgVars = size(prog_meta) allocate(ncVarID(nProgVars+1)) ! include 1 additional basin variable in ID array (possibly more later) - ! maximum number of soil layers - maxSoil = gru_struc(1)%hruInfo(1)%nSoil - - ! maximum number of snow layers - maxSnow = maxSnowLayers - ! create file err = nf90_create(trim(filename),NF90_NETCDF4,ncid) message='iCreate[create]'; call netcdf_err(err,message); if(err/=0)return ! define dimensions - err = nf90_def_dim(ncid,trim(gruDimName) ,nGRU , gruDimID); message='iCreate[gru]' ; call netcdf_err(err,message); if(err/=0)return - err = nf90_def_dim(ncid,trim(hruDimName) ,nHRU , hruDimID); message='iCreate[hru]' ; call netcdf_err(err,message); if(err/=0)return - err = nf90_def_dim(ncid,trim(tdhDimName) ,nTimeDelay , tdhDimID); message='iCreate[tdh]' ; call netcdf_err(err,message); if(err/=0)return - err = nf90_def_dim(ncid,trim(scalDimName) ,nScalar , scalDimID); message='iCreate[scalar]' ; call netcdf_err(err,message); if(err/=0)return - err = nf90_def_dim(ncid,trim(specDimName) ,nSpectral , specDimID); message='iCreate[spectral]'; call netcdf_err(err,message); if(err/=0)return - 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 + err = nf90_def_dim(ncid,trim(gruDimName) ,nGRU , gruDimID); message='iCreate[gru]' ; call netcdf_err(err,message); if(err/=0)return + err = nf90_def_dim(ncid,trim(hruDimName) ,nHRU , hruDimID); message='iCreate[hru]' ; call netcdf_err(err,message); if(err/=0)return + err = nf90_def_dim(ncid,trim(tdhDimName) ,nTimeDelay , tdhDimID); message='iCreate[tdh]' ; call netcdf_err(err,message); if(err/=0)return + err = nf90_def_dim(ncid,trim(scalDimName) ,nScalar , scalDimID); message='iCreate[scalar]' ; call netcdf_err(err,message); if(err/=0)return + err = nf90_def_dim(ncid,trim(specDimName) ,nSpecBand , specDimID); message='iCreate[spectral]'; 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(ifcTotoDimName),maxLayers+1 ,ifcTotoDimID); message='iCreate[ifcToto]' ; call netcdf_err(err,message); if(err/=0)return + if(maxSoilLayers>0) err = nf90_def_dim(ncid,trim(midSoilDimName),maxSoilLayers ,midSoilDimID); message='iCreate[midSoil]' ; call netcdf_err(err,message); if(err/=0)return + if(maxSoilLayers>0) err = nf90_def_dim(ncid,trim(ifcSoilDimName),maxSoilLayers+1 ,ifcSoilDimID); message='iCreate[ifcSoil]' ; call netcdf_err(err,message); if(err/=0)return + if(maxSnowLayers>0) err = nf90_def_dim(ncid,trim(midSnowDimName),maxSnowLayers ,midSnowDimID); message='iCreate[midSnow]' ; call netcdf_err(err,message); if(err/=0)return + if(maxSnowLayers>0) err = nf90_def_dim(ncid,trim(ifcSnowDimName),maxSnowLayers+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,nProgVars - if (prog_meta(iVar)%varType==iLookvarType%unknown) cycle + 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)) + 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%midToto); err = nf90_def_var(ncid,trim(prog_meta(iVar)%varName),nf90_double,(/hruDimID,midTotoDimID/),ncVarID(iVar)) + case(iLookVarType%ifcToto); err = nf90_def_var(ncid,trim(prog_meta(iVar)%varName),nf90_double,(/hruDimID,ifcTotoDimID/),ncVarID(iVar)) + case(iLookVarType%midSoil); if (maxSoilLayers>0) err = nf90_def_var(ncid,trim(prog_meta(iVar)%varName),nf90_double,(/hruDimID,midSoilDimID/),ncVarID(iVar)) + case(iLookVarType%ifcSoil); if (maxSoilLayers>0) err = nf90_def_var(ncid,trim(prog_meta(iVar)%varName),nf90_double,(/hruDimID,ifcSoilDimID/),ncVarID(iVar)) + case(iLookVarType%midSnow); if (maxSnowLayers>0) err = nf90_def_var(ncid,trim(prog_meta(iVar)%varName),nf90_double,(/hruDimID,midSnowDimID/),ncVarID(iVar)) + case(iLookVarType%ifcSnow); if (maxSnowLayers>0) err = nf90_def_var(ncid,trim(prog_meta(iVar)%varName),nf90_double,(/hruDimID,ifcSnowDimID/),ncVarID(iVar)) end select ! check errors @@ -618,23 +706,23 @@ subroutine writeRestart(filename, & ! intent(in): name of restart file do iVar = 1,size(prog_meta) ! excape if this variable is not used - if (prog_meta(iVar)%varType==iLookvarType%unknown) cycle + 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 + nLayers = nSnow + nSoil ! 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%wlength); okLength = (size(prog_data%gru(iGRU)%hru(iHRU)%var(iVar)%dat) == nSpecBand) 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%ifcSoil); if (nSoil>0) okLength = (size(prog_data%gru(iGRU)%hru(iHRU)%var(iVar)%dat) == nSoil+1 ) + case(iLookVarType%ifcToto); if (nSoil>0) 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 @@ -642,25 +730,25 @@ subroutine writeRestart(filename, & ! intent(in): name of restart file ! error check if(.not.okLength)then - message=trim(message)//'bad vector length for variable '//trim(prog_meta(iVar)%varname) + 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%wlength); err=nf90_put_var(ncid,ncVarID(iVar),(/prog_data%gru(iGRU)%hru(iHRU)%var(iVar)%dat/),start=(/cHRU,1/),count=(/1,nSpecBand/)) 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%ifcSoil); if (nSoil>0) 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); if (nSoil>0) 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) + if (err/=0) message=trim(message)//'writing variable:'//trim(prog_meta(iVar)%varName) call netcdf_err(err,message); if (err/=0) return err=0; message='writeRestart/' @@ -678,7 +766,7 @@ subroutine writeRestart(filename, & ! intent(in): name of restart file end do ! iGRU loop ! write HRU dimension and ID for file - call write_hru_info(ncid, err, cmessage); if(err/=0) then; message=trim(message)//trim(cmessage); return; end if + call write_hru_info(ncid, gruDimID, hruDimID, err, cmessage); if(err/=0) then; message=trim(message)//trim(cmessage); return; end if ! close file call nc_file_close(ncid,err,cmessage) diff --git a/build/source/netcdf/netcdf_util.f90 b/build/source/netcdf/netcdf_util.f90 index 2419de413..6eef5557c 100644 --- a/build/source/netcdf/netcdf_util.f90 +++ b/build/source/netcdf/netcdf_util.f90 @@ -19,7 +19,7 @@ ! along with this program. If not, see . module netcdf_util_module -USE nrtype +USE nr_type USE netcdf implicit none private diff --git a/build/source/netcdf/read_icond.f90 b/build/source/netcdf/read_icond.f90 index 127e8849e..fda413167 100644 --- a/build/source/netcdf/read_icond.f90 +++ b/build/source/netcdf/read_icond.f90 @@ -19,21 +19,17 @@ ! along with this program. If not, see . module read_icond_module -USE nrtype +USE nr_type USE netcdf -USE globalData,only: ixHRUfile_min,ixHRUfile_max -USE globalData,only: nTimeDelay ! number of hours in the time delay histogram -USE globalData,only: nSpecBand ! number of spectral bands -USE globalData,only:verySmaller ! a smaller number used as an additive constant to check if substantial difference among real numbers +USE globalData,only:ixHRUfile_min,ixHRUfile_max ! first and last HRUs in the forcing file +USE globalData,only:nTimeDelay ! number of timesteps in the time delay histogram +USE globalData,only:nSpecBand ! number of spectral bands implicit none private public::read_icond public::read_icond_nlayers -! define single HRU restart file -integer(i4b), parameter :: singleHRU=1001 -integer(i4b), parameter :: multiHRU=1002 -integer(i4b), parameter :: restartFileType=multiHRU + contains ! ************************************************************************************************ @@ -42,7 +38,7 @@ module read_icond_module subroutine read_icond_nlayers(iconFile,nGRU,indx_meta,err,message) ! -------------------------------------------------------------------------------------------------------- ! modules - USE nrtype + USE nr_type 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 @@ -55,34 +51,108 @@ subroutine read_icond_nlayers(iconFile,nGRU,indx_meta,err,message) ! -------------------------------------------------------------------------------------------------------- ! 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 + 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) :: iHRU_global ! index of HRU in the netcdf file - integer(i4b),allocatable :: snowData(:) ! number of snow layers in all HRUs - integer(i4b),allocatable :: soilData(:) ! number of soil layers in all HRUs - character(len=256) :: cmessage ! downstream error message - + integer(i4b) :: i,j ! loop indices + integer(i4b) :: ncid ! netcdf file id + integer(i4b) :: dimID ! netcdf file dimension id + integer(i4b) :: ncVarID ! netcdf variable id + integer(i4b) :: fileGRU ! number of GRUs in netcdf file + integer(i4b) :: fileHRU ! number of HRUs in netcdf file + integer(i4b) :: snowID, soilID ! netcdf variable ids + integer(i4b) :: iGRU, iHRU ! loop indexes + integer(i4b) :: iHRU_global ! index of HRU in the netcdf file + integer(i4b),allocatable :: snowData(:) ! number of snow layers in all HRUs + integer(i4b),allocatable :: soilData(:) ! number of soil layers in all HRUs + character(len=256) :: cmessage ! downstream error message + integer(i8b),allocatable :: gru_id(:) ! GRU id + integer(i8b),allocatable :: hru_id(:) ! HRU id + integer(i4b),allocatable :: index_to_hrunc(:,:) ! mapping from index to hru_nc in gru_struc + logical(lgt) :: has_gru_id ! flag for whether the file has gru_id + logical(lgt) :: has_hru_id ! flag for whether the file has hru_id ! -------------------------------------------------------------------------------------------------------- ! initialize error message err=0 message = 'read_icond_nlayers/' + has_gru_id = .true. + has_hru_id = .true. ! 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 + if (err/=nf90_noerr) then; message=trim(message)//trim(cmessage); return; end if - ! get number of HRUs in file (the GRU variable(s), if present, are processed at the end) - 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 + ! 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 + + ! check if the file has the hruId variable + allocate(hru_id(fileHRU)) + err = nf90_inq_varid(ncid,"hruId",ncVarID) + if (err/=nf90_noerr)then + write(*,*) 'WARNING: hruId is not in the initial conditions file ... assuming HRUs in attribute order' + has_hru_id = .false. + err=nf90_noerr ! reset this err + else + ! read hru_id from netcdf file + err = nf90_get_var(ncid,ncVarID,hru_id); if (err/=nf90_noerr) then; message=trim(message)//'problem reading hruId'; return; end if + end if + + ! check if the file has the GRU dimension + err = nf90_inq_dimid(ncid,"gru",dimID) + if(err/=nf90_noerr)then + write(*,*) 'WARNING: GRU is not in the initial conditions file ... assuming GRUs in attribute order' + has_gru_id = .false. + allocate(gru_id(1)) ! just allocate something to avoid problems with the deallocation at the end + err=nf90_noerr ! reset this err + else + err = nf90_inquire_dimension(ncid,dimID,len=fileGRU); if(err/=nf90_noerr)then; message=trim(message)//'problem reading gru dimension/'//trim(nf90_strerror(err)); return; end if + ! read gru_id from netcdf file + allocate(gru_id(fileGRU)) + err = nf90_inq_varid(ncid,"gruId",ncVarID) + if (err/=nf90_noerr) then + write(*,*) 'WARNING: gruId is not in the initial conditions file ... assuming GRUs in attribute order' + has_gru_id = .false. + err=nf90_noerr ! reset this err + else + ! read gru_id from netcdf file + err = nf90_get_var(ncid,ncVarID,gru_id); if (err/=nf90_noerr) then; message=trim(message)//'problem reading gruId'; return; end if + endif + end if + + ! Allocate the mapping arrays + allocate(index_to_hrunc(nGRU,maxval(gru_struc(:)%hruCount))) + + ! Populate the mapping arrays + if(has_gru_id .and. has_hru_id)then + ! if the file has both gru_id and hru_id, use these to populate the mapping arrays + do iGRU = 1, nGRU + do i = 1, fileGRU + if (gru_struc(iGRU)%gru_id == gru_id(i)) then + do iHRU = 1, gru_struc(iGRU)%hruCount + index_to_hrunc(iGRU,iHRU) = -1 + do j = 1, fileHRU + if (gru_struc(iGRU)%hruInfo(iHRU)%hru_id == hru_id(j)) then + index_to_hrunc(iGRU,iHRU) = j + exit + endif + end do + end do ! HRU id loop + exit + endif + end do + end do ! GRU id loop + else + ! assume that the order of the HRUs in the file matches the order of the HRUs in the model attributes + do iGRU = 1, nGRU + do iHRU = 1, gru_struc(iGRU)%hruCount + index_to_hrunc(iGRU,iHRU) = gru_struc(iGRU)%hruInfo(iHRU)%hru_nc + end do + end do + endif ! allocate storage for reading from file (allocate entire file size, even when doing subdomain run) allocate(snowData(fileHRU)) @@ -91,45 +161,39 @@ subroutine read_icond_nlayers(iconFile,nGRU,indx_meta,err,message) soilData = 0 ! get netcdf ids for the variables holding number of snow and soil layers in each hru - err = nf90_inq_varid(ncid,trim(indx_meta(iLookINDEX%nSnow)%varName),snowid); call netcdf_err(err,message) - err = nf90_inq_varid(ncid,trim(indx_meta(iLookINDEX%nSoil)%varName),soilid); call netcdf_err(err,message) + err = nf90_inq_varid(ncid,trim(indx_meta(iLookINDEX%nSnow)%varName),snowID); call netcdf_err(err,message) + err = nf90_inq_varid(ncid,trim(indx_meta(iLookINDEX%nSoil)%varName),soilID); call netcdf_err(err,message) ! get nSnow and nSoil data (reads entire state file) - err = nf90_get_var(ncid,snowid,snowData); call netcdf_err(err,message) - err = nf90_get_var(ncid,soilid,soilData); call netcdf_err(err,message) + err = nf90_get_var(ncid,snowID,snowData); call netcdf_err(err,message) + err = nf90_get_var(ncid,soilID,soilData); call netcdf_err(err,message) + ! find the min and max hru indices in the state file ixHRUfile_min=huge(1) ixHRUfile_max=0 - ! find the min and max hru indices in the state file do iGRU = 1,nGRU - do iHRU = 1,gru_struc(iGRU)%hruCount - if(gru_struc(iGRU)%hruInfo(iHRU)%hru_nc < ixHRUfile_min) ixHRUfile_min = gru_struc(iGRU)%hruInfo(iHRU)%hru_nc - if(gru_struc(iGRU)%hruInfo(iHRU)%hru_nc > ixHRUfile_max) ixHRUfile_max = gru_struc(iGRU)%hruInfo(iHRU)%hru_nc - end do + do iHRU = 1,gru_struc(iGRU)%hruCount + if(gru_struc(iGRU)%hruInfo(iHRU)%hru_nc < ixHRUfile_min) ixHRUfile_min = gru_struc(iGRU)%hruInfo(iHRU)%hru_nc + if(gru_struc(iGRU)%hruInfo(iHRU)%hru_nc > ixHRUfile_max) ixHRUfile_max = gru_struc(iGRU)%hruInfo(iHRU)%hru_nc + end do end do ! loop over grus in current run to update snow/soil layer information do iGRU = 1,nGRU - do iHRU = 1,gru_struc(iGRU)%hruCount - iHRU_global = gru_struc(iGRU)%hruInfo(iHRU)%hru_nc - ! single HRU (Note: 'restartFileType' is hardwired above to multiHRU) - if(restartFileType==singleHRU) then - gru_struc(iGRU)%hruInfo(iHRU)%nSnow = snowData(1) - gru_struc(iGRU)%hruInfo(iHRU)%nSoil = soilData(1) - ! multi HRU - else - gru_struc(iGRU)%hruInfo(iHRU)%nSnow = snowData(iHRU_global) - gru_struc(iGRU)%hruInfo(iHRU)%nSoil = soilData(iHRU_global) - endif - end do + do iHRU = 1,gru_struc(iGRU)%hruCount + iHRU_global = index_to_hrunc(iGRU,iHRU) ! index of HRU in the netcdf file + gru_struc(iGRU)%hruInfo(iHRU)%nSnow = snowData(iHRU_global) + gru_struc(iGRU)%hruInfo(iHRU)%nSoil = soilData(iHRU_global) + 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 + if(err/=nf90_noerr)then;message=trim(message)//trim(cmessage);return;end if ! cleanup deallocate(snowData,soilData) + deallocate(gru_id,hru_id,index_to_hrunc) end subroutine read_icond_nlayers @@ -147,7 +211,7 @@ subroutine read_icond(iconFile, & ! intent(in): name of err,message) ! intent(out): error control ! -------------------------------------------------------------------------------------------------------- ! modules - USE nrtype + USE nr_type USE var_lookup,only:iLookVarType ! variable lookup structure USE var_lookup,only:iLookPROG ! variable lookup structure USE var_lookup,only:iLookPARAM ! variable lookup structure @@ -156,7 +220,7 @@ subroutine read_icond(iconFile, & ! intent(in): name of USE globalData,only:prog_meta ! metadata for prognostic variables USE globalData,only:bvar_meta ! metadata for basin (GRU) variables USE globalData,only:gru_struc ! gru-hru mapping structures - USE globalData,only:startGRU ! index of first gru for parallel runs + USE globalData,only:startGRU ! index of first gru for parallel runs USE globalData,only:iname_soil,iname_snow ! named variables to describe the type of layer USE netcdf_util_module,only:nc_file_open ! open netcdf file USE netcdf_util_module,only:nc_file_close ! close netcdf file @@ -164,10 +228,8 @@ subroutine read_icond(iconFile, & ! intent(in): name of USE data_types,only:gru_hru_doubleVec ! full double precision structure USE data_types,only:gru_hru_intVec ! full integer structure USE data_types,only:gru_doubleVec ! gru-length double precision structure (basin variables) - USE data_types,only:var_dlength ! double precision structure for a single HRU - USE data_types,only:var_info ! metadata USE get_ixName_module,only:get_varTypeName ! to access type strings for error messages - USE updatState_module,only:updateSoil ! update soil states + USE updatState_module,only:updatSoil ! update soil states implicit none ! -------------------------------------------------------------------------------------------------------- @@ -186,7 +248,7 @@ subroutine read_icond(iconFile, & ! intent(in): name of character(len=256) :: cmessage ! downstream error message integer(i4b) :: fileHRU ! number of HRUs in file integer(i4b) :: fileGRU ! number of GRUs in file - integer(i4b) :: iVar, i ! loop indices + integer(i4b) :: iVar,i,j ! loop indices integer(i4b),dimension(1) :: ndx ! intermediate array of loop indices integer(i4b) :: iGRU ! loop index integer(i4b) :: iHRU ! loop index @@ -194,9 +256,8 @@ subroutine read_icond(iconFile, & ! intent(in): name of integer(i4b) :: ncVarID ! variable ID in netcdf file character(256) :: dimName ! not used except as a placeholder in call to inq_dim function integer(i4b) :: dimLen ! data dimensions - integer(i4b) :: ncID ! netcdf file ID - integer(i4b) :: ixFile ! index in file - integer(i4b) :: iHRU_local ! index of HRU in the data subset + integer(i4b) :: ncid ! netcdf file ID + integer(i4b) :: iGRU_global ! index of GRU in the netcdf file integer(i4b) :: iHRU_global ! index of HRU in the netcdf file real(rkind),allocatable :: varData(:,:) ! variable data storage integer(i4b) :: nSoil, nSnow, nToto ! # layers @@ -207,22 +268,97 @@ subroutine read_icond(iconFile, & ! intent(in): name of character(len=32),parameter :: midTotoDimName='midToto' ! dimension name for layered varaiables character(len=32),parameter :: ifcTotoDimName='ifcToto' ! dimension name for layered varaiables character(len=32),parameter :: tdhDimName ='tdh' ! dimension name for time-delay basin variables - + integer(i8b),allocatable :: gru_id(:) ! GRU id + integer(i8b),allocatable :: hru_id(:) ! HRU id + integer(i4b),allocatable :: index_to_gruid(:) ! mapping from index to gru_id in gru_struc + integer(i4b),allocatable :: index_to_hrunc(:,:) ! mapping from index to hru_nc in gru_struc + logical(lgt) :: has_gru_id ! flag for whether the file has gru_id + logical(lgt) :: has_hru_id ! flag for whether the file has hru_id ! -------------------------------------------------------------------------------------------------------- ! Start procedure here err=0; message="read_icond/" + has_gru_id = .true. + has_hru_id = .true. ! -------------------------------------------------------------------------------------------------------- ! (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 + call nc_file_open(iconFile,nf90_nowrite,ncid,err,cmessage) + if (err/=nf90_noerr) 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 + 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 + + ! check if the file has the hruId variable + allocate(hru_id(fileHRU)) + err = nf90_inq_varid(ncid,"hruId",ncVarID) + if (err/=nf90_noerr)then + has_hru_id = .false. + err=nf90_noerr ! reset this err + else + ! read hru_id from netcdf file + err = nf90_get_var(ncid,ncVarID,hru_id); if (err/=nf90_noerr) then; message=trim(message)//'problem reading hruId'; return; end if + end if + + ! check if the file has the GRU dimension + err = nf90_inq_dimid(ncid,"gru",dimID) + if(err/=nf90_noerr)then + has_gru_id = .false. + allocate(gru_id(1)) ! just allocate something to avoid problems with the deallocation at the end + err=nf90_noerr ! reset this err + else + err = nf90_inquire_dimension(ncid,dimID,len=fileGRU); if(err/=nf90_noerr)then; message=trim(message)//'problem reading gru dimension/'//trim(nf90_strerror(err)); return; end if + ! read gru_id from netcdf file + allocate(gru_id(fileGRU)) + err = nf90_inq_varid(ncid,"gruId",ncVarID) + if (err/=nf90_noerr) then + has_gru_id = .false. + err=nf90_noerr ! reset this err + else + ! read gru_id from netcdf file + err = nf90_get_var(ncid,ncVarID,gru_id); if (err/=nf90_noerr) then; message=trim(message)//'problem reading gruId'; return; end if + endif + end if + + ! Allocate the mapping arrays + allocate(index_to_gruid(nGRU), index_to_hrunc(nGRU,maxval(gru_struc(:)%hruCount))) + + ! Populate the mapping arrays + if(has_gru_id .and. has_hru_id)then + ! if the file has both gru_id and hru_id, use these to populate the mapping arrays + do iGRU = 1, nGRU + index_to_gruid(iGRU) = -1 ! Initialize with an invalid index + do i = 1, fileGRU + if (gru_struc(iGRU)%gru_id == gru_id(i)) then + index_to_gruid(iGRU) = i + do iHRU = 1, gru_struc(iGRU)%hruCount + index_to_hrunc(iGRU,iHRU) = -1 + do j = 1, fileHRU + if (gru_struc(iGRU)%hruInfo(iHRU)%hru_id == hru_id(j)) then + index_to_hrunc(iGRU,iHRU) = j + exit + endif + end do + end do ! HRU id loop + exit + endif + end do + end do ! GRU id loop + else + ! assume that the order of the HRUs in the file matches the order of the HRUs in the model attributes + do iGRU = 1, nGRU + index_to_gruid(iGRU) = iGRU + startGRU - 1 + do iHRU = 1, gru_struc(iGRU)%hruCount + index_to_hrunc(iGRU,iHRU) = gru_struc(iGRU)%hruInfo(iHRU)%hru_nc + end do + end do + endif + ! -------------------------------------------------------------------------------------------------------- + ! (2) read the prognostic variables + ! -------------------------------------------------------------------------------------------------------- ! loop through prognostic variables no_icond_enth=.false. do iVar = 1,size(prog_meta) @@ -235,7 +371,7 @@ subroutine read_icond(iconFile, & ! intent(in): name of prog_meta(iVar)%varName=='mLayerHeight' ) cycle ! get variable id - err = nf90_inq_varid(ncID,trim(prog_meta(iVar)%varName),ncVarID) + err = nf90_inq_varid(ncid,trim(prog_meta(iVar)%varName),ncVarID) if(err/=nf90_noerr)then if(prog_meta(iVar)%varName=='scalarCanairEnthalpy' .or. & prog_meta(iVar)%varName=='scalarCanopyEnthalpy' .or. & @@ -247,73 +383,55 @@ subroutine read_icond(iconFile, & ! intent(in): name of ! 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 (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 + if(err/=nf90_noerr)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 + err = nf90_inquire_dimension(ncid,dimID,dimName,dimLen); call netcdf_err(err,message) + if(err/=nf90_noerr)then; message=trim(message)//': problem getting the dimension length'; return; endif ! initialize the variable data allocate(varData(fileHRU,dimLen),stat=err) if(err/=0)then; message=trim(message)//'problem allocating HRU 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 for variable '//trim(prog_meta(iVar)%varName); return; endif + err = nf90_get_var(ncid,ncVarID,varData); call netcdf_err(err,message) + if(err/=nf90_noerr)then; message=trim(message)//': problem getting the data for variable '//trim(prog_meta(iVar)%varName); return; endif ! store data in prognostics structure - ! loop through GRUs do iGRU = 1,nGRU do iHRU = 1,gru_struc(iGRU)%hruCount - - iHRU_global = gru_struc(iGRU)%hruInfo(iHRU)%hru_nc - iHRU_local = (iHRU_global - ixHRUfile_min) + 1 - + iHRU_global = index_to_hrunc(iGRU,iHRU) ! index of HRU in the netcdf file ! get the number of layers nSnow = gru_struc(iGRU)%hruInfo(iHRU)%nSnow nSoil = gru_struc(iGRU)%hruInfo(iHRU)%nSoil nToto = nSnow + nSoil - ! get the index in the file: single HRU - if(restartFileType==singleHRU)then - ixFile = 1 ! use for single HRU restart file - ! get the index in the file: multi HRU - else - ixFile = iHRU_global - endif - ! put the data into data structures and check that none of the values are set to nf90_fill_double select case (prog_meta(iVar)%varType) case (iLookVarType%scalarv) - progData%gru(iGRU)%hru(iHRU)%var(iVar)%dat(1) = varData(ixFile,1) + progData%gru(iGRU)%hru(iHRU)%var(iVar)%dat(1) = varData(iHRU_global,1) if(abs(progData%gru(iGRU)%hru(iHRU)%var(iVar)%dat(1) - nf90_fill_double) < epsilon(varData))then; err=20; endif case (iLookVarType%midSoil) - progData%gru(iGRU)%hru(iHRU)%var(iVar)%dat(1:nSoil) = varData(ixFile,1:nSoil) + progData%gru(iGRU)%hru(iHRU)%var(iVar)%dat(1:nSoil) = varData(iHRU_global,1:nSoil) if(any(abs(progData%gru(iGRU)%hru(iHRU)%var(iVar)%dat(1:nSoil) - nf90_fill_double) < epsilon(varData)))then; err=20; endif case (iLookVarType%midToto) - progData%gru(iGRU)%hru(iHRU)%var(iVar)%dat(1:nToto) = varData(ixFile,1:nToto) + progData%gru(iGRU)%hru(iHRU)%var(iVar)%dat(1:nToto) = varData(iHRU_global,1:nToto) if(any(abs(progData%gru(iGRU)%hru(iHRU)%var(iVar)%dat(1:nToto) - nf90_fill_double) < epsilon(varData)))then; err=20; endif case (iLookVarType%ifcToto) - progData%gru(iGRU)%hru(iHRU)%var(iVar)%dat(0:nToto) = varData(ixFile,1:nToto+1) + progData%gru(iGRU)%hru(iHRU)%var(iVar)%dat(0:nToto) = varData(iHRU_global,1:nToto+1) if(any(abs(progData%gru(iGRU)%hru(iHRU)%var(iVar)%dat(0:nToto) - nf90_fill_double) < epsilon(varData)))then; err=20; endif 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 - if(err==20)then; message=trim(message)//"data set to the fill value (name='"//trim(prog_meta(iVar)%varName)//"')"; return; endif if(prog_meta(iVar)%varName=='iLayerHeight')then ! last variable in the loop, so we can correct prognostic variables if had legacy starting values @@ -336,25 +454,26 @@ subroutine read_icond(iconFile, & ! intent(in): name of end do ! end looping through prognostic variables (iVar) ! -------------------------------------------------------------------------------------------------------- - ! (2) set number of layers + ! (3) 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 + nSnow = gru_struc(iGRU)%hruInfo(iHRU)%nSnow + nSoil = gru_struc(iGRU)%hruInfo(iHRU)%nSoil + indxData%gru(iGRU)%hru(iHRU)%var(iLookINDEX%nSnow)%dat(1) = nSnow + indxData%gru(iGRU)%hru(iHRU)%var(iLookINDEX%nSoil)%dat(1) = nSoil + indxData%gru(iGRU)%hru(iHRU)%var(iLookINDEX%nLayers)%dat(1) = nSnow + nSoil ! 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 - + indxData%gru(iGRU)%hru(iHRU)%var(iLookINDEX%layerType)%dat(1:nSnow) = iname_snow + indxData%gru(iGRU)%hru(iHRU)%var(iLookINDEX%layerType)%dat((nSnow+1):(nSnow+nSoil)) = iname_soil end do end do ! -------------------------------------------------------------------------------------------------------- - ! (3) update soil layers (diagnostic variables) + ! (4) update soil layers (diagnostic variables) ! -------------------------------------------------------------------------------------------------------- ! loop through GRUs and HRUs do iGRU = 1,nGRU @@ -367,7 +486,7 @@ subroutine read_icond(iconFile, & ! intent(in): name of jLayer = iLayer+indxData%gru(iGRU)%hru(iHRU)%var(iLookINDEX%nSnow)%dat(1) ! update soil layers - call updateSoil(& + call updatSoil(& ! input progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerTemp )%dat(jLayer),& ! intent(in): temperature vector (K) progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerMatricHead )%dat(iLayer),& ! intent(in): matric head (m) @@ -380,7 +499,7 @@ subroutine read_icond(iconFile, & ! intent(in): name of progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerVolFracWat )%dat(jLayer),& ! intent(out): volumetric fraction of total water (-) progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerVolFracLiq )%dat(jLayer),& ! intent(out): volumetric fraction of liquid water (-) progData%gru(iGRU)%hru(iHRU)%var(iLookPROG%mLayerVolFracIce )%dat(jLayer),& ! intent(out): volumetric fraction of ice (-) - err,message) ! intent(out): error control + err,cmessage) ! intent(out): error control if (err/=0) then; message=trim(message)//trim(cmessage); return; end if end do ! looping through soil layers @@ -388,81 +507,75 @@ subroutine read_icond(iconFile, & ! intent(in): name of end do ! looping through GRUs ! -------------------------------------------------------------------------------------------------------- - ! (2) now get the basin variable(s) + ! (5) get the basin variable(s) ! -------------------------------------------------------------------------------------------------------- - ! get the index in the file: single HRU - if(restartFileType/=singleHRU)then - - ! get dimension of time delay histogram (TDH) from initial conditions file - err = nf90_inq_dimid(ncID,"tdh",dimID); - if(err/=nf90_noerr)then - write(*,*) 'WARNING: routingRunoffFuture is not in the initial conditions file ... using zeros' ! previously created in var_derive.f90 - err=nf90_noerr ! reset this err - - else - ! the state file *does* have the basin variable(s), so process them - err = nf90_inquire_dimension(ncID,dimID,len=nTDH); - if(err/=nf90_noerr)then; message=trim(message)//'problem reading tdh dimension from initial condition file/'//trim(nf90_strerror(err)); return; end if - - ! get number of GRUs in file - err = nf90_inq_dimid(ncID,"gru",dimID); if(err/=nf90_noerr)then; message=trim(message)//'problem finding gru dimension/'//trim(nf90_strerror(err)); return; end if - err = nf90_inquire_dimension(ncID,dimID,len=fileGRU); if(err/=nf90_noerr)then; message=trim(message)//'problem reading gru dimension/'//trim(nf90_strerror(err)); return; end if - - ! check vs hardwired value set in globalData.f90 - if(nTDH /= nTimeDelay)then - write(*,*) 'tdh=',nTDH,' nTimeDelay=',nTimeDelay - message=trim(message)//': state file time delay dimension tdh does not match summa expectation of nTimeDelay set in globalData()' - return - endif - - ! loop through specific basin variables (currently 1 but loop provided to enable inclusion of others) - ndx = (/iLookBVAR%routingRunoffFuture/) ! array of desired variable indices - do i = 1,size(ndx) - iVar = ndx(i) - - ! get tdh dimension Id in file (should be 'tdh') - err = nf90_inq_dimid(ncID,trim(tdhDimName), dimID); - if(err/=0)then; message=trim(message)//': problem with dimension ids for tdh vars'; return; endif - - ! get the tdh dimension length (dimName and dimLen are outputs of this call) - 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 for tdh vars'; return; endif - - ! get tdh-based variable id - err = nf90_inq_varid(ncID,trim(bvar_meta(iVar)%varName),ncVarID); call netcdf_err(err,message) - if(err/=0)then; message=trim(message)//': problem with getting basin variable id, var='//trim(bvar_meta(iVar)%varName); return; endif - - ! initialize the tdh variable data - allocate(varData(fileGRU,dimLen),stat=err) - if(err/=0)then; print*, 'err= ',err; message=trim(message)//'problem allocating GRU 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 - - ! store data in basin var (bvar) structure - do iGRU = 1,nGRU - - ! put the data into data structures - bvarData%gru(iGRU)%var(iVar)%dat(1:nTDH) = varData((iGRU+startGRU-1),1:nTDH) - ! check whether the first values is set to nf90_fill_double - if(any(abs(bvarData%gru(iGRU)%var(iVar)%dat(1:nTDH) - nf90_fill_double) < epsilon(varData)))then; err=20; endif - if(err==20)then; message=trim(message)//"data set to the fill value (name='"//trim(bvar_meta(iVar)%varName)//"')"; return; endif - - end do ! end iGRU loop - - ! deallocate temporary data array for next variable - deallocate(varData, stat=err) - if(err/=0)then; message=trim(message)//'problem deallocating GRU variable data'; return; endif + ! get dimension of time delay histogram (TDH) from initial conditions file + err = nf90_inq_dimid(ncid,"tdh",dimID); + if(err/=nf90_noerr)then + write(*,*) 'WARNING: routingRunoffFuture is not in the initial conditions file ... using zeros' ! previously created in var_derive.f90 + err=nf90_noerr ! reset this err + + else + ! the state file *does* have the basin variable(s), so process them + err = nf90_inquire_dimension(ncid,dimID,len=nTDH); + if(err/=nf90_noerr)then; message=trim(message)//'problem reading tdh dimension from initial condition file/'//trim(nf90_strerror(err)); return; end if + + ! check vs hardwired value set in globalData.f90 + if(nTDH /= nTimeDelay)then + write(*,*) 'tdh=',nTDH,' nTimeDelay=',nTimeDelay + message=trim(message)//': state file time delay dimension tdh does not match summa expectation of nTimeDelay set in globalData()' + return + endif - end do ! end looping through basin variables - endif ! end if case for tdh variables being in init. cond. file - endif ! end if case for not being a singleHRU run + ! loop through specific basin variables (currently 1 but loop provided to enable inclusion of others) + ndx = (/iLookBVAR%routingRunoffFuture/) ! array of desired variable indices + do i = 1,size(ndx) + iVar = ndx(i) + + ! get tdh dimension Id in file (should be 'tdh') + err = nf90_inq_dimid(ncid,trim(tdhDimName), dimID); + if(err/=nf90_noerr)then; message=trim(message)//': problem with dimension ids for tdh vars'; return; endif + + ! get the tdh dimension length (dimName and dimLen are outputs of this call) + err = nf90_inquire_dimension(ncid,dimID,dimName,dimLen); call netcdf_err(err,message) + if(err/=nf90_noerr)then; message=trim(message)//': problem getting the dimension length for tdh vars'; return; endif + + ! get tdh-based variable id + err = nf90_inq_varid(ncid,trim(bvar_meta(iVar)%varName),ncVarID); call netcdf_err(err,message) + if(err/=nf90_noerr)then; message=trim(message)//': problem with getting basin variable id, var='//trim(bvar_meta(iVar)%varName); return; endif + + ! initialize the tdh variable data + allocate(varData(fileGRU,dimLen),stat=err) + if(err/=0)then; message=trim(message)//'problem allocating GRU variable data'; return; endif + + ! get data + err = nf90_get_var(ncid,ncVarID,varData); call netcdf_err(err,message) + if(err/=nf90_noerr)then; message=trim(message)//': problem getting the data'; return; endif + + ! store data in basin var (bvar) structure + do iGRU = 1,nGRU + iGRU_global = index_to_gruid(iGRU) ! index of GRU in the netcdf file + ! put the data into data structures + bvarData%gru(iGRU)%var(iVar)%dat(1:nTDH) = varData(iGRU_global,1:nTDH) + ! check whether the first values is set to nf90_fill_double + if(any(abs(bvarData%gru(iGRU)%var(iVar)%dat(1:nTDH) - nf90_fill_double) < epsilon(varData)))then; err=20; endif + if(err==20)then; message=trim(message)//"data set to the fill value (name='"//trim(bvar_meta(iVar)%varName)//"')"; return; endif + end do ! end iGRU loop + + ! deallocate temporary data array for next variable + deallocate(varData, stat=err) + if(err/=nf90_noerr)then; message=trim(message)//'problem deallocating GRU variable data'; return; endif + + end do ! end looping through basin variables + endif ! end if case for tdh variables being in init. cond. file - call nc_file_close(ncID,err,cmessage) + call nc_file_close(ncid,err,cmessage) if(err/=0)then;message=trim(message)//trim(cmessage);return;end if + ! cleanup + deallocate(gru_id,hru_id,index_to_gruid,index_to_hrunc) + 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 index a1380871f..6f203dad4 100644 --- a/build/source/noah-mp/module_model_constants.F +++ b/build/source/noah-mp/module_model_constants.F @@ -2,7 +2,7 @@ ! MODULE module_model_constants - USE nrtype + USE nr_type ! 2. Following are constants for use in defining real number bounds. diff --git a/build/source/noah-mp/module_sf_noahlsm.F b/build/source/noah-mp/module_sf_noahlsm.F index 56da70cd6..b81045dd6 100644 --- a/build/source/noah-mp/module_sf_noahlsm.F +++ b/build/source/noah-mp/module_sf_noahlsm.F @@ -1,5 +1,5 @@ MODULE module_sf_noahlsm - USE nrtype + USE nr_type USE module_model_constants ! REAL(rkind), PARAMETER :: CP = 1004.5 diff --git a/build/source/noah-mp/module_sf_noahmplsm.F b/build/source/noah-mp/module_sf_noahmplsm.F index 7b1236442..147e80d15 100644 --- a/build/source/noah-mp/module_sf_noahmplsm.F +++ b/build/source/noah-mp/module_sf_noahmplsm.F @@ -1,5 +1,5 @@ module noahmp_globals - USE nrtype + USE nr_type ! Maybe most of these can be moved to a REDPRM use statement? ! MPC -- yes, all of these variables can be local to REDPRM (see additional comments) @@ -201,7 +201,7 @@ END MODULE NOAHMP_GLOBALS !------------------------------------------------------------------------------------------! !------------------------------------------------------------------------------------------! MODULE NOAHMP_VEG_PARAMETERS - use nrtype + use nr_type IMPLICIT NONE INTEGER, PARAMETER :: MAX_VEG_PARAMS = 33 @@ -440,7 +440,7 @@ END MODULE NOAHMP_VEG_PARAMETERS ! ================================================================================================== ! ================================================================================================== MODULE NOAHMP_RAD_PARAMETERS - use nrtype + use nr_type IMPLICIT NONE @@ -482,7 +482,7 @@ END MODULE NOAHMP_RAD_PARAMETERS ! ================================================================================================== MODULE NOAHMP_ROUTINES - use nrtype + use nr_type USE NOAHMP_GLOBALS IMPLICIT NONE @@ -794,9 +794,9 @@ SUBROUTINE ALBEDO (VEGTYP ,IST ,ISC ,NSOIL ,DT , & !in ! local REAL(rkind) :: FAGE !snow age function REAL(rkind) :: ALB - INTEGER :: IB !indices - INTEGER :: NBAND !number of solar radiation wave bands - INTEGER :: IC !direct beam: ic=0; diffuse: ic=1 + INTEGER :: IB !indices + INTEGER :: NBAND !number of solar radiation wave bands + INTEGER :: IC !direct beam: ic=0; diffuse: ic=1 REAL(rkind) :: WL !fraction of LAI+SAI that is LAI REAL(rkind) :: WS !fraction of LAI+SAI that is SAI @@ -1910,7 +1910,7 @@ END MODULE NOAHMP_ROUTINES ! ================================================================================================== MODULE MODULE_SF_NOAHMPLSM - use nrtype + use nr_type USE NOAHMP_ROUTINES USE NOAHMP_GLOBALS diff --git a/build/source/noah-mp/module_sf_noahutl.F b/build/source/noah-mp/module_sf_noahutl.F index b83c03afc..0fa8ef0f9 100644 --- a/build/source/noah-mp/module_sf_noahutl.F +++ b/build/source/noah-mp/module_sf_noahutl.F @@ -1,5 +1,5 @@ MODULE module_sf_noahutl - USE nrtype + USE nr_type REAL(rkind), PARAMETER :: CP = 1004.5, RD = 287.04, SIGMA = 5.67E-8, & CPH2O = 4.218E+3,CPICE = 2.106E+3, & diff --git a/build/source/engine/expIntegral.f90 b/build/source/numrec/expIntegral.f90 similarity index 98% rename from build/source/engine/expIntegral.f90 rename to build/source/numrec/expIntegral.f90 index 28f9fa3c8..017373c62 100644 --- a/build/source/engine/expIntegral.f90 +++ b/build/source/numrec/expIntegral.f90 @@ -1,5 +1,5 @@ module expIntegral_module -USE nrtype +USE nr_type implicit none private public::expint diff --git a/build/source/engine/f2008funcs.f90 b/build/source/numrec/f2008funcs.f90 similarity index 95% rename from build/source/engine/f2008funcs.f90 rename to build/source/numrec/f2008funcs.f90 index dda228a13..7844a65f4 100644 --- a/build/source/engine/f2008funcs.f90 +++ b/build/source/numrec/f2008funcs.f90 @@ -19,7 +19,7 @@ ! along with this program. If not, see . module f2008funcs_module -USE nrtype +USE nr_type implicit none private public::cloneStruc @@ -75,11 +75,11 @@ end function findIndex subroutine cloneStruc_rv(dataVec,lowerBound,source,mold,err,message) implicit none ! input-output: data vector for allocation/population - real(rkind),intent(inout),allocatable :: dataVec(:) ! data vector + real(rkind),intent(inout),allocatable :: dataVec(:) ! data vector ! input integer(i4b),intent(in) :: lowerBound ! lower bound - real(rkind),intent(in),optional :: source(lowerBound:) ! dataVec = shape of source + elements of source - real(rkind),intent(in),optional :: mold(lowerBound:) ! dataVec = shape of mold + real(rkind),intent(in),optional :: source(lowerBound:) ! dataVec = shape of source + elements of source + real(rkind),intent(in),optional :: mold(lowerBound:) ! dataVec = shape of mold ! error control integer(i4b),intent(out) :: err ! error code character(*),intent(out) :: message ! error message @@ -106,7 +106,7 @@ subroutine cloneStruc_rv(dataVec,lowerBound,source,mold,err,message) if(present(source))then; upperBound=ubound(source); end if if(present(mold)) then; upperBound=ubound(mold); end if - ! reallocate spcae + ! reallocate space 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 @@ -153,7 +153,7 @@ subroutine cloneStruc_iv(dataVec,lowerBound,source,mold,err,message) if(present(source))then; upperBound=ubound(source); end if if(present(mold)) then; upperBound=ubound(mold); end if - ! reallocate spcae + ! reallocate space 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 diff --git a/build/source/engine/hyp_2F1.f90 b/build/source/numrec/hyp_2F1.f90 similarity index 99% rename from build/source/engine/hyp_2F1.f90 rename to build/source/numrec/hyp_2F1.f90 index 33382a634..7304fe92b 100644 --- a/build/source/engine/hyp_2F1.f90 +++ b/build/source/numrec/hyp_2F1.f90 @@ -1,7 +1,7 @@ module hyp_2F1_module ! data types -USE nrtype +USE nr_type ! privacy implicit none diff --git a/build/source/engine/nrtype.f90 b/build/source/numrec/nr_type.f90 similarity index 97% rename from build/source/engine/nrtype.f90 rename to build/source/numrec/nr_type.f90 index 91088ada5..fb7de51ef 100644 --- a/build/source/engine/nrtype.f90 +++ b/build/source/numrec/nr_type.f90 @@ -1,4 +1,4 @@ -MODULE nrtype +MODULE nr_type IMPLICIT NONE SAVE ! data types @@ -27,4 +27,4 @@ MODULE nrtype real(rkind), parameter :: nr_quadMissing=-9999._qp ! missing quadruple precision number real(rkind), parameter :: nr_realMissing=-9999._rkind ! missing real number integer(i4b), parameter :: nr_integerMissing=-9999 ! missing integer -END MODULE nrtype +END MODULE nr_type diff --git a/build/source/engine/nr_utility.f90 b/build/source/numrec/nr_utils.f90 similarity index 98% rename from build/source/engine/nr_utility.f90 rename to build/source/numrec/nr_utils.f90 index 016f83a1b..97602e6c4 100644 --- a/build/source/engine/nr_utility.f90 +++ b/build/source/numrec/nr_utils.f90 @@ -1,5 +1,5 @@ -module nr_utility_module -USE nrtype +module nr_utils_module +USE nr_type ! contains functions that should really be part of the fortran standard, but are not implicit none INTERFACE arth @@ -147,4 +147,4 @@ SUBROUTINE swap(a,b) b=dum END SUBROUTINE swap -end module nr_utility_module +end module nr_utils_module diff --git a/build/source/engine/spline_int.f90 b/build/source/numrec/spline_int.f90 similarity index 99% rename from build/source/engine/spline_int.f90 rename to build/source/numrec/spline_int.f90 index 2141c0fe6..d3b9adbe1 100644 --- a/build/source/engine/spline_int.f90 +++ b/build/source/numrec/spline_int.f90 @@ -1,5 +1,5 @@ module spline_int_module -USE nrtype +USE nr_type implicit none private public::spline diff --git a/build/source/openwq/openWQ.f90 b/build/source/openwq/openWQ.f90 index fd33f8cca..b569cc99f 100644 --- a/build/source/openwq/openWQ.f90 +++ b/build/source/openwq/openWQ.f90 @@ -1,7 +1,7 @@ module openwq USE, intrinsic :: iso_c_binding - USE nrtype + USE nr_type private public :: CLASSWQ_openwq diff --git a/build/source/openwq/summa_openWQ.f90 b/build/source/openwq/summa_openWQ.f90 index 6cf46b692..026d41807 100644 --- a/build/source/openwq/summa_openWQ.f90 +++ b/build/source/openwq/summa_openWQ.f90 @@ -1,5 +1,5 @@ module summa_openwq - USE nrtype + USE nr_type USE openWQ,only:CLASSWQ_openwq USE data_types,only:gru_hru_doubleVec implicit none @@ -22,7 +22,7 @@ module summa_openwq subroutine openwq_init(err) USE globalData,only:gru_struc ! gru-hru mapping structures USE globalData,only:prog_meta - USE globalData,only:maxLayers,maxSnowLayers + USE globalData,only:maxLayers,maxSnowLayers, maxSoilLayers ! maximum number of layers for snow and soil across all HRUs (used to dimension openWQ state variables) USE allocspace_progStuct_module,only:allocGlobal_progStruct ! module to allocate space for global data structures implicit none @@ -31,7 +31,6 @@ subroutine openwq_init(err) ! local variables integer(i4b) :: hruCount - integer(i4b) :: nSoil ! OpenWQ dimensions integer(i4b) :: nCanopy_2openwq = 1 ! Canopy has only 1 layer integer(i4b) :: nRunoff_2openwq = 1 ! Runoff has only 1 layer (not a summa variable - openWQ keeps track of this) @@ -47,14 +46,12 @@ subroutine openwq_init(err) hruCount = sum( gru_struc(:)%hruCount ) - nSoil = maxLayers - maxSnowLayers - ! intialize openWQ err=openwq_obj%decl( & hruCount, & ! num HRU nCanopy_2openwq, & ! num layers of canopy (fixed to 1) maxSnowLayers, & ! num layers of snow (fixed to max of 5 because it varies) - nSoil, & ! num layers of snoil (variable) + maxSoilLayers, & ! num layers of soil (variable) nRunoff_2openwq, & ! num layers of runoff (fixed to 1) nAquifer_2openwq, & ! num layers of aquifer (fixed to 1) nYdirec_2openwq) ! num of layers in y-dir (set to 1 because not used in summa) @@ -235,7 +232,7 @@ subroutine openWQ_run_time_start_inner(openWQArrayIndex, iGRU, iHRU, & ! Copy the prog structure do iVar = 1, size(progStruct%gru(iGRU)%hru(iHRU)%var) do iDat = 1, size(progStruct%gru(iGRU)%hru(iHRU)%var(iVar)%dat) - select case(prog_meta(iVar)%vartype) + select case(prog_meta(iVar)%varType) case(iLookVarType%ifcSoil); offset = 0 case(iLookVarType%ifcToto); diff --git a/build/source/openwq/summa_openWQ_allocspace.f90 b/build/source/openwq/summa_openWQ_allocspace.f90 index 6a1fa1842..956da8816 100644 --- a/build/source/openwq/summa_openWQ_allocspace.f90 +++ b/build/source/openwq/summa_openWQ_allocspace.f90 @@ -21,7 +21,7 @@ module allocspace_progStuct_module ! data types - USE nrtype + USE nr_type ! provide access to the derived types to define the data structures USE data_types,only:& @@ -55,12 +55,8 @@ module allocspace_progStuct_module USE globalData,only:integerMissing ! missing integer USE globalData,only:realMissing ! missing real number - USE globalData,only: nTimeDelay ! number of timesteps in the time delay histogram - USE globalData,only: nSpecBand ! number of spectral bands - - ! access variable types - USE var_lookup,only:iLookVarType ! look up structure for variable typed - USE var_lookup,only:maxvarFreq ! allocation dimension (output frequency) + USE globalData,only:nTimeDelay ! number of timesteps in the time delay histogram + USE globalData,only:nSpecBand ! number of spectral bands ! privacy implicit none diff --git a/docs/assets/listedChanges.txt b/docs/assets/listedChanges.txt index 3ce5723d6..cde3237bf 100644 --- a/docs/assets/listedChanges.txt +++ b/docs/assets/listedChanges.txt @@ -8,13 +8,13 @@ c-02) eval8summa.f90 soil min water is now theta_res, commit c19473df Apr 12 202 05) run_oneHRU.f90 and run_onGRU.f90 correct error readout id’s, does not effect code results, commit d3904b51 Dec 6 2022 -06) Jacobian fixes, computed in various subroutines and then included in computJacob.f90: 1) Fix bulk heat capacity depends on frac ice/liq if updateCp, not needed it don't updateCp - 2) Fix thermal conductivity at snow soil layer interfaces depends on frac ice/liq (ssdNrgFlux) if updateCp, not needed it don't updateCp + 2) Fix thermal conductivity at snow soil layer interfaces depends on frac ice/liq (snowSoilNrgFlux) if updateCp, not needed it don't updateCp -3) Fix soil layer and aquifer transpiration depends on canopy nrg and wat (canopy transpiration), no effect if banded Jacobian -4) Fix aquifer recharge depends on soil drainage from interface above -5) Fix soil infiltration at surface depends on all layers below and above water and temp, not huge effect (but some) if banded Jacobian c-07) Jacobian, scalarCanopyLiq derivatives were getting overwritten and thus zeroed out in calculations, commit cd5002c Jul 6, 2023 08) Throughout, made “indian bread” terminology for NaN say it’s not a number for advised clarity, and there might be other other spaces and comments changed (e.g. tabs deleted and comments deleted or clarified), does not effect code results -c-09) flxMapping.f90 flux mapping of soil resistance as an energy variable corrected (was missing and messed up splitting), commit 315583df June 5, 2023 +c-09) fluxMapping.f90 flux mapping of soil resistance as an energy variable corrected (was missing and messed up splitting), commit 315583df June 5, 2023 c-10) runOneGRU.f90 fixed basin aquifer recharge was summing incorrectly the HRU soil drainage instead of the HRU aquifer recharge, commit cd6f07f1 June 20, 2023 (only affects basin aquifer recharge so does not influence results except this basin variable) c-11) read_icond.f90 canopy water only initialized to be 1e-4 positive at the start of the simulation if it is smaller (through canopy liquid), commit c0f7fa26 Jan 30, 2023, and commit 0f2e9df2 Aug 15, 2023 The canopy water was being bumped up to at least 1e-4 at the start of every substep. @@ -59,7 +59,7 @@ c-17) Use dense matrix as default with vegetation (so transpiration derivatives 18) Soil matrix compression per layer and total (mLayerCompres and scalarSoilCompress) are now outputted as averages over the data window (kg m-2 s-1) like all fluxes are done Soil matrix compression is used in the balance computations, so to have instantaneous values outputted did not make sense. Does not affect solution. c-19) If split to a scalar solution, soil compressibility was outputting as 0. Refactor for BE >1 fixes this since save inner splitting steps. - Or, if wanted to fix the old code would need to modify part of varSubStep. + Or, if wanted to fix the old code would need to modify part of varSubstep. c-20) Need to compute dTheta_dTkCanopy off of trial canopy water instead of previous canopy water, affects Jacobian and temperature adjustment in splitting operations, commit 19fca2ba Jun 7, 2023 c-21) Flux modification flag was not initialized in varSubstep, commit 312004fd Sep 20, 2022, and commit 0c5af7db Aug 11, 2023 c-22) SWE mass balance error should fail based on tolerance absConvTol_liquid*iden_water*10._rkind, not 1e-6. commit ? Reza changed this around June 16, 2021. diff --git a/docs/configuration/SUMMA_model_decisions.md b/docs/configuration/SUMMA_model_decisions.md index 0ee270543..0658ac71d 100644 --- a/docs/configuration/SUMMA_model_decisions.md +++ b/docs/configuration/SUMMA_model_decisions.md @@ -404,8 +404,8 @@ Choice of variable in energy equations (BE residual or IDA state variable) | Option | Description | |---|---| | closedForm | **use temperature with closed form heat capacity
[Energy paper stub](http://doi.org/)** | -| enthalpyFormLU | **use enthalpy with soil temperature-enthalpy lookup table
[Energy paper stub](http://doi.org/)** | -| enthalpyForm | **use enthalpy with soil temperature-enthalpy analytical solutions
[Energy paper stub](http://doi.org/)** | +| enthalpyForm | **use enthalpy with soil temperature-enthalpy lookup table
[Energy paper stub](http://doi.org/)** | +| enthalpyFormAN | **use enthalpy with soil temperature-enthalpy analytical solutions
[Energy paper stub](http://doi.org/)** | @@ -439,4 +439,24 @@ Choice of equation to calculate saturation excess runoff. | FUSEPRMS | **PRMS saturation excess runoff as implemented in FUSE**| | FUSEAVIC | **ARNO/VIC saturation excess runoff as implemented in FUSE**| | FUSETOPM | **Topmodel saturation excess runoff as implemented in FUSE**| -| zero_SE | **No saturation excess runoff**| \ No newline at end of file +| zero_SE | **No saturation excess runoff**| + + + +## 45. readForcing +Method used to read forcing data + +| Option | Description | +|---|---| +| readPerStep | **Read forcing data per time step (default)** | +| readFullSeries | **Read full forcing series in a buffered read** | + + + +## 46. writeOutput +Method used to write model output + +| Option | Description | +|---|---| +| writePerStep | **Write model output per time step (default)** | +| writeFullSeries | **Write all data for a given output file in a buffered read** | \ No newline at end of file diff --git a/docs/development/SUMMA_coding_conventions.md b/docs/development/SUMMA_coding_conventions.md index 3cd3ea092..66a005b54 100755 --- a/docs/development/SUMMA_coding_conventions.md +++ b/docs/development/SUMMA_coding_conventions.md @@ -107,7 +107,7 @@ Use one space to indent ```fortran module vegLiqFlux_module -USE nrtype +USE nr_type implicit none private public::vegLiqFlux diff --git a/docs/development/SUMMA_modularity_guidelines.md b/docs/development/SUMMA_modularity_guidelines.md index d6df1f594..d6827b1f3 100644 --- a/docs/development/SUMMA_modularity_guidelines.md +++ b/docs/development/SUMMA_modularity_guidelines.md @@ -11,15 +11,15 @@ New modular components may be added by using similar existing modular components * e.g., applies to flux calculations * Identify the appropriate source file and module * source files have self-explanatory names - * e.g., `soilLiqFlx.f90` corresponds to operations for liquid water fluxes in soil + * e.g., `soilLiqFlux.f90` corresponds to operations for liquid water fluxes in soil * each source file generally contains one module - * e.g., `soilLiqFlx.f90` contains `soilLiqFlx_module` + * e.g., `soilLiqFlux.f90` contains `soilLiqFlux_module` * Identify the appropriate procedure * isolate the module procedure - * e.g., within `soilLiqFlx_module`, the `surfaceFlx` module subroutine handles operations for surface hydrology fluxes + * e.g., within `soilLiqFlux_module`, the `surfaceFlux` module subroutine handles operations for surface hydrology fluxes * isolate the internal procedure - * e.g., within the `contains` block of `surfaceFlx`, we have `update_surfaceFlx_prescribedHead` containing operations for specifying a prescribed pressure head surface boundary condition - * `update_surfaceFlx_prescribedHead` may be used as a template for our example contribution + * e.g., within the `contains` block of `surfaceFlux`, we have `update_surfaceFlux_prescribedHead` containing operations for specifying a prescribed pressure head surface boundary condition + * `update_surfaceFlux_prescribedHead` may be used as a template for our example contribution * note that procedure names in SUMMA are organized using the terms *initialize*, *update*, and *finalize* to categorize operation types * *initialize* procedures are used for initial setup steps (initialization of variables, memory allocation, etc.) * *update* procedures are used for major computational operations (e.g., flux calculations) @@ -28,25 +28,25 @@ New modular components may be added by using similar existing modular components ## Determine input and output variables * Found by examining dummy variables in argument lists * Note that internal procedures inherit the dummy variables from the applicable module procedure by default - * e.g., for the `update_surfaceFlx_prescribedHead` internal subroutine, the argument list of the `surfaceFlx` module subroutine applies: `subroutine surfaceFlx(io_soilLiqFlx,in_surfaceFlx,io_surfaceFlx,out_surfaceFlx)` + * e.g., for the `update_surfaceFlux_prescribedHead` internal subroutine, the argument list of the `surfaceFlux` module subroutine applies: `subroutine surfaceFlux(io_soilLiqFlux,in_surfaceFlux,io_surfaceFlux,out_surfaceFlux)` * Dummy variables may be objects with multiple data and procedure components * Such objects are declared using derived types (most commonly defined in `data_types.f90`) * Objects may be used to concisely interface data between the procedure and the caller * for SUMMA objects, the nomenclature `in_foobar`, `io_foobar`, and `out_foobar` is used for objects that interface input, input-output, and output data between the `foobar` procedure and its caller, respectively * The `intent` attribute within dummy variable declarations indicates usage for input, input-output, or output - * e.g., within `surfaceFlx` we have `type(in_type_surfaceFlx) ,intent(in) :: in_surfaceFlx`, indicating the `in_surfaceFlx` object is for input data only - * as noted above, the `in_surfaceFlx` object interfaces input data between the `surfaceFlx` module subroutine and its caller (the `soilLiqFlx` module subroutine) + * e.g., within `surfaceFlux` we have `type(in_type_surfaceFlux) ,intent(in) :: in_surfaceFlux`, indicating the `in_surfaceFlux` object is for input data only + * as noted above, the `in_surfaceFlux` object interfaces input data between the `surfaceFlux` module subroutine and its caller (the `soilLiqFlux` module subroutine) ## Create a skeleton of the new procedure * Choose a self explanatory name for the new procedure - * e.g. `update_surfaceFlx_example_flux` -* e.g., at the conclusion of this step, we would have a skeleton within the `contains` block of `surfaceFlx` similar to the following: + * e.g. `update_surfaceFlux_example_flux` +* e.g., at the conclusion of this step, we would have a skeleton within the `contains` block of `surfaceFlux` similar to the following: ```fortran -subroutine update_surfaceFlx_example_flux +subroutine update_surfaceFlux_example_flux ! main computations for the calculation of an example flux -end subroutine update_surfaceFlx_example_flux +end subroutine update_surfaceFlux_example_flux ``` * For new module procedures, the argument list from the template routine should be adjusted to match the needs of the new procedure @@ -54,12 +54,12 @@ end subroutine update_surfaceFlx_example_flux ## Update derived type definitions for interface objects * It may be desirable to add data components to existing objects related to the template procedure - * e.g., adding a new numerical constant to be used in calculating a surface hydrology flux would require interfacing that data to the `update_surfaceFlx_example_flux` subroutine, which can be done using the `in_surfaceFlx` object + * e.g., adding a new numerical constant to be used in calculating a surface hydrology flux would require interfacing that data to the `update_surfaceFlux_example_flux` subroutine, which can be done using the `in_surfaceFlux` object * Derived type definitions for interface objects are found in `source/dshare/data_types.f90` - * e.g., for the `in_surfaceFlx` object we have the `in_type_surfaceFlx` derived type in the `data_types` module: + * e.g., for the `in_surfaceFlux` object we have the `in_type_surfaceFlux` derived type in the `data_types` module: ```fortran - type, public :: in_type_surfaceFlx ! intent(in) data + type, public :: in_type_surfaceFlux ! intent(in) data ! input: model control logical(lgt) :: firstSplitOper ! flag indicating if desire to compute infiltration logical(lgt) :: deriv_desired ! flag to indicate if derivatives are desired @@ -70,15 +70,15 @@ end subroutine update_surfaceFlx_example_flux integer(i4b) :: nSoil ! number of soil layers ! [...] ! additional data components here contains - procedure :: initialize => initialize_in_surfaceFlx - end type in_type_surfaceFlx + procedure :: initialize => initialize_in_surfaceFlux + end type in_type_surfaceFlux ``` * Adding a new numerical constant (say `example_flux_constant`) may be done as follows: ```fortran - type, public :: in_type_surfaceFlx ! intent(in) data + type, public :: in_type_surfaceFlux ! intent(in) data ! input: model control logical(lgt) :: firstSplitOper ! flag indicating if desire to compute infiltration logical(lgt) :: deriv_desired ! flag to indicate if derivatives are desired @@ -91,99 +91,99 @@ end subroutine update_surfaceFlx_example_flux real(rkind) :: example_flux_constant ! numerical constant for example flux ! [...] ! additional data components here contains - procedure :: initialize => initialize_in_surfaceFlx - end type in_type_surfaceFlx + procedure :: initialize => initialize_in_surfaceFlux + end type in_type_surfaceFlux ``` * note that SUMMA uses the following `kind` parameters: `lgt` for logical variables, `i4b` for integer variables, and `rkind` for real variables * Additionally, we have procedure components for *initialize* and *finalize* operations for data interfacing - * e.g., `call in_surfaceFlx % initialize` points to the `initialize_in_surfaceFlx` class procedure (in the `contains` block of the `data_types` module) for initializing data components: + * e.g., `call in_surfaceFlux % initialize` points to the `initialize_in_surfaceFlux` class procedure (in the `contains` block of the `data_types` module) for initializing data components: ```fortran - subroutine initialize_in_surfaceFlx(in_surfaceFlx,nRoots,ixIce,nSoil,ibeg,iend,in_soilLiqFlx,io_soilLiqFlx,& + subroutine initialize_in_surfaceFlux(in_surfaceFlux,nRoots,ixIce,nSoil,ibeg,iend,in_soilLiqFlux,io_soilLiqFlux,& &model_decisions,prog_data,mpar_data,flux_data,diag_data,& &iLayerHeight,dHydCond_dTemp,iceImpedeFac) - class(in_type_surfaceFlx),intent(out) :: in_surfaceFlx ! input object for surfaceFlx + class(in_type_surfaceFlux),intent(out) :: in_surfaceFlux ! input object for surfaceFlux ! [...] ! additional variable declarations here associate(& ! model control - firstSplitOper => in_soilLiqFlx % firstSplitOper, & ! flag to compute infiltration - deriv_desired => in_soilLiqFlx % deriv_desired, & ! flag indicating if derivatives are desired + firstSplitOper => in_soilLiqFlux % firstSplitOper, & ! flag to compute infiltration + deriv_desired => in_soilLiqFlux % deriv_desired, & ! flag indicating if derivatives are desired ixRichards => model_decisions(iLookDECISIONS%f_Richards)%iDecision,& ! index of the form of the Richards equation ixBcUpperSoilHydrology => model_decisions(iLookDECISIONS%bcUpprSoiH)%iDecision & ! index defining the type of boundary conditions &) ! intent(in): model control - in_surfaceFlx % firstSplitOper = firstSplitOper ! flag indicating if desire to compute infiltration - in_surfaceFlx % deriv_desired = deriv_desired ! flag indicating if derivatives are desired - in_surfaceFlx % ixRichards = ixRichards ! index defining the form of the Richards equation (moisture or mixdform) - in_surfaceFlx % bc_upper = ixBcUpperSoilHydrology ! index defining the type of boundary conditions (Neumann or Dirichlet) - in_surfaceFlx % nRoots = nRoots ! number of layers that contain roots - in_surfaceFlx % ixIce = ixIce ! index of lowest ice layer - in_surfaceFlx % nSoil = nSoil ! number of soil layers + in_surfaceFlux % firstSplitOper = firstSplitOper ! flag indicating if desire to compute infiltration + in_surfaceFlux % deriv_desired = deriv_desired ! flag indicating if derivatives are desired + in_surfaceFlux % ixRichards = ixRichards ! index defining the form of the Richards equation (moisture or mixdform) + in_surfaceFlux % bc_upper = ixBcUpperSoilHydrology ! index defining the type of boundary conditions (Neumann or Dirichlet) + in_surfaceFlux % nRoots = nRoots ! number of layers that contain roots + in_surfaceFlux % ixIce = ixIce ! index of lowest ice layer + in_surfaceFlux % nSoil = nSoil ! number of soil layers end associate ! [...] ! additional associate blocks here - end subroutine initialize_in_surfaceFlx + end subroutine initialize_in_surfaceFlux ``` * new data components, such as `example_flux_constant`, must be applied within the procedure components: ```fortran - subroutine initialize_in_surfaceFlx(in_surfaceFlx,nRoots,ixIce,nSoil,ibeg,iend,in_soilLiqFlx,io_soilLiqFlx,& + subroutine initialize_in_surfaceFlux(in_surfaceFlux,nRoots,ixIce,nSoil,ibeg,iend,in_soilLiqFlux,io_soilLiqFlux,& &model_decisions,prog_data,mpar_data,flux_data,diag_data,& &iLayerHeight,dHydCond_dTemp,iceImpedeFac,example_flux_constant) - class(in_type_surfaceFlx),intent(out) :: in_surfaceFlx ! input object for surfaceFlx + class(in_type_surfaceFlux),intent(out) :: in_surfaceFlux ! input object for surfaceFlux ! [...] ! additional variable declarations here real(rkind),intent(in) :: example_flux_constant ! declaration for new constant associate(& ! model control - firstSplitOper => in_soilLiqFlx % firstSplitOper, & ! flag to compute infiltration - deriv_desired => in_soilLiqFlx % deriv_desired, & ! flag indicating if derivatives are desired + firstSplitOper => in_soilLiqFlux % firstSplitOper, & ! flag to compute infiltration + deriv_desired => in_soilLiqFlux % deriv_desired, & ! flag indicating if derivatives are desired ixRichards => model_decisions(iLookDECISIONS%f_Richards)%iDecision,& ! index of the form of the Richards equation ixBcUpperSoilHydrology => model_decisions(iLookDECISIONS%bcUpprSoiH)%iDecision & ! index defining the type of boundary conditions &) ! intent(in): model control - in_surfaceFlx % firstSplitOper = firstSplitOper ! flag indicating if desire to compute infiltration - in_surfaceFlx % deriv_desired = deriv_desired ! flag indicating if derivatives are desired - in_surfaceFlx % ixRichards = ixRichards ! index defining the form of the Richards equation (moisture or mixdform) - in_surfaceFlx % bc_upper = ixBcUpperSoilHydrology ! index defining the type of boundary conditions (Neumann or Dirichlet) - in_surfaceFlx % nRoots = nRoots ! number of layers that contain roots - in_surfaceFlx % ixIce = ixIce ! index of lowest ice layer - in_surfaceFlx % nSoil = nSoil ! number of soil layers + in_surfaceFlux % firstSplitOper = firstSplitOper ! flag indicating if desire to compute infiltration + in_surfaceFlux % deriv_desired = deriv_desired ! flag indicating if derivatives are desired + in_surfaceFlux % ixRichards = ixRichards ! index defining the form of the Richards equation (moisture or mixdform) + in_surfaceFlux % bc_upper = ixBcUpperSoilHydrology ! index defining the type of boundary conditions (Neumann or Dirichlet) + in_surfaceFlux % nRoots = nRoots ! number of layers that contain roots + in_surfaceFlux % ixIce = ixIce ! index of lowest ice layer + in_surfaceFlux % nSoil = nSoil ! number of soil layers end associate ! [...] ! additional associate blocks here ! assignment statements for the example flux - in_surfaceFlx % example_flux_constant = example_flux_constant ! numerical constant for example flux + in_surfaceFlux % example_flux_constant = example_flux_constant ! numerical constant for example flux - end subroutine initialize_in_surfaceFlx + end subroutine initialize_in_surfaceFlux ``` - * for the above example, we have added a dummy variable for the new example flux constant and an assignment statement to initialize the new data component `in_surfaceFlx % example_flux_constant` - * note that the corresponding call to `in_surfaceFlx` within the `soilLiqFlx` subroutine would need to be updated to include the additional argument `example_flux_constant` + * for the above example, we have added a dummy variable for the new example flux constant and an assignment statement to initialize the new data component `in_surfaceFlux % example_flux_constant` + * note that the corresponding call to `in_surfaceFlux` within the `soilLiqFlux` subroutine would need to be updated to include the additional argument `example_flux_constant` ## Add operations to the skeleton procedure * add main operations within the skeleton procedure created in the above steps to complete the new modular component * for the example flux parameterization (using a toy model of constant infiltration), we have: ````fortran - subroutine update_surfaceFlx_example_flux + subroutine update_surfaceFlux_example_flux ! main computations for the calculation of an example flux associate(& ! input: flux at the upper boundary - scalarRainPlusMelt => in_surfaceFlx % scalarRainPlusMelt , & ! rain plus melt, used as input to the soil zone before computing surface runoff (m s-1) + scalarRainPlusMelt => in_surfaceFlux % scalarRainPlusMelt , & ! rain plus melt, used as input to the soil zone before computing surface runoff (m s-1) ! input: numerical constants - example_flux_constant => in_surfaceFlx % example_flux_constant + example_flux_constant => in_surfaceFlux % example_flux_constant ! output: runoff and infiltration - scalarSurfaceRunoff => out_surfaceFlx % scalarSurfaceRunoff , & ! surface runoff (m s-1) - scalarSurfaceInfiltration => out_surfaceFlx % scalarSurfaceInfiltration & ! surface infiltration (m s-1) + scalarSurfaceRunoff => out_surfaceFlux % scalarSurfaceRunoff , & ! surface runoff (m s-1) + scalarSurfaceInfiltration => out_surfaceFlux % scalarSurfaceInfiltration & ! surface infiltration (m s-1) &) scalarSurfaceInfiltration = example_flux_constant ! toy model of constant infiltration scalarSurfaceRunoff = scalarRainPlusMelt - scalarSurfaceInfiltration ! compute surface runoff end associate - end subroutine update_surfaceFlx_example_flux + end subroutine update_surfaceFlux_example_flux ```` \ No newline at end of file diff --git a/docs/input_output/SUMMA_input.md b/docs/input_output/SUMMA_input.md index 46593ad4e..72431a80b 100644 --- a/docs/input_output/SUMMA_input.md +++ b/docs/input_output/SUMMA_input.md @@ -163,10 +163,12 @@ The model decisions and their options or values are listed in the following tabl |[spatial_gw](../configuration/SUMMA_model_decisions.md#spatial_gw) | localColumn
singleBasin | (38) choice of method for spatial representation of groundwater |[subRouting](../configuration/SUMMA_model_decisions.md#subRouting) | timeDlay
qInstant | (39) choice of method for sub-grid routing |[snowDenNew](../configuration/SUMMA_model_decisions.md#snowDenNew) | hedAndPom
anderson
pahaut_76
constDens | (40) choice of method for new snow density -|[nrgConserv](../configuration/SUMMA_model_decisions.md#nrgConserv) | closedForm
enthalpyFormLU
enthalpyForm | (41) choice of variable in energy equations (BE residual or IDA state variable) +|[nrgConserv](../configuration/SUMMA_model_decisions.md#nrgConserv) | closedForm
enthalpyForm
enthalpyFormAN | (41) choice of variable in energy equations (BE residual or IDA state variable) |[aquiferIni](../configuration/SUMMA_model_decisions.md#aquiferIni) | fullStart
emptyStart | (42) choice of initial fill level for aquifer, should be used at default unless comparing solution methods |[infRateMax](../configuration/SUMMA_model_decisions.md#infRateMax) | topmodel_GA
GreenAmpt
noInfiltrationExcess | (43) choice of parametrization of maximum infiltration rate -|[surfRun_SE](../configuration/SUMMA_model_decisions.md#surfRun_SE) | homegrown_SE
FUSEPRMS
FUSEAVIC
FUSETOPM
zero_SE | (44) choice of initial fill level for aquifer, should be used at default unless comparing solution methods +|[surfRun_SE](../configuration/SUMMA_model_decisions.md#surfRun_SE) | homegrown_SE
FUSEPRMS
FUSEAVIC
FUSETOPM
zero_SE | (44) choice of equation to calculate saturation excess runoff +|[readForcing](../configuration/SUMMA_model_decisions.md#readForcing) | readPerStep
readFullSeries | (45) method used to read forcing data +|[writeOutput](../configuration/SUMMA_model_decisions.md#writeOutput) | writePerStep
writeFullSeries | (46) method used to write model output The model decisions for each simulation are included as global attributes in [SUMMA output files](SUMMA_output.md). @@ -176,18 +178,28 @@ The output control file is an [ASCII file](#infile_format_ASCII) that specifies SUMMA is pretty flexible in its output. There are many variables that you can output and for most of them you can also choose to record summary statistics. For example, you can configure the model to run with meteorological forcings that are defined every hour, but only save summary output with a daily time step. This flexibility comes at the small price that you need to be clear in specifying what output you want. -The output control file includes a listing of model variables that you would like to store, with one model variable per line. The variables that are available for output are the individual entries in the data structures specified in `build/source/dshare/var_lookup.f90`. Because there are many, there is not much point in repeating them here, but we direct the user to the model code. Any of the variables specified in the following structures can be specified in the output control file: `iLook_time`, `iLook_force`, `iLook_attr`, `iLook_type`, `iLook_param`, `iLook_index`, `iLook_prog`, `iLook_diag`, `iLook_flux`, `iLook_bpar`, `iLook_bvar`, `iLook_deriv`. SUMMA will print an error message if a specific variable cannot be output, so the faster way may be to select any variable in `build/source/dshare/var_lookup.f90` and remove it if it is not available for output. In addition, some of the variables may only be useful for debugging use, but that is up to the user. +The output control file includes a listing of model variables that you would like to store, with one model variable per line. The variables that are available for output are the individual entries in the data structures specified in `build/source/dshare/popMetadat.f90`. Because there are many, there is not much point in repeating them here, but we direct the user to the model code. Any of the variables specified in the following structures can be specified in the output control file: the time-varying variables in `forc`, `prog`, `diag`, `flux`, `bvar`; the time-constant parameters in `bpar`, `attr`, `type`, and `mpar`; and the timestep variables of `time` and `indx`. SUMMA will print an warning message if a specific variable cannot be outputted, so the faster way may be to select any variable in `build/source/dshare/popMetadat.f90` and remove it if it is not available for output. At this time, `deriv`,and `lookup` structure variables are not available for output, as well as any variables of type `unknown`. The `id` structure variables of `gruId` and `hruId` will always be outputted for variable identification purposes, but no other `id` variables will be outputted. -At a minimum, each line in the output control file will contain two fields, separated by a `|`. The first field will be the variable name as specified in `build/source/dshare/var_lookup.f90` (case-sensitive). The second field will be the frequency of the model output specified as a multiple of the time resolution in the model forcing files. Thus, if you want to output data for every forcing time step, then this value should be equal to 1. If you want daily output and your forcing frequency is 3 hours, then this value should be equal to 8. Note that you can specify different output frequencies for separate variables, but at this time you can specify only a single output frequency for each variable. For example, you can store `scalarSenHeatTotal` with an output frequency of 1 and `scalarLatHeatTotal` with an output frequency of 8, but you cannot specify two different output frequencies for `scalarSenHeatTotal`. - -For most variables you can also output a statistical summary if you output variables at a lower frequency than your forcing frequency. To do this, you extend the number of fields you specify in the output control file, with all fields separated by a `|`. For the fields after the first two, you specify a series of 0's and 1's, which indicate that a specific statistic should not (0) or should be stored (1). The available statistics are (in order) the instantaneous value, the sum over the interval, the mean, the variance, the minimum, the maximum and the mode. So, a complete line in the output control file would be +At a minimum, for any time-varying variable (in `forc`, `prog`, `diag`, `flux`, or `bvar`), each line in the output control file will contain two fields, separated by a `|`. The first field will be the variable name as specified in `build/source/dshare/popMetadat.f90` (case-sensitive). The second field will be the frequency of the model output specified as timestep, day, month, or annual. The `timestep` choice can also be inputted as `1`, and the `day` choice can also be inputted as `24`, regardless if the of the length of the actual timestep (i.e. a 30 minute timestep would still be `1` with the day being `24`). Note that for every variable you can specify multiple frequencies but you need to add a new line in the output control for each frequency. For example to output `scalarSenHeatTotal` at the timestep, day, and annual, you would input: +``` +scalarSenHeatTotal | 1 +scalarSenHeatTotal | day +scalarSenHeatTotal | annual +``` +For a scalar variable you can also output a statistical summary if you output variables at a lower frequency than your forcing frequency. To do this, you extend the number of fields you specify in the output control file, with all fields separated by a `|`. The available statistics are the the sum over the interval, the instantaneous value (computed at the last simulated timestep of the calendar day, month, or year), the mean, the variance, the minimum, and the maximum (respective names total, instant, mean, variance, minimum, and maximum). For example ``` -! varName | outFreq | sum | inst | mean | var | min | max | mode -scalarSenHeatTotal | 24 | 0 | 1 | 1 | 0 | 1 | 1 | 0 +scalarSenHeatTotal | day | mean ``` -In this example, the first line is a comment (starts with `!`) and then the sum, mean, min, max are calculated for `scalarSenHeatTotal` across 24 forcing time steps and written to the output file. +You can also do this with the backwards compatible flags, in order: +``` +! varName | outFreq | totl | inst | mean | vari | mini | maxi +scalarSenHeatTotal | 24 | 0 | 0 | 1 | 0 | 0 | 0 +``` +In this example, the first line is a comment (starts with `!`) and then the mean is calculated for `scalarSenHeatTotal` across 24 forcing time steps and written to the output file. Note, at this time, you can only specify one statistic per variable per output frequency and you cannot specify the same output frequency twice, even if the statistics are different. The default statistic, if not specified, or if the variable is not scalar, is instantaneous. + +The time-constant parameters (in `bpar`, `attr`, `type`, or `mpar`) do not have to have a frequency field, as they will be outputted without a time dimension in the timestep file (regardless if different frequency is submitted). The timestep variables (in `time` or `indx`) cannot be agggregated to frequencies longer than a timestep, so they also do not have to have a frequency field and will be outputted in the timestep file (regardless if different frequency is submitted), this time with a time dimension. -Additionally, you can specify the output precision by adding the line `outputPrecision | ` to the output control file where `` is one of `float`, `single`, or `double`. The default precision if this is not included is `double`. Both `single` and `float` correspond to single precision. +Additionally, you can specify the output precision by adding the line `outputPrecision | ` to the output control file where `` is one of `float`, `single`, or `double`. The default precision if this is not included is `double`. Both `single` and `float` correspond to single precision. The output compression level can be specified by adding the line `outputCompressionLevel | ` to the output control file where `` is 0-9. Higher levels mean smaller files but slower write/read speed. The default compression level is 4. ## List of forcing files file @@ -204,13 +216,13 @@ Each forcing file must contain a `time` and a `hru` [dimension](#forcing_file_di data_step | - | double | seconds | Length of time step | Single value that must be the same for all forcing files in the same [list of forcing files file](#infile_forcing_list) hruId | hru | int or int64 | - | Index of hydrological response unit (HRU) | Unique numeric ID for each HRU | time | time | double | [see below](#forcing_file_time_units) | time since time reference | Time stamps are [period-ending](#forcing_file_time_stamp) -pptrate | time, hru | double | kg m-2 s-1 | Precipitation rate | | -SWRadAtm | time, hru | double | W m-2 | Downward shortwave radiation at the [upper boundary](#forcing_file_upper_boundary) | | -LWRadAtm | time, hru | double | W m-2 | Downward longwave radiation at the [upper boundary](#forcing_file_upper_boundary) | | -airtemp | time, hru | double | K | Air temperature at the [measurement height](#forcing_file_measurement_height) | | -windspd | time, hru | double | m s-1 | Wind speed at the [measurement height](#forcing_file_measurement_height) | | -airpres | time, hru | double | Pa | Air pressure at the the [measurement height](#forcing_file_measurement_height)| | -spechum | time, hru | double | g g-1 | Specific humidity at the [measurement height](#forcing_file_measurement_height) | | +pptrate | time, hru | double | kg m-2 s-1 | Precipitation rate | +SWRadAtm | time, hru | double | W m-2 | Downward shortwave radiation at the [upper boundary](#forcing_file_upper_boundary) | +LWRadAtm | time, hru | double | W m-2 | Downward longwave radiation at the [upper boundary](#forcing_file_upper_boundary) | +airtemp | time, hru | double | K | Air temperature at the [measurement height](#forcing_file_measurement_height) | +windspd | time, hru | double | m s-1 | Wind speed at the [measurement height](#forcing_file_measurement_height) | +airpres | time, hru | double | Pa | Air pressure at the the [measurement height](#forcing_file_measurement_height)| +spechum | time, hru | double | g g-1 | Specific humidity at the [measurement height](#forcing_file_measurement_height) | Notes about forcing file format: @@ -241,29 +253,39 @@ The frequency with which SUMMA writes restart files is specified on the command- As an input file, the variables that need to be specified in the restart file are a subset of those listed as `iLook_prog` in the `var_lookup` module in `build/source/dshare/var_lookup.f90` (look for the comment `(6) define model prognostic (state) variables`). Variable names must match the code exactly (case-sensitive). Note that not all the variables in `iLook_prog` need to be specified, since some of them can be calculated from other variables. For example, SUMMA calculates `mLayerHeight` from `iLayerHeight` and the variable does not need to be reported separately. For similar reasons, the user does not need to specify `scalarCanopyWat`, `spectralSnowAlbedoDiffuse`, `scalarSurfaceTemp`, `mLayerVolFracWat`, and `mLayerHeight` since these are skipped when the file is read and calculated internally to ensure consistency. In addition to these variables, the restart file also needs to specify the number of soil and snow layers (`nSoil` and `nSnow`, respectively). -The restart file does not have a time dimension, since it represents a specific moment in time. However, it has the following dimensions,: `hru`, `scalarv`, `spectral`, `ifcSoil`, `ifcToto`, `midSoil`, and `midToto`. These dimensions are described in detail in the section on [SUMMA output file dimensions](SUMMA_output.md#outfile_dimensions) (keep in mind that the restart files are both input and output). +The restart file does not have a time dimension, since it represents a specific moment in time. However, it has the following dimensions,: `gru`, `hru`, `tdh`, `scalarv`, `spectral`, `ifcSoil`, `ifcToto`, `midSoil`, and `midToto`. These dimensions are described in detail in the section on [SUMMA output file dimensions](SUMMA_output.md#outfile_dimensions) (keep in mind that the restart files are both input and output). | Variable | dimension | type | units | long name | notes | |----------|-----------|------|-------|-----------|-------| -| dt_init | scalarv, hru | double | seconds | Length of initial time sub-step at start of next time interval (s) | | -| nSoil | scalarv, hru | int | - | Number of soil layers | | -| nSnow | scalarv, hru | int | - | Number of snow layers | | -| scalarCanopyIce | scalarv, hru | double | kg m-2 | Mass of ice on the vegetation canopy | | -| scalarCanopyLiq | scalarv, hru | double | kg m-2 | Mass of liquid water on the vegetation canopy | | -| scalarCanairTemp | scalarv, hru | double | Pa | Temperature of the canopy air space | | -| scalarCanopyTemp | scalarv, hru | double | K | Temperature of the vegetation canopy | | -| scalarSnowAlbedo | scalarv, hru | double | - | Snow albedo for the entire spectral band | | -| scalarSnowDepth | scalarv, hru | double | m | Total snow depth | | -| scalarSWE | scalarv, hru | double | kg m-2 | Snow water equivalent | | +| gruId | gru | int | - | ID defining the grouped (basin) response unit | +| hruId | hru | int | - | ID defining the hydrologic response unit | +| dt_init | scalarv, hru | double | seconds | Length of initial time sub-step at start of next time interval | +| nSoil | hru | int | - | Number of soil layers | +| nSnow | hru | int | - | Number of snow layers | +| scalarCanopyIce | scalarv, hru | double | kg m-2 | Mass of ice on the vegetation canopy | +| scalarCanopyLiq | scalarv, hru | double | kg m-2 | Mass of liquid water on the vegetation canopy | +| scalarCanairTemp | scalarv, hru | double | Pa | Temperature of the canopy air space | +| scalarCanopyTemp | scalarv, hru | double | K | Temperature of the vegetation canopy | +| scalarCanopyWat | scalarv, hru | double | K | Mass of water on the vegetation canopy | +| scalarCanairEnthalpy | scalarv, hru | double | J m-3 | Enthalpy of the canopy air space | +| scalarCanopyEnthalpy | scalarv, hru | double | J m-3 | Enthalpy of the vegetation canopy | +| scalarSnowAlbedo | scalarv, hru | double | - | Snow albedo for the entire spectral band | +| spectralSnowAlbedoDiffuse | spectral, hru | double | - | Diffuse snow albedo for individual spectral bands | +| scalarSnowDepth | scalarv, hru | double | m | Total snow depth | +| scalarSurfaceTemp | scalarv, hru | double | K | Surface temperature (just a copy of the upper layer temperature) | +| scalarSWE | scalarv, hru | double | kg m-2 | Snow water equivalent | | scalarSfcMeltPond | scalarv, hru | double | kg m-2 | Ponded water caused by melt of the "snow without a layer" | -| scalarAquiferStorage | scalarv, hru | double | m | Relative aquifer storage -- above bottom of the soil profile | | -| iLayerHeight | ifcToto, hru | double | m | Height of the layer interface; top of soil = 0 | | -| mLayerDepth | midToto, hru | double | m | Depth of each layer | | +| scalarAquiferStorage | scalarv, hru | double | m | Relative aquifer storage -- above bottom of the soil profile | +| iLayerHeight | ifcToto, hru | double | m | Height of the layer interface; top of soil = 0 | +| mLayerDepth | midToto, hru | double | m | Depth of each layer | layer | -| mLayerTemp | midToto, hru | double | K | Temperature of each layer | | -| mLayerVolFracIce | midToto, hru | double | - | Volumetric fraction of ice in each layer | | -| mLayerVolFracLiq | midToto, hru | double | - | Volumetric fraction of liquid water in each layer | | +| mLayerVolFracIce | midToto, hru | double | - | Volumetric fraction of ice in each layer | +| mLayerVolFracLiq | midToto, hru | double | - | Volumetric fraction of liquid water in each layer | +| mLayerVolFracWat | midToto, hru | double | - | Volumetric fraction of water in each layer | +| mLayerTemp | midToto, hru | double | K | Temperature of each layer | +| mLayeryEnthalpy | scalarv, hru | double | J m-3 | Enthalpy of each layer | | mLayerMatricHead | midSoil, hru | double | m | Matric head of water in the soil | +| routingRunoffFuture | tdh, gru | m s-1 | runoff in future timesteps for histogram | ## Attribute and parameter files SUMMA uses a number of files to specify model attributes and parameters. Although SUMMA's distinction between attributes and parameters is somewhat arbitrary, attributes generally describe characteristics of the model domain that are time-invariant during the simulation, such as GRU and HRU identifiers, spatial organization, an topography. The important part for understanding the organization of the SUMMA input files is that the values specified in the [local attributes file](#infile_local_attributes) do not overlap with those in the various parameter files. Thus, these values do not overwrite any attributes specified elsewhere. In contrast, the various parameter file are read in sequence (as explained in the next paragraph) and parameter values that are read in from the input files successively overwrite values that have been specified earlier. @@ -281,20 +303,20 @@ The local attributes file contains a `gru` and an `hru` dimension as specified i | Variable | dimension | type | units | long name | notes | |----------|-----------|------|-------|-----------|-------| -hruId | hru | int | - | Index of hydrological response unit (HRU) | Unique numeric ID for each HRU | -gruId | gru | int | - | Index of grouped response unit (GRU) | Unique numeric ID for each GRU | -hru2gruId | hru | int | - | Index of GRU to which the HRU belongs | gruId of the GRU to which the HRU belongs | -downHRUindex | hru | int | - | Index of downslope HRU (0 = basin outlet) | Downslope HRU must be within the same GRU. If the value is 0, then there is no exchange to a neighboring HRU. Setting this value to 0 for all HRUs emulates a series of independent columns | -longitude | hru | double | Decimal degree east | Longitude of HRU's centroid | West is negative or greater than 180 | -latitude | hru | double | Decimal degree north | Latitude of HRU's centroid | South is negative | -elevation | hru | double | m | Mean elevation of HRU | | -HRUarea | hru | double | m^2 | Area of HRU | | -tan_slope | hru | double | m m-1 | Average tangent slope of HRU | | -contourLength | hru | double | m | Contour length of HRU | Width of a hillslope (m) parallel to a stream. Used in `groundwatr.f90`| -slopeTypeIndex | hru | int | - | Index defining slope | | -soilTypeIndex | hru | int | - | Index defining soil type | | -vegTypeIndex | hru | int | - | Index defining vegetation type | | -mHeight | hru | double | m | Measurement height above bare ground | | +| gruId | gru | int | - | ID defining the grouped (basin) response unit | | +| hruId | hru | int | - | ID defining the hydrologic response unit | | +| hru2gruId | hru | int | - | Index of GRU to which the HRU belongs | gruId of the GRU to which the HRU belongs | +| downHRUindex | hru | int | - | Index of downslope HRU (0 = basin outlet) | Downslope HRU must be within the same GRU. If the value is 0, then there is no exchange to a | neighboring HRU. Setting this value to 0 for all HRUs emulates a series of independent columns | +| longitude | hru | double | Decimal degree east | Longitude of HRU's centroid | West is negative or greater than 180 | +| latitude | hru | double | Decimal degree north | Latitude of HRU's centroid | South is negative | +| elevation | hru | double | m | Mean elevation of HRU | | +| HRUarea | hru | double | m^2 | Area of HRU | | +| tan_slope | hru | double | m m-1 | Average tangent slope of HRU | | +| contourLength | hru | double | m | Contour length of HRU | Width of a hillslope (m) parallel to a stream. Used in `groundwatr.f90`| +| slopeTypeIndex | hru | int | - | Index defining slope | | +| soilTypeIndex | hru | int | - | Index defining soil type | | +| vegTypeIndex | hru | int | - | Index defining vegetation type | | +| mHeight | hru | double | m | Measurement height above bare ground | | Below is a sample layout of the local attributes file (the output of running `ncdump -h`). In this case, both the gru and hru dimension are of size 1 (the example is taken from one of the [test cases](../installation/SUMMA_test_cases.md), most of which are point model simulations), but of course there can be many GRUs and HRUs. diff --git a/docs/input_output/SUMMA_output.md b/docs/input_output/SUMMA_output.md index 4c2b3f752..cbf5fd92c 100755 --- a/docs/input_output/SUMMA_output.md +++ b/docs/input_output/SUMMA_output.md @@ -6,22 +6,23 @@ All SUMMA output files are in [NetCDF format](SUMMA_input#infile_format_nc). ## Output file dimensions -SUMMA output files can have the following dimensions (as defined in `build/source/netcdf/def_output.f90`). Dimensions may be present even in output files where they are not actually used. Most of these dimensions are pretty self-explanatory, except perhaps the `[mid|ifc][Snow|Soil|Toto]andTime` dimensions, which combine depth and time information as a work-around for the lack of support for variable-length or ragged arrays in earlier versions of NetCDF-4. While SUMMA will likely move to support these variable-length arrays in its output, we currently use a different organization. The dimensions indicated by `ifc` are associated with variables that are specified at the interfaces between layers including the very top and bottom. For example, the flux into or out of a layer would be arranged along an `ifc` dimension. The dimensions indicated by `mid` are associated with variables that are specified at the mid-point of each layer (or layer-average). `Snow`, `Soil`, and `Toto` indicate snow layers, soil layers, and all layers, respectively. This is explained in detail in the [model history file](#outfile_history) section. +SUMMA output files can have the following dimensions (as defined in `build/source/netcdf/def_output.f90`). Dimensions may be present even in output files where they are not actually used. Most of these dimensions are pretty self-explanatory, except perhaps the `[mid|ifc][Snow|Soil|Toto]` dimensions, which are for depth information. The dimensions indicated by `ifc` are associated with variables that are specified at the interfaces between layers including the very top and bottom. For example, the flux into or out of a layer would be arranged along an `ifc` dimension. The dimensions indicated by `mid` are associated with variables that are specified at the mid-point of each layer (or layer-average). `Snow`, `Soil`, and `Toto` indicate snow layers, soil layers, and all layers, respectively. | Dimension | long name | notes | |-----------|-----------|-------| -| hru | dimension for the HRUs | Variables and parameters that vary by HRU | -| depth | dimension for soil depth | Variables and parameters that are defined for a fixed number of layers | -| scalar | dimension for scalar variables | Scalar variables and parameters (degenerate dimension) | -| spectral_bands | dimension for the number of spectral bands | Variables and parameters that vary for different spectral regimes | -| time | dimension for the time step | Time-varying variables and parameters | -| timeDelayRouting | dimension for the time delay routing vectors | Variables and parameters that are held in memory as part of routing routines | -| midSnowAndTime | dimension for midSnow-time | Time-varying variables and parameters at the mid-point of each snow layer | -| midSoilAndTime | dimension for midSoil-time | Time-varying variables and parameters at the mid-point of each soil layer | -| midTotoAndTime | dimension for midToto-time | Time-varying variables and parameters at the mid-point of each layer in the combined soil and snow profile | -| ifcSnowAndTime | dimension for ifcSnow-time | Time-varying variables and parameters at the interfaces between snow layers (including top and bottom) | -| ifcSoilAndTime | dimension for ifcSoil-time | Time-varying variables and parameters at the interfaces between soil layers (including top and bottom) | -| ifcTotoAndTime | dimension for ifcToto-time | Time-varying variables and parameters at the interfaces between all layers in the combined soil and snow profile (including top and bottom) | +| gru | dimension for the GRUs | Variables and parameters that vary by GRU | +| hru | dimension for the HRUs | Variables and parameters that vary by HRU | +| depth | dimension for soil depth | Variables and parameters that are defined for a fixed number of layers | +| scalarv | dimension for scalar variables | Scalar variables and parameters (degenerate dimension) | +| spectral | dimension for the number of spectral bands | Variables and parameters that vary for different spectral regimes | +| time | dimension for the time step | Time-varying variables and parameters | +| tdh | dimension for the time delay routing vectors | Variables and parameters that are held in memory as part of routing routines | +| midSnow | dimension for midSnow | Variables and parameters at the mid-point of each snow layer | +| midSoil | dimension for midSoil | Variables and parameters at the mid-point of each soil layer | +| midToto | dimension for midToto | Variables and parameters at the mid-point of each layer in the combined soil and snow profile | +| ifcSnow | dimension for ifcSnow | Variables and parameters at the interfaces between snow layers (including top and bottom) | +| ifcSoil | dimension for ifcSoil | Variables and parameters at the interfaces between soil layers (including top and bottom) | +| ifcToto | dimension for ifcToto | Variables and parameters at the interfaces between all layers in the combined soil and snow profile (including top and bottom) | ## Restart or state file @@ -29,48 +30,4 @@ A SUMMA restart file is in [NetCDF forma](SUMMA_input#infile_format_nc) and is w ## Model history files -SUMMA history files are in [NetCDF format](SUMMA_input#infile_format_nc) and describe the time evolution of SUMMA variables and parameters. The files are written by the `writeParm`, `writeData`, `writeBasin`, and `writeTime` subroutines in `build/source/netcdf/modelwrite.f90`. SUMMA output is pretty flexible. You can output many time-varying model variables and parameters, including summary statistics. You can specify what you want to output in the [output control file](SUMMA_input#infile_output_control), which is one of SUMMA's required input files. - -The output is organized as a function of time and then as a function of the entire model domain, by GRU, and by HRU. For example, domain average scalar quantities such as `basin__SurfaceRunoff` are arranged along the `time` dimension only. Scalar quantities that vary by HRU will be arranged along both a `time` and `hru` dimension. This should be fairly self-explanatory. - -Where it gets a bit more complicated is when describing model output that varies by model layer as a function of time (and perhaps also by HRU). In this case, the complication arises because SUMMA allows for a time-varying number of model layers. Thus, while it would make sense to organize the layer-specific information as (`time`, `hru`, `layer`), the varying size of the layer dimension would mean that the dimension would need to be oversized (thus wasting space), unless NetCDF allows for variable-length or ragged arrays. This was not possible in earlier versions of NetCDF, but NetCDF-4 added support for a [variable length array type](https://www.unidata.ucar.edu/software/netcdf/netcdf-4/newdocs/netcdf-c/Variable-Length-Array.html) albeit with some restrictions. SUMMA will likely move to support this at some point, but currently we arrange the output differently. All layer output is stored by concatenating the output from all the layers at successive time steps (along dimensions with names such as `midSnowAndTime` or `ifcTotoAndTime`). In essence, we combing the `time` and `layer` dimensions into a single one. Because the layer information can be laid end-to-end, there is less wasted space, but the downside is that it becomes more difficult to extract the information for a specific layer or for a specific profile from the history file. The user has to construct a vector of indices into the combined time and layer dimension to extract the information that they need. - -To help retrieve or unpack the information stored along the `[mid|ifc][Snow|Soil|Toto]andTime` dimensions, SUMMA stores some additional information. We need information about the time-varying number of snow, soil and total layers and the history files store this information in the following variables - - * `nSnow` - time-varying number of snow layers - * `nSoil` - time-varying number of soil layers - * `nLayers` - time-varying number of total layers - -We also we need to know where along the `[mid|ifc][Snow|Soil|Toto]andTime` dimension the information for a specific time step is stored. SUMMA stores this information in the variables - - * `ifcSnowStartIndex` (may not be present if there is no snow) - * `ifcSoilStartIndex` - * `ifcTotoStartIndex` - * `midSnowStartIndex` (may not be present if there is no snow) - * `midSoilStartIndex` - * `midTotoStartIndex` - -Note that these indices are 1-based, so if you are using python, C, or any other 0-based language, you'll need to substract 1 when you use these indices to index a variable arranged along a `[mid|ifc][Snow|Soil|Toto]andTime` dimension. - -This information can now be used to extract the information you need. This may best be demonstrated with an example. For example, if you save the variable `mLayerVolFracWat` in the history file, then you'll find that this variable is arranged along the `midTotoAndTime` and `hru` dimensions in the NetCDF file -``` -double mLayerVolFracWat(midTotoAndTime, hru) -``` -If you want to extract the information for the first timestep then in pseudo-code you want to do something like this (assuming a 0-based language like python) - -```Python -# Note that the following is not real code. Typing this into python will not work as-is -hru = 0 # python indices are 0-based, so this is the first hru -timestep = 0 # python indices are 0-based, so this is the first time step -layers = nLayers[timestep, hru] # extract the number of layers associated with the first timestep -startIndex = midTotoStartIndex[timestep, hru] - 1 # - 1 since the SUMMA indices are 1-based and python indices are 0-based -endIndex = startIndex + layers -moistureProfile = mLayerVolFracWat[startIndex:endIndex, hru] # moisture profile at the first timestep -``` - -To get the actual vertical locations (rather than just the vertical indices), you should also include `mLayerHeight` in the history file. Since this is arranged along the same dimension, you can extract the actual vertical locations (in m) as `mLayerHeight[startIndex:endIndex, hru]`. - -You can combine these various forms of information to extract detailed information about SUMMA model output, such as the plot below which shows the time evolution of temperature in a SUMMA simulation in which there is a varying number of vertical layers because of snow accumulation and melt. Here `0.0` indicates the top of the soil layers. Negative numbers describe locations within the soil, while positive numbers indicate locations within the snow. - -![Time evolution of temperature in a simulation with a time varying number of snow layers](../assets/img/SUMMA_temperature_profile_example.png) -*Time evolution of temperature in a simulation with a time varying number of snow layers.* +SUMMA history files are in [NetCDF format](SUMMA_input#infile_format_nc) and describe the time evolution of SUMMA variables and parameters. The files are written by the `writeParam`, `writeData`, and `writeTime` subroutines in `build/source/netcdf/modelwrite.f90`. SUMMA output is pretty flexible. You can output many time-varying model variables and parameters, including summary statistics. You can specify what you want to output in the [output control file](SUMMA_input#infile_output_control), which is one of SUMMA's required input files. diff --git a/docs/sundials_bmi_flags/bmi_interface.txt b/docs/sundials_bmi_flags/bmi_interface.txt deleted file mode 100644 index f15db32e6..000000000 --- a/docs/sundials_bmi_flags/bmi_interface.txt +++ /dev/null @@ -1,38 +0,0 @@ -Note, if you want to run with just BMI, not NextGen, do the following -First install BMI. Download the latest release of BMI from https://github.com/csdms/bmi-fortran.git -% git clone https://github.com/csdms/bmi-fortran.git -% git fetch --all --tags --prune -% git checkout tags/vX.Y.Z - -Make a directory outside the bmi-fortran folder and enter it, and make the install and build dirs, enter the build dir. -% export BMIF_VERSION=2.0 -% mkdir bmi -% cd bmi -% mkdir instdir -% mkdir buildir -% cd /buildir - -The install directory needs to be set while running the cmake inside the builddir, using home directory as $(YOUR_HOME) -% cmake ../../bmi-fortran/ -DCMAKE_INSTALL_PREFIX=$(YOUR_HOME)/bmi/instdir - -The default compiler is gfortran. To change it (it should be the same as the netcdf build and the later summa build), you could also add the following option to cmake with your $(YOUR_GFORTRAN) - -DCMAKE_Fortran_COMPILER=$(YOUR_GFORTRAN) - -You can do the last two steps by running from inside buildir: -cp ../../summa/build/makefiles/build_cmakeBMI build_cmake -./build_cmake - -If the above went well, staying in the buildir directory run: -% make -% make install - -To run a BMI interface, run the executable /bin/summa_bmi.exe -To run as previously, run the executable /bin/summa_sundials.exe with appropriate command line arguments. - -All BMI files are in build/source/driver. The important ones are as following: - -summa_bmi.f90: this contains the code that was in summa_driver.f90 and adds to it the BMI functions. It is now a module and uses the BMI library. - -summa_driver.f90: this is the main program called by summa_sundials.exe that will call all other modules similar to previous editions of the code. - -summa_driverBMI.f90: this is the main program called by summa_bmi.exe that will call all other modules in the BMI interface mode. \ No newline at end of file diff --git a/docs/sundials_bmi_flags/flags_params_sundials.txt b/docs/sundials_bmi_flags/flags_params_sundials.txt deleted file mode 100644 index 91f184dae..000000000 --- a/docs/sundials_bmi_flags/flags_params_sundials.txt +++ /dev/null @@ -1,13 +0,0 @@ - -To switch between SUMMA-BE and SUMMA-SUNDIALS, the num_method in the model_decision file can be either one of the values "homegrown" (choice "itertive" is backward compatible), "kinsol", or "ida". - -In energy conservation residual for backward Euler, either the the analytical (closed form) heat capacity formula or the enthalpy finite difference formula (dH_T/dT) is used. The "nrgConserv" variable has been added to the var_lookup module to handle such decision. A user should add this variable to the model_decision file with one of the values "closedForm" or "enthalpyFD". Choice of num_method as "itertive" will set num_method=homegrown and nrgConserv=closedForm. - -All SUMMA-SUNDIALS files are in build/source/engine. The important ones are as following: - -summaSolve4ida.f90: contains public subroutine summaSolve4ida which solves the differential equation system F(y,y') = 0 by IDA (y is the state vector) and private subroutines setInitialCondition and setSolverParams. Subroutine setSolverParams can be used to to set parameters (maximum order, number of nonlinear iteration , etc) in IDA solver. - -eval8summaWithPrime.f90: contains public subroutine eval8summaWithPrime which computes the residual vector F(t,y,y') mainly by calling varExtract, updateVarsWithPrime, computFlux, and computResidWithPrime. We also switch between different forms of the energy equation in this subroutine. It also contains public function eval8summa4ida which is the interface wrapper for computing the residual vector required for the IDA solver. - -computJacobWithPrime.f90: contains public subroutine computJacobWithPrime which computes the Jacobian matrix dF/dy + c dF/dy'. It also contains the public function computJacob4ida which is the interface wrapper for computing the Jacobian matrix required for the IDA solver. - diff --git a/docs/whats-new.md b/docs/whats-new.md index 9f5bab15e..0ed07cfd7 100644 --- a/docs/whats-new.md +++ b/docs/whats-new.md @@ -3,7 +3,7 @@ This page provides simple, high-level documentation about what has changed in ea ## Pre-release ### Major changes -- General cleanup and shortening of computFlux.f90, vegNrgFlux.f90, ssdNrgFlux.f90, vegLiqFlux.f90, snowLiqFlx.f90, soilLiqFlx.f90, groundwatr.f90, and bigAquifer.f90 +- General cleanup and shortening of computFlux.f90, vegNrgFlux.f90, snowSoilNrgFlux.f90, vegLiqFlux.f90, snowLiqFlux.f90, soilLiqFlux.f90, groundwatr.f90, and bigAquifer.f90 - Added object-oriented methods to simplify flux routine calls in computFlux and improve modularity - classes for each flux routine were added to data_types.f90 - large associate statemements are no longer needed in computFlux (associate blocks are now much shorter) diff --git a/test_ngen/domain_provo/settings/SUMMA/modelDecisions.txt b/test_ngen/domain_provo/settings/SUMMA/modelDecisions.txt index ba49e5e0d..4975b7059 100755 --- a/test_ngen/domain_provo/settings/SUMMA/modelDecisions.txt +++ b/test_ngen/domain_provo/settings/SUMMA/modelDecisions.txt @@ -8,8 +8,8 @@ ! (3) the simulation start/end times must be within single quotes ! *********************************************************************************************************************** ! *********************************************************************************************************************** -soilCatTbl STAS ! (03) soil-category dataset -vegeParTbl USGS ! (04) vegetation category dataset +soilCatTbl ROSETTA ! (03) soil-category dataset +vegeParTbl USGS ! (04) vegetation category dataset soilStress NoahType ! (05) choice of function for the soil moisture control on stomatal resistance stomResist BallBerry ! (06) choice of function for stomatal resistance ! *********************************************************************************************************************** @@ -23,23 +23,24 @@ bcUpprTdyn nrg_flux ! (13) type of upper boundary co bcLowrTdyn zeroFlux ! (14) type of lower boundary condition for thermodynamics bcUpprSoiH liq_flux ! (15) type of upper boundary condition for soil hydrology bcLowrSoiH drainage ! (16) type of lower boundary condition for soil hydrology -veg_traits vegTypeTable ! (17) choice of parameterization for vegetation roughness length and displacement height +veg_traits Raupach_BLM1994 ! (17) choice of parameterization for vegetation roughness length and displacement height canopyEmis difTrans ! (18) choice of parameterization for canopy emissivity snowIncept lightSnow ! (19) choice of parameterization for snow interception windPrfile logBelowCanopy ! (20) choice of wind profile through the canopy astability louisinv ! (21) choice of stability function -canopySrad noah_mp ! (22) choice of canopy shortwave radiation method -alb_method varDecay ! (23) choice of albedo representation +canopySrad BeersLaw ! (22) choice of canopy shortwave radiation method +alb_method conDecay ! (23) choice of albedo representation compaction anderson ! (24) choice of compaction routine -snowLayers jrdn1991 ! (25) choice of method to combine and sub-divide snow layers +snowLayers CLM_2010 ! (25) choice of method to combine and sub-divide snow layers thCondSnow jrdn1991 ! (26) choice of thermal conductivity representation for snow thCondSoil funcSoilWet ! (27) choice of thermal conductivity representation for soil spatial_gw localColumn ! (28) choice of method for the spatial representation of groundwater subRouting timeDlay ! (29) choice of method for sub-grid routing nrgConserv enthalpyForm ! (30) choice of variable in energy equations (BE residual or IDA state variable) infRateMax GreenAmpt ! (31) choice of infiltration rate method -surfRun_IE homegrown_IE ! (32) infiltration excess surface runoff parameterization -surfRun_SE homegrown_SE ! (33) saturation excess surface runoff parameterization +surfRun_SE homegrown_SE ! (32) saturation excess surface runoff parameterization +read_force readPerStep ! (33) method used to read forcing data +write_buff writePerStep ! (34) method used to write model output ! *********************************************************************************************** ! ***** description of the options available -- nothing below this point is read **************** ! *********************************************************************************************** @@ -171,22 +172,26 @@ surfRun_SE homegrown_SE ! (33) saturation excess surface ! ----------------------------------------------------------------------------------------------- ! (30) choice of variable in energy equations (BE residual or IDA state variable) ! closedForm ! use temperature with closed form heat capacity -! enthalpyFormLU ! use enthalpy with soil temperature-enthalpy lookup tables -! enthalpyForm ! use enthalpy with soil temperature-enthalpy analytical solutions +! enthalpyForm ! use enthalpy with soil temperature-enthalpy lookup tables +! enthalpyFormAN ! use enthalpy with soil temperature-enthalpy analytical solutions ! ----------------------------------------------------------------------------------------------- ! (31) choice of infiltration rate method ! GreenAmpt ! Green-Ampt ! topmodel_GA ! Green-Ampt with TOPMODEL conductivity rate ! noInfExc ! no infiltration excess runoff (saturation excess may still occur) ! ----------------------------------------------------------------------------------------------- -! (32) choice of infiltration excess (IE) surface runoff parameterization -! zero_IE ! zero IE surface runoff -! homegrown_IE ! IE component of SUMMA's original liquid flux parameterization (default) -! ----------------------------------------------------------------------------------------------- -! (33) choice of saturation excess (SE) surface runoff parameterization +! (32) choice of saturation excess (SE) surface runoff parameterization ! zero_SE ! zero SE surface runoff ! homegrown_SE ! SE component of SUMMA's original liquid flux parameterization (default) ! FUSEPRMS ! FUSE PRMS surface runoff parameterization ! FUSEAVIC ! FUSE ARNO/VIC surface runoff parameterization ! FUSETOPM ! FUSE TOPMODEL surface runoff parameterization -! *********************************************************************************************** +! ----------------------------------------------------------------------------------------------- +! (33) method used to read forcing data +! readPerStep ! read forcing data per time step (default) +! readFullSeries ! read full forcing series in a buffered read +! ----------------------------------------------------------------------------------------------- +! (34) method used to write model output +! writePerStep ! write model output per time step (default) +! writeFullSeries ! write all data for a given output file in a buffered read +! *********************************************************************************************** \ No newline at end of file diff --git a/test_ngen/gauge_01073000/settings/SUMMA/modelDecisions.txt b/test_ngen/gauge_01073000/settings/SUMMA/modelDecisions.txt index ba49e5e0d..4975b7059 100644 --- a/test_ngen/gauge_01073000/settings/SUMMA/modelDecisions.txt +++ b/test_ngen/gauge_01073000/settings/SUMMA/modelDecisions.txt @@ -8,8 +8,8 @@ ! (3) the simulation start/end times must be within single quotes ! *********************************************************************************************************************** ! *********************************************************************************************************************** -soilCatTbl STAS ! (03) soil-category dataset -vegeParTbl USGS ! (04) vegetation category dataset +soilCatTbl ROSETTA ! (03) soil-category dataset +vegeParTbl USGS ! (04) vegetation category dataset soilStress NoahType ! (05) choice of function for the soil moisture control on stomatal resistance stomResist BallBerry ! (06) choice of function for stomatal resistance ! *********************************************************************************************************************** @@ -23,23 +23,24 @@ bcUpprTdyn nrg_flux ! (13) type of upper boundary co bcLowrTdyn zeroFlux ! (14) type of lower boundary condition for thermodynamics bcUpprSoiH liq_flux ! (15) type of upper boundary condition for soil hydrology bcLowrSoiH drainage ! (16) type of lower boundary condition for soil hydrology -veg_traits vegTypeTable ! (17) choice of parameterization for vegetation roughness length and displacement height +veg_traits Raupach_BLM1994 ! (17) choice of parameterization for vegetation roughness length and displacement height canopyEmis difTrans ! (18) choice of parameterization for canopy emissivity snowIncept lightSnow ! (19) choice of parameterization for snow interception windPrfile logBelowCanopy ! (20) choice of wind profile through the canopy astability louisinv ! (21) choice of stability function -canopySrad noah_mp ! (22) choice of canopy shortwave radiation method -alb_method varDecay ! (23) choice of albedo representation +canopySrad BeersLaw ! (22) choice of canopy shortwave radiation method +alb_method conDecay ! (23) choice of albedo representation compaction anderson ! (24) choice of compaction routine -snowLayers jrdn1991 ! (25) choice of method to combine and sub-divide snow layers +snowLayers CLM_2010 ! (25) choice of method to combine and sub-divide snow layers thCondSnow jrdn1991 ! (26) choice of thermal conductivity representation for snow thCondSoil funcSoilWet ! (27) choice of thermal conductivity representation for soil spatial_gw localColumn ! (28) choice of method for the spatial representation of groundwater subRouting timeDlay ! (29) choice of method for sub-grid routing nrgConserv enthalpyForm ! (30) choice of variable in energy equations (BE residual or IDA state variable) infRateMax GreenAmpt ! (31) choice of infiltration rate method -surfRun_IE homegrown_IE ! (32) infiltration excess surface runoff parameterization -surfRun_SE homegrown_SE ! (33) saturation excess surface runoff parameterization +surfRun_SE homegrown_SE ! (32) saturation excess surface runoff parameterization +read_force readPerStep ! (33) method used to read forcing data +write_buff writePerStep ! (34) method used to write model output ! *********************************************************************************************** ! ***** description of the options available -- nothing below this point is read **************** ! *********************************************************************************************** @@ -171,22 +172,26 @@ surfRun_SE homegrown_SE ! (33) saturation excess surface ! ----------------------------------------------------------------------------------------------- ! (30) choice of variable in energy equations (BE residual or IDA state variable) ! closedForm ! use temperature with closed form heat capacity -! enthalpyFormLU ! use enthalpy with soil temperature-enthalpy lookup tables -! enthalpyForm ! use enthalpy with soil temperature-enthalpy analytical solutions +! enthalpyForm ! use enthalpy with soil temperature-enthalpy lookup tables +! enthalpyFormAN ! use enthalpy with soil temperature-enthalpy analytical solutions ! ----------------------------------------------------------------------------------------------- ! (31) choice of infiltration rate method ! GreenAmpt ! Green-Ampt ! topmodel_GA ! Green-Ampt with TOPMODEL conductivity rate ! noInfExc ! no infiltration excess runoff (saturation excess may still occur) ! ----------------------------------------------------------------------------------------------- -! (32) choice of infiltration excess (IE) surface runoff parameterization -! zero_IE ! zero IE surface runoff -! homegrown_IE ! IE component of SUMMA's original liquid flux parameterization (default) -! ----------------------------------------------------------------------------------------------- -! (33) choice of saturation excess (SE) surface runoff parameterization +! (32) choice of saturation excess (SE) surface runoff parameterization ! zero_SE ! zero SE surface runoff ! homegrown_SE ! SE component of SUMMA's original liquid flux parameterization (default) ! FUSEPRMS ! FUSE PRMS surface runoff parameterization ! FUSEAVIC ! FUSE ARNO/VIC surface runoff parameterization ! FUSETOPM ! FUSE TOPMODEL surface runoff parameterization -! *********************************************************************************************** +! ----------------------------------------------------------------------------------------------- +! (33) method used to read forcing data +! readPerStep ! read forcing data per time step (default) +! readFullSeries ! read full forcing series in a buffered read +! ----------------------------------------------------------------------------------------------- +! (34) method used to write model output +! writePerStep ! write model output per time step (default) +! writeFullSeries ! write all data for a given output file in a buffered read +! *********************************************************************************************** \ No newline at end of file diff --git a/utils/post-processing/hist_per_GRU.py b/utils/post-processing/hist_per_GRU.py index 49b46d2d5..634ade48d 100644 --- a/utils/post-processing/hist_per_GRU.py +++ b/utils/post-processing/hist_per_GRU.py @@ -367,8 +367,8 @@ def run_loopb(i,var,mx,rep,stat2): mn = mx*1e-9 if var=='wallClockTime': mn = 0.0008 if fix_units_soil and 'Soil' in var: - mn = mn*3600*3.0 # mult by time step and depth to get storage - mx = mx*3600*3.0 + mn = mn*3600*4.0 # mult by time step and depth to get storage + mx = mx*3600*4.0 if 'Nrg' in var: mn=mn*1e-3 mx=mx*1e-3 @@ -388,7 +388,7 @@ def run_loopb(i,var,mx,rep,stat2): s = summa1[m][var].sel(stat=stat0).where(lambda x: x != 9999) if var=='wallClockTime': s = s.where(lambda x: x != 0) # water bodies should be 0 if fix_units_soil and 'Soil' in var: - s = s*3600*3.0 # mult by time step and depth to get storage + s = s*3600*4.0 # mult by time step and depth to get storage if 'Nrg' in var: s = s*1e-3 plot_range = (mn,mx) diff --git a/utils/post-processing/plot_per_GRUMultBal.py b/utils/post-processing/plot_per_GRUMultBal.py index 100a8a676..bfdb5e6c8 100644 --- a/utils/post-processing/plot_per_GRUMultBal.py +++ b/utils/post-processing/plot_per_GRUMultBal.py @@ -198,7 +198,7 @@ def make_default_path(suffix): for m in method_name: s = summa[m][plot_var].sel(stat=stat0) if fix_units_soil and 'Soil' in plot_var: - s = s * 3600 * 3.0 # Multiply by time step and depth to get storage + s = s * 3600 * 4.0 # Multiply by time step and depth to get storage if 'Nrg' in plot_var: s = s * 1e-3 @@ -236,8 +236,8 @@ def run_loop(j,var,the_max,stat,row_fill): vmin, vmax = the_max * 1e-9, the_max if var in ['wallClockTime',]: vmin,vmax = the_max*1e-1, the_max if fix_units_soil and 'Soil' in var: - vmin = vmin*3600*3.0 # mult by time step and depth to get storage - vmax = vmax*3600*3.0 + vmin = vmin*3600*4.0 # mult by time step and depth to get storage + vmax = vmax*3600*4.0 if 'Nrg' in var: vmin = vmin*1e-3 vmax = vmax*1e-3 diff --git a/utils/pre-processing/gen_coldstate.py b/utils/pre-processing/gen_coldstate.py index d7169ffab..d75e30a37 100644 --- a/utils/pre-processing/gen_coldstate.py +++ b/utils/pre-processing/gen_coldstate.py @@ -29,13 +29,13 @@ # Subroutines # ######################################################################## -def getNetCDFData(fn, varname): - """Read variables available to be mapped from NetCDF """ +def getNetCDFData(fn, varName): + """Read variables available to be mapped from NetCDF """ f = nc4.Dataset(fn,'r') - data = f.variables[varname][:] + data = f.variables[varName][:] f.close() # ds = xr.open_dataset(fn) -# data = ds[varname] +# data = ds[varName] return data def getOutputPolyIDs(nc_file): @@ -48,7 +48,7 @@ def getOutputPolyIDs(nc_file): def writeNC_state_vars(nc_out, newVarName, newVarDim, newVarType, newVarVals): """ Write [hru] array in netCDF4 file, and variable of - """ + """ print("adding data") ncvar = nc_out.createVariable(newVarName, newVarType, (newVarDim, 'hru',),fill_value='-999.0') @@ -58,7 +58,7 @@ def writeNC_state_vars(nc_out, newVarName, newVarDim, newVarType, newVarVals): # write dimensions and dimension variables to netcdf output file def writeNC_dims(fn, scalarv, midSoil, midToto, ifcToto, hrus, hru_type): """ Write [hru] array in netCDF4 file, and variable of - """ + """ print("writing output file") nc_out = nc4.Dataset(fn, 'w', format='NETCDF4') @@ -228,7 +228,7 @@ def usage(): # code for reading input data variable & attributes # to pass to processing and write routines (instead of hardwired calls above # f = nc4.Dataset(nc_infl, 'r') -# var_in = f.variables[varname] +# var_in = f.variables[varName] # attNames = [] # attContents = [] # attr = var_in.ncattrs() # get attributes