diff --git a/.gitignore b/.gitignore index 93dcaf90..bb4e14d0 100644 --- a/.gitignore +++ b/.gitignore @@ -27,7 +27,15 @@ *.out *.app +# directories +bin +cime +libraries +lib +manage_externals + # other files *.local *bak* *tmp* + diff --git a/docs/source/Control_file.rst b/docs/source/Control_file.rst index 0603a918..12b01780 100644 --- a/docs/source/Control_file.rst +++ b/docs/source/Control_file.rst @@ -24,72 +24,76 @@ Some of rules The following variables (not pre-defined in the code) need to be defined in control file. -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| option | tag | Description | -+========+========================+===========================================================================================+ -| 1,2,3 | | simulation case name. This used for output netCDF, and restart netCDF name | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 1,2,3 | | Directory that contains ancillary data (river netowrk, remapping, and parameter namelist) | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 1,2,3 | | Directory that contains runoff data | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 1,2,3 | | Directory that contains runoff data | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 1,2,3 | | Spatially constant parameter namelist (should be stored in | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 1,2,3 | | time of simulation start. format: yyyy-mm-dd or yyyy-mm-dd hh:mm:ss | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 1,2,3 | | time of simulation end. format: yyyy-mm-dd or yyyy-mm-dd hh:mm:ss | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 1,2,3 | | name of input netCDF for River Network | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 1,2,3 | | dimension name for reach in river network netCDF | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 1,2,3 | | dimension name for RN_HRU in river network netCDF | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 1,2,3 | | netCDF name for HM_HRU runoff | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 1,2,3 | | variable name for HM_HRU runoff | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 1,2,3 | | variable name for time | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 2 | | variable name for HM_HRU ID | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 3 | | dimension name for x, lon, or i dimension | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 3 | | dimension name for y, lat, or j dimension | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 1,2,3 | | dimension name for time | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 1,2,3 | | dimension name for HM_HRU | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 1,2,3 | | units of input runoff. e.g., mm/s | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 1,2,3 | | time interval of input runoff in second. e.g., 86400 sec for daily step | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 1,2,3 | | Logical to indicate runoff needs to be remapped to RN_HRU. T or F | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 2,3 | | netCDF name of runoff remapping | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 2,3 | | variable name for RN_HRUs | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 2,3 | | variable name for areal weights of overlapping HM_HRUs | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 2 | | variable name for HM_HRU ID | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 3 | | variable name of xlon index | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 3 | | variable name of ylat index | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 2,3 | | variable name for a numbers of overlapping HM_HRUs with RN_HRUs | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 2,3 | | dimension name for HM_HRU | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 2,3 | | dimension name for data | -+--------+------------------------+-------------------------------------------------------------------------------------------+ -| 1,2,3 | | option for routing schemes 0-> both, 1->IRF, 2->KWT, otherwise error | -+--------+------------------------+-------------------------------------------------------------------------------------------+ - ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| option | tag | Description | ++========+========================+==================================================================================================+ +| 1,2,3 | | simulation case name. This used for output netCDF, and restart netCDF name | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 1,2,3 | | Directory that contains ancillary data (river netowrk, remapping, and parameter namelist) | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 1,2,3 | | Directory that contains runoff data | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 1,2,3 | | Directory that contains runoff data | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 1,2,3 | | Spatially constant parameter namelist (should be stored in | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 1,2,3 | | time of simulation start. format: yyyy-mm-dd or yyyy-mm-dd hh:mm:ss | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 1,2,3 | | time of simulation end. format: yyyy-mm-dd or yyyy-mm-dd hh:mm:ss | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 1,2,3 | | name of input netCDF for River Network | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 1,2,3 | | dimension name for reach in river network netCDF | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 1,2,3 | | dimension name for RN_HRU in river network netCDF | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 1,2,3 | | netCDF name for HM_HRU runoff | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 1,2,3 | | variable name for HM_HRU runoff | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 1,2,3 | | variable name for time | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 2 | | variable name for HM_HRU ID | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 3 | | dimension name for x, lon, or i dimension | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 3 | | dimension name for y, lat, or j dimension | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 1,2,3 | | dimension name for time | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 1,2,3 | | dimension name for HM_HRU | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 1,2,3 | | units of input runoff. e.g., mm/s | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 1,2,3 | | time interval of input runoff in second. e.g., 86400 sec for daily step | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 1,2,3 | | Logical to indicate runoff needs to be remapped to RN_HRU. T or F | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 2,3 | | netCDF name of runoff remapping | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 2,3 | | variable name for RN_HRUs | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 2,3 | | variable name for areal weights of overlapping HM_HRUs | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 2 | | variable name for HM_HRU ID | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 3 | | variable name of xlon index | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 3 | | variable name of ylat index | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 2,3 | | variable name for a numbers of overlapping HM_HRUs with RN_HRUs | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 2,3 | | dimension name for HM_HRU | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 2,3 | | dimension name for data | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ +| 1,2,3 | | routing schem options: 0-> Sum, 1->IRF, 2->KWT, 3->KW, 4->MC, 5->DW, otherwise error. see Note 1 | ++--------+------------------------+--------------------------------------------------------------------------------------------------+ + +1. routing option + + * it is possible to specify multiple options (e.g., 0125 -> run with SUM, IRF KWT and DW). + Variables that have default values but can be overwritten +------------------------+------------------------+--------------------------------------------------------------------------+ @@ -101,7 +105,7 @@ Variables that have default values but can be overwritten +------------------------+------------------------+--------------------------------------------------------------------------+ | | _new.nc | output netCDF name for augmented river network. See note 1 and 2 | +------------------------+------------------------+--------------------------------------------------------------------------+ -| | annual | frequency for new output files (single, day, month, or annual) | +| | yearly | frequency for new output files (single, daily, monthly or yearly) | +------------------------+------------------------+--------------------------------------------------------------------------+ | | 1 | option for hydraulic geometry calculations (0=read from file, 1=compute) | +------------------------+------------------------+--------------------------------------------------------------------------+ @@ -140,7 +144,7 @@ Restart options mizuRoute does not write restart netCDF as default. The following control variables are used to control restart dropoff timing and use restart file for continuous run from the previous simulations. The restart file is written at previous time step to the specified time. In other words, if ``Specified`` is used for and ``1981-01-01-00000`` is specified in , mizuRoute writes restart file -at ``1980-12-31 00:00:00`` for daily time step. The restart file name uses the time stamp at user specified timing. ``Annual``, ``Monthly``, ``Daily`` options also follow This convention. +at ``1980-12-31 00:00:00`` for daily time step. The restart file name uses the time stamp at user specified timing. ``yearly``, ``monthly``, ``daily`` options also follow this convention. The restart file name convension: .r.yyyy-mm-dd-sssss.nc @@ -150,15 +154,15 @@ The restart file name convension: .r.yyyy-mm-dd-sssss.nc +=====================+=========================================================================================================+ | | directory for restart files. defualt is | +---------------------+---------------------------------------------------------------------------------------------------------+ -| | restart ouput options. N[n]ever (default), L[l]ast, S[s]pecified, Annual, M[m]onthly, D[d]aily. | +| | restart ouput options. never (default), last, specified, yearly, monthly, daily. | +---------------------+---------------------------------------------------------------------------------------------------------+ | | restart time in yyyy-mm-dd (hh:mm:ss). required if = "Specified" | +---------------------+---------------------------------------------------------------------------------------------------------+ -| | periodic restart month (default 1). Effective if ="Annual" | +| | periodic restart month (default 1). Effective if ="yearly" | +---------------------+---------------------------------------------------------------------------------------------------------+ -| | periodic restart day (default 1). Effective if ="Annual" or "Monthly" | +| | periodic restart day (default 1). Effective if ="yearly" or "monthly" | +---------------------+---------------------------------------------------------------------------------------------------------+ -| | periodic restart hour (default 0). Effective if ="Annual", "Monthly", or "Daily" | +| | periodic restart hour (default 0). Effective if ="yearly", "monthly", or "daily" | +---------------------+---------------------------------------------------------------------------------------------------------+ | | input restart netCDF name. If not specified, simulation start with cold start | +---------------------+---------------------------------------------------------------------------------------------------------+ @@ -184,10 +188,16 @@ The output file name convension: .h.yyyy-mm-dd-sssss.nc +------------------------+------------------------------------------------------------------------------------------------+ | | accumulated delayed runoff volume (dlyRunoff) over all upstream reaches. | +------------------------+------------------------------------------------------------------------------------------------+ -| | runoff volume [m3/s] after KWT reach routing dlayRunoff. See note 3 | +| | runoff volume [m3/s] after Kinematic wave tracking (KWT) reach routing dlayRunoff. See note 3 | +------------------------+------------------------------------------------------------------------------------------------+ | | runoff volume [m3/s] after IRF reach routing dlayRunoff. See note 3 | +------------------------+------------------------------------------------------------------------------------------------+ +| | runoff volume [m3/s] after KW (Kinematic Wave) reach routing dlayRunoff. See note 3 | ++------------------------+------------------------------------------------------------------------------------------------+ +| | runoff volume [m3/s] after MC (Muskingum-Cunge) reach routing dlayRunoff. See note 3 | ++------------------------+------------------------------------------------------------------------------------------------+ +| | runoff volume [m3/s] after DW (Diffusive wave) reach routing dlayRunoff. See note 3 | ++------------------------+------------------------------------------------------------------------------------------------+ 1. The unit of runoff depth is the same as the unit used in runoff data @@ -228,7 +238,7 @@ Option 1 - runoff input is given at RN_HRU:: cameo_v1.2.mizuRoute.r.1950-1-1-00000.nc ! netCDF name for the model state input specified ! restart write option. never, last, specified (need to specify date with 1950-08-31 00:00:00 ! restart date - 0 ! option for routing schemes 0-> both, 1->IRF, 2->KWT otherwise error + 012345 ! option for routing schemes 0-> SUM, 1->IRF, 2->KWT, 3->KW, 4->MC, 5->DW, otherwise error ! ************************************************************************************************************************** ! DEFINE FINE NAME AND DIMENSIONS ! --------------------------------------- @@ -284,7 +294,7 @@ Option 2 - runoff input is given at HM_HRU:: cameo_v1.2.mizuRoute.r.1950-1-1-00000.nc ! netCDF name for the model state input specified ! restart write option. never, last, specified (need to specify date with 1950-08-31 00:00:00 ! restart date - 0 ! option for routing schemes 0-> both, 1->IRF, 2->KWT otherwise error + 012345 ! option for routing schemes 0-> SUM, 1->IRF, 2->KWT, 3->KW, 4->MC, 5->DW, otherwise error ! ************************************************************************************************************************** ! DEFINE FINE NAME AND DIMENSIONS ! --------------------------------------- @@ -347,7 +357,7 @@ Option 3 - runoff input is given at grid:: cameo_v1.2.mizuRoute.r.1950-1-1-00000.nc ! netCDF name for the model state input specified ! restart write option. never, last, specified (need to specify date with 1950-08-31 00:00:00 ! restart date - 0 ! option for routing schemes 0-> both, 1->IRF, 2->KWT otherwise error + 012345 ! option for routing schemes 0-> SUM, 1->IRF, 2->KWT, 3->KW, 4->MC, 5->DW, otherwise error ! ************************************************************************************************************************** ! DEFINE FINE NAME AND DIMENSIONS ! --------------------------------------- diff --git a/route/build/Makefile b/route/build/Makefile index 0423ebf5..2fe677a5 100644 --- a/route/build/Makefile +++ b/route/build/Makefile @@ -15,7 +15,7 @@ FC = # Define the compiler exe, e.g., gnu=>gfortran, intel=>ifort, pgi=>pgf90 FC_EXE = -# Define the compiled executable +# Define the executable EXE = # Define optional setting @@ -35,12 +35,12 @@ F_MASTER = # Define the NetCDF libraries and path to include files ifeq "$(FC)" "gnu" NCDF_PATH = -endif -ifeq "$(FC)" "intel" +else ifeq "$(FC)" "intel" NCDF_PATH = -endif -ifeq "$(FC)" "pgi" +else ifeq "$(FC)" "pgi" NCDF_PATH = +else + $(error FC is not set correctly) endif LIBNETCDF = -Wl,-rpath,$(NCDF_PATH)/lib \ @@ -114,9 +114,15 @@ EXE_PATH = $(F_MASTER)bin #======================================================================== # Define subroutines # +# define utilities +UTILS = \ + nrtype.f90 \ + nr_utility.f90 \ + ascii_util.f90 \ + ncio_utils.f90 \ + gamma_func.f90 # data types DATATYPES = \ - nrtype.f90 \ public_var.f90 \ dataTypes.f90 \ var_lookup.f90 \ @@ -125,12 +131,6 @@ DATATYPES = \ globalData.f90 \ popMetadat.f90 \ allocation.f90 -# define utilities -UTILS = \ - nr_utility.f90 \ - ascii_util.f90 \ - ncio_utils.f90 \ - gamma_func.f90 # initialization INIT = \ network_topo.f90 \ @@ -158,11 +158,14 @@ CORE = \ basinUH.f90 \ irf_route.f90 \ kwt_route.f90 \ + dfw_route.f90 \ + kw_route.f90 \ + mc_route.f90 \ main_route.f90 \ model_setup.f90 # concatanate model subroutines -TEMP_MODSUB = $(DATATYPES) $(UTILS) $(INIT) $(IO) $(CORE) +TEMP_MODSUB = $(UTILS) $(DATATYPES) $(INIT) $(IO) $(CORE) # insert appropriate directory name MODSUB = $(patsubst %, $(F_KORE_DIR)%, $(TEMP_MODSUB)) @@ -183,6 +186,7 @@ all: compile install clean compile: $(FC_EXE) $(FLAGS) $(MODSUB) $(DRIVER) \ $(LIBNETCDF) $(INCNETCDF) -o $(EXE) + @echo "Succesfully compiled" # Remove object files clean: @@ -190,8 +194,10 @@ clean: rm -f *.lst rm -f *.mod rm -f *__genmod.f90 + @echo "Successfully cleaned object files" # # Copy the executable to the bin directory install: @mkdir -p $(EXE_PATH) @mv $(EXE) $(EXE_PATH) + @echo "Successfully installed" diff --git a/route/build/src/accum_runoff.f90 b/route/build/src/accum_runoff.f90 index 8efa546f..8f541d0e 100644 --- a/route/build/src/accum_runoff.f90 +++ b/route/build/src/accum_runoff.f90 @@ -1,16 +1,19 @@ MODULE accum_runoff_module USE nrtype -USE public_var - ! data type -USE dataTypes, only : STRFLX ! fluxes in each reach -USE dataTypes, only : RCHTOPO ! Network topology +USE dataTypes, ONLY: STRFLX ! fluxes in each reach +USE dataTypes, ONLY: RCHTOPO ! Network topology +USE dataTypes, ONLY: subbasin_omp ! mainstem+tributary data structures +! global data +USE public_var, ONLY: iulog ! i/o logical unit number +USE globalData, ONLY: idxSUM ! index of accumulation method +! subroutines: general +USE model_finalize, ONLY : handle_err implicit none private - public::accum_runoff CONTAINS @@ -33,9 +36,6 @@ SUBROUTINE accum_runoff(iEns, & ! input: index of runoff ensemble to be ! ! ---------------------------------------------------------------------------------------- - USE dataTypes, ONLY: subbasin_omp ! mainstem+tributary data structures - USE model_finalize, ONLY : handle_err - implicit none ! input integer(i4b), intent(in) :: iens ! runoff ensemble index @@ -114,7 +114,7 @@ END SUBROUTINE accum_runoff ! ********************************************************************* ! subroutine: perform accumulate immediate upstream flow ! ********************************************************************* - subroutine accum_qupstream(iEns, & ! input: index of runoff ensemble to be processed + SUBROUTINE accum_qupstream(iEns, & ! input: index of runoff ensemble to be processed segIndex, & ! input: index of reach to be processed ixDesire, & ! input: reachID to be checked by on-screen pringing NETOPO_in, & ! input: reach topology data structure @@ -122,9 +122,9 @@ subroutine accum_qupstream(iEns, & ! input: index of runoff ensemble to ierr, message) ! output: error control implicit none ! Input - INTEGER(I4B), intent(IN) :: iEns ! runoff ensemble to be routed - INTEGER(I4B), intent(IN) :: segIndex ! segment where routing is performed - INTEGER(I4B), intent(IN) :: ixDesire ! index of the reach for verbose output + integer(i4b), intent(in) :: iEns ! runoff ensemble to be routed + integer(i4b), intent(in) :: segIndex ! segment where routing is performed + integer(i4b), intent(in) :: ixDesire ! index of the reach for verbose output type(RCHTOPO),intent(in), allocatable :: NETOPO_in(:) ! River Network topology ! inout TYPE(STRFLX), intent(inout), allocatable :: RCHFLX_out(:,:) ! Reach fluxes (ensembles, space [reaches]) for decomposed domains @@ -137,24 +137,23 @@ subroutine accum_qupstream(iEns, & ! input: index of runoff ensemble to integer(i4b) :: iUps ! upstream reach index integer(i4b) :: iRch_ups ! index of upstream reach in NETOPO character(len=strLen) :: fmt1,fmt2 ! format string - character(len=strLen) :: cmessage ! error message from subroutine ierr=0; message='accum_qupstream/' ! identify number of upstream segments of the reach being processed nUps = size(NETOPO_in(segIndex)%UREACHI) - RCHFLX_out(iEns,segIndex)%UPSTREAM_QI = RCHFLX_out(iEns,segIndex)%BASIN_QR(1) + RCHFLX_out(iEns,segIndex)%ROUTE(idxSUM)%REACH_Q = RCHFLX_out(iEns,segIndex)%BASIN_QR(1) q_upstream = 0._dp if (nUps>0) then do iUps = 1,nUps iRch_ups = NETOPO_in(segIndex)%UREACHI(iUps) ! index of upstream of segIndex-th reach - q_upstream = q_upstream + RCHFLX_out(iens,iRch_ups)%UPSTREAM_QI + q_upstream = q_upstream + RCHFLX_out(iens,iRch_ups)%ROUTE(idxSUM)%REACH_Q end do - RCHFLX_out(iEns,segIndex)%UPSTREAM_QI = RCHFLX_out(iEns,segIndex)%UPSTREAM_QI + q_upstream + RCHFLX_out(iEns,segIndex)%ROUTE(idxSUM)%REACH_Q = RCHFLX_out(iEns,segIndex)%ROUTE(idxSUM)%REACH_Q + q_upstream endif @@ -162,16 +161,16 @@ subroutine accum_qupstream(iEns, & ! input: index of runoff ensemble to if(segIndex == ixDesire)then write(fmt1,'(A,I5,A)') '(A,1X',nUps,'(1X,I10))' write(fmt2,'(A,I5,A)') '(A,1X',nUps,'(1X,F20.7))' - write(*,'(2a)') new_line('a'),'** Check upstream discharge accumulation **' - write(*,'(a,x,I10,x,I10)') ' Reach index & ID =', segIndex, NETOPO_in(segIndex)%REACHID - write(*,'(a)') ' * upstream reach index (NETOPO_in%UREACH) and discharge (uprflux) [m3/s] :' - write(*,fmt1) ' UREACHK =', (NETOPO_in(segIndex)%UREACHK(iUps), iUps=1,nUps) - write(*,fmt2) ' prflux =', (RCHFLX_out(iens,NETOPO_in(segIndex)%UREACHI(iUps))%UPSTREAM_QI, iUps=1,nUps) - write(*,'(a)') ' * local area discharge (RCHFLX_out%BASIN_QR(1)) and final discharge (RCHFLX_out%UPSTREAM_QI) [m3/s] :' - write(*,'(a,x,F15.7)') ' RCHFLX_out%BASIN_QR(1) =', RCHFLX_out(iEns,segIndex)%BASIN_QR(1) - write(*,'(a,x,F15.7)') ' RCHFLX_out%UPSTREAM_QI =', RCHFLX_out(iens,segIndex)%UPSTREAM_QI + write(iulog,'(2a)') new_line('a'),'** Check upstream discharge accumulation **' + write(iulog,'(a,x,I10,x,I10)') ' Reach index & ID =', segIndex, NETOPO_in(segIndex)%REACHID + write(iulog,'(a)') ' * upstream reach index (NETOPO_in%UREACH) and discharge (uprflux) [m3/s] :' + write(iulog,fmt1) ' UREACHK =', (NETOPO_in(segIndex)%UREACHK(iUps), iUps=1,nUps) + write(iulog,fmt2) ' prflux =', (RCHFLX_out(iens,NETOPO_in(segIndex)%UREACHI(iUps))%ROUTE(idxSUM)%REACH_Q, iUps=1,nUps) + write(iulog,'(a)') ' * local area discharge (RCHFLX_out%BASIN_QR(1)) and final discharge (RCHFLX_out%ROUTE(idxSUM)%REACH_Q) [m3/s] :' + write(iulog,'(a,x,F15.7)') ' RCHFLX_out%BASIN_QR(1) =', RCHFLX_out(iEns,segIndex)%BASIN_QR(1) + write(iulog,'(a,x,F15.7)') ' RCHFLX_out%ROUTE(idxSUM)%REACH_Q =', RCHFLX_out(iens,segIndex)%ROUTE(idxSUM)%REACH_Q endif - end subroutine accum_qupstream + END SUBROUTINE accum_qupstream END MODULE accum_runoff_module diff --git a/route/build/src/ascii_util.f90 b/route/build/src/ascii_util.f90 index 17f30278..1a408993 100644 --- a/route/build/src/ascii_util.f90 +++ b/route/build/src/ascii_util.f90 @@ -1,11 +1,18 @@ -module ascii_util_module +MODULE ascii_util_module + USE nrtype + implicit none + private + public::file_open public::split_line public::get_vlines -contains +public::lower +public::upper + +CONTAINS ! ********************************************************************************************** ! new subroutine: get unused file unit (modified from DMSL) @@ -204,4 +211,44 @@ subroutine get_vlines(unt,vlines,err,message) end subroutine get_vlines -end module ascii_util_module + FUNCTION upper(strIn) RESULT(strOut) + ! convert string to upper-case + ! only ASCII character code works + implicit none + + character(*), intent(in) :: strIn + character(len(strIn)) :: strOut + integer, parameter :: DUC = ichar('A') - ichar('a') + character :: ch + integer :: i + + do i = 1, len(strIn) + ch = strIn(i:i) + if (ch>='a' .and. ch<='z') ch = char(ichar(ch)+DUC) + strOut(i:i) = ch + end do + + END FUNCTION upper + + + pure FUNCTION lower(strIn) RESULT(strOut) + ! convert string to lower-case + ! only ASCII character code works + implicit none + + character(*), intent(in) :: strIn + character(len(strIn)) :: strOut + integer, parameter :: DUC = ichar('A') - ichar('a') + character :: ch + integer :: i + + do i = 1,len(strIn) + ch = strIn(i:i) + if (ch>='A' .and. ch<='Z') ch = char(ichar(ch)-DUC) + strOut(i:i) = ch + end do + + END FUNCTION lower + + +END MODULE ascii_util_module diff --git a/route/build/src/dataTypes.f90 b/route/build/src/dataTypes.f90 index 9fa5964e..8314238a 100644 --- a/route/build/src/dataTypes.f90 +++ b/route/build/src/dataTypes.f90 @@ -202,45 +202,78 @@ module dataTypes LOGICAL(LGT) :: USRTAKE ! .TRUE. if user takes from reach, .FALSE. otherwise end type RCHTOPO - ! ---------- kinematic wave states (collection of particles) --------------------------------- + ! ---------- reach states -------------------------------------------------------------------- + !---------- Lagrangian kinematic wave states (collection of particles) --------------------------------- ! Individual flow particles ! NOTE: type could possibly be private - TYPE, public :: FPOINT - REAL(DP) :: QF ! Flow - REAL(DP) :: QM ! Modified flow - REAL(DP) :: TI ! initial time of point in reach - REAL(DP) :: TR ! time point expected to exit reach - LOGICAL(LGT) :: RF ! routing flag (T if point has exited) - END TYPE FPOINT + type, public :: FPOINT + real(dp) :: QF ! Flow + real(dp) :: QM ! Modified flow + real(dp) :: TI ! initial time of point in reach + real(dp) :: TR ! time point expected to exit reach + logical(lgt) :: RF ! routing flag (T if point has exited) + end type FPOINT ! Collection of flow points within a given reach - TYPE, public :: KREACH - TYPE(FPOINT),allocatable :: KWAVE(:) - END TYPE KREACH + type, public :: kwtRCH + type(FPOINT),allocatable :: KWAVE(:) + end type kwtRCH ! ---------- irf states (future flow series ) --------------------------------- - ! Future flow series - TYPE, public :: IRFREACH - REAL(DP), allocatable :: qfuture(:) ! runoff volume in future time steps for IRF routing (m3/s) - END TYPE IRFREACH + type, public :: irfRCH + real(dp), allocatable :: qfuture(:) ! runoff volume in future time steps for IRF routing (m3/s) + end type irfRCH + + ! ---------- computational molecule --------------------------------- + type, public :: cMolecule + integer(i4b) :: KW_ROUTE + integer(i4b) :: MC_ROUTE + integer(i4b) :: DW_ROUTE + end type cMolecule + + type, public :: SUBRCH + real(dp), allocatable :: Q(:) ! Discharge at sub-reaches at current step (m3/s) + real(dp), allocatable :: A(:) ! Flow area at sub-reach at current step (m2) + real(dp), allocatable :: H(:) ! Flow height at sub-reach at current step (m) + end type SUBRCH + + type, public :: kwRch + type(SUBRCH) :: molecule + end type kwRCH + + type, public :: mcRch + type(SUBRCH) :: molecule + end type mcRCH + + type, public :: dwRch + type(SUBRCH) :: molecule + end type dwRCH + + type, public :: STRSTA + type(irfRCH) :: IRF_ROUTE + type(kwtRCH) :: LKW_ROUTE + type(kwRCH) :: KW_ROUTE + type(mcRCH) :: MC_ROUTE + type(dwRCH) :: DW_ROUTE + end type STRSTA ! ---------- reach fluxes -------------------------------------------------------------------- + type, public :: fluxes + real(dp) :: REACH_Q + real(dp) :: REACH_VOL(0:1) + end type fluxes ! fluxes in each reach TYPE, public :: STRFLX - REAL(DP), allocatable :: QFUTURE(:) ! runoff volume in future time steps (m3/s) - REAL(DP), allocatable :: QFUTURE_IRF(:) ! runoff volume in future time steps for IRF routing (m3/s) - REAL(DP) :: BASIN_QI ! instantaneous runoff volume from the local basin (m3/s) - REAL(DP) :: BASIN_QR(0:1) ! routed runoff volume from the local basin (m3/s) - REAL(DP) :: BASIN_QR_IRF(0:1) ! routed runoff volume from all the upstream basin (m3/s) - REAL(DP) :: REACH_Q ! time-step average streamflow (m3/s) - REAL(DP) :: REACH_Q_IRF ! time-step average streamflow (m3/s) from IRF routing - REAL(DP) :: UPSTREAM_QI ! sum of upstream streamflow (m3/s) - REAL(DP) :: REACH_VOL(0:1) ! volume of water at a reach [m3] - REAL(DP) :: TAKE ! average take - logical(lgt) :: CHECK_IRF ! .true. if the reach is routed + real(dp), allocatable :: QFUTURE(:) ! runoff volume in future time steps (m3/s) + real(dp), allocatable :: QFUTURE_IRF(:) ! runoff volume in future time steps for IRF routing (m3/s) + real(dp) :: BASIN_QI ! instantaneous runoff volume from the local basin (m3/s) + real(dp) :: BASIN_QR(0:1) ! routed runoff volume from the local basin (m3/s) + real(dp) :: BASIN_QR_IRF(0:1) ! routed runoff volume from all the upstream basin (m3/s) + type(fluxes), allocatable :: ROUTE(:) ! reach fluxes and states for each routing method + real(dp) :: TAKE ! average take ENDTYPE STRFLX ! ---------- lake data types ----------------------------------------------------------------- diff --git a/route/build/src/dfw_route.f90 b/route/build/src/dfw_route.f90 new file mode 100644 index 00000000..a518d96a --- /dev/null +++ b/route/build/src/dfw_route.f90 @@ -0,0 +1,508 @@ +MODULE dfw_route_module + +USE nrtype +! data types +USE dataTypes, ONLY: STRFLX ! fluxes in each reach +USE dataTypes, ONLY: STRSTA ! state in each reach +USE dataTypes, ONLY: RCHTOPO ! Network topology +USE dataTypes, ONLY: RCHPRP ! Reach parameter +USE dataTypes, ONLY: dwRCH ! dw specific state data structure +USE dataTypes, ONLY: subbasin_omp ! mainstem+tributary data strucuture +! global data +USE public_var, ONLY: iulog ! i/o logical unit number +USE public_var, ONLY: realMissing ! missing value for real number +USE public_var, ONLY: integerMissing ! missing value for integer number +USE globalData, ONLY: idxDW +! subroutines: general +USE model_finalize, ONLY : handle_err + +! privary +implicit none +private + +public::dfw_route + +CONTAINS + + ! ********************************************************************* + ! subroutine: perform diffusive wave routing through the river network + ! ********************************************************************* + SUBROUTINE dfw_route(iens, & ! input: ensemble index + river_basin, & ! input: river basin information (mainstem, tributary outlet etc.) + T0,T1, & ! input: start and end of the time step + ixDesire, & ! input: reachID to be checked by on-screen pringing + NETOPO_in, & ! input: reach topology data structure + RPARAM_in, & ! input: reach parameter data structure + RCHSTA_out, & ! inout: reach state data structure + RCHFLX_out, & ! inout: reach flux data structure + ierr,message, & ! output: error control + ixSubRch) ! optional input: subset of reach indices to be processed + + implicit none + ! Input + integer(i4b), intent(in) :: iEns ! ensemble member + type(subbasin_omp), intent(in), allocatable :: river_basin(:) ! river basin information (mainstem, tributary outlet etc.) + real(dp), intent(in) :: T0,T1 ! start and end of the time step (seconds) + integer(i4b), intent(in) :: ixDesire ! index of the reach for verbose output + type(RCHTOPO), intent(in), allocatable :: NETOPO_in(:) ! River Network topology + type(RCHPRP), intent(in), allocatable :: RPARAM_in(:) ! River reach parameter + ! inout + type(STRSTA), intent(inout), allocatable :: RCHSTA_out(:,:) ! reach state data + type(STRFLX), intent(inout), allocatable :: RCHFLX_out(:,:) ! Reach fluxes (ensembles, space [reaches]) for decomposed domains + ! output variables + integer(i4b), intent(out) :: ierr ! error code + character(*), intent(out) :: message ! error message + ! input (optional) + integer(i4b), intent(in), optional :: ixSubRch(:) ! subset of reach indices to be processed + ! local variables + character(len=strLen) :: cmessage ! error message for downwind routine + logical(lgt), allocatable :: doRoute(:) ! logical to indicate which reaches are processed + integer(i4b) :: LAKEFLAG=0 ! >0 if processing lakes + integer(i4b) :: nOrder ! number of stream order + integer(i4b) :: nTrib ! number of tributary basins + integer(i4b) :: nSeg ! number of reaches in the network + integer(i4b) :: iSeg, jSeg ! loop indices - reach + integer(i4b) :: iTrib ! loop indices - branch + integer(i4b) :: ix ! loop indices stream order + + ! initialize error control + ierr=0; message='dfw_route/' + + ! number of reach check + if (size(NETOPO_in)/=size(RCHFLX_out(iens,:))) then + ierr=20; message=trim(message)//'sizes of NETOPO and RCHFLX mismatch'; return + endif + + nSeg = size(RCHFLX_out(iens,:)) + + allocate(doRoute(nSeg), stat=ierr) + + if (present(ixSubRch))then + doRoute(:)=.false. + doRoute(ixSubRch) = .true. ! only subset of reaches are on + else + doRoute(:)=.true. ! every reach is on + endif + + nOrder = size(river_basin) + + do ix = 1, nOrder + + ! route diffusive waves through the river network + nTrib=size(river_basin(ix)%branch) + +!$OMP PARALLEL DO schedule(dynamic,1) & ! chunk size of 1 +!$OMP private(jSeg, iSeg) & ! private for a given thread +!$OMP private(ierr, cmessage) & ! private for a given thread +!$OMP shared(T0,T1) & ! private for a given thread +!$OMP shared(LAKEFLAG) & ! private for a given thread +!$OMP shared(river_basin) & ! data structure shared +!$OMP shared(doRoute) & ! data array shared +!$OMP shared(NETOPO_in) & ! data structure shared +!$OMP shared(RPARAM_in) & ! data structure shared +!$OMP shared(RCHSTA_out) & ! data structure shared +!$OMP shared(RCHFLX_out) & ! data structure shared +!$OMP shared(ix, iEns, ixDesire) & ! indices shared +!$OMP firstprivate(nTrib) + trib:do iTrib = 1,nTrib + seg:do iSeg=1,river_basin(ix)%branch(iTrib)%nRch + jSeg = river_basin(ix)%branch(iTrib)%segIndex(iSeg) + if (.not. doRoute(jSeg)) cycle + call dfw_rch(iEns,jSeg, & ! input: array indices + ixDesire, & ! input: index of the desired reach + T0,T1, & ! input: start and end of the time step + LAKEFLAG, & ! input: flag if lakes are to be processed + NETOPO_in, & ! input: reach topology data structure + RPARAM_in, & ! input: reach parameter data structure + RCHSTA_out, & ! inout: reach state data structure + RCHFLX_out, & ! inout: reach flux data structure + ierr,cmessage) ! output: error control + if(ierr/=0) call handle_err(ierr, trim(message)//trim(cmessage)) + end do seg + end do trib +!$OMP END PARALLEL DO + + end do + + END SUBROUTINE dfw_route + + ! ********************************************************************* + ! subroutine: perform diffusive wave routing for one segment + ! ********************************************************************* + SUBROUTINE dfw_rch(iEns, segIndex, & ! input: index of runoff ensemble to be processed + ixDesire, & ! input: reachID to be checked by on-screen pringing + T0,T1, & ! input: start and end of the time step + LAKEFLAG, & ! input: flag if lakes are to be processed + NETOPO_in, & ! input: reach topology data structure + RPARAM_in, & ! input: reach parameter data structure + RCHSTA_out, & ! inout: reach state data structure + RCHFLX_out, & ! inout: reach flux data structure + ierr, message) ! output: error control + + implicit none + + ! Input + integer(i4b), intent(in) :: iEns ! runoff ensemble to be routed + integer(i4b), intent(in) :: segIndex ! segment where routing is performed + integer(i4b), intent(in) :: ixDesire ! index of the reach for verbose output + real(dp), intent(in) :: T0,T1 ! start and end of the time step (seconds) + integer(i4b), intent(in) :: LAKEFLAG ! >0 if processing lakes + type(RCHTOPO), intent(in), allocatable :: NETOPO_in(:) ! River Network topology + type(RCHPRP), intent(in), allocatable :: RPARAM_in(:) ! River reach parameter + ! inout + type(STRSTA), intent(inout), allocatable :: RCHSTA_out(:,:) ! reach state data + type(STRFLX), intent(inout), allocatable :: RCHFLX_out(:,:) ! Reach fluxes (ensembles, space [reaches]) for decomposed domains + ! Output + integer(i4b), intent(out) :: ierr ! error code + character(*), intent(out) :: message ! error message + ! Local variables to + logical(lgt) :: doCheck ! check details of variables + logical(lgt) :: isHW ! headwater basin? + integer(i4b) :: nUps ! number of upstream segment + integer(i4b) :: iUps ! upstream reach index + integer(i4b) :: iRch_ups ! index of upstream reach in NETOPO + real(dp) :: q_upstream ! total discharge at top of the reach being processed + character(len=strLen) :: cmessage ! error message from subroutine + + ierr=0; message='dfw_rch/' + + doCheck = .false. + if(NETOPO_in(segIndex)%REACHIX == ixDesire)then + doCheck = .true. + end if + + ! get discharge coming from upstream + nUps = size(NETOPO_in(segIndex)%UREACHI) + isHW = .true. + q_upstream = 0.0_dp + if (nUps>0) then + isHW = .false. + do iUps = 1,nUps + iRch_ups = NETOPO_in(segIndex)%UREACHI(iUps) ! index of upstream of segIndex-th reach + q_upstream = q_upstream + RCHFLX_out(iens, iRch_ups)%ROUTE(idxDW)%REACH_Q + end do + endif + + if(doCheck)then + write(iulog,'(A)') 'CHECK diffusive wave routing' + if (nUps>0) then + do iUps = 1,nUps + iRch_ups = NETOPO_in(segIndex)%UREACHI(iUps) ! index of upstream of segIndex-th reach + write(iulog,'(A,X,I12,X,G15.4)') ' UREACHK, uprflux=',NETOPO_in(segIndex)%UREACHK(iUps),RCHFLX_out(iens, iRch_ups)%ROUTE(idxDW)%REACH_Q + enddo + end if + write(iulog,'(A,X,G15.4)') ' RCHFLX_out(iEns,segIndex)%BASIN_QR(1)=',RCHFLX_out(iEns,segIndex)%BASIN_QR(1) + endif + + ! solve diffusive wave equation + call diffusive_wave(RPARAM_in(segIndex), & ! input: parameter at segIndex reach + T0,T1, & ! input: start and end of the time step + q_upstream, & ! input: total discharge at top of the reach being processed + isHW, & ! input: is this headwater basin? + RCHSTA_out(iens,segIndex)%DW_ROUTE, & ! inout: + RCHFLX_out(iens,segIndex), & ! inout: updated fluxes at reach + doCheck, & ! input: reach index to be examined + ierr, cmessage) ! output: error control + if(ierr/=0)then + write(message, '(A,X,I12,X,A)') trim(message)//'/segment=', NETOPO_in(segIndex)%REACHID, '/'//trim(cmessage) + return + endif + + if(doCheck)then + write(iulog,'(A,X,G15.4)') ' RCHFLX_out(iens,segIndex)%REACH_Q=', RCHFLX_out(iens,segIndex)%ROUTE(idxDW)%REACH_Q + endif + + END SUBROUTINE dfw_rch + + + ! ********************************************************************* + ! subroutine: solve diffuisve wave equation + ! ********************************************************************* + SUBROUTINE diffusive_wave(rch_param, & ! input: river parameter data structure + T0,T1, & ! input: start and end of the time step + q_upstream, & ! input: discharge from upstream + isHW, & ! input: is this headwater basin? + rstate, & ! inout: reach state at a reach + rflux, & ! inout: reach flux at a reach + doCheck, & ! input: reach index to be examined + ierr,message) + ! ---------------------------------------------------------------------------------------- + ! Solve linearlized diffusive wave equation per reach and time step. + ! dQ/dt + ck*dQ/dx = dk*d2Q/dx2 - a) + ! + ! ck (celerity) and dk (diffusivity) are computed with previous inflow and outflow and current inflow + ! + ! 1) dQ/dt = (Q(t,x) - Q(t-1,x))/dt + ! 2) dQ/dx = [(1-wck)(Q(t-1,x+1)-Q(t-1,x-1)) + wck*(Q(t,x+1)-Q(t,x-1))]/2dx + ! 3) d2Q/dx2 = [(1-wdk)(Q(t-1,x+1)-2Q(t-1,x)+Q(t-1,x-1)) + wdk*(Q(t,x+1)-2Q(t,x)+Q(t,x-1))]/2dx + ! + ! upstream B.C: Dirchlet BC with inflow at current time-step,t, from upstream basin + ! downstream B.C: Neumann BC with prescribed Q gradient (Sbc) + ! dQ/dx|x=N = Sbc -> 4) Q(t,N)-Q(t,N-1)) = Sbc*dx + ! Another downstream B.C option is absorbing boundary condition + ! dQ/dt|x=N + ck*dQ/dx|x=N = 0 + ! + ! Inserting 1), 2), 3) and 4) into a) and moving Q(t,*) terms to left-hand side and Q(t-1,*) terms to the righ-hand side + ! results in tridiagonal matrix equation A*Q = b + ! where A is [N x N] matrix, Q is [N x 1] vector to be solved (next time step Q) and b is [N x 1] vector + ! N (nMolecule is used in the code) is the number of internal nodes including upstream and downstream boundaries + ! + ! Since A is a tridiagonal matrix, the code stores only three diagnoal elements - upper, diagonal, and lower + ! solving the matrix equation use thomas algorithm + ! + ! ---------------------------------------------------------------------------------------- + USE globalData, ONLY : nMolecule ! number of internal nodes for finite difference (including upstream and downstream boundaries) + implicit none + ! Input + type(RCHPRP), intent(in) :: rch_param ! River reach parameter + real(dp), intent(in) :: T0,T1 ! start and end of the time step (seconds) + real(dp), intent(in) :: q_upstream ! total discharge at top of the reach being processed + logical(lgt), intent(in) :: isHW ! is this headwater basin? + logical(lgt), intent(in) :: doCheck ! reach index to be examined + ! Input/Output + type(dwRCH), intent(inout) :: rstate ! curent reach states + type(STRFLX), intent(inout) :: rflux ! current Reach fluxes + ! Output + integer(i4b), intent(out) :: ierr ! error code + character(*), intent(out) :: message ! error message + ! Local variables + real(dp) :: alpha ! sqrt(slope)(/mannings N* width) + real(dp) :: beta ! constant, 5/3 + real(dp) :: Cd ! Fourier number + real(dp) :: Ca ! Courant number + real(dp) :: dt ! interval of time step [sec] + real(dp) :: dx ! length of segment [m] + real(dp) :: Qbar ! 3-point average discharge [m3/s] + real(dp) :: Abar ! 3-point average flow area [m2] + real(dp) :: Vbar ! 3-point average velocity [m/s] + real(dp) :: ck ! kinematic wave celerity [m/s] + real(dp) :: dk ! diffusivity [m2/s] + real(dp) :: Sbc ! neumann BC slope + real(dp), allocatable :: diagonal(:,:) ! diagonal part of matrix + real(dp), allocatable :: b(:) ! right-hand side of the matrix equation + real(dp), allocatable :: Qlocal(:,:) ! sub-reach & sub-time step discharge at previous and current time step [m3/s] + real(dp), allocatable :: Qprev(:) ! sub-reach discharge at previous time step [m3/s] + real(dp) :: dTsub ! time inteval for sub time-step [sec] + real(dp) :: wck ! weight for advection + real(dp) :: wdk ! weight for diffusion + integer(i4b) :: ix,it ! loop index + integer(i4b) :: ntSub ! number of sub time-step + integer(i4b) :: Nx ! number of internal reach segments + integer(i4b) :: downstreamBC ! method of B.C condition - absorbing or Neumann + character(len=strLen) :: fmt1 ! format string + character(len=strLen) :: cmessage ! error message from subroutine + ! Local parameters + integer(i4b), parameter :: absorbingBC=1 + integer(i4b), parameter :: neumannBC=2 + + ierr=0; message='diffusive_wave/' + + ! hard-coded parameters + downstreamBC = neumannBC + Sbc = 0._dp + + ntSub = 1 ! number of sub-time step + wck = 1.0 ! weight in advection term + wdk = 1.0 ! weight in diffusion term 0.0-> fully explicit, 0.5-> Crank-Nicolson, 1.0 -> fully implicit + + Nx = nMolecule%DW_ROUTE - 1 ! Nx: number of internal reach segments + + if (.not. isHW) then + + allocate(Qprev(nMolecule%DW_ROUTE), stat=ierr, errmsg=cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + + allocate(b(nMolecule%DW_ROUTE), stat=ierr, errmsg=cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + + allocate(diagonal(nMolecule%DW_ROUTE,3), stat=ierr, errmsg=cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! initialize previous time step flow + Qprev(1:nMolecule%DW_ROUTE) = rstate%molecule%Q ! flow state at previous time step + + ! Get the reach parameters + ! A = (Q/alpha)**(1/beta) + ! Q = alpha*A**beta + alpha = sqrt(rch_param%R_SLOPE)/(rch_param%R_MAN_N*rch_param%R_WIDTH**(2._dp/3._dp)) + beta = 5._dp/3._dp + dx = rch_param%RLENGTH/Nx + dt = T1-T0 + + if (doCheck) then + write(iulog,'(4(A,X,G15.4))') ' length [m] =',rch_param%RLENGTH,'slope [-] =',rch_param%R_SLOPE,'channel width [m] =',rch_param%R_WIDTH,'manning coef =',rch_param%R_MAN_N + end if + + ! time-step adjustment so Courant number is less than 1 + dTsub = dt/ntSub + + if (doCheck) then + write(iulog,'(A,X,I3,A,X,G12.5)') ' No. sub timestep=',nTsub,' sub time-step [sec]=',dTsub + end if + + allocate(Qlocal(0:1, 1:nMolecule%DW_ROUTE), stat=ierr, errmsg=cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + Qlocal(0:1,:) = realMissing + Qlocal(0,1:nMolecule%DW_ROUTE) = Qprev ! previous time step + Qlocal(1,1) = q_upstream ! infllow at sub-time step in current time step + + do it = 1, nTsub + + Qbar = (Qlocal(1,1)+Qlocal(0,1)+Qlocal(0,nMolecule%DW_ROUTE))/3.0 ! 3 point average discharge [m3/s] + Abar = (abs(Qbar)/alpha)**(1/beta) ! flow area [m2] (manning equation) + Vbar = 0._dp + if (Abar>0._dp) Vbar = Qbar/Abar ! average velocity [m/s] + ck = beta*Vbar ! kinematic wave celerity [m/s] + dk = Qbar/(2*rch_param%R_WIDTH*rch_param%R_SLOPE) ! diffusivity [m2/s] + + Cd = dk*dTsub/dx**2 + Ca = ck*dTsub/dx + + ! create a matrix - current time step + ! populate tridiagonal elements + ! diagonal + diagonal(1,2) = 1._dp + diagonal(2:nMolecule%DW_ROUTE-1,2) = 2._dp + 4*wdk*Cd + if (downstreamBC == absorbingBC) then + diagonal(nMolecule%DW_ROUTE,2) = 1._dp + wck*Ca + else if (downstreamBC == neumannBC) then + diagonal(nMolecule%DW_ROUTE,2) = 1._dp + end if + + ! upper + diagonal(:,1) = 0._dp + diagonal(3:nMolecule%DW_ROUTE,1) = wck*Ca - 2._dp*wdk*Cd + + ! lower + diagonal(:,3) = 0._dp + diagonal(1:nMolecule%DW_ROUTE-2,3) = -wck*Ca - 2._dp*wdk*Cd + if (downstreamBC == absorbingBC) then + diagonal(nMolecule%DW_ROUTE-1,3) = -wck*Ca + else if (downstreamBC == neumannBC) then + diagonal(nMolecule%DW_ROUTE-1,3) = -1._dp + end if + + ! populate left-hand side + ! upstream boundary condition + b(1) = Qlocal(1,1) + ! downstream boundary condition + if (downstreamBC == absorbingBC) then + b(nMolecule%DW_ROUTE) = (1._dp-(1._dp-wck)*Ca)*Qlocal(0,nMolecule%DW_ROUTE) + (1-wck)*Ca*Qlocal(0,nMolecule%DW_ROUTE-1) + else if (downstreamBC == neumannBC) then + b(nMolecule%DW_ROUTE) = Sbc*dx + end if + ! internal node points + b(2:nMolecule%DW_ROUTE-1) = ((1._dp-wck)*Ca+2._dp*(1._dp-wdk))*Cd*Qlocal(0,1:nMolecule%DW_ROUTE-2) & + + (2._dp-4._dp*(1._dp-wdk)*Cd)*Qlocal(0,2:nMolecule%DW_ROUTE-1) & + - ((1._dp-wck)*Ca - (1._dp-wdk)*Cd)*Qlocal(0,3:nMolecule%DW_ROUTE) + + ! solve matrix equation - get updated Qlocal + call TDMA(nMolecule%DW_ROUTE, diagonal, b, Qlocal(1,:)) + + if (doCheck) then + write(fmt1,'(A,I5,A)') '(A,1X',nMolecule%DW_ROUTE,'(1X,F15.7))' + write(*,fmt1) ' Q sub_reqch=', (Qlocal(1,ix), ix=1,nMolecule%DW_ROUTE) + end if + + Qlocal(0,:) = Qlocal(1,:) + end do + + ! store final outflow in data structure + rflux%ROUTE(idxDW)%REACH_Q = Qlocal(1, nMolecule%DW_ROUTE) + rflux%BASIN_QR(1) + + if (doCheck) then + write(iulog,*) 'rflux%REACH_Q= ', rflux%ROUTE(idxDW)%REACH_Q + write(iulog,*) 'Qprev(1:nMolecule)= ', Qprev(1:nMolecule%DW_ROUTE) + write(iulog,*) 'Qbar, Abar, Vbar, ck, dk= ',Qbar, Abar, Vbar, ck, dk + write(iulog,*) 'Cd, Ca= ', Cd, Ca + write(iulog,*) 'diagonal(:,1)= ', diagonal(:,1) + write(iulog,*) 'diagonal(:,2)= ', diagonal(:,2) + write(iulog,*) 'diagonal(:,3)= ', diagonal(:,3) + write(iulog,*) 'b= ', b(1:nMolecule%DW_ROUTE) + end if + + ! compute volume + rflux%ROUTE(idxDW)%REACH_VOL(0) = rflux%ROUTE(idxDW)%REACH_VOL(1) + rflux%ROUTE(idxDW)%REACH_VOL(1) = rflux%ROUTE(idxDW)%REACH_VOL(0) + (Qlocal(1,1) - Qlocal(1,nMolecule%DW_ROUTE))*dT + + ! update state + rstate%molecule%Q = Qlocal(1,:) + + else ! if head-water + + rflux%ROUTE(idxDW)%REACH_Q = rflux%BASIN_QR(1) + + rflux%ROUTE(idxDW)%REACH_VOL(0) = 0._dp + rflux%ROUTE(idxDW)%REACH_VOL(1) = 0._dp + + rstate%molecule%Q(1:nMolecule%DW_ROUTE) = 0._dp + rstate%molecule%Q(nMolecule%DW_ROUTE) = rflux%ROUTE(idxDW)%REACH_Q + + if (doCheck) then + write(iulog,'(A)') ' This is headwater ' + endif + + endif + + if (doCheck) then + write(iulog,'(A,X,G12.5)') ' Qout(t) =', rflux%ROUTE(idxDW)%REACH_Q + endif + + END SUBROUTINE diffusive_wave + + SUBROUTINE TDMA(NX,MAT,b,T) + ! Solve tridiagonal matrix system of linear equation + ! NX is the number of unknowns (gridblocks minus boundaries) + ! Solve system of linear equations, A*T = b where A is tridiagonal matrix + ! MAT = NX x 3 array holding tri-diagonal portion of A + ! MAT(NX,1) - uppder diagonals for matrix A + ! MAT(NX,2) - diagonals for matrix A + ! MAT(NX,3) - lower diagonals for matrix A + ! b(NX) - vector of the right hand coefficients b + ! T(NX) - The solution matrix + ! + ! example, A + ! d u 0 0 0 + ! l d u 0 0 + ! 0 l d u 0 + ! 0 0 l d u + ! 0 0 0 l d + ! + ! MAT(:,1) = [0, u, u, u, u] + ! MAT(:,2) = [d, d, d, d, d] + ! MAT(:,3) = [l, l, l, l, 0] + + IMPLICIT NONE + ! Input + integer(i4b), intent(in) :: NX ! number of unknown (= number of matrix size, grid point minus two end points) + real(dp), intent(in) :: MAT(NX,3) + real(dp), intent(in) :: b(NX) + ! Output + real(dp), intent(inout) :: T(NX) + ! Local + integer(i4b) :: ix + real(dp) :: U(NX) + real(dp) :: D(NX) + real(dp) :: L(NX) + real(dp) :: b1(NX) + real(dp) :: coef + + U(1:NX) = MAT(1:NX,1) + D(1:NX) = MAT(1:NX,2) + L(1:NX) = MAT(1:NX,3) + b1(1:NX) = b(1:NX) + do ix = 2, NX + coef = L(ix-1)/D(ix-1) + D(ix) = D(ix)-coef*U(ix) + b1(ix) = b1(ix)-coef*b1(ix-1) + end do + + T(NX) = b1(NX)/D(NX) ! Starts the countdown of answers + do ix = NX-1, 1, -1 + T(ix) = (b1(ix) - U(ix+1)*T(ix+1))/D(ix) + end do + + END SUBROUTINE TDMA + + +END MODULE dfw_route_module diff --git a/route/build/src/globalData.f90 b/route/build/src/globalData.f90 index 73c2390d..48fb864d 100644 --- a/route/build/src/globalData.f90 +++ b/route/build/src/globalData.f90 @@ -1,57 +1,63 @@ -module globalData +MODULE globalData ! This module includes global data structures - use public_var, only : integerMissing + USE public_var ! data types - use nrtype + USE nrtype ! metadata types - use dataTypes, only : struct_info ! metadata type - use dataTypes, only : dim_info ! metadata type - use dataTypes, only : var_info ! metadata type - use objTypes, only : meta_var ! metadata type + USE dataTypes, ONLY : struct_info ! metadata type + USE dataTypes, ONLY : dim_info ! metadata type + USE dataTypes, ONLY : var_info ! metadata type + USE objTypes, ONLY : meta_var ! metadata type ! parameter structures - USE dataTypes, only : RCHPRP ! Reach parameters (properties) - USE dataTypes, only : RCHTOPO ! Network topology + USE dataTypes, ONLY : RCHPRP ! Reach parameters (properties) + USE dataTypes, ONLY : RCHTOPO ! Network topology ! routing structures - USE dataTypes, only : KREACH ! Collection of flow particles in each reach - USE dataTypes, only : STRFLX ! fluxes in each reach + USE dataTypes, ONLY : STRSTA ! restart state in each reach + USE dataTypes, ONLY : STRFLX ! fluxes in each reach ! lake structures - USE dataTypes, only : LAKPRP ! lake properties - USE dataTypes, only : LAKTOPO ! lake topology - USE dataTypes, only : LKFLX ! lake fluxes + USE dataTypes, ONLY : LAKPRP ! lake properties + USE dataTypes, ONLY : LAKTOPO ! lake topology + USE dataTypes, ONLY : LKFLX ! lake fluxes ! remapping structures - use dataTypes, only : remap ! remapping data type - use dataTypes, only : runoff ! runoff data type + USE dataTypes, ONLY : remap ! remapping data type + USE dataTypes, ONLY : runoff ! runoff data type ! basin data structure - use dataTypes, only : subbasin_omp ! mainstem+tributary data structures + USE dataTypes, ONLY : subbasin_omp ! mainstem+tributary data structures ! time data structure - use date_time, only : datetime ! time data + USE date_time, ONLY : datetime ! time data ! time data structure - use dataTypes, only : nc ! netCDF data + USE dataTypes, ONLY : nc ! netCDF data + + USE dataTypes, ONLY : cMolecule ! ! data size - USE var_lookup, only : nStructures ! number of variables for data structure - USE var_lookup, only : nDimensions ! number of variables for data structure - USE var_lookup, only : nStateDims ! number of variables for data structure - USE var_lookup, only : nQdims ! number of variables for data structure - USE var_lookup, only : nVarsHRU ! number of variables for data structure - USE var_lookup, only : nVarsHRU2SEG ! number of variables for data structure - USE var_lookup, only : nVarsSEG ! number of variables for data structure - USE var_lookup, only : nVarsNTOPO ! number of variables for data structure - USE var_lookup, only : nVarsPFAF ! number of variables for data structure - USE var_lookup, only : nVarsRFLX ! number of variables for data structure - USE var_lookup, only : nVarsIRFbas ! number of variables for data structure - USE var_lookup, only : nVarsIRF ! number of variables for data structure - USE var_lookup, only : nVarsKWT ! number of variables for data structure + USE var_lookup, ONLY : nStructures ! number of variables for data structure + USE var_lookup, ONLY : nDimensions ! number of variables for data structure + USE var_lookup, ONLY : nStateDims ! number of variables for data structure + USE var_lookup, ONLY : nQdims ! number of variables for data structure + USE var_lookup, ONLY : nVarsHRU ! number of variables for data structure + USE var_lookup, ONLY : nVarsHRU2SEG ! number of variables for data structure + USE var_lookup, ONLY : nVarsSEG ! number of variables for data structure + USE var_lookup, ONLY : nVarsNTOPO ! number of variables for data structure + USE var_lookup, ONLY : nVarsPFAF ! number of variables for data structure + USE var_lookup, ONLY : nVarsRFLX ! number of variables for data structure + USE var_lookup, ONLY : nVarsIRFbas ! number of variables for data structure + USE var_lookup, ONLY : nVarsBasinQ ! number of variables for data structure + USE var_lookup, ONLY : nVarsIRF ! number of variables for data structure + USE var_lookup, ONLY : nVarsKWT ! number of variables for data structure + USE var_lookup, ONLY : nVarsKW ! number of variables for data structure + USE var_lookup, ONLY : nVarsDW ! number of variables for data structure + USE var_lookup, ONLY : nVarsMC ! number of variables for data structure implicit none @@ -91,7 +97,11 @@ module globalData type(var_info) , public :: meta_PFAF (nVarsPFAF ) ! pfafstetter code type(meta_var) , public :: meta_rflx (nVarsRFLX ) ! reach flux variables type(meta_var) , public :: meta_irf_bas(nVarsIRFbas ) ! basin IRF routing fluxes/states - type(meta_var) , public :: meta_kwt (nVarsKWT ) ! KWT routing fluxes/states + type(meta_var) , public :: meta_basinQ (nVarsBasinQ ) ! reach inflow from basin + type(meta_var) , public :: meta_kwt (nVarsKWT ) ! KWT routing restart fluxes/states + type(meta_var) , public :: meta_kw (nVarsKW ) ! KW routing restart fluxes/states + type(meta_var) , public :: meta_dw (nVarsDW ) ! DW routing restart fluxes/states + type(meta_var) , public :: meta_mc (nVarsMC ) ! MC routing restart fluxes/states type(meta_var) , public :: meta_irf (nVarsIRF ) ! IRF routing fluxes/states ! ---------- data structures ---------------------------------------------------------------------- @@ -100,6 +110,17 @@ module globalData integer(i4b) , public :: nHRU ! number of HRUs in the whole river network integer(i4b) , public :: nRch ! number of reaches in the whole river network + ! routing methods + integer(i4b) , public :: nRoutes ! number of active routing methods + integer(i4b) , allocatable , public :: routeMethods(:) ! active routing method id + logical(lgt) , public :: onRoute(0:nRouteMethods-1) ! logical to indicate active routing method(s) + integer(i4b) , public :: idxSUM ! index of SUM method + integer(i4b) , public :: idxIRF ! index of IRF method + integer(i4b) , public :: idxKWT ! index of KWT method + integer(i4b) , public :: idxKW ! index of KW method + integer(i4b) , public :: idxMC ! index of MC method + integer(i4b) , public :: idxDW ! index of DW method + ! basin and reach IDs (to be removed) integer(i8b) , allocatable , public :: basinID(:) ! HRU id integer(i4b) , allocatable , public :: reachID(:) ! reach id @@ -125,7 +146,7 @@ module globalData REAL(DP) , ALLOCATABLE , public :: FRAC_FUTURE(:) ! fraction of runoff in future time steps ! routing data structures - TYPE(KREACH) , allocatable , public :: KROUTE(:,:) ! Routing state variables (ensembles, space [reaches]) for the entire river network + TYPE(STRSTA) , allocatable , public :: RCHSTA(:,:) ! Routing state variables (ensembles, space [reaches]) for the entire river network TYPE(STRFLX) , allocatable , public :: RCHFLX(:,:) ! Reach fluxes (ensembles, space [reaches]) for entire river network ! lakes data structures @@ -142,5 +163,6 @@ module globalData ! miscellaneous integer(i4b) , public :: ixPrint=integerMissing ! index of desired reach to be on-screen print + type(cMolecule) , public :: nMolecule ! number of computational molecule (used for KW, MC, DW) end module globalData diff --git a/route/build/src/irf_route.f90 b/route/build/src/irf_route.f90 index 1002dcb2..0c49a103 100644 --- a/route/build/src/irf_route.f90 +++ b/route/build/src/irf_route.f90 @@ -6,10 +6,14 @@ module irf_route_module USE dataTypes, only : STRFLX ! fluxes in each reach USE dataTypes, only : RCHTOPO ! Network topology USE dataTypes, only : RCHPRP ! Reach parameter +USE dataTypes, only : irfRCH ! irf specific state data structure ! global parameters USE public_var, only : realMissing ! missing value for real number USE public_var, only : integerMissing ! missing value for integer number -USE globalData, only : nThreads ! number of threads used for openMP +USE globalData, only : nThreads ! number of threads used for openMP +USE globalData, only : idxIRF ! index of IRF method +! subroutines: general +USE model_finalize, ONLY : handle_err implicit none @@ -32,7 +36,6 @@ subroutine irf_route(iEns, & ! input: index of runoff ensemble to be p ixSubRch) ! optional input: subset of reach indices to be processed USE dataTypes, ONLY : subbasin_omp ! mainstem+tributary data structures - USE model_finalize, ONLY : handle_err implicit none ! Input @@ -75,9 +78,6 @@ subroutine irf_route(iEns, & ! input: index of runoff ensemble to be p allocate(doRoute(nSeg), stat=ierr) - ! Initialize CHEC_IRF to False. - RCHFLX_out(iEns,:)%CHECK_IRF=.False. - if (present(ixSubRch))then doRoute(:)=.false. doRoute(ixSubRch) = .true. ! only subset of reaches are on @@ -195,7 +195,7 @@ subroutine segment_irf(& if (nUps>0) then do iUps = 1,nUps iRch_ups = NETOPO_in(segIndex)%UREACHI(iUps) ! index of upstream of segIndex-th reach - q_upstream = q_upstream + RCHFLX_out(iens, iRch_ups)%REACH_Q_IRF + q_upstream = q_upstream + RCHFLX_out(iens, iRch_ups)%ROUTE(idxIRF)%REACH_Q end do endif @@ -208,9 +208,6 @@ subroutine segment_irf(& ierr, message) ! output: error control if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif - ! Check True since now this reach now routed - RCHFLX_out(iEns,segIndex)%CHECK_IRF=.True. - ! check if(segIndex==ixDesire)then ntdh = size(NETOPO_in(segIndex)%UH) @@ -221,7 +218,7 @@ subroutine segment_irf(& write(*,'(a)') ' * total discharge from upstream(q_upstream) [m3/s], local area discharge [m3/s], and Final discharge [m3/s]:' write(*,'(a,x,F15.7)') ' q_upstream =', q_upstream write(*,'(a,x,F15.7)') ' RCHFLX_out%BASIN_QR(1) =', RCHFLX_out(iens,segIndex)%BASIN_QR(1) - write(*,'(a,x,F15.7)') ' RCHFLX_out%REACH_Q_IRF =', RCHFLX_out(iens,segIndex)%REACH_Q_IRF + write(*,'(a,x,F15.7)') ' RCHFLX_out%ROUTE%REACH_Q =', RCHFLX_out(iens,segIndex)%ROUTE(idxIRF)%REACH_Q endif end subroutine segment_irf @@ -275,22 +272,22 @@ subroutine conv_upsbas_qr(reach_uh, & ! input: reach unit hydrograph enddo ! compute volume in reach - rflux%REACH_VOL(0) = rflux%REACH_VOL(1) - rflux%REACH_VOL(1) = rflux%REACH_VOL(0) + (QupMod - rflux%QFUTURE_IRF(1))/dt + rflux%ROUTE(idxIRF)%REACH_VOL(0) = rflux%ROUTE(idxIRF)%REACH_VOL(1) + rflux%ROUTE(idxIRF)%REACH_VOL(1) = rflux%ROUTE(idxIRF)%REACH_VOL(0) + (QupMod - rflux%QFUTURE_IRF(1))/dt ! Add local routed flow at the bottom of reach - rflux%REACH_Q_IRF = rflux%QFUTURE_IRF(1) + rflux%BASIN_QR(1) + rflux%ROUTE(idxIRF)%REACH_Q = rflux%QFUTURE_IRF(1) + rflux%BASIN_QR(1) ! Q abstraction ! Compute actual abstraction (Qabs) m3/s - values should be negative - ! Compute abstraction (Qmod) m3 taken from outlet discharge (REACH_Q_IRF) - ! Compute REACH_Q_IRF subtracted from Qmod abstraction + ! Compute abstraction (Qmod) m3 taken from outlet discharge (REACH_Q) + ! Compute REACH_Q subtracted from Qmod abstraction ! Compute REACH_VOL subtracted from total abstraction minus abstraction from outlet discharge if (Qtake<0) then - Qabs = max(-(rflux%REACH_VOL(1)/dt+rflux%REACH_Q_IRF), Qtake) - Qmod = min(rflux%REACH_VOL(1) + Qabs*dt, 0._dp) - rflux%REACH_Q_IRF = max(rflux%REACH_Q_IRF + Qmod/dt, Qmin) - rflux%REACH_VOL(1) = rflux%REACH_VOL(1) + (Qabs*dt - Qmod) + Qabs = max(-(rflux%ROUTE(idxIRF)%REACH_VOL(1)/dt+rflux%ROUTE(idxIRF)%REACH_Q), Qtake) + Qmod = min(rflux%ROUTE(idxIRF)%REACH_VOL(1) + Qabs*dt, 0._dp) + rflux%ROUTE(idxIRF)%REACH_Q = max(rflux%ROUTE(idxIRF)%REACH_Q + Qmod/dt, Qmin) + rflux%ROUTE(idxIRF)%REACH_VOL(1) = rflux%ROUTE(idxIRF)%REACH_VOL(1) + (Qabs*dt - Qmod) end if ! move array back use eoshift diff --git a/route/build/src/kw_route.f90 b/route/build/src/kw_route.f90 new file mode 100644 index 00000000..7222bb01 --- /dev/null +++ b/route/build/src/kw_route.f90 @@ -0,0 +1,371 @@ +MODULE kw_route_module + +USE nrtype +! data types +USE dataTypes, ONLY: STRFLX ! fluxes in each reach +USE dataTypes, ONLY: STRSTA ! state in each reach +USE dataTypes, ONLY: RCHTOPO ! Network topology +USE dataTypes, ONLY: RCHPRP ! Reach parameter +USE dataTypes, ONLY: kwRCH ! kw specific state data structure +USE dataTypes, ONLY: subbasin_omp ! mainstem+tributary data strucuture +! global data +USE public_var, ONLY: iulog ! i/o logical unit number +USE public_var, ONLY: realMissing ! missing value for real number +USE public_var, ONLY: integerMissing ! missing value for integer number +USE globalData, ONLY: idxKW +! subroutines: general +USE model_finalize, ONLY : handle_err + +! privary +implicit none +private + +public::kw_route + +real(dp), parameter :: critFactor=0.01 + +CONTAINS + + ! ********************************************************************* + ! subroutine: route kinematic waves with Euler solution through the river network + ! ********************************************************************* + SUBROUTINE kw_route(iens, & ! input: ensemble index + river_basin, & ! input: river basin information (mainstem, tributary outlet etc.) + T0,T1, & ! input: start and end of the time step + ixDesire, & ! input: reachID to be checked by on-screen pringing + NETOPO_in, & ! input: reach topology data structure + RPARAM_in, & ! input: reach parameter data structure + RCHSTA_out, & ! inout: reach state data structure + RCHFLX_out, & ! inout: reach flux data structure + ierr,message, & ! output: error control + ixSubRch) ! optional input: subset of reach indices to be processed + + implicit none + ! Input + integer(i4b), intent(in) :: iEns ! ensemble member + type(subbasin_omp), intent(in), allocatable :: river_basin(:) ! river basin information (mainstem, tributary outlet etc.) + real(dp), intent(in) :: T0,T1 ! start and end of the time step (seconds) + integer(i4b), intent(in) :: ixDesire ! index of the reach for verbose output + type(RCHTOPO), intent(in), allocatable :: NETOPO_in(:) ! River Network topology + type(RCHPRP), intent(in), allocatable :: RPARAM_in(:) ! River reach parameter + ! inout + type(STRSTA), intent(inout), allocatable :: RCHSTA_out(:,:) ! reach state data + type(STRFLX), intent(inout), allocatable :: RCHFLX_out(:,:) ! Reach fluxes (ensembles, space [reaches]) for decomposed domains + ! output variables + integer(i4b), intent(out) :: ierr ! error code + character(*), intent(out) :: message ! error message + ! input (optional) + integer(i4b), intent(in), optional :: ixSubRch(:) ! subset of reach indices to be processed + ! local variables + character(len=strLen) :: cmessage ! error message for downwind routine + logical(lgt), allocatable :: doRoute(:) ! logical to indicate which reaches are processed + integer(i4b) :: LAKEFLAG=0 ! >0 if processing lakes + integer(i4b) :: nOrder ! number of stream order + integer(i4b) :: nTrib ! number of tributary basins + integer(i4b) :: nSeg ! number of reaches in the network + integer(i4b) :: iSeg, jSeg ! loop indices - reach + integer(i4b) :: iTrib ! loop indices - branch + integer(i4b) :: ix ! loop indices stream order + + ierr=0; message='kw_route/' + + ! number of reach check + if (size(NETOPO_in)/=size(RCHFLX_out(iens,:))) then + ierr=20; message=trim(message)//'sizes of NETOPO and RCHFLX mismatch'; return + endif + + nSeg = size(RCHFLX_out(iens,:)) + + allocate(doRoute(nSeg), stat=ierr) + + if (present(ixSubRch))then + doRoute(:)=.false. + doRoute(ixSubRch) = .true. ! only subset of reaches are on + else + doRoute(:)=.true. ! every reach is on + endif + + nOrder = size(river_basin) + + ! route kinematic waves through the river network + do ix = 1, nOrder + + nTrib=size(river_basin(ix)%branch) + +!$OMP PARALLEL DO schedule(dynamic,1) & ! chunk size of 1 +!$OMP private(jSeg, iSeg) & ! private for a given thread +!$OMP private(ierr, cmessage) & ! private for a given thread +!$OMP shared(T0,T1) & ! private for a given thread +!$OMP shared(LAKEFLAG) & ! private for a given thread +!$OMP shared(river_basin) & ! data structure shared +!$OMP shared(doRoute) & ! data array shared +!$OMP shared(NETOPO_in) & ! data structure shared +!$OMP shared(RPARAM_in) & ! data structure shared +!$OMP shared(RCHSTA_out) & ! data structure shared +!$OMP shared(RCHFLX_out) & ! data structure shared +!$OMP shared(ix, iEns, ixDesire) & ! indices shared +!$OMP firstprivate(nTrib) + trib:do iTrib = 1,nTrib + seg:do iSeg=1,river_basin(ix)%branch(iTrib)%nRch + jSeg = river_basin(ix)%branch(iTrib)%segIndex(iSeg) + if (.not. doRoute(jSeg)) cycle + call kw_rch(iEns,jSeg, & ! input: array indices + ixDesire, & ! input: index of the desired reach + T0,T1, & ! input: start and end of the time step + LAKEFLAG, & ! input: flag if lakes are to be processed + NETOPO_in, & ! input: reach topology data structure + RPARAM_in, & ! input: reach parameter data structure + RCHSTA_out, & ! inout: reach state data structure + RCHFLX_out, & ! inout: reach flux data structure + ierr,cmessage) ! output: error control + if(ierr/=0) call handle_err(ierr, trim(message)//trim(cmessage)) + end do seg + end do trib +!$OMP END PARALLEL DO + + end do + + END SUBROUTINE kw_route + + ! ********************************************************************* + ! subroutine: perform one segment route KW routing + ! ********************************************************************* + SUBROUTINE kw_rch(iEns, segIndex, & ! input: index of runoff ensemble to be processed + ixDesire, & ! input: reachID to be checked by on-screen pringing + T0,T1, & ! input: start and end of the time step + LAKEFLAG, & ! input: flag if lakes are to be processed + NETOPO_in, & ! input: reach topology data structure + RPARAM_in, & ! input: reach parameter data structure + RCHSTA_out, & ! inout: reach state data structure + RCHFLX_out, & ! inout: reach flux data structure + ierr, message) ! output: error control + implicit none + ! Input + integer(i4b), intent(in) :: iEns ! runoff ensemble to be routed + integer(i4b), intent(in) :: segIndex ! segment where routing is performed + integer(i4b), intent(in) :: ixDesire ! index of the reach for verbose output + real(dp), intent(in) :: T0,T1 ! start and end of the time step (seconds) + integer(i4b), intent(in) :: LAKEFLAG ! >0 if processing lakes + type(RCHTOPO), intent(in), allocatable :: NETOPO_in(:) ! River Network topology + type(RCHPRP), intent(in), allocatable :: RPARAM_in(:) ! River reach parameter + ! inout + type(STRSTA), intent(inout), allocatable :: RCHSTA_out(:,:) ! reach state data + type(STRFLX), intent(inout), allocatable :: RCHFLX_out(:,:) ! Reach fluxes (ensembles, space [reaches]) for decomposed domains + ! Output + integer(i4b), intent(out) :: ierr ! error code + character(*), intent(out) :: message ! error message + ! Local variables to + logical(lgt) :: doCheck ! check details of variables + logical(lgt) :: isHW ! headwater basin? + integer(i4b) :: nUps ! number of upstream segment + integer(i4b) :: iUps ! upstream reach index + integer(i4b) :: iRch_ups ! index of upstream reach in NETOPO + real(dp) :: q_upstream ! total discharge at top of the reach being processed + character(len=strLen) :: cmessage ! error message from subroutine + + ierr=0; message='kw_rch/' + + doCheck = .false. + if(NETOPO_in(segIndex)%REACHIX == ixDesire)then + doCheck = .true. + end if + + ! get discharge coming from upstream + nUps = size(NETOPO_in(segIndex)%UREACHI) + isHW = .true. + q_upstream = 0.0_dp + if (nUps>0) then + isHW = .false. + do iUps = 1,nUps + iRch_ups = NETOPO_in(segIndex)%UREACHI(iUps) ! index of upstream of segIndex-th reach + q_upstream = q_upstream + RCHFLX_out(iens, iRch_ups)%ROUTE(idxKW)%REACH_Q + end do + endif + + if(doCheck)then + write(iulog,'(A)') 'CHECK Kinematic wave routing' + if (nUps>0) then + do iUps = 1,nUps + iRch_ups = NETOPO_in(segIndex)%UREACHI(iUps) ! index of upstream of segIndex-th reach + write(iulog,'(A,X,I6,X,G12.5)') ' UREACHK, uprflux=',NETOPO_in(segIndex)%UREACHK(iUps),RCHFLX_out(iens, iRch_ups)%ROUTE(idxKW)%REACH_Q + enddo + end if + write(iulog,'(A,X,G15.4)') ' RCHFLX_out(iEns,segIndex)%BASIN_QR(1)=',RCHFLX_out(iEns,segIndex)%BASIN_QR(1) + endif + + ! perform river network KW routing + call kinematic_wave(RPARAM_in(segIndex), & ! input: parameter at segIndex reach + T0,T1, & ! input: start and end of the time step + q_upstream, & ! input: total discharge at top of the reach being processed + isHW, & ! input: is this headwater basin? + RCHSTA_out(iens,segIndex)%KW_ROUTE, & ! inout: + RCHFLX_out(iens,segIndex), & ! inout: updated fluxes at reach + doCheck, & ! input: reach index to be examined + ierr, cmessage) ! output: error control + if(ierr/=0)then + write(message, '(A,X,I12,X,A)') trim(message)//'/segment=', NETOPO_in(segIndex)%REACHID, '/'//trim(cmessage) + return + endif + + if(doCheck)then + write(iulog,'(A,X,G15.4)') ' RCHFLX_out(iens,segIndex)%REACH_Q=', RCHFLX_out(iens,segIndex)%ROUTE(idxKW)%REACH_Q + endif + + END SUBROUTINE kw_rch + + + ! ********************************************************************* + ! subroutine: route kinematic waves at one segment + ! ********************************************************************* + SUBROUTINE kinematic_wave(rch_param, & ! input: river parameter data structure + T0,T1, & ! input: start and end of the time step + q_upstream, & ! input: discharge from upstream + isHW, & ! input: is this headwater basin? + rstate, & ! inout: reach state at a reach + rflux, & ! inout: reach flux at a reach + doCheck, & ! input: reach index to be examined + ierr,message) + ! ---------------------------------------------------------------------------------------- + ! Kinematic wave equation is solved based on conservative form the equation + ! + ! Method: Li, R.‐M., Simons, D. B., and Stevens, M. A. (1975), Nonlinear kinematic wave approximation for water routing, + ! Water Resour. Res., 11( 2), 245– 252, doi:10.1029/WR011i002p00245 + ! + ! * Use analytical solution (eq 29 in paper) for Q using the 2nd order Talor series of nonlinear kinematic equation: theta*Q + alpha*Q^beta = omega + ! * Use initial guess using explicit Euler solution of kinematic approximation equation to start iterative computation of Q + ! * iterative Q computation till LHS ~= RHS + ! + ! state array: + ! (time:0:1, loc:0:1) 0-previous time step/inlet, 1-current time step/outlet. + ! Q or A(1,2,3,4): 1: (t=0,x=0), 2: (t=0,x=1), 3: (t=1,x=0), 4: (t=1,x=1) + + IMPLICIT NONE + ! Input + type(RCHPRP), intent(in) :: rch_param ! River reach parameter + real(dp), intent(in) :: T0,T1 ! start and end of the time step (seconds) + real(dp), intent(in) :: q_upstream ! total discharge at top of the reach being processed + logical(lgt), intent(in) :: isHW ! is this headwater basin? + logical(lgt), intent(in) :: doCheck ! reach index to be examined + ! Input/Output + type(kwRCH), intent(inout) :: rstate ! curent reach states + type(STRFLX), intent(inout) :: rflux ! current Reach fluxes + ! Output + integer(i4b), intent(out) :: ierr ! error code + character(*), intent(out) :: message ! error message + ! Local variables + real(dp) :: alpha ! sqrt(slope)(/mannings N* width) + real(dp) :: beta ! constant, 5/3 + real(dp) :: alpha1 ! sqrt(slope)(/mannings N* width) + real(dp) :: beta1 ! constant, 5/3 + real(dp) :: theta ! dT/dX + real(dp) :: omega ! right-hand side of kw finite difference + real(dp) :: f0,f1,f2 ! values of function f, 1st and 2nd derivatives at solution + real(dp) :: X ! + real(dp) :: dT ! interval of time step [sec] + real(dp) :: dX ! length of segment [m] + real(dp) :: Q(0:1,0:1) ! + real(dp) :: Qtrial(2) ! trial solution of kw equation + real(dp) :: Qbar ! + real(dp) :: absErr(2) ! absolute error of nonliear equation solution + real(dp) :: f0eval(2) ! + integer(i4b) :: imin ! index at minimum value + + ierr=0; message='kinematic_wave/' + + ! current time and inlet 3 (1,0) -> previous time and inlet 1 (0,0) + ! current time and outlet 4 (1,1) -> previous time and outlet 2 (0,1) + Q(0,0) = rstate%molecule%Q(1) + Q(0,1) = rstate%molecule%Q(2) + + if (.not. isHW) then + + Q(1,1) = realMissing + + ! Get the reach parameters + ! A = (Q/alpha)**(1/beta) + ! Q = alpha*A**beta + alpha = sqrt(rch_param%R_SLOPE)/(rch_param%R_MAN_N*rch_param%R_WIDTH**(2._dp/3._dp)) + beta = 5._dp/3._dp + beta1 = 1._dp/beta + alpha1 = (1.0/alpha)**beta1 + dX = rch_param%RLENGTH + dT = T1-T0 + theta = dT/dX + + ! compute total flow rate and flow area at upstream end at current time step + Q(1,0) = q_upstream + + if (doCheck) then + write(iulog,'(3(A,X,G12.5))') ' R_SLOPE=',rch_param%R_SLOPE,' R_WIDTH=',rch_param%R_WIDTH,' R_MANN=',rch_param%R_MAN_N + write(iulog,'(3(A,X,G12.5))') ' Q(0,0)=',Q(0,0),' Q(0,1)=',Q(0,1),' Q(1,0)=',Q(1,0) + end if + + ! ---------- + ! solve flow rate and flow area at downstream end at current time step + ! ---------- + ! initial guess + Qbar = (Q(0,1) + Q(1,0))/2._dp + Q(1,1) = (theta*Q(1,0) + alpha1*beta1*Qbar**(beta1-1)*Q(0,1))/(theta + alpha1*beta1*Qbar**(beta1-1)) + + omega = theta*Q(1,0)+alpha1*Q(0,1)**(beta1) + + f0eval(1) = theta*Q(1,1) + alpha1*Q(1,1)**beta1 + absErr(1) = abs(f0eval(1)-omega) + + if ( abs(Q(1,1)-0.0_dp) < epsilon(Q(1,1))) then + Q(1,1) = omega/(theta+alpha1) + else if (absErr(1) > critFactor*omega) then + ! iterative solution + do + f0 = theta*Q(1,1) + alpha1*Q(1,1)**beta1 + f1 = theta + alpha1*beta1*Q(1,1)**(beta1-1) ! 1st derivative of f w.r.t. Q + f2 = alpha1*beta1*(beta1-1)*Q(1,1)**(beta1-2) ! 2nd derivative of f w.r.t. Q + + X = (f1/f2)**2._dp - 2._dp*(f0-omega)/f2 + if (X<0) X=0._dp + + ! two solutions + Qtrial(1) = abs(Q(1,1) - f1/f2 + sqrt(X)) + Qtrial(2) = abs(Q(1,1) - f1/f2 - sqrt(X)) + + f0eval = theta*Qtrial + alpha1*Qtrial**beta1 + absErr = abs(f0eval-omega) + imin = minloc(absErr,DIM=1) + Q(1,1) = Qtrial(imin) + + if (absErr(imin) < critFactor*omega) exit + end do + endif + + if (doCheck) then + write(iulog,'(1(A,X,G15.4))') ' Q(1,1)=',Q(1,1) + end if + + else ! if head-water + + Q(1,0) = 0._dp + Q(1,1) = 0._dp + + if (doCheck) then + write(iulog,'(A)') ' This is headwater ' + write(iulog,'(1(A,X,G15.4))') ' Q(1,1)=',Q(1,1) + endif + + endif + + ! compute volume + rflux%ROUTE(idxKW)%REACH_VOL(0) = rflux%ROUTE(idxKW)%REACH_VOL(1) + rflux%ROUTE(idxKW)%REACH_VOL(1) = rflux%ROUTE(idxKW)%REACH_VOL(0) + (Q(1,0)-Q(1,1))*dT + rflux%ROUTE(idxKW)%REACH_VOL(1) = max(rflux%ROUTE(idxKW)%REACH_VOL(1), 0._dp) + + ! add catchment flow + rflux%ROUTE(idxKW)%REACH_Q = Q(1,1)+rflux%BASIN_QR(1) + + ! update state + rstate%molecule%Q(1) = Q(1,0) + rstate%molecule%Q(2) = Q(1,1) + + END SUBROUTINE kinematic_wave + + +END MODULE kw_route_module diff --git a/route/build/src/kwt_route.f90 b/route/build/src/kwt_route.f90 index 97829e99..6d085f7c 100644 --- a/route/build/src/kwt_route.f90 +++ b/route/build/src/kwt_route.f90 @@ -3,18 +3,20 @@ MODULE kwt_route_module !numeric type USE nrtype ! data types -USE dataTypes, ONLY : FPOINT ! particle -USE dataTypes, ONLY : KREACH ! collection of particles in a given reach -USE dataTypes, ONLY : STRFLX ! fluxes in each reach -USE dataTypes, ONLY : RCHTOPO ! Network topology -USE dataTypes, ONLY : RCHPRP ! Reach parameter +USE dataTypes, ONLY: FPOINT ! particle +USE dataTypes, ONLY: STRFLX ! fluxes in each reach +USE dataTypes, ONLY: STRSTA ! states in each reach +USE dataTypes, ONLY: RCHTOPO ! Network topology +USE dataTypes, ONLY: RCHPRP ! Reach parameter +USE dataTypes, ONLY: kwtRCH ! kwt specific state data structure ! global data -USE public_var, ONLY : runoffMin ! minimum runoff -USE public_var, ONLY : verySmall ! a very small value -USE public_var, ONLY : realMissing ! missing value for real number -USE public_var, ONLY : integerMissing ! missing value for integer number +USE public_var, ONLY: runoffMin ! minimum runoff +USE public_var, ONLY: verySmall ! a very small value +USE public_var, ONLY: realMissing ! missing value for real number +USE public_var, ONLY: integerMissing ! missing value for integer number +USE globalData, ONLY: idxKWT ! index of KWT method ! utilities -USE nr_utility_module, ONLY : arth ! Num. Recipies utilities +USE nr_utility_module, ONLY: arth ! Num. Recipies utilities implicit none @@ -33,7 +35,7 @@ SUBROUTINE kwt_route(iens, & ! input: ensemble index ixDesire, & ! input: reachID to be checked by on-screen pringing NETOPO_in, & ! input: reach topology data structure RPARAM_in, & ! input: reach parameter data structure - KROUTE_out, & ! inout: reach state data structure + RCHSTA_out, & ! inout: reach state data structure RCHFLX_out, & ! inout: reach flux data structure ierr,message, & ! output: error control ixSubRch) ! optional input: subset of reach indices to be processed @@ -50,7 +52,7 @@ SUBROUTINE kwt_route(iens, & ! input: ensemble index type(RCHTOPO), intent(in), allocatable :: NETOPO_in(:) ! River Network topology type(RCHPRP), intent(in), allocatable :: RPARAM_in(:) ! River reach parameter ! inout - type(KREACH), intent(inout), allocatable :: KROUTE_out(:,:) ! reach state data + type(STRSTA), intent(inout), allocatable :: RCHSTA_out(:,:) ! reach state data type(STRFLX), intent(inout), allocatable :: RCHFLX_out(:,:) ! Reach fluxes (ensembles, space [reaches]) for decomposed domains ! output variables integer(i4b), intent(out) :: ierr ! error code @@ -114,7 +116,7 @@ SUBROUTINE kwt_route(iens, & ! input: ensemble index !$OMP shared(doRoute) & ! data array shared !$OMP shared(NETOPO_in) & ! data structure shared !$OMP shared(RPARAM_in) & ! data structure shared -!$OMP shared(KROUTE_out) & ! data structure shared +!$OMP shared(RCHSTA_out) & ! data structure shared !$OMP shared(RCHFLX_out) & ! data structure shared !$OMP shared(ix, iEns, ixDesire) & ! indices shared !$OMP firstprivate(nTrib) @@ -128,14 +130,13 @@ SUBROUTINE kwt_route(iens, & ! input: ensemble index seg:do iSeg=1,river_basin(ix)%branch(iTrib)%nRch jSeg = river_basin(ix)%branch(iTrib)%segIndex(iSeg) if (.not. doRoute(jSeg)) cycle - ! route kinematic waves through the river network call qroute_rch(iEns,jSeg, & ! input: array indices - ixDesire, & ! input: index of the desired reach + ixDesire, & ! input: index of verbose reach T0,T1, & ! input: start and end of the time step LAKEFLAG, & ! input: flag if lakes are to be processed NETOPO_in, & ! input: reach topology data structure RPARAM_in, & ! input: reach parameter data structure - KROUTE_out, & ! inout: reach state data structure + RCHSTA_out, & ! inout: reach state data structure RCHFLX_out, & ! inout: reach flux data structure ierr,cmessage) ! output: error control if(ierr/=0) call handle_err(ierr, trim(message)//trim(cmessage)) @@ -166,7 +167,7 @@ SUBROUTINE qroute_rch(IENS,JRCH, & ! input: array indices LAKEFLAG, & ! input: flag if lakes are to be processed NETOPO_in, & ! input: reach topology data structure RPARAM_in, & ! input: reach parameter data structure - KROUTE_out, & ! inout: reach state data structure + RCHSTA_out, & ! inout: reach state data structure RCHFLX_out, & ! inout: reach flux data structure ierr,message, & ! output: error control RSTEP) ! optional input: retrospective time step offset @@ -215,65 +216,65 @@ SUBROUTINE qroute_rch(IENS,JRCH, & ! input: array indices ! ! * all variables are defined (implicit none) and described (comments) ! - ! * use of a new data structure (KROUTE_out) to hold and update the flow particles + ! * use of a new data structure (RCHSTA_out) to hold and update the flow particles ! ! * upgrade to F90 (especially structured variables and dynamic memory allocation) ! ! ---------------------------------------------------------------------------------------- - implicit none - ! Input - integer(i4b), intent(in) :: IENS ! ensemble member - integer(i4b), intent(in) :: JRCH ! reach to process - integer(i4b), intent(in) :: ixDesire ! index of the reach for verbose output - real(dp), intent(in) :: T0,T1 ! start and end of the time step (seconds) - integer(i4b), intent(in) :: LAKEFLAG ! >0 if processing lakes - type(RCHTOPO),intent(in), allocatable :: NETOPO_in(:) ! River Network topology - type(RCHPRP), intent(in), allocatable :: RPARAM_in(:) ! River reach parameter - integer(i4b), intent(in), optional :: RSTEP ! retrospective time step offset - ! inout - type(KREACH), intent(inout), allocatable :: KROUTE_out(:,:) ! reach state data - type(STRFLX), intent(inout), allocatable :: RCHFLX_out(:,:) ! Reach fluxes (ensembles, space [reaches]) for decomposed domains - ! output variables - integer(i4b), intent(out) :: ierr ! error code - character(*), intent(out) :: message ! error message - ! (1) extract flow from upstream reaches and append to the non-routed flow in JRCH - integer(i4b) :: NUPS ! number of upstream reaches - real(dp),dimension(:),allocatable :: Q_JRCH ! flow in downstream reach JRCH - real(dp),dimension(:),allocatable :: TENTRY ! entry time to JRCH (exit time u/s) - integer(i4b) :: NQ1 ! # flow particles - ! (2) route flow within the current [JRCH] river segment - integer(I4B) :: ROFFSET ! retrospective offset due to rstep - real(dp) :: T_START ! start of time step - real(dp) :: T_END ! end of time step - real(dp),dimension(:),allocatable :: T_EXIT ! time particle expected exit JRCH - logical(LGT),dimension(:),allocatable :: FROUTE ! routing flag .T. if particle exits - integer(I4B) :: NQ2 ! # flow particles (<=NQ1 b/c merge) - ! (3) calculate time-step averages - integer(I4B) :: NR ! # routed particles - integer(I4B) :: NN ! # non-routed particles - real(dp),dimension(2) :: TNEW ! start/end of time step - real(dp),dimension(1) :: QNEW ! interpolated flow - ! (4) housekeeping - real(dp) :: Q_END ! flow at the end of the timestep - real(dp) :: TIMEI ! entry time at the end of the timestep - TYPE(FPOINT),allocatable,dimension(:) :: NEW_WAVE ! temporary wave - ! random stuff - integer(i4b) :: IWV ! rech index - character(len=strLen) :: fmt1,fmt2 ! format string - character(len=strLen) :: CMESSAGE ! error message for downwind routine - - ierr=0; message='qroute_rch/' - - if(JRCH==ixDesire) then - write(*,'(2a)') new_line('a'),'** Check kinematic wave tracking routing **' - write(*,"(a,x,I10,x,I10)") ' Reach index & ID =', JRCH, NETOPO_in(JRCH)%REACHID - write(*,"(a,x,F20.7,1x,F20.7)") ' time step(T0,T1) =', T0, T1 - write(*,'(a,x,F15.7)') ' RPARAM_in%R_SLOPE =', RPARAM_in(JRCH)%R_SLOPE - write(*,'(a,x,F15.7)') ' RPARAM_in%R_MAN_N =', RPARAM_in(JRCH)%R_MAN_N - write(*,'(a,x,F15.7)') ' RPARAM_in%R_WIDTH =', RPARAM_in(JRCH)%R_WIDTH - end if + implicit none + ! Input + integer(i4b), intent(in) :: IENS ! ensemble member + integer(i4b), intent(in) :: JRCH ! reach to process + integer(i4b), intent(in) :: ixDesire ! index of the reach for verbose output + real(dp), intent(in) :: T0,T1 ! start and end of the time step (seconds) + integer(i4b), intent(in) :: LAKEFLAG ! >0 if processing lakes + type(RCHTOPO),intent(in), allocatable :: NETOPO_in(:) ! River Network topology + type(RCHPRP), intent(in), allocatable :: RPARAM_in(:) ! River reach parameter + integer(i4b), intent(in), optional :: RSTEP ! retrospective time step offset + ! inout + type(STRSTA), intent(inout), allocatable :: RCHSTA_out(:,:) ! reach state data + type(STRFLX), intent(inout), allocatable :: RCHFLX_out(:,:) ! Reach fluxes (ensembles, space [reaches]) for decomposed domains + ! output variables + integer(i4b), intent(out) :: ierr ! error code + character(*), intent(out) :: message ! error message + ! (1) extract flow from upstream reaches and append to the non-routed flow in JRCH + integer(i4b) :: NUPS ! number of upstream reaches + real(dp),dimension(:),allocatable :: Q_JRCH ! flow in downstream reach JRCH + real(dp),dimension(:),allocatable :: TENTRY ! entry time to JRCH (exit time u/s) + integer(i4b) :: NQ1 ! # flow particles + ! (2) route flow within the current [JRCH] river segment + integer(i4b) :: ROFFSET ! retrospective offset due to rstep + real(dp) :: T_START ! start of time step + real(dp) :: T_END ! end of time step + real(dp),dimension(:),allocatable :: T_EXIT ! time particle expected exit JRCH + logical(LGT),dimension(:),allocatable :: FROUTE ! routing flag .T. if particle exits + integer(i4b) :: NQ2 ! # flow particles (<=NQ1 b/c merge) + ! (3) calculate time-step averages + integer(i4b) :: NR ! # routed particles + integer(i4b) :: NN ! # non-routed particles + real(dp),dimension(2) :: TNEW ! start/end of time step + real(dp),dimension(1) :: QNEW ! interpolated flow + ! (4) housekeeping + real(dp) :: Q_END ! flow at the end of the timestep + real(dp) :: TIMEI ! entry time at the end of the timestep + TYPE(FPOINT),allocatable,dimension(:) :: NEW_WAVE ! temporary wave + ! random stuff + integer(i4b) :: IWV ! rech index + character(len=strLen) :: fmt1,fmt2 ! format string + character(len=strLen) :: CMESSAGE ! error message for downwind routine + + ierr=0; message='qroute_rch/' + + if(JRCH==ixDesire) then + write(*,'(2a)') new_line('a'),'** Check kinematic wave tracking routing **' + write(*,"(a,x,I10,x,I10)") ' Reach index & ID =', JRCH, NETOPO_in(JRCH)%REACHID + write(*,"(a,x,F20.7,1x,F20.7)") ' time step(T0,T1) =', T0, T1 + write(*,'(a,x,F15.7)') ' RPARAM_in%R_SLOPE =', RPARAM_in(JRCH)%R_SLOPE + write(*,'(a,x,F15.7)') ' RPARAM_in%R_MAN_N =', RPARAM_in(JRCH)%R_MAN_N + write(*,'(a,x,F15.7)') ' RPARAM_in%R_WIDTH =', RPARAM_in(JRCH)%R_WIDTH + end if - RCHFLX_out(IENS,JRCH)%TAKE=0.0_dp ! initialize take from this reach + RCHFLX_out(IENS,JRCH)%TAKE=0.0_dp ! initialize take from this reach ! ---------------------------------------------------------------------------------------- ! (1) EXTRACT FLOW FROM UPSTREAM REACHES & APPEND TO THE NON-ROUTED FLOW PARTICLES IN JRCH @@ -283,7 +284,7 @@ SUBROUTINE qroute_rch(IENS,JRCH, & ! input: array indices if (NUPS.GT.0) then call getusq_rch(IENS,JRCH,LAKEFLAG,T0,T1,ixDesire, & ! input NETOPO_in,RPARAM_in,RCHFLX_out, & ! input - KROUTE_out, & ! inout + RCHSTA_out, & ! inout Q_JRCH,TENTRY,T_EXIT,ierr,cmessage,& ! output RSTEP) ! optional input if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif @@ -299,22 +300,22 @@ SUBROUTINE qroute_rch(IENS,JRCH, & ! input: array indices endif else ! set flow in headwater reaches to modelled streamflow from time delay histogram - RCHFLX_out(IENS,JRCH)%REACH_Q = RCHFLX_out(IENS,JRCH)%BASIN_QR(1) - if (allocated(KROUTE_out(IENS,JRCH)%KWAVE)) then - deallocate(KROUTE_out(IENS,JRCH)%KWAVE,STAT=IERR) - if(ierr/=0)then; message=trim(message)//'problem deallocating space for KROUTE_out'; return; endif + RCHFLX_out(IENS,JRCH)%ROUTE(idxKWT)%REACH_Q = RCHFLX_out(IENS,JRCH)%BASIN_QR(1) + if (allocated(RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE)) then + deallocate(RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE,STAT=IERR) + if(ierr/=0)then; message=trim(message)//'problem deallocating space for RCHSTA_out'; return; endif endif - allocate(KROUTE_out(IENS,JRCH)%KWAVE(0:0),STAT=ierr) - if(ierr/=0)then; message=trim(message)//'problem allocating space for KROUTE_out(IENS,JRCH)%KWAVE(1)'; return; endif - KROUTE_out(IENS,JRCH)%KWAVE(0)%QF=-9999 - KROUTE_out(IENS,JRCH)%KWAVE(0)%TI=-9999 - KROUTE_out(IENS,JRCH)%KWAVE(0)%TR=-9999 - KROUTE_out(IENS,JRCH)%KWAVE(0)%RF=.False. - KROUTE_out(IENS,JRCH)%KWAVE(0)%QM=-9999 + allocate(RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(0:0),STAT=ierr) + if(ierr/=0)then; message=trim(message)//'problem allocating space for RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(1)'; return; endif + RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(0)%QF=-9999 + RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(0)%TI=-9999 + RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(0)%TR=-9999 + RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(0)%RF=.False. + RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(0)%QM=-9999 if(JRCH==ixDesire) then write(*,'(a)') ' * Final discharge (RCHFLX_out(IENS,JRCH)%REACH_Q) [m3/s]:' - write(*,'(x,F20.7)') RCHFLX_out(IENS,JRCH)%REACH_Q + write(*,'(x,F20.7)') RCHFLX_out(IENS,JRCH)%ROUTE(idxKWT)%REACH_Q end if return ! no upstream reaches (routing for sub-basins done using time-delay histogram) endif @@ -374,7 +375,7 @@ SUBROUTINE qroute_rch(IENS,JRCH, & ! input: array indices write(*,fmt1) ' TENTRY=',(TENTRY(IWV), IWV=0,NQ1) write(*,fmt1) ' T_EXIT=',(T_EXIT(IWV), IWV=0,NQ1) write(*,fmt2) ' FROUTE=',(FROUTE(IWV), IWV=0,NQ1) - endif + end if ! ---------------------------------------------------------------------------------------- ! (4) COMPUTE TIME-STEP AVERAGES @@ -388,13 +389,13 @@ SUBROUTINE qroute_rch(IENS,JRCH, & ! input: array indices if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif ! m2/s --> m3/s + instantaneous runoff from basin - RCHFLX_out(IENS,JRCH)%REACH_Q = QNEW(1)*RPARAM_in(JRCH)%R_WIDTH + RCHFLX_out(IENS,JRCH)%BASIN_QR(1) + RCHFLX_out(IENS,JRCH)%ROUTE(idxKWT)%REACH_Q = QNEW(1)*RPARAM_in(JRCH)%R_WIDTH + RCHFLX_out(IENS,JRCH)%BASIN_QR(1) if(JRCH == ixDesire)then write(*,'(a)') ' * Time-ave. wave discharge that exit (QNEW(1)) [m2/s], local-area discharge (RCHFLX_out%BASIN_QR(1)) [m3/s] and Final discharge (RCHFLX_out%REACH_Q) [m3/s]:' write(*,"(A,1x,F15.7)") ' QNEW(1) =', QNEW(1) write(*,"(A,1x,F15.7)") ' RCHFLX_out%BASIN_QR(1) =', RCHFLX_out(IENS,JRCH)%BASIN_QR(1) - write(*,"(A,1x,F15.7)") ' RCHFLX_out%REACH_Q =', RCHFLX_out(IENS,JRCH)%REACH_Q + write(*,"(A,1x,F15.7)") ' RCHFLX_out%REACH_Q =', RCHFLX_out(IENS,JRCH)%ROUTE(idxKWT)%REACH_Q endif ! ---------------------------------------------------------------------------------------- @@ -408,24 +409,24 @@ SUBROUTINE qroute_rch(IENS,JRCH, & ! input: array indices TIMEI = TENTRY(NR) + & ! (dT/dT) (dT) ( (TENTRY(NR+1)-TENTRY(NR)) / (T_EXIT(NR+1)-T_EXIT(NR)) ) * (T_END-T_EXIT(NR)) ! allocate space for the routed data (+1 to allocate space for the interpolated point) - if (.not.allocated(KROUTE_out(IENS,JRCH)%KWAVE)) then - ierr=20; message=trim(message)//'KROUTE_out is not associated'; return + if (.not.allocated(RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE)) then + ierr=20; message=trim(message)//'RCHSTA_out is not associated'; return else - deallocate(KROUTE_out(IENS,JRCH)%KWAVE, STAT=ierr) - if(ierr/=0)then; message=trim(message)//'problem deallocating space for KROUTE_out(IENS,JRCH)%KWAVE'; return; endif - allocate(KROUTE_out(IENS,JRCH)%KWAVE(0:NQ2+1),STAT=ierr) ! NQ2 is number of points for kinematic routing - if(ierr/=0)then; message=trim(message)//'problem allocating space for KROUTE_out(IENS,JRCH)%KWAVE(0:NQ2+1)'; return; endif + deallocate(RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE, STAT=ierr) + if(ierr/=0)then; message=trim(message)//'problem deallocating space for RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE'; return; endif + allocate(RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(0:NQ2+1),STAT=ierr) ! NQ2 is number of points for kinematic routing + if(ierr/=0)then; message=trim(message)//'problem allocating space for RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(0:NQ2+1)'; return; endif endif ! insert the interpolated point (TI is irrelevant, as the point is "routed") - KROUTE_out(IENS,JRCH)%KWAVE(NR+1)%QF=Q_END; KROUTE_out(IENS,JRCH)%KWAVE(NR+1)%TI=TIMEI - KROUTE_out(IENS,JRCH)%KWAVE(NR+1)%TR=T_END; KROUTE_out(IENS,JRCH)%KWAVE(NR+1)%RF=.true. + RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(NR+1)%QF=Q_END; RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(NR+1)%TI=TIMEI + RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(NR+1)%TR=T_END; RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(NR+1)%RF=.true. ! add the output from kinwave... - skip NR+1 ! (when JRCH becomes IR routed points will be stripped out & the structures updated again) - KROUTE_out(IENS,JRCH)%KWAVE(0:NR)%QF=Q_JRCH(0:NR); KROUTE_out(IENS,JRCH)%KWAVE(NR+2:NQ2+1)%QF=Q_JRCH(NR+1:NQ2) - KROUTE_out(IENS,JRCH)%KWAVE(0:NR)%TI=TENTRY(0:NR); KROUTE_out(IENS,JRCH)%KWAVE(NR+2:NQ2+1)%TI=TENTRY(NR+1:NQ2) - KROUTE_out(IENS,JRCH)%KWAVE(0:NR)%TR=T_EXIT(0:NR); KROUTE_out(IENS,JRCH)%KWAVE(NR+2:NQ2+1)%TR=T_EXIT(NR+1:NQ2) - KROUTE_out(IENS,JRCH)%KWAVE(0:NR)%RF=FROUTE(0:NR); KROUTE_out(IENS,JRCH)%KWAVE(NR+2:NQ2+1)%RF=FROUTE(NR+1:NQ2) - KROUTE_out(IENS,JRCH)%KWAVE(0:NQ2+1)%QM=-9999 + RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(0:NR)%QF=Q_JRCH(0:NR); RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(NR+2:NQ2+1)%QF=Q_JRCH(NR+1:NQ2) + RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(0:NR)%TI=TENTRY(0:NR); RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(NR+2:NQ2+1)%TI=TENTRY(NR+1:NQ2) + RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(0:NR)%TR=T_EXIT(0:NR); RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(NR+2:NQ2+1)%TR=T_EXIT(NR+1:NQ2) + RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(0:NR)%RF=FROUTE(0:NR); RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(NR+2:NQ2+1)%RF=FROUTE(NR+1:NQ2) + RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(0:NQ2+1)%QM=-9999 ! implement water use !IF (NUSER.GT.0.AND.UCFFLAG.GE.1) THEN @@ -439,31 +440,31 @@ SUBROUTINE qroute_rch(IENS,JRCH, & ! input: array indices ! *** ! remove flow particles from the most downstream reach ! if the last reach or lake inlet (and lakes are enabled), remove routed elements from memory - IF ((NETOPO_in(JRCH)%DREACHK<=0 ).OR. & ! if the last reach (down reach ID:DREACHK is negative), then there is no downstream reach - (LAKEFLAG.EQ.1.AND.NETOPO_in(JRCH)%LAKINLT)) THEN ! if lake inlet + if ((NETOPO_in(JRCH)%DREACHK<=0 ).OR. & ! if the last reach (down reach ID:DREACHK is negative), then there is no downstream reach + (LAKEFLAG.EQ.1.AND.NETOPO_in(JRCH)%LAKINLT)) then ! if lake inlet ! copy data to a temporary wave - if (allocated(NEW_WAVE)) THEN + if (allocated(NEW_WAVE)) then deallocate(NEW_WAVE,STAT=IERR) if(ierr/=0)then; message=trim(message)//'problem deallocating space for NEW_WAVE'; return; endif endif allocate(NEW_WAVE(0:NN),STAT=IERR) ! NN = number non-routed (the zero element is the last routed point) if(ierr/=0)then; message=trim(message)//'problem allocating space for NEW_WAVE'; return; endif - NEW_WAVE(0:NN) = KROUTE_out(IENS,JRCH)%KWAVE(NR+1:NQ2+1) ! +1 because of the interpolated point + NEW_WAVE(0:NN) = RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(NR+1:NQ2+1) ! +1 because of the interpolated point ! re-size wave structure - if (allocated(KROUTE_out(IENS,JRCH)%KWAVE)) THEN - deallocate(KROUTE_out(IENS,JRCH)%KWAVE,STAT=IERR) - if(ierr/=0)then; message=trim(message)//'problem deallocating space for KROUTE_out'; return; endif + if (allocated(RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE)) then + deallocate(RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE,STAT=IERR) + if(ierr/=0)then; message=trim(message)//'problem deallocating space for RCHSTA_out'; return; endif endif - allocate(KROUTE_out(IENS,JRCH)%KWAVE(0:NN),STAT=IERR) ! again, the zero element for the last routed point - if(ierr/=0)then; message=trim(message)//'problem allocating space for KROUTE_out'; return; endif + allocate(RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(0:NN),STAT=IERR) ! again, the zero element for the last routed point + if(ierr/=0)then; message=trim(message)//'problem allocating space for RCHSTA_out'; return; endif ! copy data back to the wave structure and deallocate space for the temporary wave - KROUTE_out(IENS,JRCH)%KWAVE(0:NN) = NEW_WAVE(0:NN) + RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(0:NN) = NEW_WAVE(0:NN) endif ! (if JRCH is the last reach) END SUBROUTINE qroute_rch ! ********************************************************************* - ! subroutine: wave discharge mod to extract water from the JRCH reach + ! subroutine: wave discharge mod to extract/infect water from the JRCH reach ! ********************************************************************* SUBROUTINE extract_from_rch(iens, jrch, & ! input: ensemble and reach indices T_START, T_END, & ! input: start and end time [sec] for this time step @@ -531,7 +532,7 @@ SUBROUTINE extract_from_rch(iens, jrch, & ! input: ensemble and rea else ! everything taken.... - q_jrch_mod = runoffMin ! remaining wave Q after abstraction + Q_jrch_mod = runoffMin ! remaining wave Q after abstraction end if @@ -573,7 +574,7 @@ END SUBROUTINE extract_from_rch ! ********************************************************************* subroutine getusq_rch(IENS,JRCH,LAKEFLAG,T0,T1,ixDesire, & ! input NETOPO_in,RPARAM_in,RCHFLX_in, & ! input - KROUTE_out, & ! inout + RCHSTA_out, & ! inout Q_JRCH,TENTRY,T_EXIT,ierr,message, & ! output RSTEP) ! optional input ! ---------------------------------------------------------------------------------------- @@ -600,7 +601,7 @@ subroutine getusq_rch(IENS,JRCH,LAKEFLAG,T0,T1,ixDesire, & ! input ! RSTEP: Retrospective time step ! ! Inout: - ! KROUTE_out: reach wave data structures + ! RCHSTA_out: reach wave data structures ! ! Outputs: ! Q_JRCH(:): Vector of merged flow particles in reach JRCH @@ -608,21 +609,21 @@ subroutine getusq_rch(IENS,JRCH,LAKEFLAG,T0,T1,ixDesire, & ! input ! T_EXIT(:): Vector of times flow particles are expected to exit reach JRCH ! ! ---------------------------------------------------------------------------------------- - USE globalData, only : LKTOPO ! Lake topology - USE globalData, only : LAKFLX ! Lake fluxes + USE globalData, ONLY: LKTOPO ! Lake topology + USE globalData, ONLY: LAKFLX ! Lake fluxes implicit none ! Input - integer(I4B), intent(in) :: IENS ! ensemble member - integer(I4B), intent(in) :: JRCH ! reach to process - integer(I4B), intent(in) :: LAKEFLAG ! >0 if processing lakes - real(DP), intent(in) :: T0,T1 ! start and end of the time step - integer(I4B), intent(in) :: ixDesire ! index of the reach for verbose output + integer(i4b), intent(in) :: IENS ! ensemble member + integer(i4b), intent(in) :: JRCH ! reach to process + integer(i4b), intent(in) :: LAKEFLAG ! >0 if processing lakes + real(dp), intent(in) :: T0,T1 ! start and end of the time step + integer(i4b), intent(in) :: ixDesire ! index of the reach for verbose output type(RCHTOPO),intent(in), allocatable :: NETOPO_in(:) ! River Network topology type(RCHPRP), intent(in), allocatable :: RPARAM_in(:) ! River reach parameter type(STRFLX), intent(in), allocatable :: RCHFLX_in(:,:) ! Reach fluxes (ensembles, space [reaches]) for decomposed domains - integer(I4B), intent(in), optional :: RSTEP ! retrospective time step offset + integer(i4b), intent(in), optional :: RSTEP ! retrospective time step offset ! inout - type(KREACH), intent(inout), allocatable :: KROUTE_out(:,:) ! reach state data + type(STRSTA), intent(inout), allocatable :: RCHSTA_out(:,:) ! reach state data ! Output real(dp),allocatable, intent(out) :: Q_JRCH(:) ! merged (non-routed) flow in JRCH real(dp),allocatable, intent(out) :: TENTRY(:) ! time flow particles entered JRCH @@ -643,18 +644,17 @@ subroutine getusq_rch(IENS,JRCH,LAKEFLAG,T0,T1,ixDesire, & ! input character(len=strLen) :: cmessage ! error message for downwind routine ierr=0; message='getusq_rch/' + ! ---------------------------------------------------------------------------------------- + ! (1) EXTRACT (AND MERGE) FLOW FROM UPSTREAM REACHES OR LAKE + ! ---------------------------------------------------------------------------------------- - ! set the retrospective offset and model time step [sec] DT = (T1 - T0) + ! set the retrospective offset if (.not.present(RSTEP)) then ROFFSET = 0 else ROFFSET = RSTEP end if - - ! ---------------------------------------------------------------------------------------- - ! (1) EXTRACT (AND MERGE) FLOW FROM UPSTREAM REACHES OR LAKE - ! ---------------------------------------------------------------------------------------- if (LAKEFLAG.EQ.1) then ! lakes are enabled ! get lake outflow and only lake outflow if reach is a lake outlet reach, else do as normal ILAK = NETOPO_in(JRCH)%LAKE_IX ! lake index @@ -668,15 +668,15 @@ subroutine getusq_rch(IENS,JRCH,LAKEFLAG,T0,T1,ixDesire, & ! input else call qexmul_rch(IENS,JRCH,T0,T1,ixDesire, & ! input NETOPO_in,RPARAM_in,RCHFLX_in, & ! input - KROUTE_out, & ! inout + RCHSTA_out, & ! inout ND,QD,TD,ierr,cmessage, & ! output RSTEP) ! optional input if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif - endif + end if else call qexmul_rch(IENS,JRCH,T0,T1,ixDesire, & ! input NETOPO_in,RPARAM_in,RCHFLX_in, & ! input - KROUTE_out, & ! inout + RCHSTA_out, & ! inout ND,QD,TD,ierr,cmessage, & ! output RSTEP) ! optional input if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif @@ -684,53 +684,52 @@ subroutine getusq_rch(IENS,JRCH,LAKEFLAG,T0,T1,ixDesire, & ! input else ! lakes disabled call qexmul_rch(IENS,JRCH,T0,T1,ixDesire, & ! input NETOPO_in,RPARAM_in,RCHFLX_in, & ! input - KROUTE_out, & ! inout + RCHSTA_out, & ! inout ND,QD,TD,ierr,cmessage, & ! output RSTEP) ! optional input if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif - if(JRCH == ixDesire) then + if (JRCH == ixDesire) then write(fmt1,'(A,I5,A)') '(A,1X',ND,'(1X,F15.7))' write(*,'(a)') ' * After qexmul_rch: # of routed wave from upstreams (ND) and wave discharge (QD) [m2/s]:' write(*,'(A,x,I5)') ' ND=', ND write(*,fmt1) ' QD=', (QD(iw), iw=1,ND) end if - endif + end if ! ---------------------------------------------------------------------------------------- ! (2) EXTRACT NON-ROUTED FLOW FROM THE REACH JRCH & APPEND TO THE FLOW JUST ROUTED D/S ! ---------------------------------------------------------------------------------------- ! check that the routing structure is associated - if(allocated(KROUTE_out).eqv..false.)THEN - ierr=20; message='routing structure KROUTE_out is not associated'; return + if (allocated(RCHSTA_out).eqv..false.) then + ierr=20; message='routing structure RCHSTA_out is not associated'; return endif ! check that the wave has been initialized - if (allocated(KROUTE_out(IENS,JRCH)%KWAVE).eqv..false.) THEN + if (allocated(RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE).eqv..false.) then ! if not initialized, then set initial flow to first flow ! (this will only occur for a cold start in the case of no streamflow observations) - allocate(KROUTE_out(IENS,JRCH)%KWAVE(0:0),STAT=IERR) + allocate(RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(0:0),STAT=IERR) if(ierr/=0)then; message=trim(message)//'problem allocating array for KWAVE'; return; endif - KROUTE_out(IENS,JRCH)%KWAVE(0)%QF = QD(1) - KROUTE_out(IENS,JRCH)%KWAVE(0)%TI = T0 - DT - DT*ROFFSET - KROUTE_out(IENS,JRCH)%KWAVE(0)%TR = T0 - DT*ROFFSET - KROUTE_out(IENS,JRCH)%KWAVE(0)%RF = .true. + RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(0)%QF = QD(1) + RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(0)%TI = T0 - DT - DT*ROFFSET + RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(0)%TR = T0 - DT*ROFFSET + RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(0)%RF = .true. endif ! now extract the non-routed flow ! NB: routed flows were stripped out in the previous timestep when JRCH was index of u/s reach ! {only non-routed flows remain in the routing structure [ + zero element (last routed)]} - NJ = size(KROUTE_out(IENS,JRCH)%KWAVE) - 1 ! number of elements not routed (-1 for 0) + NJ = size(RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE) - 1 ! number of elements not routed (-1 for 0) NK = NJ + ND ! pts still in reach + u/s pts just routed allocate(Q_JRCH(0:NK),TENTRY(0:NK),T_EXIT(0:NK),STAT=IERR) ! include zero element for INTERP later if(ierr/=0)then; message=trim(message)//'problem allocating array for [Q_JRCH, TENTRY, T_EXIT]'; return; endif - - Q_JRCH(0:NJ) = KROUTE_out(IENS,JRCH)%KWAVE(0:NJ)%QF ! extract the non-routed flow from reach JR - TENTRY(0:NJ) = KROUTE_out(IENS,JRCH)%KWAVE(0:NJ)%TI ! extract the non-routed time from reach JR - T_EXIT(0:NJ) = KROUTE_out(IENS,JRCH)%KWAVE(0:NJ)%TR ! extract the expected exit time - Q_JRCH(NJ+1:NJ+ND) = QD(1:ND) ! append u/s flow just routed downstream - TENTRY(NJ+1:NJ+ND) = TD(1:ND) ! append u/s time just routed downstream - T_EXIT(NJ+1:NJ+ND) = -9999.0D0 ! set un-used T_EXIT to missing + Q_JRCH(0:NJ) = RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(0:NJ)%QF ! extract the non-routed flow from reach JR + TENTRY(0:NJ) = RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(0:NJ)%TI ! extract the non-routed time from reach JR + T_EXIT(0:NJ) = RCHSTA_out(IENS,JRCH)%LKW_ROUTE%KWAVE(0:NJ)%TR ! extract the expected exit time + Q_JRCH(NJ+1:NJ+ND) = QD(1:ND) ! append u/s flow just routed downstream + TENTRY(NJ+1:NJ+ND) = TD(1:ND) ! append u/s time just routed downstream + T_EXIT(NJ+1:NJ+ND) = -9999.0D0 ! set un-used T_EXIT to missing END SUBROUTINE getusq_rch @@ -740,7 +739,7 @@ END SUBROUTINE getusq_rch ! ********************************************************************* SUBROUTINE qexmul_rch(IENS,JRCH,T0,T1,ixDesire, & ! input NETOPO_in,RPARAM_in,RCHFLX_in, & ! input - KROUTE_out, & ! inout + RCHSTA_out, & ! inout ND,QD,TD,ierr,message, & ! output RSTEP) ! optional input ! ---------------------------------------------------------------------------------------- @@ -768,7 +767,7 @@ SUBROUTINE qexmul_rch(IENS,JRCH,T0,T1,ixDesire, & ! input ! RSTEP: Retrospective time step ! ! Inout: - ! KROUTE_out: reach wave data structures + ! RCHSTA_out: reach wave data structures ! ! Outputs: ! ND : Number of routed particles @@ -778,16 +777,16 @@ SUBROUTINE qexmul_rch(IENS,JRCH,T0,T1,ixDesire, & ! input ! ---------------------------------------------------------------------------------------- implicit none ! Input - INTEGER(i4b), intent(in) :: IENS ! ensemble member - INTEGER(i4b), intent(in) :: JRCH ! reach to process - REAL(dp), intent(in) :: T0,T1 ! start and end of the time step + integer(i4b), intent(in) :: IENS ! ensemble member + integer(i4b), intent(in) :: JRCH ! reach to process + real(dp), intent(in) :: T0,T1 ! start and end of the time step integer(i4b), intent(in) :: ixDesire ! index of the reach for verbose output type(RCHTOPO),intent(in), allocatable :: NETOPO_in(:) ! River Network topology type(RCHPRP), intent(in), allocatable :: RPARAM_in(:) ! River reach parameter type(STRFLX), intent(in), allocatable :: RCHFLX_in(:,:) ! Reach fluxes (ensembles, space [reaches]) for decomposed domains integer(i4b), intent(in), optional :: RSTEP ! retrospective time step offset ! Inout - type(KREACH), intent(inout), allocatable :: KROUTE_out(:,:) ! reach state data + type(STRSTA), intent(inout), allocatable :: RCHSTA_out(:,:) ! reach state data ! Output integer(i4b), intent(out) :: ND ! number of routed particles real(dp), allocatable, intent(out) :: QD(:) ! flow particles just enetered JRCH @@ -803,7 +802,7 @@ SUBROUTINE qexmul_rch(IENS,JRCH,T0,T1,ixDesire, & ! input integer(i4b) :: INDX ! index of the IUPS u/s reach integer(i4b) :: MUPR ! # reaches u/s of IUPS u/s reach integer(i4b) :: NUPS ! number of upstream elements - TYPE(KREACH), allocatable :: USFLOW(:) ! waves for all upstream segments + TYPE(kwtRCH), allocatable :: USFLOW(:) ! waves for all upstream segments real(dp), allocatable :: UWIDTH(:) ! width of all upstream segments integer(i4b) :: IMAX ! max number of upstream particles integer(i4b) :: IUPR ! counter for reaches with particles @@ -811,7 +810,7 @@ SUBROUTINE qexmul_rch(IENS,JRCH,T0,T1,ixDesire, & ! input integer(i4b) :: NS ! size of the wave integer(i4b) :: NR ! # routed particles in u/s reach integer(i4b) :: NQ ! NR+1, if non-routed particle exists - TYPE(FPOINT), allocatable :: NEW_WAVE(:) ! temporary wave + type(FPOINT), allocatable :: NEW_WAVE(:) ! temporary wave ! Local variables to merge flow logical(lgt), dimension(:), allocatable :: MFLG ! T = all particles processed integer(i4b), dimension(:), allocatable :: ITIM ! processing point for all u/s segments @@ -833,8 +832,8 @@ SUBROUTINE qexmul_rch(IENS,JRCH,T0,T1,ixDesire, & ! input ierr=0; message='qexmul_rch/' - ! set the retrospective offset and model time step [sec] - if (.not.PRESENT(RSTEP)) then + ! set the retrospective offset + if (.NOT.present(RSTEP)) then ROFFSET = 0 else ROFFSET = RSTEP @@ -880,7 +879,7 @@ SUBROUTINE qexmul_rch(IENS,JRCH,T0,T1,ixDesire, & ! input end if return - endif + end if ! allocate space for the upstream flow, time, and flags allocate(USFLOW(NUPS),UWIDTH(NUPS),CTIME(NUPS),STAT=IERR) @@ -923,23 +922,23 @@ SUBROUTINE qexmul_rch(IENS,JRCH,T0,T1,ixDesire, & ! input ! identify the index for the IUPS upstream segment IR = NETOPO_in(JRCH)%UREACHI(IUPS) ! identify the size of the wave - NS = size(KROUTE_out(IENS,IR)%KWAVE) + NS = size(RCHSTA_out(IENS,IR)%LKW_ROUTE%KWAVE) ! identify number of routed flow elements in the IUPS upstream segment - NR = count(KROUTE_out(IENS,IR)%KWAVE(:)%RF) + NR = count(RCHSTA_out(IENS,IR)%LKW_ROUTE%KWAVE(:)%RF) ! include a non-routed point, if it exists NQ = MIN(NR+1,NS) ! allocate space for the IUPS stream segment (flow, time, and flags) allocate(USFLOW(NUPB+IUPR)%KWAVE(0:NQ-1),STAT=IERR) ! (zero position = last routed) if(ierr/=0)then; message=trim(message)//'problem allocating array USFLOW(NUPB+IUPR)%KWAVE(0:NQ-1)'; return; endif ! place data in the new arrays - USFLOW(NUPB+IUPR)%KWAVE(0:NQ-1) = KROUTE_out(IENS,IR)%KWAVE(0:NQ-1) + USFLOW(NUPB+IUPR)%KWAVE(0:NQ-1) = RCHSTA_out(IENS,IR)%LKW_ROUTE%KWAVE(0:NQ-1) ! here a statement where we check for a modification in the upstream reach; - ! if flow upstream is modified, then copy KROUTE_out(:,:)%KWAVE(:)%QM to USFLOW(..)%KWAVE%QF + ! if flow upstream is modified, then copy RCHSTA_out(:,:)%LKW_ROUTE%KWAVE(:)%QM to USFLOW(..)%KWAVE%QF !IF (NUSER.GT.0.AND.SIMDAT%UCFFLAG.GE.1) THEN !if the irrigation module is active and there are users ! IF (RCHFLX_out(IENS,IR)%TAKE.GT.0._DP) THEN !if take from upstream reach is greater then zero ! ! replace QF with modified flow (as calculated in extract_from_rch) - ! USFLOW(NUPB+IUPR)%KWAVE(0:NQ-1)%QF = KROUTE_out(IENS,IR)%KWAVE(0:NQ-1)%QM + ! USFLOW(NUPB+IUPR)%KWAVE(0:NQ-1)%QF = RCHSTA_out(IENS,IR)%LKW_ROUTE%KWAVE(0:NQ-1)%QM ! ENDIF !ENDIF @@ -951,19 +950,21 @@ SUBROUTINE qexmul_rch(IENS,JRCH,T0,T1,ixDesire, & ! input end if allocate(NEW_WAVE(0:NS-1),STAT=IERR) ! get new wave if(ierr/=0)then; message=trim(message)//'problem allocating array NEW_WAVE'; return; endif - NEW_WAVE(0:NS-1) = KROUTE_out(IENS,IR)%KWAVE(0:NS-1) ! copy + NEW_WAVE(0:NS-1) = RCHSTA_out(IENS,IR)%LKW_ROUTE%KWAVE(0:NS-1) ! copy ! (re-size wave structure) - if (.not.allocated(KROUTE_out(IENS,IR)%KWAVE))then; print*,' not allocated. in qex ';return; endif - if (allocated(KROUTE_out(IENS,IR)%KWAVE)) then - deallocate(KROUTE_out(IENS,IR)%KWAVE,STAT=IERR) - if(ierr/=0)then; message=trim(message)//'problem deallocating array KROUTE_out'; return; endif + if (.not.allocated(RCHSTA_out(IENS,IR)%LKW_ROUTE%KWAVE))then + ierr=20; message=trim(message)//'RCHSTA_out%LKW_ROUTE%KWAVE is not associated'; return end if - allocate(KROUTE_out(IENS,IR)%KWAVE(0:NS-NR),STAT=IERR) ! reduced size - if(ierr/=0)then; message=trim(message)//'problem allocating array KROUTE_out'; return; endif + if (allocated(RCHSTA_out(IENS,IR)%LKW_ROUTE%KWAVE)) then + deallocate(RCHSTA_out(IENS,IR)%LKW_ROUTE%KWAVE,STAT=IERR) + if(ierr/=0)then; message=trim(message)//'problem deallocating array RCHSTA_out'; return; endif + end if + allocate(RCHSTA_out(IENS,IR)%LKW_ROUTE%KWAVE(0:NS-NR),STAT=IERR) ! reduced size + if(ierr/=0)then; message=trim(message)//'problem allocating array RCHSTA_out'; return; endif ! (copy "last routed" and "non-routed" elements) - KROUTE_out(IENS,IR)%KWAVE(0:NS-NR) = NEW_WAVE(NR-1:NS-1) + RCHSTA_out(IENS,IR)%LKW_ROUTE%KWAVE(0:NS-NR) = NEW_WAVE(NR-1:NS-1) ! (de-allocate temporary wave) deallocate(NEW_WAVE,STAT=IERR) @@ -976,7 +977,7 @@ SUBROUTINE qexmul_rch(IENS,JRCH,T0,T1,ixDesire, & ! input ! keep track of the total number of points that must be routed downstream IMAX = IMAX + (NR-1) ! exclude zero point for the last routed - endif ! if reach has particles in it + end if ! if reach has particles in it end do ! iups ! ---------------------------------------------------------------------------------------- @@ -1022,7 +1023,7 @@ SUBROUTINE qexmul_rch(IENS,JRCH,T0,T1,ixDesire, & ! input ! check that we're not stuck in a continuous do loop if (JUPS.EQ.JUPS_OLD .and. ITIM(JUPS).EQ.ITIM_OLD) then ierr=20; message=trim(message)//'stuck in the continuous do-loop'; return - endif + end if ! save jups and itim(jups) to check that we don't get stuck in a continuous do-loop JUPS_OLD = JUPS ITIM_OLD = ITIM(JUPS) @@ -1041,9 +1042,9 @@ SUBROUTINE qexmul_rch(IENS,JRCH,T0,T1,ixDesire, & ! input TIME_OLD = -HUGE(SFLOW) end if ! check that the particles are being processed in the correct order - IF (CTIME(JUPS).LT.TIME_OLD) then + if (CTIME(JUPS).LT.TIME_OLD) then ierr=30; message=trim(message)//'expect process in order of time'; return - endif + end if ! don't process if time already exists if (CTIME(JUPS).NE.TIME_OLD) then ! ------------------------------------------------------------------------------------- @@ -1067,13 +1068,13 @@ SUBROUTINE qexmul_rch(IENS,JRCH,T0,T1,ixDesire, & ! input if (USFLOW(IUPS)%KWAVE(IEND)%TR.LT.CTIME(JUPS) .or. & USFLOW(IUPS)%KWAVE(IBEG)%TR.GT.CTIME(JUPS)) then ierr=40; message=trim(message)//'the times are not ordered as we assume'; return - endif ! test for bracketing + end if ! test for bracketing ! estimate flow for the IUPS upstream reach at time CTIME(JUPS) SLOPE = (USFLOW(IUPS)%KWAVE(IEND)%QF - USFLOW(IUPS)%KWAVE(IBEG)%QF) / & (USFLOW(IUPS)%KWAVE(IEND)%TR - USFLOW(IUPS)%KWAVE(IBEG)%TR) PREDV = USFLOW(IUPS)%KWAVE(IBEG)%QF + SLOPE*(CTIME(JUPS)-USFLOW(IUPS)%KWAVE(IBEG)%TR) SFLOW = PREDV * SCFAC ! scaled flow - endif ! (if interpolating) + end if ! (if interpolating) ! aggregate flow Q_AGG = Q_AGG + SFLOW end do ! looping through upstream elements @@ -1082,7 +1083,7 @@ SUBROUTINE qexmul_rch(IENS,JRCH,T0,T1,ixDesire, & ! input IPRT = IPRT + 1 QD_TEMP(IPRT) = Q_AGG TD_TEMP(IPRT) = CTIME(JUPS) - endif ! (check that time doesn't already exist) + end if ! (check that time doesn't already exist) ! check if the particle just processed is the last element if (ITIM(JUPS).EQ.size(USFLOW(JUPS)%KWAVE)-1) then ! -1 because of the zero element MFLG(JUPS) = .true. ! have processed all particles in a given u/s reach @@ -1090,9 +1091,9 @@ SUBROUTINE qexmul_rch(IENS,JRCH,T0,T1,ixDesire, & ! input else ITIM(JUPS) = ITIM(JUPS) + 1 ! move on to the next flow element CTIME(JUPS) = USFLOW(JUPS)%KWAVE(ITIM(JUPS))%TR ! save the time - endif ! (check if particle is the last element) - endif ! (check if the particle is a routed element) - endif ! (check that there are still particles to process) + end if ! (check if particle is the last element) + end if ! (check if the particle is a routed element) + end if ! (check that there are still particles to process) ! if processed all particles in all upstream reaches, then EXIT IF (count(MFLG).EQ.NUPS) exit end do ! do-forever @@ -1208,13 +1209,13 @@ SUBROUTINE remove_rch(MAXQPAR,& ! input INEG=INDEX1(ISEL-2); IMID=INDEX1(ISEL-1); IPOS=INDEX1(ISEL+1) Q_INTP = INTERP(T(IMID),Q(INEG),Q(IPOS),T(INEG),T(IPOS)) ABSERR(IMID) = abs(Q_INTP-Q(IMID)) - endif + end if ! re-interpolate the point immediately after the point flagged for removal if (INDEX1(ISEL+1).LT.NPRT) then INEG=INDEX1(ISEL-1); IMID=INDEX1(ISEL+1); IPOS=INDEX1(ISEL+2) Q_INTP = INTERP(T(IMID),Q(INEG),Q(IPOS),T(INEG),T(IPOS)) ABSERR(IMID) = abs(Q_INTP-Q(IMID)) - endif + end if ! flag the point as "removed" PARFLG(INDEX1(ISEL)) = .false. ! de-allocate arrays @@ -1337,9 +1338,9 @@ SUBROUTINE kinwav_rch(JRCH,T_START,T_END,ixDesire, & ! input: loca type(RCHTOPO),intent(in), allocatable :: NETOPO_in(:) ! River Network topology type(RCHPRP), intent(in), allocatable :: RPARAM_in(:) ! River reach parameter ! Input/Output - REAL(dp), intent(inout) :: Q_JRCH(:)! flow to be routed - REAL(dp), intent(inout) :: TENTRY(:)! time to be routed - REAL(dp), intent(inout) :: T_EXIT(:)! time pts expected exit segment + real(dp), intent(inout) :: Q_JRCH(:)! flow to be routed + real(dp), intent(inout) :: TENTRY(:)! time to be routed + real(dp), intent(inout) :: T_EXIT(:)! time pts expected exit segment logical(lgt), intent(inout) :: FROUTE(:)! routing flag, T=routed ! Output integer(i4b), intent(out) :: NQ2 ! # particles (<= input b/c merge) @@ -1402,7 +1403,7 @@ SUBROUTINE kinwav_rch(JRCH,T_START,T_END,ixDesire, & ! input: loca ! Identify the number of points to route NN = size(Q1) ! modified when elements are merged NI = NN ! original size of the input - if(NN.EQ.0) return ! don't do anything if no points in the reach + if (NN.EQ.0) return ! don't do anything if no points in the reach ! Initialize the vector that indicates which output element the input elements are merged MF = arth(1,1,NI) ! Num. Rec. intrinsic: see MODULE nrutil.f90 @@ -1423,7 +1424,7 @@ SUBROUTINE kinwav_rch(JRCH,T_START,T_END,ixDesire, & ! input: loca end if ! handle breaking waves - GT_ONE: if(NN.GT.1) then ! no breaking if just one point + GT_ONE: if (NN.GT.1) then ! no breaking if just one point X = 0. ! altered later to describe "closest" shock GOTALL: do ! keep going until all shocks are merged XB = XMX ! initialized to length of the stream segment @@ -1432,12 +1433,12 @@ SUBROUTINE kinwav_rch(JRCH,T_START,T_END,ixDesire, & ! input: loca ! -------------------------------------------------------------------------------------- WCHECK: do IW=2,NN JW=IW-1 - if(WC(IW).EQ.0. .or. WC(JW).EQ.0.) cycle ! waves not moving + if (WC(IW).EQ.0. .or. WC(JW).EQ.0.) cycle ! waves not moving WDIFF = 1./WC(JW) - 1./WC(IW) ! difference in wave celerity - if(WDIFF.EQ.0.) cycle ! waves moving at the same speed - if(WC(IW).EQ.WC(JW)) cycle ! identical statement to the above? + if (WDIFF.EQ.0.) cycle ! waves moving at the same speed + if (WC(IW).EQ.WC(JW)) cycle ! identical statement to the above? XXB = (T1(IW)-T1(JW)) / WDIFF ! XXB is point of breaking in x direction - if(XXB.LT.X .or. XXB.GT.XB) cycle ! XB init at LENGTH, so > XB do in next reach + if (XXB.LT.X .or. XXB.GT.XB) cycle ! XB init at LENGTH, so > XB do in next reach ! if get to here, the wave is breaking XB = XXB ! identify break "closest to upstream" first IXB = IW @@ -1471,7 +1472,7 @@ SUBROUTINE kinwav_rch(JRCH,T_START,T_END,ixDesire, & ! input: loca X = XB ! -------------------------------------------------------------------------------------- end do GOTALL - endif GT_ONE + end if GT_ONE ! check if(jRch==ixDesire) then @@ -1508,21 +1509,21 @@ SUBROUTINE kinwav_rch(JRCH,T_START,T_END,ixDesire, & ! input: loca ierr=30; message=trim(message)//'TEXIT equals TEXIT2 in kinwav'; return end if ! fill output arrays - call RUPDATE(Q1(IROUTE),T1(IROUTE),TEXIT,ierr,cmessage) ! fill arrays w/ Q1, T1, + run checks + call rUpdate(Q1(IROUTE),T1(IROUTE),TEXIT,ierr,cmessage) ! fill arrays w/ Q1, T1, + run checks if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif - call RUPDATE(Q2(IROUTE),T1(IROUTE),TEXIT2,ierr,cmessage) ! fill arrays w/ Q2, T1, + run checks + call rUpdate(Q2(IROUTE),T1(IROUTE),TEXIT2,ierr,cmessage) ! fill arrays w/ Q2, T1, + run checks if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif else ! merged elements have not exited ! when a merged element does not exit, need to disaggregate into original particles do JROUTE=1,NI ! loop thru # original inputs if (MF(JROUTE).EQ.IROUTE) & - call RUPDATE(Q0(JROUTE),T0(JROUTE),TEXIT,ierr,cmessage) ! fill arrays w/ Q0, T0, + run checks + call rUpdate(Q0(JROUTE),T0(JROUTE),TEXIT,ierr,cmessage) ! fill arrays w/ Q0, T0, + run checks if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif end do ! JROUTE end if ! TEXIT ! now process un-merged particles else MERGED ! (i.e., not merged) - call RUPDATE(Q1(IROUTE),T1(IROUTE),TEXIT,ierr,cmessage) ! fill arrays w/ Q1, T1, + run checks + call rUpdate(Q1(IROUTE),T1(IROUTE),TEXIT,ierr,cmessage) ! fill arrays w/ Q1, T1, + run checks if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif end if MERGED end do @@ -1531,7 +1532,7 @@ SUBROUTINE kinwav_rch(JRCH,T_START,T_END,ixDesire, & ! input: loca CONTAINS - SUBROUTINE RUPDATE(QNEW,TOLD,TNEW,ierr,message) + SUBROUTINE rUpdate(QNEW,TOLD,TNEW,ierr,message) real(dp),intent(in) :: QNEW ! Q0,Q1, or Q2 real(dp),intent(in) :: TOLD,TNEW ! entry/exit times integer(i4b), intent(out) :: ierr ! error code @@ -1546,7 +1547,7 @@ SUBROUTINE RUPDATE(QNEW,TOLD,TNEW,ierr,message) ! check for array bounds exceeded if (ICOUNT.GT.size(Q_JRCH)) then ierr=60; message=trim(message)//'array bounds exceeded'; return - endif + end if ! fill output arrays Q_JRCH(ICOUNT) = QNEW ! flow (Q1 always smaller than Q2) TENTRY(ICOUNT) = TOLD ! time - note, T1 altered if element merged @@ -1559,7 +1560,7 @@ SUBROUTINE RUPDATE(QNEW,TOLD,TNEW,ierr,message) if (ICOUNT.EQ.1.and.T_EXIT(ICOUNT).LE.T_START) T_EXIT(ICOUNT)=T_START+1. ! update flag for routed elements if (T_EXIT(ICOUNT).LT.T_END) FROUTE(ICOUNT) =.true. - END SUBROUTINE RUPDATE + END SUBROUTINE rUpdate END SUBROUTINE kinwav_rch @@ -1671,7 +1672,7 @@ SUBROUTINE interp_rch(TOLD,QOLD,TNEW,QNEW,IERR,MESSAGE) ! check that the input time series starts before the first required output time ! and ends after the last required output time - if( (TOLD(1).GT.TNEW(1)) .OR. (TOLD(NOLD).LT.TNEW(NNEW)) ) then + if( (TOLD(1).GT.TNEW(1)) .or. (TOLD(NOLD).LT.TNEW(NNEW)) ) then IERR=1; message=trim(message)//'bad bounds'; return end if @@ -1724,7 +1725,7 @@ SUBROUTINE interp_rch(TOLD,QOLD,TNEW,QNEW,IERR,MESSAGE) SLOPE = (QOLD(IEND)-QOLD(IEND-1))/(TOLD(IEND)-TOLD(IEND-1)) QEST1 = SLOPE*(T1-TOLD(IEND-1)) + QOLD(IEND-1) AREAE = (T1-TOLD(IEND-1)) * 0.5*(QOLD(IEND-1) + QEST1) - endif + end if ! check if there are extra points to process if (IBEG.LT.IEND) then diff --git a/route/build/src/main_route.f90 b/route/build/src/main_route.f90 index ee8a3b25..1b351ca5 100644 --- a/route/build/src/main_route.f90 +++ b/route/build/src/main_route.f90 @@ -1,17 +1,17 @@ module main_route_module -! variable types -USE nrtype ! variable types, etc. - +USE nrtype ! variable types, etc. ! mapping HRU runoff to reach USE remapping, only : basin2reach ! subroutines: basin routing -USE basinUH_module, only : IRF_route_basin ! perform UH convolution for basin routing - +USE basinUH_module, only : IRF_route_basin ! perform UH convolution for basin routing ! subroutines: river routing -USE accum_runoff_module, only : accum_runoff ! upstream flow accumulation -USE kwt_route_module, only : kwt_route ! kinematic wave routing method +USE accum_runoff_module, only : accum_runoff ! upstream flow accumulation +USE kwt_route_module, only : kwt_route ! lagrangian kinematic wave routing method USE irf_route_module, only : irf_route ! unit hydrograph (impulse response function) routing method +USE dfw_route_module, only : dfw_route ! diffusive wave routing method +USE kw_route_module, only : kw_route ! kinematic wave routing method +USE mc_route_module, only : mc_route ! muskingum-cunge routing method implicit none @@ -28,27 +28,28 @@ subroutine main_route(iens, & ! input: ensemble index ierr, message) ! output: error control ! Details: ! Given HRU (basin) runoff, perform hru routing (optional) to get reach runoff, and then channel routing ! Restriction: - ! 1. Reach order in NETOPO, RPARAM, RCHFLX, KROUTE must be in the same orders + ! 1. Reach order in NETOPO, RPARAM, RCHFLX, RCHSTA must be in the same orders ! 2. Process a list of reach indices (in terms of NETOPO etc.) given by ixRchProcessed ! 3. basinRunoff_in is given in the order of NETOPO(:)%HRUIX. - ! shared data - USE public_var, only : routOpt - USE public_var, only : doesBasinRoute - USE public_var, only : doesAccumRunoff - USE public_var, only : allRoutingMethods - USE public_var, only : kinematicWave - USE public_var, only : impulseResponseFunc - USE globalData, only : TSEC ! beginning/ending of simulation time step [sec] - USE globalData, only : ixPrint ! desired reach index to be on-screen print - - USE globalData, only : NETOPO ! entire river reach netowrk topology structure - USE globalData, only : RPARAM ! entire river reach parameter structure - USE globalData, only : RCHFLX ! entire reach flux structure - USE globalData, only : KROUTE ! entire river reach kwt sate structure - USE globalData, only : runoff_data ! runoff data structure - USE globalData, only : river_basin ! OMP basin decomposition - USE globalData, only : nRch ! number of reaches in the whoel river network + USE public_var, ONLY: doesBasinRoute + USE public_var, ONLY: accumRunoff + USE public_var, ONLY: impulseResponseFunc + USE public_var, ONLY: kinematicWaveTracking + USE public_var, ONLY: kinematicWave + USE public_var, ONLY: muskingumCunge + USE public_var, ONLY: diffusiveWave + USE globalData, ONLY: onRoute ! logical to indicate which routing method(s) is on + USE globalData, ONLY: TSEC ! beginning/ending of simulation time step [sec] + USE globalData, ONLY: ixPrint ! desired reach index to be on-screen print + + USE globalData, ONLY: NETOPO ! entire river reach netowrk topology structure + USE globalData, ONLY: RPARAM ! entire river reach parameter structure + USE globalData, ONLY: RCHFLX ! entire reach flux structure + USE globalData, ONLY: RCHSTA ! entire river reach restart structure + USE globalData, ONLY: runoff_data ! runoff data structure + USE globalData, ONLY: river_basin ! OMP basin decomposition + USE globalData, ONLY: nRch ! number of reaches in the whoel river network implicit none @@ -111,23 +112,21 @@ subroutine main_route(iens, & ! input: ensemble index end if ! 3. subroutine: river reach routing - ! perform upstream flow accumulation - if (doesAccumRunoff == 1) then - call system_clock(startTime) - call accum_runoff(iens, & ! input: ensemble index - river_basin, & ! input: river basin data type - ixPrint, & ! input: index of verbose reach - NETOPO, & ! input: reach topology data structure - RCHFLX, & ! inout: reach flux data structure - ierr, cmessage) ! output: error controls - if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif - call system_clock(endTime) - elapsedTime = real(endTime-startTime, kind(dp))/real(cr) - write(*,"(A,1PG15.7,A)") ' elapsed-time [accum_runoff] = ', elapsedTime, ' s' - endif - - ! perform KWT routing - if (routOpt==allRoutingMethods .or. routOpt==kinematicWave) then + if (onRoute(accumRunoff)) then + call system_clock(startTime) + call accum_runoff(iens, & ! input: ensemble index + river_basin, & ! input: river basin data type + ixPrint, & ! input: index of verbose reach + NETOPO, & ! input: reach topology data structure + RCHFLX, & ! inout: reach flux data structure + ierr, cmessage) ! output: error controls + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + call system_clock(endTime) + elapsedTime = real(endTime-startTime, kind(dp))/real(cr) + write(*,"(A,1PG15.7,A)") ' elapsed-time [accum_runoff] = ', elapsedTime, ' s' + endif + + if (onRoute(kinematicWaveTracking)) then call system_clock(startTime) call kwt_route(iens, & ! input: ensemble index river_basin, & ! input: river basin data type @@ -135,17 +134,16 @@ subroutine main_route(iens, & ! input: ensemble index ixPrint, & ! input: index of the desired reach NETOPO, & ! input: reach topology data structure RPARAM, & ! input: reach parameter data structure - KROUTE, & ! inout: reach state data structure + RCHSTA, & ! inout: reach state data structure RCHFLX, & ! inout: reach flux data structure ierr,cmessage) ! output: error control if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif call system_clock(endTime) elapsedTime = real(endTime-startTime, kind(dp))/real(cr) write(*,"(A,1PG15.7,A)") ' elapsed-time [kwt_route] = ', elapsedTime, ' s' - endif + end if - ! perform IRF routing - if (routOpt==allRoutingMethods .or. routOpt==impulseResponseFunc) then + if (onRoute(impulseResponseFunc)) then call system_clock(startTime) call irf_route(iens, & ! input: ensemble index river_basin, & ! input: river basin data type @@ -158,9 +156,59 @@ subroutine main_route(iens, & ! input: ensemble index call system_clock(endTime) elapsedTime = real(endTime-startTime, kind(dp))/real(cr) write(*,"(A,1PG15.7,A)") ' elapsed-time [irf_route] = ', elapsedTime, ' s' - endif + endif - end subroutine main_route + if (onRoute(kinematicWave)) then + call system_clock(startTime) + call kw_route(iens, & ! input: ensemble index + river_basin, & ! input: river basin data type + T0,T1, & ! input: start and end of the time step + ixPrint, & ! input: index of the desired reach + NETOPO, & ! input: reach topology data structure + RPARAM, & ! input: reach parameter data structure + RCHSTA, & ! inout: reach state data structure + RCHFLX, & ! inout: reach flux data structure + ierr,cmessage) ! output: error control + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + call system_clock(endTime) + elapsedTime = real(endTime-startTime, kind(dp))/real(cr) + write(*,"(A,1PG15.7,A)") ' elapsed-time [kw_route] = ', elapsedTime, ' s' + endif + + if (onRoute(muskingumCunge)) then + call system_clock(startTime) + call mc_route(iens, & ! input: ensemble index + river_basin, & ! input: river basin data type + T0,T1, & ! input: start and end of the time step + ixPrint, & ! input: index of the desired reach + NETOPO, & ! input: reach topology data structure + RPARAM, & ! input: reach parameter data structure + RCHSTA, & ! inout: reach state data structure + RCHFLX, & ! inout: reach flux data structure + ierr,cmessage) ! output: error control + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + call system_clock(endTime) + elapsedTime = real(endTime-startTime, kind(dp))/real(cr) + write(*,"(A,1PG15.7,A)") ' elapsed-time [mc_route] = ', elapsedTime, ' s' + endif + if (onRoute(diffusiveWave)) then + call system_clock(startTime) + call dfw_route(iens, & ! input: ensemble index + river_basin, & ! input: river basin data type + T0,T1, & ! input: start and end of the time step + ixPrint, & ! input: index of the desired reach + NETOPO, & ! input: reach topology data structure + RPARAM, & ! input: reach parameter data structure + RCHSTA, & ! inout: reach state data structure + RCHFLX, & ! inout: reach flux data structure + ierr,cmessage) ! output: error control + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + call system_clock(endTime) + elapsedTime = real(endTime-startTime, kind(dp))/real(cr) + write(*,"(A,1PG15.7,A)") ' elapsed-time [dfw_route] = ', elapsedTime, ' s' + endif + + end subroutine main_route end module main_route_module diff --git a/route/build/src/mc_route.f90 b/route/build/src/mc_route.f90 new file mode 100644 index 00000000..6b1d82df --- /dev/null +++ b/route/build/src/mc_route.f90 @@ -0,0 +1,391 @@ +MODULE mc_route_module + +! muskingum-cunge routing + +USE nrtype +! data types +USE dataTypes, ONLY: STRFLX ! fluxes in each reach +USE dataTypes, ONLY: STRSTA ! state in each reach +USE dataTypes, ONLY: RCHTOPO ! Network topology +USE dataTypes, ONLY: RCHPRP ! Reach parameter +USE dataTypes, ONLY: mcRCH ! MC specific state data structure +USE dataTypes, ONLY: subbasin_omp ! mainstem+tributary data strucuture +! global data +USE public_var, ONLY: iulog ! i/o logical unit number +USE public_var, ONLY: realMissing ! missing value for real number +USE public_var, ONLY: integerMissing ! missing value for integer number +USE globalData, ONLY: idxMC ! index of IRF method +! subroutines: general +USE model_finalize, ONLY : handle_err + +! privary +implicit none +private + +public::mc_route + +contains + + ! ********************************************************************* + ! subroutine: perform muskingum-cunge routing through the river network + ! ********************************************************************* + SUBROUTINE mc_route(iens, & ! input: ensemble index + river_basin, & ! input: river basin information (mainstem, tributary outlet etc.) + T0,T1, & ! input: start and end of the time step + ixDesire, & ! input: reachID to be checked by on-screen pringing + NETOPO_in, & ! input: reach topology data structure + RPARAM_in, & ! input: reach parameter data structure + RCHSTA_out, & ! inout: reach state data structure + RCHFLX_out, & ! inout: reach flux data structure + ierr,message, & ! output: error control + ixSubRch) ! optional input: subset of reach indices to be processed + + implicit none + + ! Input + integer(i4b), intent(in) :: iEns ! ensemble member + type(subbasin_omp), intent(in), allocatable :: river_basin(:) ! river basin information (mainstem, tributary outlet etc.) + real(dp), intent(in) :: T0,T1 ! start and end of the time step (seconds) + integer(i4b), intent(in) :: ixDesire ! index of the reach for verbose output + type(RCHTOPO), intent(in), allocatable :: NETOPO_in(:) ! River Network topology + type(RCHPRP), intent(in), allocatable :: RPARAM_in(:) ! River reach parameter + ! inout + type(STRSTA), intent(inout), allocatable :: RCHSTA_out(:,:) ! reach state data + type(STRFLX), intent(inout), allocatable :: RCHFLX_out(:,:) ! Reach fluxes (ensembles, space [reaches]) for decomposed domains + ! output variables + integer(i4b), intent(out) :: ierr ! error code + character(*), intent(out) :: message ! error message + ! input (optional) + integer(i4b), intent(in), optional :: ixSubRch(:) ! subset of reach indices to be processed + ! local variables + character(len=strLen) :: cmessage ! error message for downwind routine + logical(lgt), allocatable :: doRoute(:) ! logical to indicate which reaches are processed + integer(i4b) :: LAKEFLAG=0 ! >0 if processing lakes + integer(i4b) :: nOrder ! number of stream order + integer(i4b) :: nTrib ! number of tributary basins + integer(i4b) :: nSeg ! number of reaches in the network + integer(i4b) :: iSeg, jSeg ! loop indices - reach + integer(i4b) :: iTrib ! loop indices - branch + integer(i4b) :: ix ! loop indices stream order + + ierr=0; message='mc_route/' + + ! number of reach check + if (size(NETOPO_in)/=size(RCHFLX_out(iens,:))) then + ierr=20; message=trim(message)//'sizes of NETOPO and RCHFLX mismatch'; return + endif + + nSeg = size(NETOPO_in) + + allocate(doRoute(nSeg), stat=ierr) + + if (present(ixSubRch))then + doRoute(:)=.false. + doRoute(ixSubRch) = .true. ! only subset of reaches are on + else + doRoute(:)=.true. ! every reach is on + endif + + nOrder = size(river_basin) + + do ix = 1, nOrder + + nTrib=size(river_basin(ix)%branch) + +!$OMP PARALLEL DO schedule(dynamic,1) & ! chunk size of 1 +!$OMP private(jSeg, iSeg) & ! private for a given thread +!$OMP private(ierr, cmessage) & ! private for a given thread +!$OMP shared(T0,T1) & ! private for a given thread +!$OMP shared(LAKEFLAG) & ! private for a given thread +!$OMP shared(river_basin) & ! data structure shared +!$OMP shared(doRoute) & ! data array shared +!$OMP shared(NETOPO_in) & ! data structure shared +!$OMP shared(RPARAM_in) & ! data structure shared +!$OMP shared(RCHSTA_out) & ! data structure shared +!$OMP shared(RCHFLX_out) & ! data structure shared +!$OMP shared(ix, iEns, ixDesire) & ! indices shared +!$OMP firstprivate(nTrib) + trib:do iTrib = 1,nTrib + seg:do iSeg=1,river_basin(ix)%branch(iTrib)%nRch + jSeg = river_basin(ix)%branch(iTrib)%segIndex(iSeg) + if (.not. doRoute(jSeg)) cycle + call mc_rch(iEns,jSeg, & ! input: array indices + ixDesire, & ! input: index of the desired reach + T0,T1, & ! input: start and end of the time step + LAKEFLAG, & ! input: flag if lakes are to be processed + NETOPO_in, & ! input: reach topology data structure + RPARAM_in, & ! input: reach parameter data structure + RCHSTA_out, & ! inout: reach state data structure + RCHFLX_out, & ! inout: reach flux data structure + ierr,cmessage) ! output: error control + if(ierr/=0) call handle_err(ierr, trim(message)//trim(cmessage)) + end do seg + end do trib +!$OMP END PARALLEL DO + + end do + + END SUBROUTINE mc_route + + ! ********************************************************************* + ! subroutine: perform muskingum-cunge routing for one segment + ! ********************************************************************* + SUBROUTINE mc_rch(iEns, segIndex, & ! input: index of runoff ensemble to be processed + ixDesire, & ! input: reachID to be checked by on-screen pringing + T0,T1, & ! input: start and end of the time step + LAKEFLAG, & ! input: flag if lakes are to be processed + NETOPO_in, & ! input: reach topology data structure + RPARAM_in, & ! input: reach parameter data structure + RCHSTA_out, & ! inout: reach state data structure + RCHFLX_out, & ! inout: reach flux data structure + ierr, message) ! output: error control + + implicit none + + ! Input + integer(i4b), intent(in) :: iEns ! runoff ensemble to be routed + integer(i4b), intent(in) :: segIndex ! segment where routing is performed + integer(i4b), intent(in) :: ixDesire ! index of the reach for verbose output + real(dp), intent(in) :: T0,T1 ! start and end of the time step (seconds) + integer(i4b), intent(in) :: LAKEFLAG ! >0 if processing lakes + type(RCHTOPO), intent(in), allocatable :: NETOPO_in(:) ! River Network topology + type(RCHPRP), intent(in), allocatable :: RPARAM_in(:) ! River reach parameter + ! inout + type(STRSTA), intent(inout), allocatable :: RCHSTA_out(:,:) ! reach state data + type(STRFLX), intent(inout), allocatable :: RCHFLX_out(:,:) ! Reach fluxes (ensembles, space [reaches]) for decomposed domains + ! Output + integer(i4b), intent(out) :: ierr ! error code + character(*), intent(out) :: message ! error message + ! Local variables to + logical(lgt) :: doCheck ! check details of variables + logical(lgt) :: isHW ! headwater basin? + integer(i4b) :: nUps ! number of upstream segment + integer(i4b) :: iUps ! upstream reach index + integer(i4b) :: iRch_ups ! index of upstream reach in NETOPO + real(dp) :: q_upstream ! total discharge at top of the reach being processed + character(len=strLen) :: cmessage ! error message from subroutine + + ierr=0; message='mc_rch/' + + doCheck = .false. + if(NETOPO_in(segIndex)%REACHIX == ixDesire)then + doCheck = .true. + end if + + ! get discharge coming from upstream + nUps = size(NETOPO_in(segIndex)%UREACHI) + isHW = .true. + q_upstream = 0.0_dp + if (nUps>0) then + isHW = .false. + do iUps = 1,nUps + iRch_ups = NETOPO_in(segIndex)%UREACHI(iUps) ! index of upstream of segIndex-th reach + q_upstream = q_upstream + RCHFLX_out(iens, iRch_ups)%ROUTE(idxMC)%REACH_Q + end do + endif + + if(doCheck)then + write(iulog,'(A)') 'CHECK muskingum-cunge routing' + if (nUps>0) then + do iUps = 1,nUps + iRch_ups = NETOPO_in(segIndex)%UREACHI(iUps) ! index of upstream of segIndex-th reach + write(iulog,'(A,X,I6,X,G12.5)') ' UREACHK, uprflux=',NETOPO_in(segIndex)%UREACHK(iUps),RCHFLX_out(iens, iRch_ups)%ROUTE(idxMC)%REACH_Q + enddo + end if + write(iulog,'(A,X,G12.5)') ' RCHFLX_out(iEns,segIndex)%BASIN_QR(1)=',RCHFLX_out(iEns,segIndex)%BASIN_QR(1) + endif + + ! solve muskingum-cunge alogorithm + call muskingum_cunge(RPARAM_in(segIndex), & ! input: parameter at segIndex reach + T0,T1, & ! input: start and end of the time step + q_upstream, & ! input: total discharge at top of the reach being processed + isHW, & ! input: is this headwater basin? + RCHSTA_out(iens,segIndex)%MC_ROUTE, & ! inout: + RCHFLX_out(iens,segIndex), & ! inout: updated fluxes at reach + doCheck, & ! input: reach index to be examined + ierr, cmessage) ! output: error control + if(ierr/=0)then + write(message, '(A,X,I10,X,A)') trim(message)//'/segment=', NETOPO_in(segIndex)%REACHID, '/'//trim(cmessage) + return + endif + + if(doCheck)then + write(iulog,'(A,X,G12.5)') ' RCHFLX_out(iens,segIndex)%REACH_Q=', RCHFLX_out(iens,segIndex)%ROUTE(idxMC)%REACH_Q + endif + + END SUBROUTINE mc_rch + + + ! ********************************************************************* + ! subroutine: solve muskingum equation + ! ********************************************************************* + SUBROUTINE muskingum_cunge(rch_param, & ! input: river parameter data structure + T0,T1, & ! input: start and end of the time step + q_upstream, & ! input: discharge from upstream + isHW, & ! input: is this headwater basin? + rstate, & ! inout: reach state at a reach + rflux, & ! inout: reach flux at a reach + doCheck, & ! input: reach index to be examined + ierr,message) + ! ---------------------------------------------------------------------------------------- + ! Perform muskingum-cunge routing + ! + ! + ! + ! + ! * + ! * + ! * + ! + ! state array: + ! (time:0:1, loc:0:1) 0-previous time step/inlet, 1-current time step/outlet. + ! Q or A(1,2,3,4): 1: (t=0,x=0), 2: (t=0,x=1), 3: (t=1,x=0), 4: (t=1,x=1) + + IMPLICIT NONE + ! Input + type(RCHPRP), intent(in) :: rch_param ! River reach parameter + real(dp), intent(in) :: T0,T1 ! start and end of the time step (seconds) + real(dp), intent(in) :: q_upstream ! total discharge at top of the reach being processed + logical(lgt), intent(in) :: isHW ! is this headwater basin? + logical(lgt), intent(in) :: doCheck ! reach index to be examined + ! Input/Output + type(mcRCH), intent(inout) :: rstate ! curent reach states + type(STRFLX), intent(inout) :: rflux ! current Reach fluxes + ! Output + integer(i4b), intent(out) :: ierr ! error code + character(*), intent(out) :: message ! error message + ! LOCAL VAIRABLES + real(dp) :: alpha ! sqrt(slope)(/mannings N* width) + real(dp) :: beta ! constant, 5/3 + real(dp) :: theta ! dT/dX + real(dp) :: X ! X-factor in descreterized kinematic wave + real(dp) :: dt ! interval of time step [sec] + real(dp) :: dx ! length of segment [m] + real(dp) :: Q(0:1,0:1) ! discharge at computational molecule + real(dp) :: Qbar ! 3-point average discharge [m3/s] + real(dp) :: Abar ! 3-point average flow area [m2] + real(dp) :: Vbar ! 3-point average velocity [m/s] + real(dp) :: Ybar ! 3-point average flow depth [m] + real(dp) :: B ! flow top width [m] + real(dp) :: ck ! kinematic wave celerity [m/s] + real(dp) :: Cn ! Courant number [-] + real(dp) :: dTsub ! time inteval for sut time-step [sec] + real(dp) :: C0,C1,C2 ! muskingum parameters + real(dp), allocatable :: QoutLocal(:) ! out discharge [m3/s] at sub time step + real(dp), allocatable :: QinLocal(:) ! in discharge [m3/s] at sub time step + integer(i4b) :: ix ! loop index + integer(i4b) :: ntSub ! number of sub time-step + character(len=strLen) :: cmessage ! error message from subroutine + real(dp), parameter :: Y = 0.5 ! muskingum parameter Y (this is fixed) + + ierr=0; message='muskingum-cunge/' + + Q(0,0) = rstate%molecule%Q(1) ! inflow at previous time step (t-1) + Q(0,1) = rstate%molecule%Q(2) ! outflow at previous time step (t-1) + Q(1,1) = realMissing + + if (.not. isHW) then + + ! Get the reach parameters + ! A = (Q/alpha)**(1/beta) + ! Q = alpha*A**beta + alpha = sqrt(rch_param%R_SLOPE)/(rch_param%R_MAN_N*rch_param%R_WIDTH**(2._dp/3._dp)) + beta = 5._dp/3._dp + dx = rch_param%RLENGTH + dt = T1-T0 + theta = dt/dx ! [s/m] + + ! compute total flow rate and flow area at upstream end at current time step + Q(1,0) = q_upstream + + if (doCheck) then + write(iulog,'(4(A,X,G12.5))') ' length [m] =',rch_param%RLENGTH,'slope [-] =',rch_param%R_SLOPE,'channel width [m] =',rch_param%R_WIDTH,'manning coef =',rch_param%R_MAN_N + write(iulog,'(3(A,X,G12.5))') ' Qin(t-1) Q(0,0)=',Q(0,0),' Qin(t) Q(0,1)=',Q(0,1),' Qout(t-1) Q(1,0)=',Q(1,0) + end if + + ! first, using 3-point average in computational molecule, check Cournat number is less than 1, otherwise subcycle within one time step + Qbar = (Q(0,0)+Q(1,0)+Q(0,1))/3.0 ! average discharge [m3/s] + Abar = (Qbar/alpha)**(1/beta) ! average flow area [m2] (from manning equation) + Vbar = Qbar/Abar ! average velocity [m/s] + ck = beta*Vbar ! kinematic wave celerity [m/s] + Cn = ck*theta ! Courant number [-] + + ! time-step adjustment so Courant number is less than 1 + ntSub = 1 + dTsub = dt + if (Cn>1.0_dp) then + ntSub = ceiling(dt/dx*cK) + dTsub = dt/ntSub + end if + if (doCheck) then + write(iulog,'(A,X,I3,A,X,G12.5)') ' No. sub timestep=',nTsub,' sub time-step [sec]=',dTsub + end if + + allocate(QoutLocal(0:ntSub), QinLocal(0:ntSub), stat=ierr, errmsg=cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + QoutLocal(:) = realMissing + QoutLocal(0) = Q(0,1) ! outfloe last time step + QinLocal(0) = Q(0,0) ! inflow at last time step + QinLocal(1:ntSub) = Q(1,0) ! infllow at sub-time step in current time step + + ! solve outflow at each sub time step + do ix = 1, nTsub + + Qbar = (QinLocal(ix)+QinLocal(ix-1)+QoutLocal(ix-1))/3.0 ! 3 point average discharge [m3/s] + Abar = (Qbar/alpha)**(1/beta) ! flow area [m2] (manning equation) + Ybar = Abar/rch_param%R_WIDTH ! flow depth [m] (rectangular channel) + B = rch_param%R_WIDTH ! top width at water level [m] (rectangular channel) + ck = beta*(Qbar/Abar) ! kinematic wave celerity [m/s] + + X = 0.5*(1.0 - Qbar/(B*rch_param%R_SLOPE*ck*dX)) ! X factor for descreterized kinematic wave equation + Cn = ck*dTsub/dx ! Courant number [-] + + C0 = (-X+Cn*(1-Y))/(1-X+Cn*(1-Y)) + C1 = (X+Cn*Y)/(1-X+Cn*(1-Y)) + C2 = (1-X-Cn*Y)/(1-X+Cn*(1-Y)) + + QoutLocal(ix) = C0* QinLocal(ix)+ C1* QinLocal(ix-1)+ C2* QoutLocal(ix-1) + QoutLocal(ix) = max(0.0, QoutLocal(ix)) + + if (isnan(QoutLocal(ix))) then + ierr=10; message=trim(message)//'QoutLocal is Nan; activate vodose for this segment for diagnosis';return + end if + + if (doCheck) then + write(iulog,'(A,I3,X,A,G12.5,X,A,G12.5)') ' sub time-step= ',ix,'Courant number= ',Cn, 'Q= ',QoutLocal(ix) + end if + end do + + Q(1,1) = sum(QoutLocal(1:nTsub))/real(nTsub,kind=dp) + + else ! if head-water + + Q(1,0) = 0._dp + Q(1,1) = 0._dp + + if (doCheck) then + write(iulog,'(A)') ' This is headwater ' + endif + + endif + + ! compute volume + rflux%ROUTE(idxMC)%REACH_VOL(0) = rflux%ROUTE(idxMC)%REACH_VOL(1) + rflux%ROUTE(idxMC)%REACH_VOL(1) = rflux%ROUTE(idxMC)%REACH_VOL(0) + (Q(1,0)-Q(1,1))*dT + rflux%ROUTE(idxMC)%REACH_VOL(1) = max(rflux%ROUTE(idxMC)%REACH_VOL(1), 0._dp) + + ! add catchment flow + rflux%ROUTE(idxMC)%REACH_Q = Q(1,1)+rflux%BASIN_QR(1) + + if (doCheck) then + write(iulog,'(A,X,G12.5)') ' Qout(t)=',Q(1,1) + endif + + ! save inflow (index 1) and outflow (index 2) at current time step + rstate%molecule%Q(1) = Q(1,0) + rstate%molecule%Q(2) = Q(1,1) + + END SUBROUTINE muskingum_cunge + + +END MODULE mc_route_module diff --git a/route/build/src/model_setup.f90 b/route/build/src/model_setup.f90 index c8f5a4fc..8f4c5e04 100644 --- a/route/build/src/model_setup.f90 +++ b/route/build/src/model_setup.f90 @@ -93,10 +93,11 @@ subroutine init_data(ierr, message) USE var_lookup, ONLY : ixHRU2SEG ! index of variables for data structure USE var_lookup, ONLY : ixNTOPO ! index of variables for data structure USE globalData, ONLY : RCHFLX ! Reach flux data structures (entire river network) - USE globalData, ONLY : KROUTE ! Reach k-wave data structures (entire river network) + USE globalData, ONLY : RCHSTA ! Reach state structures (entire river network) USE globalData, ONLY : nHRU, nRch ! number of HRUs and Reaches in the whole network USE globalData, ONLY : nEns ! number of ensembles + USE globalData, ONLY : nRoutes ! number of active routing methods USE globalData, ONLY : basinID ! HRU id vector USE globalData, ONLY : reachID ! reach ID vector USE globalData, ONLY : ixPrint ! reach index to be examined by on-screen printing @@ -134,8 +135,12 @@ subroutine init_data(ierr, message) if (ntopAugmentMode .or. idSegOut>0) stop ! allocate space for the entire river network - allocate(RCHFLX(nEns,nRch), KROUTE(nEns,nRch), stat=ierr) - if(ierr/=0)then; message=trim(message)//'problem allocating [RCHFLX, KROUTE]'; return; endif + allocate(RCHFLX(nEns,nRch), RCHSTA(nEns,nRch), stat=ierr) + if(ierr/=0)then; message=trim(message)//'problem allocating [RCHFLX, RCHSTA]'; return; endif + + do iRch = 1,nRch + allocate(RCHFLX(nEns,iRch)%ROUTE(nRoutes)) + end do ! populate basiID and reachID vectors for output (in ONLY master processor) ! populate runoff data structure (only meta, no runoff values) @@ -223,16 +228,25 @@ END SUBROUTINE update_time ! ********************************************************************* ! private subroutine: initialize channel state data ! ********************************************************************* - subroutine init_state(ierr, message) + SUBROUTINE init_state(ierr, message) ! subroutines - USE read_restart, ONLY : read_state_nc ! read netcdf state output file + USE ascii_util_module, ONLY : lower ! convert string to lower case + USE read_restart, ONLY : read_state_nc ! read netcdf state output file ! global data - USE public_var, ONLY : dt ! simulation time step (seconds) - USE public_var, ONLY : routOpt ! routing scheme options 0-> both, 1->IRF, 2->KWT, otherwise error - USE public_var, ONLY : fname_state_in ! name of state input file - USE public_var, ONLY : restart_dir ! directory containing output data - USE globalData, ONLY : RCHFLX ! reach flux structure - USE globalData, ONLY : TSEC ! begining/ending of simulation time step [sec] + USE public_var, ONLY : dt ! simulation time step (seconds) + USE public_var, ONLY : impulseResponseFunc ! IRF routing ID = 1 + USE public_var, ONLY : kinematicWaveTracking ! KWT routing ID = 2 + USE public_var, ONLY : kinematicWave ! KW routing ID = 3 + USE public_var, ONLY : muskingumCunge ! MC routing ID = 4 + USE public_var, ONLY : diffusiveWave ! DW routing ID = 5 + USE public_var, ONLY : fname_state_in ! name of state input file + USE public_var, ONLY : restart_dir ! directory containing output data + USE globalData, ONLY : nRoutes ! + USE globalData, ONLY : routeMethods ! ID of active routing method + USE globalData, ONLY : RCHFLX ! reach flux structure + USE globalData, ONLY : RCHSTA ! reach restart state structure + USE globalData, ONLY : nMolecule ! computational molecule + USE globalData, ONLY : TSEC ! begining/ending of simulation time step [sec] implicit none @@ -241,32 +255,65 @@ subroutine init_state(ierr, message) character(*), intent(out) :: message ! error message ! local variable real(dp) :: T0,T1 ! begining/ending of simulation time step [sec] + integer(i4b) :: iens ! ensemble index (currently only 1) + integer(i4b) :: ix,iRoute ! loop index character(len=strLen) :: cmessage ! error message of downwind routine - ! initialize error control ierr=0; message='init_state/' - ! read restart file and initialize states - if (trim(fname_state_in)/=charMissing) then - - call read_state_nc(trim(restart_dir)//trim(fname_state_in), routOpt, T0, T1, ierr, cmessage) - if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + iens = 1_i4b - TSEC(0)=T0; TSEC(1)=T1 + ! read restart file and initialize states + if (trim(fname_state_in)==charMissing .or. lower(trim(fname_state_in))=='none' .or. lower(trim(fname_state_in))=='coldstart') then + ! Cold start ....... + ! initialize flux structures + RCHFLX(:,:)%BASIN_QI = 0._dp + RCHFLX(:,:)%BASIN_QR(0) = 0._dp + RCHFLX(:,:)%BASIN_QR(1) = 0._dp + + do iRoute = 1, nRoutes + if (routeMethods(iRoute)==impulseResponseFunc) then + do ix = 1, size(RCHSTA(1,:)) + RCHFLX(iens,ix)%ROUTE(iRoute)%REACH_VOL(0:1) = 0._dp + end do + else if (routeMethods(iRoute)==kinematicWaveTracking) then + do ix = 1, size(RCHSTA(1,:)) + RCHFLX(iens,ix)%ROUTE(iRoute)%REACH_VOL(0:1) = 0._dp + end do + else if (routeMethods(iRoute)==kinematicWave) then + nMolecule%KW_ROUTE = 2 + do ix = 1, size(RCHSTA(1,:)) + RCHFLX(iens,ix)%ROUTE(iRoute)%REACH_VOL(0:1) = 0._dp + allocate(RCHSTA(iens,ix)%KW_ROUTE%molecule%Q(nMolecule%KW_ROUTE), stat=ierr, errmsg=cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage)//' [RCHSTA]'; return; endif + RCHSTA(iens,ix)%KW_ROUTE%molecule%Q(:) = 0._dp + end do + else if (routeMethods(iRoute)==muskingumCunge) then + nMolecule%MC_ROUTE = 2 + do ix = 1, size(RCHSTA(1,:)) + RCHFLX(iens,ix)%ROUTE(iRoute)%REACH_VOL(0:1) = 0._dp + allocate(RCHSTA(iens,ix)%MC_ROUTE%molecule%Q(nMolecule%MC_ROUTE), stat=ierr, errmsg=cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage)//' [RCHSTA]'; return; endif + RCHSTA(iens,ix)%MC_ROUTE%molecule%Q(:) = 0._dp + end do + else if (routeMethods(iRoute)==diffusiveWave) then + nMolecule%DW_ROUTE = 5 + do ix = 1, size(RCHSTA(1,:)) + RCHFLX(iens,ix)%ROUTE(iRoute)%REACH_VOL(0:1) = 0._dp + allocate(RCHSTA(iens,ix)%DW_ROUTE%molecule%Q(nMolecule%DW_ROUTE), stat=ierr, errmsg=cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage)//' [RCHSTA]'; return; endif + RCHSTA(iens,ix)%DW_ROUTE%molecule%Q(:) = 0._dp + end do + end if + end do + ! initialize time + TSEC(0)=0._dp; TSEC(1)=dt else + call read_state_nc(trim(restart_dir)//trim(fname_state_in), T0, T1, ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif - ! Cold start ....... - ! initialize flux structures - RCHFLX(:,:)%BASIN_QI = 0._dp - RCHFLX(:,:)%BASIN_QR(0) = 0._dp - RCHFLX(:,:)%BASIN_QR(1) = 0._dp - RCHFLX(:,:)%REACH_VOL(0) = 0._dp - RCHFLX(:,:)%REACH_VOL(1) = 0._dp - - ! initialize time - TSEC(0)=0._dp; TSEC(1)=dt - + TSEC(0)=T0; TSEC(1)=T1 endif END SUBROUTINE init_state @@ -278,6 +325,7 @@ SUBROUTINE init_time(nTime, & ! input: number of time steps ierr, message) ! output ! subroutines: + USE ascii_util_module, ONLY : lower ! convert string to lower case USE io_netcdf, ONLY : open_nc ! netcdf input USE io_netcdf, ONLY : close_nc ! netcdf input USE io_netcdf, ONLY : get_nc ! netcdf input @@ -413,21 +461,21 @@ SUBROUTINE init_time(nTime, & ! input: number of time steps ! "Annual" option: if user input day exceed number of days given user input month, set to last day ! "Monthly" option: use 2000-01 as template calendar yr/month ! "Daily" option: use 2000-01-01 as template calendar yr/month/day - select case(trim(restart_write)) - case('Annual','annual') + select case(lower(trim(restart_write))) + case('yearly') call dummyCal%set_datetime(2000, restart_month, 1, 0, 0, 0.0_dp) nDays = dummyCal%ndays_month(calendar, ierr, cmessage) if(ierr/=0) then; message=trim(message)//trim(cmessage); return; endif if (restart_day > nDays) restart_day=nDays - case('Monthly','monthly'); restart_month = 1 - case('Daily','daily'); restart_month = 1; restart_day = 1 + case('monthly'); restart_month = 1 + case('daily'); restart_month = 1; restart_day = 1 end select - select case(trim(restart_write)) - case('last','Last') + select case(lower(trim(restart_write))) + case('last') dropCal = endCal restart_month = dropCal%month(); restart_day = dropCal%day(); restart_hour = dropCal%hour() - case('specified','Specified') + case('specified') if (trim(restart_date) == charMissing) then ierr=20; message=trim(message)//' must be provided when option is "specified"'; return end if @@ -436,15 +484,15 @@ SUBROUTINE init_time(nTime, & ! input: number of time steps dropCal = restCal%add_sec(-dt, calendar, ierr, cmessage) if(ierr/=0) then; message=trim(message)//trim(cmessage)//' [restCal->dropCal]'; return; endif restart_month = dropCal%month(); restart_day = dropCal%day(); restart_hour = dropCal%hour() - case('Annual','Monthly','Daily','annual','monthly','daily') + case('yearly','monthly','daily') call restCal%set_datetime(2000, restart_month, restart_day, restart_hour, 0, 0._dp) dropCal = restCal%add_sec(-dt, calendar, ierr, cmessage) if(ierr/=0) then; message=trim(message)//trim(cmessage)//' [ dropCal for periodical restart]'; return; endif restart_month = dropCal%month(); restart_day = dropCal%day(); restart_hour = dropCal%hour() - case('never','Never') + case('never') call dropCal%set_datetime(integerMissing, integerMissing, integerMissing, integerMissing, integerMissing, realMissing) case default - ierr=20; message=trim(message)//'Current accepted options: L[l]ast, N[n]ever, S[s]pecified, A[a]nnual, M[m]onthly, D[d]aily'; return + ierr=20; message=trim(message)//'Current accepted options: last, never, specified, yearly, monthly, daily'; return end select END SUBROUTINE init_time diff --git a/route/build/src/nr_utility.f90 b/route/build/src/nr_utility.f90 index 5f4987bc..387cc4b1 100644 --- a/route/build/src/nr_utility.f90 +++ b/route/build/src/nr_utility.f90 @@ -1,34 +1,45 @@ -module nr_utility_module -USE nrtype +MODULE nr_utility_module ! contains functions that should really be part of the fortran standard, but are not + +USE nrtype + implicit none -INTERFACE arth - MODULE PROCEDURE arth_r, arth_d, arth_i4b, arth_i8b -END INTERFACE + +interface arth + MODULE PROCEDURE arth_r, arth_d, arth_i4b, arth_i8b +end interface interface indexx -module procedure indexx_i4b -module procedure indexx_i8b + module procedure indexx_i4b + module procedure indexx_i8b end interface interface swap -module procedure swap_i4b -module procedure swap_i8b + module procedure swap_i4b + module procedure swap_i8b end interface interface unique -module procedure unique_i4b -module procedure unique_i8b + module procedure unique_i4b + module procedure unique_i8b end interface -! (everything private unless otherwise specifed) +INTERFACE char2int + module procedure :: char2int_1d + module procedure :: char2int_2d +END INTERFACE + private public::arth public::indexx public::findIndex +public::match_index public::indexTrue public::unique -contains +public::get_digits +public::char2int + +CONTAINS ! ************************************************************************************************* ! * the arth function, used to build a vector of regularly spaced numbers @@ -264,102 +275,93 @@ SUBROUTINE swap_i8b(a,b) END SUBROUTINE swap_i8b ! ************************************************************************************************ - ! * findIndex: find the first index within a vector + ! findIndex: find the first index within a vector ! ************************************************************************************************ function findIndex(vector,desiredValue,missingValue) - ! finds the first index within a vector - ! -- if the index does not exist, returns zero - ! NOTE: workaround for (not-yet-implemented) f2008 intrinsic findloc - implicit none - ! dummy variables - integer(i4b),intent(in) :: vector(:) ! vector to search - integer(i4b),intent(in) :: desiredValue ! desired value in the vector - integer(i4b),intent(in),optional :: missingValue ! desired missing value if desiredValue is not found - integer(i4b) :: findIndex ! first index of the desired value in the vector - ! local variables - integer(i4b),dimension(1) :: vecIndex ! first index of the desired value in the vector (vec of length=1) - - ! check if the value exisits - if(any(vector==desiredValue))then - - ! get the index: merge provides a vector with 1s where mask is true and 0s otherwise, so maxloc(merge) is the first index of value=1 - ! NOTE: workaround for (not-yet-implemented) f2008 intrinsic findloc - vecIndex=maxloc( merge(1, 0, vector==desiredValue) ) - - ! value does not exist - else - if(present(missingValue))then - vecIndex=missingValue - else - vecIndex=0 - endif - endif - - ! return function value (extract into a scalar) - findIndex=vecIndex(1) + ! NOTE: if the index does not exist, returns zero + ! workaround for (not-yet-implemented) f2008 intrinsic findloc + implicit none + ! argument variables + integer(i4b),intent(in) :: vector(:) ! vector to search + integer(i4b),intent(in) :: desiredValue ! desired value in the vector + integer(i4b),intent(in),optional :: missingValue ! desired missing value if desiredValue is not found + integer(i4b) :: findIndex ! first index of the desired value in the vector + ! local variables + integer(i4b),dimension(1) :: vecIndex ! first index of the desired value in the vector (vec of length=1) + ! check if the value exisits + if(any(vector==desiredValue))then + ! get the index: merge provides a vector with 1s where mask is true and 0s otherwise, so maxloc(merge) is the first index of value=1 + vecIndex=maxloc( merge(1, 0, vector==desiredValue) ) + else + if(present(missingValue))then + vecIndex=missingValue + else + vecIndex=0 + endif + endif + findIndex=vecIndex(1) end function findIndex + ! ************************************************************************************************* + ! Return indices of True in TF array + ! ************************************************************************************************* subroutine indexTrue(TF,pos) - ! Return indices of True in TF array - implicit none - ! Inlet variables - logical(lgt),intent(in) :: TF(:) ! Logical vector (True or False) - ! Outlet variables - integer(i4b), allocatable, intent(out) :: pos(:) ! position of "true" conditions - ! Local variable - integer(i4b) :: npos ! number of "true" conditions - integer(i4b) :: idx(size(TF)) ! vector of all positions - - idx = arth(1,1,size(TF)) ! Enumerate all positions - npos = count(TF) ! Count the elements of TF that are .True. - allocate(pos(npos)) - pos = pack(idx,TF) ! With Pack function, verify position of true conditions + implicit none + ! argument variables + logical(lgt),intent(in) :: TF(:) ! Logical vector (True or False) + integer(i4b), allocatable, intent(out) :: pos(:) ! position of "true" conditions + ! Local variables + integer(i4b) :: npos ! number of "true" conditions + integer(i4b) :: idx(size(TF)) ! vector of all positions + idx = arth(1,1,size(TF)) ! Enumerate all positions + npos = count(TF) ! Count the elements of TF that are .True. + allocate(pos(npos)) + pos = pack(idx,TF) ! With Pack function, verify position of true conditions end subroutine indexTrue + ! ************************************************************************************************* + ! Find unique elements and indices given array + ! ************************************************************************************************* SUBROUTINE unique_i4b(array, unq, idx) - implicit none - ! Input variables - integer(i4b), intent(in) :: array(:) ! integer array including duplicated elements - ! outpu variables - integer(i4b),allocatable,intent(out) :: unq(:) ! integer array including unique elements - integer(i4b),allocatable,intent(out) :: idx(:) ! integer array including unique element index - ! local - integer(i4b) :: ranked(size(array)) ! - integer(i4b) :: unq_tmp(size(array)) ! - logical(lgt) :: flg_tmp(size(array)) ! - integer(i4b) :: ix ! loop index, counter - integer(i4b) :: last_unique ! last unique element - - flg_tmp = .false. - call indexx(array, ranked) - - unq_tmp(ranked(1)) = array(ranked(1)) - flg_tmp(ranked(1)) = .true. - last_unique = array(ranked(1)) - do ix = 2,size(ranked) - if (last_unique==array(ranked(ix))) cycle - flg_tmp(ranked(ix)) = .true. - unq_tmp(ranked(ix)) = array(ranked(ix)) - last_unique = array(ranked(ix)) - end do + implicit none + ! argument variables + integer(i4b), intent(in) :: array(:) ! integer array including duplicated elements + integer(i4b),allocatable,intent(out) :: unq(:) ! integer array including unique elements + integer(i4b),allocatable,intent(out) :: idx(:) ! integer array including unique element index + ! local variables + integer(i4b) :: ranked(size(array)) ! + integer(i4b) :: unq_tmp(size(array)) ! + logical(lgt) :: flg_tmp(size(array)) ! + integer(i4b) :: ix ! loop index, counter + integer(i4b) :: last_unique ! last unique element - allocate(unq(count(flg_tmp)),idx(count(flg_tmp))) + flg_tmp = .false. + call indexx(array, ranked) - idx = pack(arth(1,1,size(array)), flg_tmp) - unq = unq_tmp(idx) + unq_tmp(ranked(1)) = array(ranked(1)) + flg_tmp(ranked(1)) = .true. + last_unique = array(ranked(1)) + do ix = 2,size(ranked) + if (last_unique==array(ranked(ix))) cycle + flg_tmp(ranked(ix)) = .true. + unq_tmp(ranked(ix)) = array(ranked(ix)) + last_unique = array(ranked(ix)) + end do + allocate(unq(count(flg_tmp)),idx(count(flg_tmp))) + idx = pack(arth(1,1,size(array)), flg_tmp) + unq = unq_tmp(idx) END SUBROUTINE unique_i4b - + ! ------------------------------------------------------------------------------------------------ SUBROUTINE unique_i8b(array, unq, idx) implicit none - ! Input variables + ! argument variables integer(i8b), intent(in) :: array(:) ! integer array including duplicated elements - ! outpu variables integer(i8b),allocatable,intent(out) :: unq(:) ! integer array including unique elements integer(i4b),allocatable,intent(out) :: idx(:) ! integer array including unique element index - ! local + ! local variables integer(i4b) :: ranked(size(array)) ! integer(i8b) :: unq_tmp(size(array)) ! logical(lgt) :: flg_tmp(size(array)) ! @@ -386,4 +388,144 @@ SUBROUTINE unique_i8b(array, unq, idx) END SUBROUTINE unique_i8b -end module nr_utility_module + ! ************************************************************************************************* + ! * convert integer to digit array + ! ************************************************************************************************* + FUNCTION get_digits(num) result(digs) + implicit none + ! argument variables + integer(i4b), intent(in) :: num + ! local variables + integer(i4b), allocatable :: digs(:) + integer(i4b) :: num_digits, ix, rem + if (num==0) then + allocate(digs(1)) + digs=0 + else + num_digits = floor(log10(real(num))+1) + allocate(digs(num_digits)) + rem = num + do ix = 1, num_digits + digs(num_digits-ix+1) = rem - (rem/10)*10 ! Take advantage of integer division + rem = rem/10 + end do + end if + END FUNCTION get_digits + + ! ************************************************************************************************* + ! character-to-integer routines/functions + ! ************************************************************************************************* + SUBROUTINE char2int_1d(char_array, int_array, invalid_value) + ! Convert character array to one digit integer array + ! if character array is '-9999' or '0', int_array(:) = [invalid_value,...,invalid_value] + implicit none + ! argument variables + character(*), intent(in) :: char_array + integer(i4b), allocatable, intent(out) :: int_array(:) + integer(i4b), optional, intent(in) :: invalid_value + ! local variables + character(len=strLen) :: string + integer(i4b) :: str_len + integer(i4b) :: iChr + integer(i4b) :: invalValue + + if (present(invalid_value)) then + invalValue = invalid_value + else + invalValue = -1 + endif + + allocate(int_array(len(char_array))) + int_array = invalValue + + string = adjustl(char_array) + str_len = len(trim(string)) + + if (trim(string)=='-9999' .or. trim(string)=='0') then + int_array(1) = invalValue + else + do iChr =1,str_len + read(string(iChr:iChr),'(I1)') int_array(iChr) + end do + endif + END SUBROUTINE char2int_1d + + SUBROUTINE char2int_2d(char_array, int_array, invalid_value) + ! convert character array to one digit integer array + ! if character array is '-9999' or '0', int_array(:) = [invalid_value,...,invalid_value] + implicit none + ! Argument variables + character(*), intent(in) :: char_array(:) + integer(i4b), allocatable, intent(out) :: int_array(:,:) + integer(i4b), optional, intent(in) :: invalid_value + ! local variables + character(len=strLen) :: string + integer(i4b) :: str_len + integer(i4b) :: iSize + integer(i4b) :: iChr + integer(i4b) :: invalValue + + if (present(invalid_value)) then + invalValue = invalid_value + else + invalValue = -1 + endif + + allocate(int_array(size(char_array),len(char_array))) + int_array = invalValue + + do iSize = 1, size(char_array) + str_len = len(trim(adjustl(char_array(iSize)))) + string = adjustl(char_array(iSize)) + if (trim(string) == '-9999' .or. trim(string) == '0') then + int_array(iSize, 1) = invalValue + else + do iChr =1,str_len + read(string(iChr:iChr),'(I1)') int_array(iSize, iChr) + end do + end if + end do + END SUBROUTINE char2int_2d + + ! ************************************************************************************************ + ! match_index: find array1 indix for each array2 element if array2 includes matching element in array1 + ! ************************************************************************************************ + FUNCTION match_index(array1, array2, missingValue) RESULT(index1) + implicit none + ! Argument variables: + integer(i4b), allocatable, intent(in) :: array1(:) + integer(i4b), allocatable, intent(in) :: array2(:) + integer(i4b), optional, intent(in) :: missingValue ! desired missing value if desiredValue is not found + ! Local variables: + integer(i4b), allocatable :: index1(:) + integer(i4b), allocatable :: rnkArray1(:) + integer(i4b), allocatable :: rnkArray2(:) + integer(i4b) :: ix, jx, begIx + + allocate(index1(size(array2)), rnkArray1(size(array1)), rnkArray2(size(array2)) ) + + if(present(missingValue))then + index1=missingValue + else + index1 = -9999 + endif + + call indexx(array1, rnkArray1) + call indexx(array2, rnkArray2) + + begIx=1 + do ix=1,size(rnkArray2) + do jx=begIx,size(rnkArray1) + if (array2(rnkArray2(ix))==array1(rnkArray1(jx))) then + index1(rnkArray2(ix)) = rnkArray1(jx) + begIx=jx + exit + else if (array2(rnkArray2(ix)) 0.999_dp) then ! in case if the cumprob is close to 1 in one model time step ntdh_try = 1.999_dp @@ -69,7 +67,7 @@ SUBROUTINE basinUH(dt, fshape, tscale, IERR, MESSAGE) ntdh_max = 1000._dp ntdh_try = 0.5_dp*(ntdh_min + ntdh_max) do itry=1,maxtry - x_value = alamb*dt*ntdh_try + x_value = dt*ntdh_try/tscale cumprob = gammp(fshape, x_value) !print*, tscale, ntdh_try, cumprob, x_value, itry if(cumprob < 0.99_dp) ntdh_min = ntdh_try @@ -89,7 +87,7 @@ SUBROUTINE basinUH(dt, fshape, tscale, IERR, MESSAGE) PSAVE = 0. ! cumulative probability at JTIM-1 DO JTIM=1,NTDH TFUTURE = REAL(JTIM, kind(dp))*DT ! future time - CUMPROB = gammp(fshape,alamb*TFUTURE) ! cumulative probability at JTIM + CUMPROB = gammp(fshape,TFUTURE/tscale) ! cumulative probability at JTIM FRAC_FUTURE(JTIM) = MAX(0._DP, CUMPROB-PSAVE) ! probability between JTIM-1 and JTIM PSAVE = CUMPROB ! cumulative probability at JTIM-1 !WRITE(*,'(I5,1X,F20.5,1X,2(F11.5))') JTIM, TFUTURE, FRAC_FUTURE(JTIM), CUMPROB diff --git a/route/build/src/public_var.f90 b/route/build/src/public_var.f90 index 401c491c..75ab89c6 100644 --- a/route/build/src/public_var.f90 +++ b/route/build/src/public_var.f90 @@ -9,12 +9,13 @@ module public_var save ! ---------- mizuRoute version ------------------------------------------------------------------- - character(len=strLen), parameter, public :: mizuRouteVersion='v1.2.1' + + character(len=strLen), parameter, public :: mizuRouteVersion='v1.2.2' ! ---------- common constants --------------------------------------------------------------------- ! physical constants - real(dp), parameter,public :: pi=3.14159265359_dp ! pi + real(dp), parameter,public :: pi=3.14159265359_dp ! pi ! some common constant variables (not likely to change value) real(dp), parameter,public :: secprmin=60._dp ! number of seconds in a minute @@ -61,9 +62,13 @@ module public_var integer(i4b), parameter,public :: readFromFile=0 ! read given variable from a file ! routing methods - integer(i4b), parameter,public :: allRoutingMethods=0 ! all routing methods - integer(i4b), parameter,public :: impulseResponseFunc=1 ! impulse response function - integer(i4b), parameter,public :: kinematicWave=2 ! kinematic wave + integer(i4b), parameter,public :: nRouteMethods=6 ! number of routing methods available + integer(i4b), parameter,public :: accumRunoff=0 ! runoff accumulation over all the upstream reaches + integer(i4b), parameter,public :: impulseResponseFunc=1 ! impulse response function + integer(i4b), parameter,public :: kinematicWaveTracking=2 ! Lagrangian kinematic wave + integer(i4b), parameter,public :: kinematicWave=3 ! kinematic wave + integer(i4b), parameter,public :: muskingumCunge=4 ! muskingum-cunge + integer(i4b), parameter,public :: diffusiveWave=5 ! diffusiveWave ! ---------- variables in the control file -------------------------------------------------------- @@ -73,9 +78,6 @@ module public_var character(len=strLen),public :: input_dir = '' ! directory containing input runoff netCDF character(len=strLen),public :: output_dir = '' ! directory for routed flow output (netCDF) character(len=strLen),public :: restart_dir = charMissing ! directory for restart output (netCDF) - ! SIMULATION TIME - character(len=strLen),public :: simStart = '' ! date string defining the start of the simulation - character(len=strLen),public :: simEnd = '' ! date string defining the end of the simulation ! RIVER NETWORK TOPOLOGY character(len=strLen),public :: fname_ntopOld = '' ! old filename containing stream network topology information logical(lgt) ,public :: ntopAugmentMode = .false. ! option for river network augmentation mode. terminate the program after writing augmented ntopo. @@ -106,8 +108,12 @@ module public_var character(len=strLen),public :: vname_j_index = '' ! variable for numbers of x (longitude) index if runoff file is grid character(len=strLen),public :: dname_hru_remap = '' ! dimension name for river network HRU character(len=strLen),public :: dname_data_remap = '' ! dimension name for runoff HRU ID - ! ROUTED FLOW OUTPUT + ! RUN CONTROL character(len=strLen),public :: case_name = '' ! name of simulation. used as head of model output and restart file + character(len=strLen),public :: simStart = '' ! date string defining the start of the simulation + character(len=strLen),public :: simEnd = '' ! date string defining the end of the simulation + character(len=10) ,public :: routOpt = '0' ! routing scheme options 0: accum runoff, 1:IRF, 2:KWT, 3:KW, 4:MC, 5:DW + integer(i4b) ,public :: doesBasinRoute = 1 ! basin routing options 0-> no, 1->IRF, otherwise error character(len=strLen),public :: newFileFrequency = 'annual' ! frequency for new output files (day, month, annual, single) ! STATES character(len=strLen),public :: restart_write = 'never' ! restart write option: N[n]ever-> never write, L[l]ast -> write at last time step, S[s]pecified, Monthly, Daily @@ -129,10 +135,7 @@ module public_var ! MISCELLANEOUS logical(lgt) ,public :: debug = .false. ! print out detaled information integer(i4b) ,public :: idSegOut = integerMissing ! id of outlet stream segment - integer(i4b) ,public :: routOpt = integerMissing ! routing scheme options 0-> both, 1->IRF, 2->KWT, otherwise error integer(i4b) ,public :: desireId = integerMissing ! turn off checks or speficy reach ID if necessary to print on screen - integer(i4b) ,public :: doesBasinRoute = 1 ! basin routing options 0-> no, 1->IRF, otherwise error - integer(i4b) ,public :: doesAccumRunoff = 1 ! option to delayed runoff accumulation over all the upstream reaches character(len=strLen),public :: netcdf_format = 'netcdf4' ! netcdf format for output ! PFAFCODE integer(i4b) ,public :: maxPfafLen = 32 ! maximum digit of pfafstetter code (default 32). diff --git a/route/build/src/read_control.f90 b/route/build/src/read_control.f90 index 1b3de3bc..c847f304 100644 --- a/route/build/src/read_control.f90 +++ b/route/build/src/read_control.f90 @@ -1,52 +1,55 @@ -module read_control_module +MODULE read_control_module + +! USE nrtype USE public_var implicit none -! privacy + private public::read_control -contains + +CONTAINS ! ======================================================================================================= - ! * new subroutine: read the control file + ! subroutine: read the control file ! ======================================================================================================= - ! read the control file - subroutine read_control(ctl_fname, err, message) - - ! data types - USE nrtype ! variable types, etc. + SUBROUTINE read_control(ctl_fname, err, message) ! global vars USE globalData, only:time_conv,length_conv ! conversion factors ! metadata structures - USE globalData, only : meta_HRU ! HRU properties - USE globalData, only : meta_HRU2SEG ! HRU-to-segment mapping - USE globalData, only : meta_SEG ! stream segment properties - USE globalData, only : meta_NTOPO ! network topology - USE globalData, only : meta_PFAF ! pfafstetter code - USE globalData, only : meta_rflx ! river flux variables - + USE globalData, ONLY: meta_HRU ! HRU properties + USE globalData, ONLY: meta_HRU2SEG ! HRU-to-segment mapping + USE globalData, ONLY: meta_SEG ! stream segment properties + USE globalData, ONLY: meta_NTOPO ! network topology + USE globalData, ONLY: meta_PFAF ! pfafstetter code + USE globalData, ONLY: meta_rflx ! river flux variables + USE globalData, ONLY: nRoutes ! number of active routing methods + USE globalData, ONLY: routeMethods ! active routing method index and id + USE globalData, ONLY: onRoute ! logical to indicate actiive routing method(s) + USE globalData, ONLY: idxSUM,idxIRF,idxKWT, & + idxKW, idxMC, idxDW ! named variables in each structure - USE var_lookup, only : ixHRU ! index of variables for data structure - USE var_lookup, only : ixHRU2SEG ! index of variables for data structure - USE var_lookup, only : ixSEG ! index of variables for data structure - USE var_lookup, only : ixNTOPO ! index of variables for data structure - USE var_lookup, only : ixPFAF ! index of variables for data structure - USE var_lookup, only : ixRFLX ! index of variables for data structure + USE var_lookup, ONLY : ixHRU ! index of variables for data structure + USE var_lookup, ONLY : ixHRU2SEG ! index of variables for data structure + USE var_lookup, ONLY : ixSEG ! index of variables for data structure + USE var_lookup, ONLY : ixNTOPO ! index of variables for data structure + USE var_lookup, ONLY : ixPFAF ! index of variables for data structure + USE var_lookup, ONLY : ixRFLX, nVarsRFLX ! index of variables for data structure ! external subroutines - USE ascii_util_module,only:file_open ! open file (performs a few checks as well) - USE ascii_util_module,only:get_vlines ! get a list of character strings from non-comment lines + USE ascii_util_module, only: file_open ! open file (performs a few checks as well) + USE ascii_util_module, only: get_vlines ! get a list of character strings from non-comment lines + USE nr_utility_module, ONLY: char2int ! convert integer number to a array containing individual digits implicit none - ! input + ! arguments character(*), intent(in) :: ctl_fname ! name of the control file - ! 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=strLen),allocatable :: cLines(:) ! vector of character strings @@ -59,8 +62,9 @@ subroutine read_control(ctl_fname, err, message) integer(i4b) :: iLine ! index of line in cLines integer(i4b) :: iunit ! file unit integer(i4b) :: io_error ! error in I/O + integer(i4b) :: iRoute ! loop index character(len=strLen) :: cmessage ! error message from subroutine - ! initialize error control + err=0; message='read_control/' ! *** get a list of character strings from non-comment lines **** @@ -101,9 +105,6 @@ subroutine read_control(ctl_fname, err, message) case(''); input_dir = trim(cData) ! directory containing input runoff netCDF case(''); output_dir = trim(cData) ! directory for routed flow output (netCDF) case(''); restart_dir = trim(cData) ! directory for restart output (netCDF) - ! SIMULATION TIME - case(''); simStart = trim(cData) ! date string defining the start of the simulation - case(''); simEnd = trim(cData) ! date string defining the end of the simulation ! RIVER NETWORK TOPOLOGY case(''); fname_ntopOld = trim(cData) ! name of file containing stream network topology information case(''); read(cData,*,iostat=io_error) ntopAugmentMode ! option for river network augmentation mode. terminate the program after writing augmented ntopo. @@ -135,11 +136,15 @@ subroutine read_control(ctl_fname, err, message) case(''); vname_j_index = trim(cData) ! name of variable containing index of ylat dimension in runoff grid (if runoff file is grid) case(''); dname_hru_remap = trim(cData) ! name of dimension of river network HRU ID case(''); dname_data_remap = trim(cData) ! name of dimension of runoff HRU overlapping with river network HRU - ! ROUTED FLOW OUTPUT + ! RUN CONTROL case(''); case_name = trim(cData) ! name of simulation. used as head of model output and restart file - case(''); newFileFrequency = trim(cData) ! frequency for new output files (day, month, annual, single) + case(''); simStart = trim(cData) ! date string defining the start of the simulation + case(''); simEnd = trim(cData) ! date string defining the end of the simulation + case(''); routOpt = trim(cData) ! routing scheme options 0-> accumRunoff, 1->IRF, 2->KWT, 3-> KW, 4->MC, 5->DW + case(''); read(cData,*,iostat=io_error) doesBasinRoute ! basin routing options 0-> no, 1->IRF, otherwise error + case(''); newFileFrequency = trim(cData) ! frequency for new output options (case-insensitive): daily, monthly, yearly, or single ! RESTART - case(''); restart_write = trim(cData) ! restart write option: N[n]ever, L[l]ast, S[s]pecified, Monthly, Daily + case(''); restart_write = trim(cData) ! restart write option (case-insensitive): never, last, specified, yearly, monthly, or daily case(''); restart_date = trim(cData) ! specified restart date, yyyy-mm-dd (hh:mm:ss) for Specified option case(''); read(cData,*,iostat=io_error) restart_month ! restart periodic month case(''); read(cData,*,iostat=io_error) restart_day ! restart periodic day @@ -158,10 +163,7 @@ subroutine read_control(ctl_fname, err, message) ! MISCELLANEOUS case(''); read(cData,*,iostat=io_error) debug ! print out detailed information throught the probram case('' ); read(cData,*,iostat=io_error) idSegOut ! desired outlet reach id (if -9999 --> route over the entire network) - case(''); read(cData,*,iostat=io_error) routOpt ! routing scheme options 0-> both, 1->IRF, 2->KWT, otherwise error case('' ); read(cData,*,iostat=io_error) desireId ! turn off checks or speficy reach ID if necessary to print on screen - case(''); read(cData,*,iostat=io_error) doesBasinRoute ! basin routing options 0-> no, 1->IRF, otherwise error - case(''); read(cData,*,iostat=io_error) doesAccumRunoff ! option to delayed runoff accumulation over all the upstream reaches. 0->no, 1->yes case(''); netcdf_format = trim(cData) ! netcdf format for output 'classic','64bit_offset','netcdf4' ! PFAFCODE case(''); read(cData,*,iostat=io_error) maxPfafLen ! maximum digit of pfafstetter code (default 32) @@ -173,6 +175,9 @@ subroutine read_control(ctl_fname, err, message) case(''); read(cData,*,iostat=io_error) meta_rflx(ixRFLX%sumUpstreamRunoff)%varFile case(''); read(cData,*,iostat=io_error) meta_rflx(ixRFLX%KWTroutedRunoff )%varFile case(''); read(cData,*,iostat=io_error) meta_rflx(ixRFLX%IRFroutedRunoff )%varFile + case(''); read(cData,*,iostat=io_error) meta_rflx(ixRFLX%KWroutedRunoff )%varFile + case(''); read(cData,*,iostat=io_error) meta_rflx(ixRFLX%DWroutedRunoff )%varFile + case(''); read(cData,*,iostat=io_error) meta_rflx(ixRFLX%MCroutedRunoff )%varFile ! VARIABLE NAMES for data (overwrite default name in popMeta.f90) ! HRU structure @@ -218,13 +223,11 @@ subroutine read_control(ctl_fname, err, message) message=trim(message)//'unexpected text in control file -- provided '//trim(cName)& //' (note strings in control file must match the variable names in public_var.f90)' err=20; return - end select ! check I/O error if(io_error/=0)then - message=trim(message)//'problem with internal read of '//trim(cName) - err=20; return + message=trim(message)//'problem with internal read of '//trim(cName); err=20; return endif end do ! looping through lines in the control file @@ -265,8 +268,8 @@ subroutine read_control(ctl_fname, err, message) ! find the position of the "/" character ipos = index(trim(units_qsim),'/') if(ipos==0)then - message=trim(message)//'expect the character "/" exists in the units string [units='//trim(units_qsim)//']' - err=80; return + message=trim(message)//'expect the character "/" exists in the units string [units='//trim(units_qsim)//']' + err=80; return endif ! get the length and time units @@ -275,23 +278,58 @@ subroutine read_control(ctl_fname, err, message) ! get the conversion factor for length select case(trim(cLength)) - case('m'); length_conv = 1._dp - case('mm'); length_conv = 1._dp/1000._dp - case default - message=trim(message)//'expect the length units to be "m" or "mm" [units='//trim(cLength)//']' - err=81; return + case('m'); length_conv = 1._dp + case('mm'); length_conv = 1._dp/1000._dp + case default + message=trim(message)//'expect the length units to be "m" or "mm" [units='//trim(cLength)//']' + err=81; return end select ! get the conversion factor for time select case(trim(cTime)) - case('d','day'); time_conv = 1._dp/secprday - case('h','hr','hour'); time_conv = 1._dp/secprhour - case('s','sec','second'); time_conv = 1._dp - case default - message=trim(message)//'expect the time units to be "day"("d"), "hour"("h") or "second"("s") [time units = '//trim(cTime)//']' - err=81; return + case('d','day'); time_conv = 1._dp/secprday + case('h','hr','hour'); time_conv = 1._dp/secprhour + case('s','sec','second'); time_conv = 1._dp + case default + message=trim(message)//'expect the time units to be "day"("d"), "hour"("h") or "second"("s") [time units = '//trim(cTime)//']' + err=81; return end select - end subroutine read_control - -end module read_control_module + ! ---------- output options -------------------------------------------------------------------------------------------- + ! Assign index for each active routing method + ! Make sure to turn off write option for routines not used + if (trim(routOpt)=='0')then; write(iulog,'(a)') 'WARNING: routOpt=0 is accumRunoff option now. 12 is previous 0 now'; endif + call char2int(trim(routOpt), routeMethods, invalid_value=0) + nRoutes = size(routeMethods) + onRoute = .false. + do iRoute = 1, nRoutes + select case(routeMethods(iRoute)) + case(accumRunoff); idxSUM = iRoute; onRoute(accumRunoff)=.true. + case(kinematicWaveTracking); idxKWT = iRoute; onRoute(kinematicWaveTracking)=.true. + case(impulseResponseFunc); idxIRF = iRoute; onRoute(impulseResponseFunc)=.true. + case(muskingumCunge); idxMC = iRoute; onRoute(muskingumCunge)=.true. + case(kinematicWave); idxKW = iRoute; onRoute(kinematicWave)=.true. + case(diffusiveWave); idxDW = iRoute; onRoute(diffusiveWave)=.true. + case default + message=trim(message)//'routOpt may include invalid digits; expect digits 1-5 in routOpt'; err=81; return + end select + end do + + do iRoute = 0, nRouteMethods-1 + select case(iRoute) + case(accumRunoff); if (.not. onRoute(iRoute)) meta_rflx(ixRFLX%sumUpstreamRunoff)%varFile=.false. + case(kinematicWaveTracking); if (.not. onRoute(iRoute)) meta_rflx(ixRFLX%KWTroutedRunoff)%varFile=.false. + case(impulseResponseFunc); if (.not. onRoute(iRoute)) meta_rflx(ixRFLX%IRFroutedRunoff)%varFile=.false. + case(muskingumCunge); if (.not. onRoute(iRoute)) meta_rflx(ixRFLX%MCroutedRunoff)%varFile=.false. + case(kinematicWave); if (.not. onRoute(iRoute)) meta_rflx(ixRFLX%KWroutedRunoff)%varFile=.false. + case(diffusiveWave); if (.not. onRoute(iRoute)) meta_rflx(ixRFLX%DWroutedRunoff)%varFile=.false. + case default; message=trim(message)//'expect digits from 0 and 5'; err=81; return + end select + end do + + ! basin runoff routing option + if (doesBasinRoute==0) meta_rflx(ixRFLX%instRunoff)%varFile=.false. + + END SUBROUTINE read_control + +END MODULE read_control_module diff --git a/route/build/src/read_restart.f90 b/route/build/src/read_restart.f90 index 261e6416..e0794f7d 100644 --- a/route/build/src/read_restart.f90 +++ b/route/build/src/read_restart.f90 @@ -21,18 +21,24 @@ MODULE read_restart ! ********************************************************************* SUBROUTINE read_state_nc(& fname, & ! Input: state netcdf name - opt, & ! input: which routing options T0, T1, & ! output: start and end time [sec] ierr, message) ! Output: error control - USE dataTypes, ONLY: states - USE globalData, ONLY: meta_stateDims ! dimension for state variables - USE var_lookup, ONLY: ixStateDims, nStateDims + USE globalData, ONLY: RCHFLX ! To get q future for basin IRF and IRF (these should not be in this data strucuture) + USE globalData, ONLY: RCHSTA ! restart state data structure + USE dataTypes, ONLY: states + USE globalData, ONLY: meta_stateDims ! dimension for state variables + USE globalData, ONLY: onRoute ! logical to indicate which routing method(s) is on + USE public_var, ONLY: impulseResponseFunc + USE public_var, ONLY: kinematicWaveTracking + USE public_var, ONLY: kinematicWave + USE public_var, ONLY: muskingumCunge + USE public_var, ONLY: diffusiveWave + USE var_lookup, ONLY: ixStateDims, nStateDims implicit none ! input variables character(*), intent(in) :: fname ! filename - integer(i4b), intent(in) :: opt ! routing option 0=all, 1=kwt, 2=irf ! output variables real(dp), intent(out) :: T0 ! beginning time [sec] of ith time step - lapse time from the beginning of the simulation real(dp), intent(out) :: T1 ! ending time [sec] ith time step - lapse time from the beginning of the simulation @@ -41,18 +47,17 @@ SUBROUTINE read_state_nc(& ! local variables integer(i4b) :: ncidRestart ! restart netcdf id real(dp) :: TB(2) ! 2 element-time bound vector - type(states) :: state(0:2) ! temporal state data structures -currently 2 river routing scheme + basin IRF routing integer(i4b) :: nSeg,nens ! dimenion sizes - integer(i4b) :: nTime,ntbound ! dimenion sizes - integer(i4b) :: ixDim_common(4) ! custom dimension ID array + integer(i4b) :: ntbound ! dimenion sizes + integer(i4b) :: ixDim_common(3) ! custom dimension ID array integer(i4b) :: jDim ! index loops for dimension character(len=strLen) :: cmessage ! error message of downwind routine ierr=0; message='read_state_nc/' ! get Dimension sizes - ! For common dimension/variables - seg id, time, time-bound ----------- - ixDim_common = (/ixStateDims%seg, ixStateDims%ens, ixStateDims%time, ixStateDims%tbound/) + ! For common dimension/variables - seg id, time-bound ----------- + ixDim_common = (/ixStateDims%seg, ixStateDims%ens, ixStateDims%tbound/) call open_nc(fname, 'r', ncidRestart, ierr, cmessage) if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif @@ -62,7 +67,6 @@ SUBROUTINE read_state_nc(& select case(ixDim_tmp) case(ixStateDims%seg); call get_nc_dim_len(ncidRestart, meta_stateDims(ixDim_tmp)%dimName, nSeg, ierr, cmessage) case(ixStateDims%ens); call get_nc_dim_len(ncidRestart, meta_stateDims(ixDim_tmp)%dimName, nens, ierr, cmessage) - case(ixStateDims%time); call get_nc_dim_len(ncidRestart, meta_stateDims(ixDim_tmp)%dimName, nTime, ierr, cmessage) case(ixStateDims%tbound); call get_nc_dim_len(ncidRestart, meta_stateDims(ixDim_tmp)%dimName, ntbound, ierr, cmessage) case default; ierr=20; message=trim(message)//'unable to identify dimension name index'; return end select @@ -82,14 +86,32 @@ SUBROUTINE read_state_nc(& if(ierr/=0)then; message=trim(message)//trim(cmessage); return;endif endif - if (opt==allRoutingMethods .or. opt==kinematicWave) then - call read_KWT_state(ierr, cmessage) - if(ierr/=0)then; message=trim(message)//trim(cmessage);return; endif - endif + call read_basinQ_state(ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return;endif + + if (onRoute(kinematicWaveTracking)) then + call read_KWT_state(ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage);return; endif + end if - if (opt==allRoutingMethods .or. opt==impulseResponseFunc) then - call read_IRF_state(ierr, cmessage) - if(ierr/=0)then; message=trim(message)//trim(cmessage);return; endif + if (onRoute(impulseResponseFunc)) then + call read_IRF_state(ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage);return; endif + end if + + if (onRoute(kinematicWave)) then + call read_KW_state(ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage);return; endif + end if + + if (onRoute(muskingumCunge)) then + call read_MC_state(ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage);return; endif + end if + + if (onRoute(diffusiveWave)) then + call read_DW_state(ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage);return; endif end if call close_nc(ncidRestart, ierr, cmessage) @@ -97,227 +119,406 @@ SUBROUTINE read_state_nc(& CONTAINS - SUBROUTINE read_IRFbas_state(ierr, message1) - ! meta data - USE globalData, ONLY: meta_irf_bas ! basin IRF routing - ! State/flux data structures - USE globalData, ONLY: RCHFLX ! To get q future for basin IRF and IRF (these should not be in this data strucuture) - ! Named variables - USE var_lookup, ONLY: ixIRFbas, nVarsIRFbas - implicit none - ! output - integer(i4b), intent(out) :: ierr ! error code - character(*), intent(out) :: message1 ! error message - ! local variables - integer(i4b) :: iVar,iens,iSeg ! index loops for variables, ensembles, reaches respectively - integer(i4b) :: ntdh ! dimension size - - ! initialize error control - ierr=0; message1='read_IRFbas_state/' - - call get_nc_dim_len(ncidRestart, meta_stateDims(ixStateDims%tdh)%dimName, ntdh, ierr, cmessage) - if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif - - allocate(state(0)%var(nVarsIRFbas), stat=ierr, errmsg=cmessage) - if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif - - do iVar=1,nVarsIRFbas - - select case(iVar) - case(ixIRFbas%qfuture); allocate(state(0)%var(iVar)%array_3d_dp(nSeg, ntdh, nens), stat=ierr) - case(ixIRFbas%q); allocate(state(0)%var(iVar)%array_2d_dp(nSeg, nens), stat=ierr) - case default; ierr=20; message1=trim(message1)//'unable to identify basin routing variable index'; return - end select - if(ierr/=0)then; message1=trim(message1)//'problem allocating space for basin IRF routing state '//trim(meta_irf_bas(iVar)%varName); return; endif + SUBROUTINE read_basinQ_state(ierr, message1) + USE globalData, ONLY: meta_basinQ ! reach inflow from basin at previous time step + USE var_lookup, ONLY: ixBasinQ, nVarsBasinQ + implicit none + ! output + integer(i4b), intent(out) :: ierr ! error code + character(*), intent(out) :: message1 ! error message + ! local variables + character(len=strLen) :: cmessage1 ! error message of downwind routine + type(states) :: state ! temporal state data structures + integer(i4b) :: iVar,iens,iSeg ! index loops for variables, ensembles, reaches respectively + + ! initialize error control + ierr=0; message1='read_basinQ_state/' + + allocate(state%var(nVarsBasinQ), stat=ierr, errmsg=cmessage1) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage1); return; endif + + do iVar=1,nVarsBasinQ + select case(iVar) + case(ixBasinQ%q); allocate(state%var(iVar)%array_2d_dp(nSeg, nens), stat=ierr) + case default; ierr=20; message1=trim(message1)//'unable to identify basin routing variable index'; return + end select + if(ierr/=0)then; message1=trim(message1)//'problem allocating space for reach inflow:'//trim(meta_basinQ(iVar)%varName); return; endif + end do + + do iVar=1,nVarsBasinQ - end do + select case(iVar) + case(ixBasinQ%q); call get_nc(ncidRestart, meta_basinQ(iVar)%varName, state%var(iVar)%array_2d_dp, (/1,1/), (/nSeg,nens/), ierr, cmessage1) + case default; ierr=20; message1=trim(message1)//'unable to identify previous time step reach inflow variable index for nc writing'; return + end select + if(ierr/=0)then; message1=trim(message1)//trim(cmessage1)//':'//trim(meta_basinQ(iVar)%varName); return; endif - do iVar=1,nVarsIRFbas + enddo - select case(iVar) - case(ixIRFbas%q); call get_nc(ncidRestart, meta_irf_bas(iVar)%varName, state(0)%var(iVar)%array_2d_dp, (/1,1/), (/nSeg,nens/), ierr, cmessage) - case(ixIRFbas%qfuture); call get_nc(ncidRestart, meta_irf_bas(iVar)%varName, state(0)%var(iVar)%array_3d_dp, (/1,1,1/), (/nSeg,ntdh,nens/), ierr, cmessage) - case default; ierr=20; message1=trim(message1)//'unable to identify basin IRF variable index for nc writing'; return - end select - if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif + do iens=1,nens + do iSeg=1,nSeg + do iVar=1,nVarsBasinQ + select case(iVar) + case(ixBasinQ%q); RCHFLX(iens,iSeg)%BASIN_QR(1) = state%var(iVar)%array_2d_dp(iSeg,iens) + case default; ierr=20; message1=trim(message1)//'unable to identify previous time step reach inflow variable index'; return + end select + enddo + enddo + enddo - enddo + END SUBROUTINE read_basinQ_state - do iens=1,nens - do iSeg=1,nSeg - allocate(RCHFLX(iens,iSeg)%QFUTURE(ntdh), stat=ierr, errmsg=cmessage) - if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif + SUBROUTINE read_IRFbas_state(ierr, message1) + USE globalData, ONLY: meta_irf_bas ! basin IRF routing + USE var_lookup, ONLY: ixIRFbas, nVarsIRFbas + implicit none + ! output + integer(i4b), intent(out) :: ierr ! error code + character(*), intent(out) :: message1 ! error message + ! local variables + character(len=strLen) :: cmessage1 ! error message of downwind routine + type(states) :: state ! temporal state data structures + integer(i4b) :: iVar,iens,iSeg ! index loops for variables, ensembles, reaches respectively + integer(i4b) :: ntdh ! dimension size + + ! initialize error control + ierr=0; message1='read_IRFbas_state/' + + call get_nc_dim_len(ncidRestart, meta_stateDims(ixStateDims%tdh)%dimName, ntdh, ierr, cmessage1) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage1); return; endif + + allocate(state%var(nVarsIRFbas), stat=ierr, errmsg=cmessage1) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage1); return; endif do iVar=1,nVarsIRFbas + select case(iVar) + case(ixIRFbas%qfuture); allocate(state%var(iVar)%array_3d_dp(nSeg, ntdh, nens), stat=ierr) + case default; ierr=20; message1=trim(message1)//'unable to identify basin routing variable index'; return + end select + if(ierr/=0)then; message1=trim(message1)//'problem allocating space for basin IRF routing state:'//trim(meta_irf_bas(iVar)%varName); return; endif + end do - select case(iVar) - case(ixIRFbas%q); RCHFLX(iens,iSeg)%BASIN_QR(1) = state(0)%var(iVar)%array_2d_dp(iSeg,iens) - case(ixIRFbas%qfuture); RCHFLX(iens,iSeg)%QFUTURE(:) = state(0)%var(iVar)%array_3d_dp(iSeg,:,iens) - case default; ierr=20; message1=trim(message1)//'unable to identify basin IRF state variable index'; return - end select + do iVar=1,nVarsIRFbas + select case(iVar) + case(ixIRFbas%qfuture); call get_nc(ncidRestart, meta_irf_bas(iVar)%varName, state%var(iVar)%array_3d_dp, (/1,1,1/), (/nSeg,ntdh,nens/), ierr, cmessage1) + case default; ierr=20; message1=trim(message1)//'unable to identify basin IRF variable index for nc writing'; return + end select + if(ierr/=0)then; message1=trim(message1)//trim(cmessage1)//':'//trim(meta_irf_bas(iVar)%varName); return; endif + enddo + do iens=1,nens + do iSeg=1,nSeg + allocate(RCHFLX(iens,iSeg)%QFUTURE(ntdh), stat=ierr, errmsg=cmessage1) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage1); return; endif + do iVar=1,nVarsIRFbas + select case(iVar) + case(ixIRFbas%qfuture); RCHFLX(iens,iSeg)%QFUTURE(:) = state%var(iVar)%array_3d_dp(iSeg,:,iens) + case default; ierr=20; message1=trim(message1)//'unable to identify basin IRF state variable index'; return + end select + enddo + enddo enddo - enddo - enddo END SUBROUTINE read_IRFbas_state SUBROUTINE read_IRF_state(ierr, message1) - ! meta data - USE globalData, ONLY: meta_irf ! IRF routing - ! State/flux data structures - USE globalData, ONLY: RCHFLX ! To get q future for basin IRF and IRF (these should not be in this data strucuture) - ! Named variables - USE var_lookup, ONLY: ixIRF, nVarsIRF - implicit none - integer(i4b), intent(out) :: ierr ! error code - character(*), intent(out) :: message1 ! error message - ! local variables - integer(i4b) :: iVar,iens,iSeg ! index loops for variables, ensembles, reaches respectively - integer(i4b), allocatable :: numQF(:,:) ! number of future Q time steps for each ensemble and segment - integer(i4b) :: ntdh_irf ! dimenion sizes - - ierr=0; message1='read_IRF_state/' - - call get_nc_dim_len(ncidRestart, meta_stateDims(ixStateDims%tdh_irf)%dimName, ntdh_irf, ierr, cmessage) - if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif - - allocate(state(impulseResponseFunc)%var(nVarsIRF), stat=ierr, errmsg=cmessage) - if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif - - allocate(numQF(nens,nSeg), stat=ierr, errmsg=cmessage) - if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif - - do iVar=1,nVarsIRF - - select case(iVar) - case(ixIRF%qfuture); allocate(state(impulseResponseFunc)%var(iVar)%array_3d_dp(nSeg, ntdh_irf, nens), stat=ierr) - case(ixIRF%irfVol); allocate(state(impulseResponseFunc)%var(iVar)%array_2d_dp(nSeg, nens), stat=ierr) - case default; ierr=20; message1=trim(message1)//'unable to identify variable index'; return - end select - if(ierr/=0)then; message1=trim(message1)//'problem allocating space for IRF routing state '//trim(meta_irf(iVar)%varName); return; endif + USE globalData, ONLY: meta_irf ! IRF routing + USE globalData, ONLY: idxIRF + USE var_lookup, ONLY: ixIRF, nVarsIRF + implicit none + integer(i4b), intent(out) :: ierr ! error code + character(*), intent(out) :: message1 ! error message + ! local variables + character(len=strLen) :: cmessage1 ! error message of downwind routine + type(states) :: state ! temporal state data structures + integer(i4b) :: iVar,iens,iSeg ! index loops for variables, ensembles, reaches respectively + integer(i4b), allocatable :: numQF(:,:) ! number of future Q time steps for each ensemble and segment + integer(i4b) :: ntdh_irf ! dimenion sizes + + ierr=0; message1='read_IRF_state/' + + call get_nc_dim_len(ncidRestart, meta_stateDims(ixStateDims%tdh_irf)%dimName, ntdh_irf, ierr, cmessage1) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage1); return; endif + + allocate(state%var(nVarsIRF), stat=ierr, errmsg=cmessage1) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage1); return; endif + + allocate(numQF(nens,nSeg), stat=ierr, errmsg=cmessage1) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage1); return; endif - end do - - call get_nc(ncidRestart,'numQF',numQF,(/1,1/),(/nSeg,nens/),ierr,cmessage) - if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif + do iVar=1,nVarsIRF + select case(iVar) + case(ixIRF%qfuture); allocate(state%var(iVar)%array_3d_dp(nSeg, ntdh_irf, nens), stat=ierr) + case(ixIRF%irfVol); allocate(state%var(iVar)%array_2d_dp(nSeg, nens), stat=ierr) + case default; ierr=20; message1=trim(message1)//'unable to identify variable index'; return + end select + if(ierr/=0)then; message1=trim(message1)//'problem allocating space for IRF routing state:'//trim(meta_irf(iVar)%varName); return; endif + end do - do iVar=1,nVarsIRF + call get_nc(ncidRestart,'numQF',numQF,(/1,1/),(/nSeg,nens/),ierr,cmessage1) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage1)//':'//trim(meta_irf(iVar)%varName); return; endif - select case(iVar) - case(ixIRF%qfuture); call get_nc(ncidRestart, meta_irf(iVar)%varName, state(impulseResponseFunc)%var(iVar)%array_3d_dp, (/1,1,1/), (/nSeg,ntdh_irf,nens/), ierr, cmessage) - case(ixIRF%irfVol); call get_nc(ncidRestart, meta_irf(iVar)%varName, state(impulseResponseFunc)%var(iVar)%array_2d_dp, (/1,1/), (/nSeg, nens/), ierr, cmessage) - case default; ierr=20; message1=trim(message1)//'unable to identify IRF variable index for nc reading'; return - end select - if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif + do iVar=1,nVarsIRF + select case(iVar) + case(ixIRF%qfuture); call get_nc(ncidRestart, meta_irf(iVar)%varName, state%var(iVar)%array_3d_dp, (/1,1,1/), (/nSeg,ntdh_irf,nens/), ierr, cmessage1) + case(ixIRF%irfVol); call get_nc(ncidRestart, meta_irf(iVar)%varName, state%var(iVar)%array_2d_dp, (/1,1/), (/nSeg, nens/), ierr, cmessage1) + case default; ierr=20; message1=trim(message1)//'unable to identify IRF variable index for nc reading'; return + end select + if(ierr/=0)then; message1=trim(message1)//trim(cmessage1)//':'//trim(meta_irf(iVar)%varName); return; endif + end do + + do iens=1,nens + do iSeg=1,nSeg + allocate(RCHFLX(iens,iSeg)%QFUTURE_IRF(numQF(iens,iSeg)), stat=ierr, errmsg=cmessage1) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage1); return; endif + do iVar=1,nVarsIRF + select case(iVar) + case(ixIRF%qfuture); RCHFLX(iens,iSeg)%QFUTURE_IRF = state%var(iVar)%array_3d_dp(iSeg,1:numQF(iens,iSeg),iens) + case(ixIRF%irfVol); RCHFLX(iens,iSeg)%ROUTE(idxIRF)%REACH_VOL(1) = state%var(iVar)%array_2d_dp(iSeg,iens) + case default; ierr=20; message1=trim(message1)//'unable to identify variable index'; return + end select + enddo ! variable loop + enddo ! seg loop + enddo ! ensemble loop - end do + END SUBROUTINE read_IRF_state - do iens=1,nens - do iSeg=1,nSeg - allocate(RCHFLX(iens,iSeg)%QFUTURE_IRF(numQF(iens,iSeg)), stat=ierr, errmsg=cmessage) - if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif + SUBROUTINE read_KWT_state(ierr, message1) + USE globalData, ONLY: meta_kwt + USE var_lookup, ONLY: ixKWT, nVarsKWT + implicit none + integer(i4b), intent(out) :: ierr ! error code + character(*), intent(out) :: message1 ! error message + ! local + character(len=strLen) :: cmessage1 ! error message of downwind routine + type(states) :: state ! temporal state data structures + integer(i4b) :: iVar,iens,iSeg ! index loops for variables, ensembles, reaches respectively + integer(i4b) :: nwave ! dimenion sizes + integer(i4b), allocatable :: RFvec(:) ! temporal vector + integer(i4b), allocatable :: numWaves(:,:) ! number of waves for each ensemble and segment + ! initialize error control + ierr=0; message1='read_KWT_state/' + + allocate(state%var(nVarsKWT), stat=ierr, errmsg=cmessage1) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage1); return; endif + + allocate(numWaves(nens,nSeg), stat=ierr, errmsg=cmessage1) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage1); return; endif + + ! get Dimension sizes + call get_nc_dim_len(ncidRestart, meta_stateDims(ixStateDims%wave)%dimName, nwave, ierr, cmessage1) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage1); return; endif - do iVar=1,nVarsIRF + do iVar=1,nVarsKWT - select case(iVar) - case(ixIRF%qfuture); RCHFLX(iens,iSeg)%QFUTURE_IRF = state(impulseResponseFunc)%var(iVar)%array_3d_dp(iSeg,1:numQF(iens,iSeg),iens) - case(ixIRF%irfVol); RCHFLX(iens,iSeg)%REACH_VOL(1) = state(impulseResponseFunc)%var(iVar)%array_2d_dp(iSeg,iens) - case default; ierr=20; message1=trim(message1)//'unable to identify variable index'; return - end select + select case(iVar) + case(ixKWT%routed); allocate(state%var(iVar)%array_3d_dp(nSeg, nwave, nens), stat=ierr) + case(ixKWT%tentry, ixKWT%texit, ixKWT%qwave, ixKWT%qwave_mod) + allocate(state%var(iVar)%array_3d_dp(nSeg, nwave, nens), stat=ierr) + case default; ierr=20; message1=trim(message1)//'unable to identify variable index'; return + end select + if(ierr/=0)then; message1=trim(message1)//'problem allocating space for KWT routing state:'//trim(meta_kwt(iVar)%varName); return; endif + end do - enddo ! variable loop - enddo ! seg loop - enddo ! ensemble loop + call get_nc(ncidRestart,'numWaves',numWaves, (/1,1/), (/nSeg,nens/), ierr, cmessage1) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage1); return; endif - END SUBROUTINE read_IRF_state + do iVar=1,nVarsKWT + select case(iVar) + case(ixKWT%routed) + call get_nc(ncidRestart, meta_kwt(iVar)%varName, state%var(iVar)%array_3d_dp, (/1,1,1/), (/nSeg,nwave,nens/), ierr, cmessage1) + case(ixKWT%tentry, ixKWT%texit, ixKWT%qwave, ixKWT%qwave_mod) + call get_nc(ncidRestart, meta_kwt(iVar)%varName, state%var(iVar)%array_3d_dp, (/1,1,1/), (/nSeg,nwave,nens/), ierr, cmessage1) + case default; ierr=20; message1=trim(message1)//'unable to identify KWT variable index for nc reading'; return + end select + if(ierr/=0)then; message1=trim(message1)//trim(cmessage1)//':'//trim(meta_kwt(iVar)%varName); return; endif + end do + + do iens=1,nens + do iSeg=1,nSeg + allocate(RCHSTA(iens,iSeg)%LKW_ROUTE%KWAVE(0:numWaves(iens,iSeg)-1), stat=ierr) + do iVar=1,nVarsKWT + select case(iVar) + case(ixKWT%tentry); RCHSTA(iens,iSeg)%LKW_ROUTE%KWAVE(0:numWaves(iens,iSeg)-1)%TI = state%var(iVar)%array_3d_dp(iSeg,1:numWaves(iens,iSeg),iens) + case(ixKWT%texit); RCHSTA(iens,iSeg)%LKW_ROUTE%KWAVE(0:numWaves(iens,iSeg)-1)%TR = state%var(iVar)%array_3d_dp(iSeg,1:numWaves(iens,iSeg),iens) + case(ixKWT%qwave); RCHSTA(iens,iSeg)%LKW_ROUTE%KWAVE(0:numWaves(iens,iSeg)-1)%QF = state%var(iVar)%array_3d_dp(iSeg,1:numWaves(iens,iSeg),iens) + case(ixKWT%qwave_mod); RCHSTA(iens,iSeg)%LKW_ROUTE%KWAVE(0:numWaves(iens,iSeg)-1)%QM = state%var(iVar)%array_3d_dp(iSeg,1:numWaves(iens,iSeg),iens) + case(ixKWT%routed) ! this is suppposed to be logical variable, but put it as 0 or 1 in double now + if (allocated(RFvec)) deallocate(RFvec, stat=ierr) + allocate(RFvec(0:numWaves(iens,iSeg)-1),stat=ierr) + RFvec = nint(state%var(iVar)%array_3d_dp(iSeg,1:numWaves(iens,iSeg),iens)) + RCHSTA(iens,iSeg)%LKW_ROUTE%KWAVE(0:numWaves(iens,iSeg)-1)%RF=.False. + where (RFvec==1_i4b) RCHSTA(iens,iSeg)%LKW_ROUTE%KWAVE(0:numWaves(iens,iSeg)-1)%RF=.True. + case default; ierr=20; message1=trim(message1)//'unable to identify KWT routing state variable index'; return + end select + end do + end do + end do + END SUBROUTINE read_KWT_state - SUBROUTINE read_KWT_state(ierr, message1) - ! meta data - USE globalData, ONLY: meta_kwt ! kwt routing - ! State/flux data structures - USE globalData, ONLY: KROUTE ! KWT routing state - ! Named variables - USE var_lookup, ONLY: ixKWT, nVarsKWT - implicit none - integer(i4b), intent(out) :: ierr ! error code - character(*), intent(out) :: message1 ! error message - ! output - integer(i4b) :: iVar,iens,iSeg ! index loops for variables, ensembles, reaches respectively - integer(i4b) :: nwave ! dimenion sizes - integer(i4b), allocatable :: RFvec(:) ! temporal vector - integer(i4b), allocatable :: numWaves(:,:) ! number of waves for each ensemble and segment - ! initialize error control - ierr=0; message1='read_KWT_state/' - - allocate(state(kinematicWave)%var(nVarsKWT), stat=ierr, errmsg=cmessage) - if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif - - allocate(numWaves(nens,nSeg), stat=ierr, errmsg=cmessage) - if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif - - ! get Dimension sizes - call get_nc_dim_len(ncidRestart, meta_stateDims(ixStateDims%wave)%dimName, nwave, ierr, cmessage) - if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif - - do iVar=1,nVarsKWT - - select case(iVar) - case(ixKWT%routed); allocate(state(kinematicWave)%var(iVar)%array_3d_dp(nSeg, nwave, nens), stat=ierr) - case(ixKWT%tentry, ixKWT%texit, ixKWT%qwave, ixKWT%qwave_mod) - allocate(state(kinematicWave)%var(iVar)%array_3d_dp(nSeg, nwave, nens), stat=ierr) - case default; ierr=20; message1=trim(message1)//'unable to identify variable index'; return - end select - if(ierr/=0)then; message1=trim(message1)//'problem allocating space for KWT routing state '//trim(meta_kwt(iVar)%varName); return; endif - end do - - call get_nc(ncidRestart,'numWaves',numWaves, (/1,1/), (/nSeg,nens/), ierr, cmessage) - if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif - - do iVar=1,nVarsKWT - - select case(iVar) - case(ixKWT%routed) - call get_nc(ncidRestart, meta_kwt(iVar)%varName, state(kinematicWave)%var(iVar)%array_3d_dp, (/1,1,1/), (/nSeg,nwave,nens/), ierr, cmessage) - case(ixKWT%tentry, ixKWT%texit, ixKWT%qwave, ixKWT%qwave_mod) - call get_nc(ncidRestart, meta_kwt(iVar)%varName, state(kinematicWave)%var(iVar)%array_3d_dp, (/1,1,1/), (/nSeg,nwave,nens/), ierr, cmessage) - case default; ierr=20; message1=trim(message)//'unable to identify KWT variable index for nc reading'; return - end select - if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif - end do - - do iens=1,nens - do iSeg=1,nSeg - - allocate(KROUTE(iens,iSeg)%KWAVE(0:numWaves(iens,iSeg)-1), stat=ierr) - do iVar=1,nVarsKWT + SUBROUTINE read_KW_state(ierr, message1) + USE globalData, ONLY: meta_kw + USE globalData, ONLY: nMolecule + USE var_lookup, ONLY: ixKW, nVarsKW + implicit none + integer(i4b), intent(out) :: ierr ! error code + character(*), intent(out) :: message1 ! error message + ! local variables + character(len=strLen) :: cmessage1 ! error message of downwind routine + type(states) :: state ! temporal state data structures + integer(i4b) :: iVar,iens,iSeg ! index loops for variables, ensembles, reaches respectively + + ierr=0; message1='read_KW_state/' + + allocate(state%var(nVarsKW), stat=ierr, errmsg=cmessage1) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage1); return; endif + + ! get Dimension sizes + call get_nc_dim_len(ncidRestart, trim(meta_stateDims(ixStateDims%mol_kw)%dimName), nMolecule%KW_ROUTE, ierr, cmessage1) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage1); return; endif + + do iVar=1,nVarsKW + select case(iVar) + case(ixKW%qsub); allocate(state%var(iVar)%array_3d_dp(nSeg, nMolecule%KW_ROUTE, nens), stat=ierr) + case default; ierr=20; message1=trim(message1)//'unable to identify variable index'; return + end select + if(ierr/=0)then; message1=trim(message1)//'problem allocating space for KW routing state:'//trim(meta_kw(iVar)%varName); return; endif + end do + + do iVar=1,nVarsKW + select case(iVar) + case(ixKW%qsub) + call get_nc(ncidRestart, trim(meta_kw(iVar)%varName), state%var(iVar)%array_3d_dp, (/1,1,1/), (/nSeg,nMolecule%KW_ROUTE,nens/), ierr, cmessage1) + case default; ierr=20; message1=trim(message1)//'unable to identify KW variable index for nc reading'; return + end select + if(ierr/=0)then; message1=trim(message1)//trim(cmessage1)//':'//trim(meta_kw(iVar)%varName); return; endif + end do + + do iens=1,nens + do iSeg=1,nSeg + allocate(RCHSTA(iens,iSeg)%KW_ROUTE%molecule%Q(nMolecule%KW_ROUTE), stat=ierr) + do iVar=1,nVarsKW + select case(iVar) + case(ixKW%qsub); RCHSTA(iens,iSeg)%KW_ROUTE%molecule%Q(1:nMolecule%KW_ROUTE) = state%var(iVar)%array_3d_dp(iSeg,1:nMolecule%KW_ROUTE,iens) + case default; ierr=20; message1=trim(message1)//'unable to identify KW routing state variable index'; return + end select + enddo + enddo + enddo - select case(iVar) - case(ixKWT%tentry); KROUTE(iens,iSeg)%KWAVE(0:numWaves(iens,iSeg)-1)%TI = state(kinematicWave)%var(iVar)%array_3d_dp(iSeg,1:numWaves(iens,iSeg),iens) - case(ixKWT%texit); KROUTE(iens,iSeg)%KWAVE(0:numWaves(iens,iSeg)-1)%TR = state(kinematicWave)%var(iVar)%array_3d_dp(iSeg,1:numWaves(iens,iSeg),iens) - case(ixKWT%qwave); KROUTE(iens,iSeg)%KWAVE(0:numWaves(iens,iSeg)-1)%QF = state(kinematicWave)%var(iVar)%array_3d_dp(iSeg,1:numWaves(iens,iSeg),iens) - case(ixKWT%qwave_mod); KROUTE(iens,iSeg)%KWAVE(0:numWaves(iens,iSeg)-1)%QM = state(kinematicWave)%var(iVar)%array_3d_dp(iSeg,1:numWaves(iens,iSeg),iens) - case(ixKWT%routed) ! this is suppposed to be logical variable, but put it as 0 or 1 in double now - if (allocated(RFvec)) deallocate(RFvec, stat=ierr) - allocate(RFvec(0:numWaves(iens,iSeg)-1),stat=ierr) - RFvec = nint(state(kinematicWave)%var(iVar)%array_3d_dp(iSeg,1:numWaves(iens,iSeg),iens)) - KROUTE(iens,iSeg)%KWAVE(0:numWaves(iens,iSeg)-1)%RF=.False. - where (RFvec==1_i4b) KROUTE(iens,iSeg)%KWAVE(0:numWaves(iens,iSeg)-1)%RF=.True. - case default; ierr=20; message1=trim(message1)//'unable to identify KWT routing state variable index'; return - end select + END SUBROUTINE read_KW_state + + + SUBROUTINE read_MC_state(ierr, message1) + USE globalData, ONLY: meta_mc + USE globalData, ONLY: nMolecule + USE var_lookup, ONLY: ixMC, nVarsMC + implicit none + integer(i4b), intent(out) :: ierr ! error code + character(*), intent(out) :: message1 ! error message + ! local variables + character(len=strLen) :: cmessage1 ! error message of downwind routine + type(states) :: state ! temporal state data structures + integer(i4b) :: iVar,iens,iSeg ! index loops for variables, ensembles, reaches respectively + + ierr=0; message1='read_MC_state/' + + allocate(state%var(nVarsMC), stat=ierr, errmsg=cmessage1) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage1); return; endif + + ! get Dimension sizes + call get_nc_dim_len(ncidRestart, trim(meta_stateDims(ixStateDims%mol_mc)%dimName), nMolecule%MC_ROUTE, ierr, cmessage1) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage1); return; endif + + do iVar=1,nVarsMC + select case(iVar) + case(ixMC%qsub); allocate(state%var(iVar)%array_3d_dp(nSeg, nMolecule%MC_ROUTE, nens), stat=ierr) + case default; ierr=20; message1=trim(message1)//'unable to identify variable index'; return + end select + if(ierr/=0)then; message1=trim(message1)//'problem allocating space for MC routing state:'//trim(meta_mc(iVar)%varName); return; endif + end do + + do iVar=1,nVarsMC + select case(iVar) + case(ixMC%qsub) + call get_nc(ncidRestart, trim(meta_mc(iVar)%varName), state%var(iVar)%array_3d_dp, (/1,1,1/), (/nSeg,nMolecule%MC_ROUTE,nens/), ierr, cmessage1) + case default; ierr=20; message1=trim(message1)//'unable to identify MC variable index for nc reading'; return + end select + if(ierr/=0)then; message1=trim(message1)//trim(cmessage1)//':'//trim(meta_mc(iVar)%varName); return; endif + end do + + do iens=1,nens + do iSeg=1,nSeg + allocate(RCHSTA(iens,iSeg)%MC_ROUTE%molecule%Q(nMolecule%MC_ROUTE), stat=ierr) + do iVar=1,nVarsMC + select case(iVar) + case(ixMC%qsub); RCHSTA(iens,iSeg)%MC_ROUTE%molecule%Q(1:nMolecule%MC_ROUTE) = state%var(iVar)%array_3d_dp(iSeg,1:nMolecule%MC_ROUTE,iens) + case default; ierr=20; message1=trim(message1)//'unable to identify MC routing state variable index'; return + end select + enddo + enddo + enddo + END SUBROUTINE read_MC_state + + + SUBROUTINE read_DW_state(ierr, message1) + USE globalData, ONLY: meta_dw + USE globalData, ONLY: nMolecule + USE var_lookup, ONLY: ixDW, nVarsDW + implicit none + integer(i4b), intent(out) :: ierr ! error code + character(*), intent(out) :: message1 ! error message + ! local variables + character(len=strLen) :: cmessage1 ! error message of downwind routine + type(states) :: state ! temporal state data structures + integer(i4b) :: iVar,iens,iSeg ! index loops for variables, ensembles, reaches respectively + + ierr=0; message1='read_DW_state/' + + allocate(state%var(nVarsDW), stat=ierr, errmsg=cmessage1) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage1); return; endif + + ! get Dimension sizes + call get_nc_dim_len(ncidRestart, trim(meta_stateDims(ixStateDims%mol_dw)%dimName), nMolecule%DW_ROUTE, ierr, cmessage1) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage1); return; endif + + do iVar=1,nVarsDW + select case(iVar) + case(ixDW%qsub); allocate(state%var(iVar)%array_3d_dp(nSeg, nMolecule%DW_ROUTE, nens), stat=ierr) + case default; ierr=20; message1=trim(message1)//'unable to identify variable index'; return + end select + if(ierr/=0)then; message1=trim(message1)//'problem allocating space for DW routing state:'//trim(meta_dw(iVar)%varName); return; endif + end do + + do iVar=1,nVarsDW + select case(iVar) + case(ixDW%qsub) + call get_nc(ncidRestart, trim(meta_dw(iVar)%varName), state%var(iVar)%array_3d_dp, (/1,1,1/), (/nSeg,nMolecule%DW_ROUTE,nens/), ierr, cmessage1) + case default; ierr=20; message1=trim(message1)//'unable to identify DW variable index for nc reading'; return + end select + if(ierr/=0)then; message1=trim(message1)//trim(cmessage1)//':'//trim(meta_dw(iVar)%varName); return; endif + end do + + do iens=1,nens + do iSeg=1,nSeg + allocate(RCHSTA(iens,iSeg)%DW_ROUTE%molecule%Q(nMolecule%DW_ROUTE), stat=ierr) + do iVar=1,nVarsDW + select case(iVar) + case(ixDW%qsub); RCHSTA(iens,iSeg)%DW_ROUTE%molecule%Q(1:nMolecule%DW_ROUTE) = state%var(iVar)%array_3d_dp(iSeg,1:nMolecule%DW_ROUTE,iens) + case default; ierr=20; message1=trim(message1)//'unable to identify DW routing state variable index'; return + end select + enddo + enddo enddo - enddo - enddo - END SUBROUTINE read_KWT_state + END SUBROUTINE read_DW_state END SUBROUTINE read_state_nc - END MODULE read_restart diff --git a/route/build/src/time_utils.f90 b/route/build/src/time_utils.f90 index 6d564820..c4454356 100644 --- a/route/build/src/time_utils.f90 +++ b/route/build/src/time_utils.f90 @@ -60,6 +60,7 @@ end function isLeapYear ! public subroutine: get number of days within a month ! ****************************************************************************************** subroutine ndays_month(yr, mo, calendar, ndays, ierr, message) + USE ascii_util_module, ONLY : lower ! convert string to lower case implicit none ! input integer(i4b),intent(in) :: yr @@ -76,7 +77,7 @@ subroutine ndays_month(yr, mo, calendar, ndays, ierr, message) ierr=0; message="ndays_month/" - select case(trim(calendar)) + select case(lower(trim(calendar))) case ('standard','gregorian','proleptic_gregorian') call compJulday(yr,mo,1,0,0,0._dp,julday1,ierr,cmessage) case('noleap') @@ -92,7 +93,7 @@ subroutine ndays_month(yr, mo, calendar, ndays, ierr, message) yr_next = yr mo_next = mo+1 end if - select case(trim(calendar)) + select case(lower(trim(calendar))) case ('standard','gregorian','proleptic_gregorian') call compJulday(yr_next,mo_next,1,0,0,0._dp,julday2,ierr,cmessage) case('noleap') diff --git a/route/build/src/var_lookup.f90 b/route/build/src/var_lookup.f90 index e6354851..f5e60c95 100644 --- a/route/build/src/var_lookup.f90 +++ b/route/build/src/var_lookup.f90 @@ -38,6 +38,9 @@ MODULE var_lookup integer(i4b) :: tbound = integerMissing ! 2 elelment time bound vector integer(i4b) :: ens = integerMissing ! runoff ensemble integer(i4b) :: wave = integerMissing ! waves in a channel + integer(i4b) :: mol_kw = integerMissing ! kw finite difference computational molecule + integer(i4b) :: mol_mc = integerMissing ! mc finite difference computational molecule + integer(i4b) :: mol_dw = integerMissing ! dw finite difference computational molecule integer(i4b) :: tdh_irf = integerMissing ! irf routed future channel flow in a segment integer(i4b) :: tdh = integerMissing ! uh routed future overland flow endtype iLook_stateDims @@ -136,12 +139,19 @@ MODULE var_lookup integer(i4b) :: dlayRunoff = integerMissing ! delayed runoff in each reac integer(i4b) :: sumUpstreamRunoff = integerMissing ! sum of upstream runoff in each reach integer(i4b) :: KWTroutedRunoff = integerMissing ! Lagrangian KWT routed runoff in each reach + integer(i4b) :: KWroutedRunoff = integerMissing ! KW routed runoff in each reach + integer(i4b) :: MCroutedRunoff = integerMissing ! muskingum-cunge routed runoff in each reach + integer(i4b) :: DWroutedRunoff = integerMissing ! diffusive wave routed runoff in each reach integer(i4b) :: IRFroutedRunoff = integerMissing ! IRF routed runoff in each reach + integer(i4b) :: volume = integerMissing ! water volume endtype iLook_RFLX + ! Reach inflow from basin + type, public :: iLook_basinQ + integer(i4b) :: q = integerMissing ! final discharge + endtype iLook_basinQ ! Basin IRF state/fluxes type, public :: iLook_IRFbas integer(i4b) :: qfuture = integerMissing ! future routed flow - integer(i4b) :: q = integerMissing ! final discharge endtype iLook_IRFbas ! KWT state/fluxes type, public :: iLook_KWT @@ -151,6 +161,18 @@ MODULE var_lookup integer(i4b) :: qwave_mod = integerMissing ! wave flow after merged integer(i4b) :: routed = integerMissing ! Routed out of a segment or not endtype iLook_KWT + ! KW state/fluxes + type, public :: iLook_KW + integer(i4b) :: qsub = integerMissing ! discharge + endtype iLook_KW + ! DW state/fluxes + type, public :: iLook_DW + integer(i4b) :: qsub = integerMissing ! discharge + endtype iLook_DW + ! MC state/fluxes + type, public :: iLook_MC + integer(i4b) :: qsub = integerMissing ! discharge + endtype iLook_MC !IRF state/fluxes type, public :: iLook_IRF integer(i4b) :: qfuture = integerMissing ! future routed flow @@ -161,17 +183,21 @@ MODULE var_lookup ! *********************************************************************************************************** type(iLook_struct) ,public,parameter :: ixStruct = iLook_struct (1,2,3,4,5) type(iLook_dims) ,public,parameter :: ixDims = iLook_dims (1,2,3,4,5,6,7) - type(iLook_stateDims),public,parameter :: ixStateDims = iLook_stateDims(1,2,3,4,5,6,7) + type(iLook_stateDims),public,parameter :: ixStateDims = iLook_stateDims(1,2,3,4,5,6,7,8,9,10) type(iLook_qDims) ,public,parameter :: ixqDims = iLook_qDims (1,2,3,4) type(iLook_HRU) ,public,parameter :: ixHRU = iLook_HRU (1) type(iLook_HRU2SEG) ,public,parameter :: ixHRU2SEG = iLook_HRU2SEG (1,2,3,4) type(iLook_SEG) ,public,parameter :: ixSEG = iLook_SEG (1,2,3,4,5,6,7,8,9,10,11,12,13,14) type(iLook_NTOPO) ,public,parameter :: ixNTOPO = iLook_NTOPO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17) type(iLook_PFAF) ,public,parameter :: ixPFAF = iLook_PFAF (1) - type(iLook_RFLX) ,public,parameter :: ixRFLX = iLook_RFLX (1,2,3,4,5,6) + type(iLook_RFLX) ,public,parameter :: ixRFLX = iLook_RFLX (1,2,3,4,5,6,7,8,9,10) type(iLook_KWT) ,public,parameter :: ixKWT = iLook_KWT (1,2,3,4,5) + type(iLook_KW) ,public,parameter :: ixKW = iLook_KW (1) + type(iLook_DW) ,public,parameter :: ixDW = iLook_DW (1) + type(iLook_MC) ,public,parameter :: ixMC = iLook_MC (1) type(iLook_IRF) ,public,parameter :: ixIRF = iLook_IRF (1,2) - type(iLook_IRFbas ) ,public,parameter :: ixIRFbas = iLook_IRFbas (1,2) + type(iLook_IRFbas ) ,public,parameter :: ixIRFbas = iLook_IRFbas (1) + type(iLook_basinQ ) ,public,parameter :: ixBasinQ = iLook_basinQ (1) ! *********************************************************************************************************** ! ** define size of data vectors ! *********************************************************************************************************** @@ -185,9 +211,13 @@ MODULE var_lookup integer(i4b),parameter,public :: nVarsNTOPO = storage_size(ixNTOPO )/iLength integer(i4b),parameter,public :: nVarsPFAF = storage_size(ixPFAF )/iLength integer(i4b),parameter,public :: nVarsRFLX = storage_size(ixRFLX )/iLength - integer(i4b),parameter,public :: nVarsKWT = storage_size(ixKWT )/iLength - integer(i4b),parameter,public :: nVarsIRF = storage_size(ixIRF )/iLength - integer(i4b),parameter,public :: nVarsIRFbas = storage_size(ixIRFbas )/iLength + integer(i4b),parameter,public :: nVarsKWT = storage_size(ixKWT )/iLength + integer(i4b),parameter,public :: nVarsKW = storage_size(ixKW )/iLength + integer(i4b),parameter,public :: nVarsDW = storage_size(ixDW )/iLength + integer(i4b),parameter,public :: nVarsMC = storage_size(ixMC )/iLength + integer(i4b),parameter,public :: nVarsIRF = storage_size(ixIRF )/iLength + integer(i4b),parameter,public :: nVarsIRFbas = storage_size(ixIRFbas )/iLength + integer(i4b),parameter,public :: nVarsBasinQ = storage_size(ixBasinQ )/iLength ! *********************************************************************************************************** END MODULE var_lookup diff --git a/route/build/src/write_restart.f90 b/route/build/src/write_restart.f90 index 87da7434..c855f33f 100644 --- a/route/build/src/write_restart.f90 +++ b/route/build/src/write_restart.f90 @@ -1,19 +1,29 @@ MODULE write_restart -! Moudle wide external modules -USE nrtype, ONLY: i4b, dp, lgt, strLen -USE public_var +USE nrtype USE date_time, ONLY: datetime USE io_netcdf, ONLY: ncd_int USE io_netcdf, ONLY: ncd_float, ncd_double USE io_netcdf, ONLY: ncd_unlimited -USE io_netcdf, only: def_nc ! define netcdf +USE io_netcdf, ONLY: def_nc ! define netcdf USE io_netcdf, ONLY: def_var ! define netcdf variable +USE io_netcdf, ONLY: put_global_attr ! write global attribute USE io_netcdf, ONLY: def_dim ! define netcdf dimension USE io_netcdf, ONLY: end_def ! end defining netcdf -USE io_netcdf, only: open_nc ! open netcdf +USE io_netcdf, ONLY: open_nc ! open netcdf USE io_netcdf, ONLY: close_nc ! close netcdf USE io_netcdf, ONLY: write_nc +USE globalData, ONLY: onRoute ! logical to indicate which routing method(s) is on +USE public_var, ONLY: iulog ! i/o logical unit number +USE public_var, ONLY: integerMissing +USE public_var, ONLY: realMissing +USE public_var, ONLY: dt +USE public_var, ONLY: doesBasinRoute +USE public_var, ONLY: impulseResponseFunc +USE public_var, ONLY: kinematicWaveTracking +USE public_var, ONLY: kinematicWave +USE public_var, ONLY: muskingumCunge +USE public_var, ONLY: diffusiveWave implicit none @@ -58,6 +68,7 @@ END SUBROUTINE main_restart ! ********************************************************************* SUBROUTINE restart_alarm(ierr, message) + USE ascii_util_module, ONLY: lower USE public_var, ONLY: calendar USE public_var, ONLY: restart_write ! restart write options USE public_var, ONLY: restart_day @@ -91,19 +102,19 @@ SUBROUTINE restart_alarm(ierr, message) if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif end if - select case(trim(restart_write)) - case('Specified','specified','Last','last') + select case(lower(trim(restart_write))) + case('specified','last') restartAlarm = (dropCal==modTime(1)) - case('Annual','annual') + case('yearly') restartAlarm = (dropCal%is_equal_mon(modTime(1)) .and. dropCal%is_equal_day(modTime(1)) .and. dropCal%is_equal_time(modTime(1))) - case('Monthly','monthly') + case('monthly') restartAlarm = (dropCal%is_equal_day(modTime(1)) .and. dropCal%is_equal_time(modTime(1))) - case('Daily','daily') + case('daily') restartAlarm = dropCal%is_equal_time(modTime(1)) - case('Never','never') + case('never') restartAlarm = .false. case default - ierr=20; message=trim(message)//'Current accepted options: L[l]ast, N[n]ever, S[s]pecified, Annual, Monthly, or Daily '; return + ierr=20; message=trim(message)//'Accepted options (case insensitive): last, never, specified, yearly, monthly, or daily '; return end select END SUBROUTINE restart_alarm @@ -114,10 +125,6 @@ END SUBROUTINE restart_alarm ! ********************************************************************* SUBROUTINE restart_output(ierr, message) - USE public_var, ONLY: routOpt - USE public_var, ONLY: time_units - USE public_var, ONLY: dt - USE globalData, ONLY: runoff_data ! runoff data for one time step for LSM HRUs and River network HRUs USE globalData, ONLY: TSEC USE globalData, ONLY: reachID @@ -136,7 +143,7 @@ SUBROUTINE restart_output(ierr, message) call restart_fname(fnameRestart, nextTimeStep, ierr, cmessage) if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif - call define_state_nc(fnameRestart, time_units, routOpt, ierr, cmessage) + call define_state_nc(fnameRestart, ierr, cmessage) if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif ! update model time step bound @@ -144,8 +151,7 @@ SUBROUTINE restart_output(ierr, message) TSEC2 = TSEC1 + dt call write_state_nc(fnameRestart, & ! Input: state netcdf name - routOpt, & ! input: which routing options - runoff_data%time, 1, TSEC1, TSEC2, & ! Input: time, time step, start and end time [sec] + TSEC1, TSEC2, & ! Input: time, time step, start and end time [sec] reachID, & ! Input: segment id vector ierr, message) ! Output: error control if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif @@ -162,7 +168,6 @@ SUBROUTINE restart_fname(fnameRestart, timeStamp, ierr, message) USE public_var, ONLY: case_name ! simulation name ==> output filename head USE public_var, ONLY: calendar USE public_var, ONLY: secprday - USE public_var, ONLY: dt USE globalData, ONLY: modTime ! current model datetime implicit none @@ -203,32 +208,33 @@ END SUBROUTINE restart_fname ! subroutine: define restart NetCDF file ! ********************************************************************* SUBROUTINE define_state_nc(fname, & ! input: filename - units_time, & ! input: time units - opt, & ! input: which routing options (state variables depends on routing options) ierr, message) ! output: error control - ! External modules + USE globalData, ONLY: meta_stateDims + USE globalData, ONLY: modTime ! current model datetime + USE public_var, ONLY: calendar USE var_lookup, ONLY: ixStateDims, nStateDims + implicit none + ! input variables character(*), intent(in) :: fname ! filename - integer(i4b), intent(in) :: opt ! routing option 0=all, 1=kwt, 2=irf - character(*), intent(in) :: units_time ! time units ! output variables integer(i4b), intent(out) :: ierr ! error code character(*), intent(out) :: message ! error message ! local variables + type(datetime) :: timeStampCal ! datetime corresponding to file name time stamp + character(len=50),parameter :: fmtYMDHMS='(I0.4,a,I0.2,a,I0.2,x,I0.2,a,I0.2,a,I0.2)' + character(len=strLen) :: globalDesc ! global attributes: description integer(i4b) :: jDim ! loop index for dimension integer(i4b) :: ncid ! NetCDF file ID - integer(i4b) :: ixDim_common(4) ! custom dimension ID array + integer(i4b) :: ixDim_common(3) ! custom dimension ID array character(len=strLen) :: cmessage ! error message of downwind routine - ! initialize error control ierr=0; message='define_state_nc/' associate(dim_seg => meta_stateDims(ixStateDims%seg)%dimName, & dim_ens => meta_stateDims(ixStateDims%ens)%dimName, & - dim_time => meta_stateDims(ixStateDims%time)%dimName, & dim_tbound => meta_stateDims(ixStateDims%tbound)%dimName) ! Create file @@ -236,50 +242,73 @@ SUBROUTINE define_state_nc(fname, & ! input: filename if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif ! For common dimension/variables - seg id, time, time-bound ----------- - ixDim_common = (/ixStateDims%seg, ixStateDims%ens, ixStateDims%time, ixStateDims%tbound/) + ixDim_common = (/ixStateDims%seg, ixStateDims%ens, ixStateDims%tbound/) ! Define dimensions do jDim = 1,size(ixDim_common) - associate(ixDim_tmp => ixDim_common(jDim)) - if (meta_stateDims(ixDim_tmp)%dimLength == integerMissing) then - call set_dim_len(ixDim_tmp, ierr, cmessage) - if(ierr/=0)then; message=trim(message)//trim(cmessage)//' for '//trim(meta_stateDims(ixDim_tmp)%dimName); return; endif - endif - call def_dim(ncid, meta_stateDims(ixDim_tmp)%dimName, meta_stateDims(ixDim_tmp)%dimLength, meta_stateDims(ixDim_tmp)%dimId, ierr, cmessage) - if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif - end associate + associate(ixDim_tmp => ixDim_common(jDim)) + if (meta_stateDims(ixDim_tmp)%dimLength == integerMissing) then + call set_dim_len(ixDim_tmp, ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage)//' for '//trim(meta_stateDims(ixDim_tmp)%dimName); return; endif + endif + call def_dim(ncid, meta_stateDims(ixDim_tmp)%dimName, meta_stateDims(ixDim_tmp)%dimLength, meta_stateDims(ixDim_tmp)%dimId, ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + end associate end do ! Define variable call def_var(ncid, 'reachID', (/dim_seg/), ncd_int, ierr, cmessage, vdesc='reach ID', vunit='-') if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif - call def_var(ncid, 'time ', (/dim_time/), ncd_double, ierr, cmessage, vdesc='time', vunit=units_time) + call def_var(ncid,'time_bound', (/dim_tbound/), ncd_double, ierr, cmessage, vdesc='time bound at last time step', vunit='sec') if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif - call def_var(ncid,'time_bound', (/dim_tbound, dim_time/), ncd_double, ierr, cmessage, vdesc='time bound at last time step', vunit='sec') + end associate + + ! Write global attribute + call put_global_attr(ncid, 'Title', 'mizuRoute restart file', ierr, cmessage) if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif - end associate + ! get which time is for restarting + timeStampCal = modTime(1)%add_sec(dt, calendar, ierr, cmessage) + write(globalDesc, fmtYMDHMS) timeStampCal%year(),'-',timeStampCal%month(),'-',timeStampCal%day(),timeStampCal%hour(),':',timeStampCal%minute(),':',nint(timeStampCal%sec()) - ! Routing specific variables -------------- + call put_global_attr(ncid, 'Restart time', trim(globalDesc), ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + + ! previous-time step hru inflow into reach + call define_basinQ_state(ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif - ! basin IRF + ! Routing specific variables -------------- if (doesBasinRoute == 1) then call define_IRFbas_state(ierr, cmessage) if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif end if - ! KWT routing - if (opt==allRoutingMethods .or. opt==kinematicWave) then - call define_KWT_state(ierr, cmessage) - if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + if (onRoute(kinematicWaveTracking)) then + call define_KWT_state(ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif end if - ! IRF routing - if (opt==allRoutingMethods .or. opt==impulseResponseFunc) then - call define_IRF_state(ierr, cmessage) - if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + if (onRoute(impulseResponseFunc))then + call define_IRF_state(ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + end if + + if (onRoute(kinematicWave)) then + call define_KW_state(ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + end if + + if (onRoute(muskingumCunge)) then + call define_MC_state(ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + end if + + if (onRoute(diffusiveWave)) then + call define_DW_state(ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif end if ! Finishing up definition ------- @@ -294,11 +323,15 @@ SUBROUTINE define_state_nc(fname, & ! input: filename CONTAINS SUBROUTINE set_dim_len(ixDim, ierr, message1) - ! State/flux data structures + USE globalData, ONLY: meta_stateDims ! states dimension meta USE globalData, ONLY: nRch + USE globalData, ONLY: nMolecule + USE public_var, ONLY: MAXQPAR USE globalData, ONLY: FRAC_FUTURE ! To get size of q future for basin IRF + implicit none + ! input integer(i4b), intent(in) :: ixDim ! ixDim ! output @@ -309,37 +342,79 @@ SUBROUTINE set_dim_len(ixDim, ierr, message1) ierr=0; message1='set_dim_len/' select case(ixDim) - case(ixStateDims%time); meta_stateDims(ixStateDims%time)%dimLength = ncd_unlimited - case(ixStateDims%seg); meta_stateDims(ixStateDims%seg)%dimLength = nRch - case(ixStateDims%ens); meta_stateDims(ixStateDims%ens)%dimLength = 1 - case(ixStateDims%tbound); meta_stateDims(ixStateDims%tbound)%dimLength = 2 - case(ixStateDims%tdh); meta_stateDims(ixStateDims%tdh)%dimLength = size(FRAC_FUTURE) - case(ixStateDims%tdh_irf); meta_stateDims(ixStateDims%tdh_irf)%dimLength = 50 !just temporarily - case(ixStateDims%wave); meta_stateDims(ixStateDims%wave)%dimLength = MAXQPAR - case default; ierr=20; message1=trim(message1)//'unable to identify dimension variable index'; return + case(ixStateDims%time); meta_stateDims(ixStateDims%time)%dimLength = ncd_unlimited + case(ixStateDims%seg); meta_stateDims(ixStateDims%seg)%dimLength = nRch + case(ixStateDims%ens); meta_stateDims(ixStateDims%ens)%dimLength = 1 + case(ixStateDims%tbound); meta_stateDims(ixStateDims%tbound)%dimLength = 2 + case(ixStateDims%tdh); meta_stateDims(ixStateDims%tdh)%dimLength = size(FRAC_FUTURE) + case(ixStateDims%tdh_irf); meta_stateDims(ixStateDims%tdh_irf)%dimLength = 50 !just temporarily + case(ixStateDims%wave); meta_stateDims(ixStateDims%wave)%dimLength = MAXQPAR + case(ixStateDims%mol_kw); meta_stateDims(ixStateDims%mol_kw)%dimLength = nMolecule%KW_ROUTE + case(ixStateDims%mol_mc); meta_stateDims(ixStateDims%mol_mc)%dimLength = nMolecule%MC_ROUTE + case(ixStateDims%mol_dw); meta_stateDims(ixStateDims%mol_dw)%dimLength = nMolecule%DW_ROUTE + case default; ierr=20; message1=trim(message1)//'unable to identify dimension variable index'; return end select END SUBROUTINE + + SUBROUTINE define_basinQ_state(ierr, message1) + + USE globalData, ONLY: meta_basinQ + USE var_lookup, ONLY: ixBasinQ, nVarsBasinQ + + implicit none + + ! output + integer(i4b), intent(out) :: ierr ! error code + character(*), intent(out) :: message1 ! error message + ! local + integer(i4b) :: iVar,ixDim ! index loop for variables + integer(i4b) :: nDims ! number of dimensions + character(len=strLen),allocatable :: dim_set(:) ! dimensions combination + + ! initialize error control + ierr=0; message1='define_basinQ_state/' + + associate(dim_seg => meta_stateDims(ixStateDims%seg)%dimName, & + dim_ens => meta_stateDims(ixStateDims%ens)%dimName) + + do iVar=1,nVarsBasinQ + nDims = size(meta_basinQ(iVar)%varDim) + if (allocated(dim_set)) deallocate(dim_set) + allocate(dim_set(nDims)) + + do ixDim = 1, nDims + dim_set(ixDim) = meta_stateDims(meta_basinQ(iVar)%varDim(ixDim))%dimName + end do + + call def_var(ncid, meta_basinQ(iVar)%varName, dim_set, meta_basinQ(iVar)%varType, ierr, cmessage, vdesc=meta_basinQ(iVar)%varDesc, vunit=meta_basinQ(iVar)%varUnit ) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif + end do + end associate + + END SUBROUTINE define_basinQ_state + + SUBROUTINE define_IRFbas_state(ierr, message1) - ! External modules + USE globalData, ONLY: meta_irf_bas USE var_lookup, ONLY: ixIRFbas, nVarsIRFbas + implicit none + ! output integer(i4b), intent(out) :: ierr ! error code character(*), intent(out) :: message1 ! error message ! local integer(i4b) :: iVar,ixDim ! index loop for variables integer(i4b) :: nDims ! number of dimensions - character(len=strLen),allocatable :: dim_IRFbas(:) ! dimensions combination case 4 + character(len=strLen),allocatable :: dim_set(:) ! dimensions combination case 4 - ! initialize error control ierr=0; message1='define_IRFbas_state/' associate(dim_seg => meta_stateDims(ixStateDims%seg)%dimName, & dim_ens => meta_stateDims(ixStateDims%ens)%dimName, & - dim_time => meta_stateDims(ixStateDims%time)%dimName, & dim_tdh => meta_stateDims(ixStateDims%tdh)%dimName) ! Check dimension length is populated @@ -352,43 +427,41 @@ SUBROUTINE define_IRFbas_state(ierr, message1) if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif do iVar=1,nVarsIRFbas - nDims = size(meta_irf_bas(iVar)%varDim) - if (allocated(dim_IRFbas)) then - deallocate(dim_IRFbas) - end if - allocate(dim_IRFbas(nDims)) + if (allocated(dim_set)) deallocate(dim_set) + allocate(dim_set(nDims)) + do ixDim = 1, nDims - dim_IRFbas(ixDim) = meta_stateDims(meta_irf_bas(iVar)%varDim(ixDim))%dimName + dim_set(ixDim) = meta_stateDims(meta_irf_bas(iVar)%varDim(ixDim))%dimName end do - call def_var(ncid, meta_irf_bas(iVar)%varName, dim_IRFbas, meta_irf_bas(iVar)%varType, ierr, cmessage, vdesc=meta_irf_bas(iVar)%varDesc, vunit=meta_irf_bas(iVar)%varUnit ) + call def_var(ncid, meta_irf_bas(iVar)%varName, dim_set, meta_irf_bas(iVar)%varType, ierr, cmessage, vdesc=meta_irf_bas(iVar)%varDesc, vunit=meta_irf_bas(iVar)%varUnit ) if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif - end do end associate END SUBROUTINE define_IRFbas_state + SUBROUTINE define_KWT_state(ierr, message1) - ! External modules + USE globalData, ONLY: meta_kwt USE var_lookup, ONLY: ixKWT, nVarsKWT + implicit none + ! output integer(i4b), intent(out) :: ierr ! error code character(*), intent(out) :: message1 ! error message ! local integer(i4b) :: iVar,ixDim ! index loop for variables integer(i4b) :: nDims ! number of dimensions - character(len=strLen),allocatable :: dim_kwt(:) ! dimensions combination case 4 + character(len=strLen),allocatable :: dim_set(:) ! dimensions combination case 4 - ! initialize error control ierr=0; message1='define_KWT_state/' associate(dim_seg => meta_stateDims(ixStateDims%seg)%dimName, & dim_ens => meta_stateDims(ixStateDims%ens)%dimName, & - dim_time => meta_stateDims(ixStateDims%time)%dimName, & dim_wave => meta_stateDims(ixStateDims%wave)%dimName) ! Check dimension length is populated @@ -401,51 +474,49 @@ SUBROUTINE define_KWT_state(ierr, message1) call def_dim(ncid, meta_stateDims(ixStateDims%wave)%dimName, meta_stateDims(ixStateDims%wave)%dimLength, meta_stateDims(ixStateDims%wave)%dimId, ierr, cmessage) if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif - call def_var(ncid, 'numWaves', (/dim_seg,dim_ens,dim_time/), ncd_int, ierr, cmessage, vdesc='number of waves in a reach', vunit='-') + call def_var(ncid, 'numWaves', (/dim_seg,dim_ens/), ncd_int, ierr, cmessage, vdesc='number of waves in a reach', vunit='-') if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif do iVar=1,nVarsKWT - nDims = size(meta_kwt(iVar)%varDim) - if (allocated(dim_kwt)) then - deallocate(dim_kwt) - endif - allocate(dim_kwt(nDims)) + if (allocated(dim_set)) deallocate(dim_set) + allocate(dim_set(nDims)) + do ixDim = 1, nDims - dim_kwt(ixDim) = meta_stateDims(meta_kwt(iVar)%varDim(ixDim))%dimName + dim_set(ixDim) = meta_stateDims(meta_kwt(iVar)%varDim(ixDim))%dimName end do - call def_var(ncid, meta_kwt(iVar)%varName, dim_kwt, meta_kwt(iVar)%varType, ierr, cmessage, vdesc=meta_kwt(iVar)%varDesc, vunit=meta_kwt(iVar)%varUnit) + call def_var(ncid, meta_kwt(iVar)%varName, dim_set, meta_kwt(iVar)%varType, ierr, cmessage, vdesc=meta_kwt(iVar)%varDesc, vunit=meta_kwt(iVar)%varUnit) if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif - end do end associate END SUBROUTINE define_KWT_state + SUBROUTINE define_IRF_state(ierr, message1) - ! External modules + USE globalData, ONLY: meta_irf USE var_lookup, ONLY: ixIRF, nVarsIRF + implicit none + ! output integer(i4b), intent(out) :: ierr ! error code character(*), intent(out) :: message1 ! error message ! local integer(i4b) :: iVar,ixDim ! index loop for variables integer(i4b) :: nDims ! number of dimensions - character(len=strLen),allocatable :: dim_irf(:) ! dimensions combination case 4 - ! initialize error control + character(len=strLen),allocatable :: dim_set(:) ! dimensions combination case 4 + ierr=0; message1='define_IRF_state/' associate(dim_seg => meta_stateDims(ixStateDims%seg)%dimName, & dim_ens => meta_stateDims(ixStateDims%ens)%dimName, & - dim_time => meta_stateDims(ixStateDims%time)%dimName, & dim_tdh_irf => meta_stateDims(ixStateDims%tdh_irf)%dimName) ! define dimension ID array - if (meta_stateDims(ixStateDims%tdh_irf)%dimLength == integerMissing) then call set_dim_len(ixStateDims%tdh_irf, ierr, cmessage) if(ierr/=0)then; message1=trim(message1)//trim(cmessage)//' for '//trim(meta_stateDims(ixStateDims%tdh_irf)%dimName); return; endif @@ -455,29 +526,179 @@ SUBROUTINE define_IRF_state(ierr, message1) call def_dim(ncid, meta_stateDims(ixStateDims%tdh_irf)%dimName, meta_stateDims(ixStateDims%tdh_irf)%dimLength, meta_stateDims(ixStateDims%tdh_irf)%dimId, ierr, cmessage) if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif - call def_var(ncid, 'numQF', (/dim_seg,dim_ens,dim_time/), ncd_int, ierr, cmessage, vdesc='number of future q time steps in a reach', vunit='-') + call def_var(ncid, 'numQF', (/dim_seg,dim_ens/), ncd_int, ierr, cmessage, vdesc='number of future q time steps in a reach', vunit='-') if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif do iVar=1,nVarsIRF - nDims = size(meta_irf(iVar)%varDim) - if (allocated(dim_irf)) then - deallocate(dim_irf) - endif - allocate(dim_irf(nDims)) + if (allocated(dim_set)) deallocate(dim_set) + allocate(dim_set(nDims)) + do ixDim = 1, nDims - dim_irf(ixDim) = meta_stateDims(meta_irf(iVar)%varDim(ixDim))%dimName + dim_set(ixDim) = meta_stateDims(meta_irf(iVar)%varDim(ixDim))%dimName end do - call def_var(ncid, meta_irf(iVar)%varName, dim_irf, meta_irf(iVar)%varType, ierr, cmessage, vdesc=meta_irf(iVar)%varDesc, vunit=meta_irf(iVar)%varUnit) + call def_var(ncid, meta_irf(iVar)%varName, dim_set, meta_irf(iVar)%varType, ierr, cmessage, vdesc=meta_irf(iVar)%varDesc, vunit=meta_irf(iVar)%varUnit) if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif - end do end associate END SUBROUTINE define_IRF_state + + SUBROUTINE define_KW_state(ierr, message1) + + USE globalData, ONLY: meta_kw + USE var_lookup, ONLY: ixKW, nVarsKW + + implicit none + + ! output + integer(i4b), intent(out) :: ierr ! error code + character(*), intent(out) :: message1 ! error message + ! local + integer(i4b) :: iVar,ixDim ! index loop for variables + integer(i4b) :: nDims ! number of dimensions + character(len=strLen),allocatable :: dim_set(:) ! dimensions combination + + ierr=0; message1='define_KW_state/' + + associate(dim_seg => meta_stateDims(ixStateDims%seg)%dimName, & + dim_ens => meta_stateDims(ixStateDims%ens)%dimName, & + dim_mesh => meta_stateDims(ixStateDims%mol_kw)%dimName) + + ! Check dimension length is populated + if (meta_stateDims(ixStateDims%mol_kw)%dimLength == integerMissing) then + call set_dim_len(ixStateDims%mol_kw, ierr, cmessage) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage)//' for '//trim(meta_stateDims(ixStateDims%mol_kw)%dimName); return; endif + end if + + ! Define dimension needed for this routing specific state variables + call def_dim(ncid, meta_stateDims(ixStateDims%mol_kw)%dimName, & + meta_stateDims(ixStateDims%mol_kw)%dimLength, & + meta_stateDims(ixStateDims%mol_kw)%dimId, ierr, cmessage) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif + + do iVar=1,nVarsKW + nDims = size(meta_kw(iVar)%varDim) + if (allocated(dim_set)) deallocate(dim_set) + allocate(dim_set(nDims)) + + do ixDim = 1, nDims + dim_set(ixDim) = meta_stateDims(meta_kw(iVar)%varDim(ixDim))%dimName + end do + + call def_var(ncid, meta_kw(iVar)%varName, dim_set, meta_kw(iVar)%varType, ierr, cmessage, vdesc=meta_kw(iVar)%varDesc, vunit=meta_kw(iVar)%varUnit) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif + end do + + end associate + + END SUBROUTINE define_KW_state + + + SUBROUTINE define_MC_state(ierr, message1) + + USE globalData, ONLY: meta_mc + USE var_lookup, ONLY: ixMC, nVarsMC + + implicit none + + ! output + integer(i4b), intent(out) :: ierr ! error code + character(*), intent(out) :: message1 ! error message + ! local + integer(i4b) :: iVar,ixDim ! index loop for variables + integer(i4b) :: nDims ! number of dimensions + character(len=strLen),allocatable :: dim_set(:) ! dimensions combination case 4 + + ierr=0; message1='define_MC_state/' + + associate(dim_seg => meta_stateDims(ixStateDims%seg)%dimName, & + dim_ens => meta_stateDims(ixStateDims%ens)%dimName, & + dim_mesh => meta_stateDims(ixStateDims%mol_mc)%dimName) + + ! Check dimension length is populated + if (meta_stateDims(ixStateDims%mol_mc)%dimLength == integerMissing) then + call set_dim_len(ixStateDims%mol_mc, ierr, cmessage) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage)//' for '//trim(meta_stateDims(ixStateDims%mol_mc)%dimName); return; endif + end if + + ! Define dimension needed for this routing specific state variables + call def_dim(ncid, meta_stateDims(ixStateDims%mol_mc)%dimName, & + meta_stateDims(ixStateDims%mol_mc)%dimLength, & + meta_stateDims(ixStateDims%mol_mc)%dimId, ierr, cmessage) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif + + do iVar=1,nVarsMC + nDims = size(meta_mc(iVar)%varDim) + if (allocated(dim_set)) deallocate(dim_set) + allocate(dim_set(nDims)) + + do ixDim = 1, nDims + dim_set(ixDim) = meta_stateDims(meta_mc(iVar)%varDim(ixDim))%dimName + end do + + call def_var(ncid, meta_mc(iVar)%varName, dim_set, meta_mc(iVar)%varType, ierr, cmessage, vdesc=meta_mc(iVar)%varDesc, vunit=meta_mc(iVar)%varUnit) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif + end do + + end associate + + END SUBROUTINE define_MC_state + + + SUBROUTINE define_DW_state(ierr, message1) + + USE globalData, ONLY: meta_dw + USE var_lookup, ONLY: ixDW, nVarsDW + + implicit none + + ! output + integer(i4b), intent(out) :: ierr ! error code + character(*), intent(out) :: message1 ! error message + ! local + integer(i4b) :: iVar,ixDim ! index loop for variables + integer(i4b) :: nDims ! number of dimensions + character(len=strLen),allocatable :: dim_set(:) ! dimensions combination case 4 + + ierr=0; message1='define_DW_state/' + + associate(dim_seg => meta_stateDims(ixStateDims%seg)%dimName, & + dim_ens => meta_stateDims(ixStateDims%ens)%dimName, & + dim_mesh => meta_stateDims(ixStateDims%mol_dw)%dimName) + + ! Check dimension length is populated + if (meta_stateDims(ixStateDims%mol_dw)%dimLength == integerMissing) then + call set_dim_len(ixStateDims%mol_dw, ierr, cmessage) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage)//' for '//trim(meta_stateDims(ixStateDims%mol_dw)%dimName); return; endif + end if + + ! Define dimension needed for this routing specific state variables + call def_dim(ncid, meta_stateDims(ixStateDims%mol_dw)%dimName, & + meta_stateDims(ixStateDims%mol_dw)%dimLength, & + meta_stateDims(ixStateDims%mol_dw)%dimId, ierr, cmessage) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif + + do iVar=1,nVarsDW + nDims = size(meta_dw(iVar)%varDim) + if (allocated(dim_set)) deallocate(dim_set) + allocate(dim_set(nDims)) + + do ixDim = 1, nDims + dim_set(ixDim) = meta_stateDims(meta_dw(iVar)%varDim(ixDim))%dimName + end do + + call def_var(ncid, meta_dw(iVar)%varName, dim_set, meta_dw(iVar)%varType, ierr, cmessage, vdesc=meta_dw(iVar)%varDesc, vunit=meta_dw(iVar)%varUnit) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif + end do + + end associate + + END SUBROUTINE define_DW_state + END SUBROUTINE define_state_nc @@ -485,22 +706,20 @@ END SUBROUTINE define_state_nc ! public subroutine: writing routing state NetCDF file ! ********************************************************************* SUBROUTINE write_state_nc(fname, & ! Input: state netcdf name - opt, & ! input: which routing options - time, iTime, T0, T1, & ! Input: time, time step, start and end time [sec] + T0, T1, & ! Input: time, time step, start and end time [sec] seg_id, & ! Input: segment id vector ierr, message) ! Output: error control - ! External module + USE dataTypes, ONLY: states - ! meta data - USE globalData, ONLY: meta_stateDims ! dimension for state variables - ! Named variables + USE globalData, ONLY: RCHFLX + USE globalData, ONLY: RCHSTA + USE globalData, ONLY: meta_stateDims ! dimension meta for state variables USE var_lookup, ONLY: ixStateDims, nStateDims + implicit none + ! input variables character(*), intent(in) :: fname ! filename - integer(i4b), intent(in) :: opt ! routing option 0=all, 1=kwt, 2=irf - real(dp), intent(in) :: time ! calendar time - integer(i4b), intent(in) :: iTime ! ith Time step real(dp), intent(in) :: T0 ! beginning time [sec] of ith time step - lapse time from the beginning of the simulation real(dp), intent(in) :: T1 ! ending time [sec] ith time step - lapse time from the beginning of the simulation integer(i4b), intent(in) :: seg_id(:) ! segment id vector @@ -509,7 +728,6 @@ SUBROUTINE write_state_nc(fname, & ! Input: state netcdf name character(*), intent(out) :: message ! error message ! local variables integer(i4b) :: ncid ! netCDF ID - type(states) :: state(0:2) ! temporal state data structures -currently 2 river routing scheme + basin IRF routing character(len=strLen) :: cmessage ! error message of downwind routine ! initialize error control @@ -524,25 +742,40 @@ SUBROUTINE write_state_nc(fname, & ! Input: state netcdf name call write_nc(ncid,'reachID', seg_id, (/1/), (/size(seg_id)/), ierr, cmessage); if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif - call write_nc(ncid,'time', (/time/), (/iTime/), (/1/), ierr, cmessage) + call write_nc(ncid,'time_bound', (/T0,T1/), (/1/), (/2/), ierr, cmessage) if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif - call write_nc(ncid,'time_bound', (/T0,T1/), (/1,iTime/), (/2,1/), ierr, cmessage) + call write_basinQ_state(ierr, cmessage) if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif if (doesBasinRoute == 1) then - call write_IRFbas_state(ierr, cmessage) - if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + call write_IRFbas_state(ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif end if - if (opt==allRoutingMethods .or. opt==impulseResponseFunc)then - call write_IRF_state(ierr, cmessage) - if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + if (onRoute(impulseResponseFunc)) then + call write_IRF_state(ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif end if - if (opt==allRoutingMethods .or. opt==kinematicWave)then - call write_KWT_state(ierr, cmessage) - if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + if (onRoute(kinematicWaveTracking)) then + call write_KWT_state(ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + end if + + if (onRoute(kinematicWave)) then + call write_KW_state(ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + end if + + if (onRoute(muskingumCunge)) then + call write_MC_state(ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + end if + + if (onRoute(diffusiveWave)) then + call write_DW_state(ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif end if ! -- close netCDF @@ -551,17 +784,75 @@ SUBROUTINE write_state_nc(fname, & ! Input: state netcdf name CONTAINS + ! reach inflow writing procedure + SUBROUTINE write_basinQ_state(ierr, message1) + + USE globalData, ONLY: meta_basinQ + USE var_lookup, ONLY: ixBasinQ, nVarsBasinQ + + implicit none + + ! output + integer(i4b), intent(out) :: ierr ! error code + character(*), intent(out) :: message1 ! error message + ! local variables + type(states) :: state ! temporal state data structures + integer(i4b) :: iVar,iens,iSeg ! index loops for variables, ensembles and segments respectively + + ! initialize error control + ierr=0; message1='write_basinQ_state/' + + associate(nSeg => meta_stateDims(ixStateDims%seg)%dimLength, & + nens => meta_stateDims(ixStateDims%ens)%dimLength) + + allocate(state%var(nVarsBasinQ), stat=ierr, errmsg=cmessage) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif + + do iVar=1,nVarsBasinQ + select case(iVar) + case(ixBasinQ%q); allocate(state%var(iVar)%array_2d_dp(nSeg, nens), stat=ierr) + case default; ierr=20; message1=trim(message1)//'unable to identify basin routing variable index'; return + end select + if(ierr/=0)then; message1=trim(message1)//'problem allocating space for basin IRF routing state '//trim(meta_basinQ(iVar)%varName); return; endif + end do + + ! --Convert data structures to arrays + do iens=1,nens + do iSeg=1,nSeg + do iVar=1,nVarsBasinQ + select case(iVar) + case(ixBasinQ%q); state%var(iVar)%array_2d_dp(iSeg,iens) = RCHFLX(iens,iSeg)%BASIN_QR(1) + case default; ierr=20; message1=trim(message1)//'unable to identify basin IRF state variable index'; return + end select + end do + end do + end do + + do iVar=1,nVarsBasinQ + select case(iVar) + case(ixBasinQ%q); call write_nc(ncid, meta_basinQ(iVar)%varName, state%var(iVar)%array_2d_dp, (/1,1/), (/nSeg,nens/), ierr, cmessage) + case default; ierr=20; message1=trim(message1)//'unable to identify reach inflow variable index for nc writing'; return + end select + if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif + end do + + end associate + + END SUBROUTINE write_basinQ_state + ! Basin IRF writing procedures SUBROUTINE write_IRFbas_state(ierr, message1) - ! external module + USE globalData, ONLY: meta_irf_bas USE var_lookup, ONLY: ixIRFbas, nVarsIRFbas - USE globalData, ONLY: RCHFLX ! To get q future for basin IRF and IRF (these should not be in this data strucuture) + implicit none + ! output integer(i4b), intent(out) :: ierr ! error code character(*), intent(out) :: message1 ! error message ! local variables + type(states) :: state ! temporal state data structures integer(i4b) :: iVar,iens,iSeg ! index loops for variables, ensembles and segments respectively ! initialize error control @@ -571,44 +862,35 @@ SUBROUTINE write_IRFbas_state(ierr, message1) nens => meta_stateDims(ixStateDims%ens)%dimLength, & ntdh => meta_stateDims(ixStateDims%tdh)%dimLength) ! maximum future q time steps among basins - allocate(state(0)%var(nVarsIRFbas), stat=ierr, errmsg=cmessage) + allocate(state%var(nVarsIRFbas), stat=ierr, errmsg=cmessage) if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif do iVar=1,nVarsIRFbas - - select case(iVar) - case(ixIRFbas%qfuture); allocate(state(0)%var(iVar)%array_3d_dp(nSeg, ntdh, nens), stat=ierr) - case(ixIRFbas%q); allocate(state(0)%var(iVar)%array_2d_dp(nSeg, nens), stat=ierr) - case default; ierr=20; message1=trim(message1)//'unable to identify basin routing variable index'; return - end select - if(ierr/=0)then; message1=trim(message1)//'problem allocating space for basin IRF routing state '//trim(meta_irf_bas(iVar)%varName); return; endif - + select case(iVar) + case(ixIRFbas%qfuture); allocate(state%var(iVar)%array_3d_dp(nSeg, ntdh, nens), stat=ierr) + case default; ierr=20; message1=trim(message1)//'unable to identify basin routing variable index'; return + end select + if(ierr/=0)then; message1=trim(message1)//'problem allocating space for basin IRF routing state '//trim(meta_irf_bas(iVar)%varName); return; endif end do ! --Convert data structures to arrays do iens=1,nens - do iSeg=1,nSeg - do iVar=1,nVarsIRFbas - - select case(iVar) - case(ixIRFbas%qfuture); state(0)%var(iVar)%array_3d_dp(iSeg,:,iens) = RCHFLX(iens,iSeg)%QFUTURE - case(ixIRFbas%q); state(0)%var(iVar)%array_2d_dp(iSeg,iens) = RCHFLX(iens,iSeg)%BASIN_QR(1) - case default; ierr=20; message1=trim(message1)//'unable to identify basin IRF state variable index'; return - end select - - enddo - enddo - enddo + do iSeg=1,nSeg + do iVar=1,nVarsIRFbas + select case(iVar) + case(ixIRFbas%qfuture); state%var(iVar)%array_3d_dp(iSeg,:,iens) = RCHFLX(iens,iSeg)%QFUTURE + case default; ierr=20; message1=trim(message1)//'unable to identify basin IRF state variable index'; return + end select + end do + end do + end do do iVar=1,nVarsIRFbas - select case(iVar) - case(ixIRFbas%q); call write_nc(ncid, meta_irf_bas(iVar)%varName, state(0)%var(iVar)%array_2d_dp, (/1,1,iTime/), (/nSeg,nens,1/), ierr, cmessage) - case(ixIRFbas%qfuture); call write_nc(ncid, meta_irf_bas(iVar)%varName, state(0)%var(iVar)%array_3d_dp, (/1,1,1,iTime/), (/nSeg,ntdh,nens,1/), ierr, cmessage) + case(ixIRFbas%qfuture); call write_nc(ncid, meta_irf_bas(iVar)%varName, state%var(iVar)%array_3d_dp, (/1,1,1/), (/nSeg,ntdh,nens/), ierr, cmessage) case default; ierr=20; message1=trim(message1)//'unable to identify basin IRF variable index for nc writing'; return end select if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif - enddo end associate @@ -617,15 +899,17 @@ END SUBROUTINE write_IRFbas_state ! KWT writing procedures SUBROUTINE write_KWT_state(ierr, message1) - ! External module + USE globalData, ONLY: meta_kwt USE var_lookup, ONLY: ixKWT, nVarsKWT - USE globalData, ONLY: KROUTE + implicit none + ! output integer(i4b), intent(out) :: ierr ! error code character(*), intent(out) :: message1 ! error message ! local variables + type(states) :: state ! temporal state data structures integer(i4b) :: iVar,iens,iSeg ! index loops for variables, ensembles and segments respectively integer(i4b), allocatable :: RFvec(:) ! temporal vector integer(i4b), allocatable :: numWaves(:,:) ! number of waves for each ensemble and segment @@ -636,7 +920,7 @@ SUBROUTINE write_KWT_state(ierr, message1) nens => meta_stateDims(ixStateDims%ens)%dimLength, & nwave => meta_stateDims(ixStateDims%wave)%dimLength) ! maximum waves allowed in a reach - allocate(state(kinematicWave)%var(nVarsKWT), stat=ierr, errmsg=cmessage) + allocate(state%var(nVarsKWT), stat=ierr, errmsg=cmessage) if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif ! array to store number of wave per segment and ensemble @@ -645,9 +929,9 @@ SUBROUTINE write_KWT_state(ierr, message1) do iVar=1,nVarsKWT select case(iVar) - case(ixKWT%routed); allocate(state(kinematicWave)%var(iVar)%array_3d_int(nSeg, nwave, nens), stat=ierr) + case(ixKWT%routed); allocate(state%var(iVar)%array_3d_int(nSeg, nwave, nens), stat=ierr) case(ixKWT%tentry, ixKWT%texit, ixKWT%qwave, ixKWT%qwave_mod) - allocate(state(kinematicWave)%var(iVar)%array_3d_dp(nSeg, nwave, nens), stat=ierr) + allocate(state%var(iVar)%array_3d_dp(nSeg, nwave, nens), stat=ierr) case default; ierr=20; message1=trim(message1)//'unable to identify variable index'; return end select if(ierr/=0)then; message1=trim(message1)//'problem allocating space for KWT routing state '//trim(meta_kwt(iVar)%varName); return; endif @@ -655,53 +939,47 @@ SUBROUTINE write_KWT_state(ierr, message1) ! --Convert data structures to arrays do iens=1,nens - do iSeg=1,nSeg - - numWaves(iens,iseg) = size(KROUTE(iens,iseg)%KWAVE) - - do iVar=1,nVarsKWT - - select case(iVar) - case(ixKWT%tentry) - state(kinematicWave)%var(iVar)%array_3d_dp(iSeg,1:numWaves(iens,iSeg),iens) = KROUTE(iens,iSeg)%KWAVE(:)%TI - state(kinematicWave)%var(iVar)%array_3d_dp(iSeg,numWaves(iens,iSeg)+1:,iens) = realMissing - case(ixKWT%texit) - state(kinematicWave)%var(iVar)%array_3d_dp(iSeg,1:numWaves(iens,iSeg),iens) = KROUTE(iens,iSeg)%KWAVE(:)%TR - state(kinematicWave)%var(iVar)%array_3d_dp(iSeg,numWaves(iens,iSeg)+1:,iens) = realMissing - case(ixKWT%qwave) - state(kinematicWave)%var(iVar)%array_3d_dp(iSeg,1:numWaves(iens,iSeg),iens) = KROUTE(iens,iSeg)%KWAVE(:)%QF - state(kinematicWave)%var(iVar)%array_3d_dp(iSeg,numWaves(iens,iSeg)+1:,iens) = realMissing - case(ixKWT%qwave_mod) - state(kinematicWave)%var(iVar)%array_3d_dp(iSeg,1:numWaves(iens,iSeg),iens) = KROUTE(iens,iSeg)%KWAVE(:)%QM - state(kinematicWave)%var(iVar)%array_3d_dp(iSeg,numWaves(iens,iSeg)+1:,iens) = realMissing - case(ixKWT%routed) ! this is suppposed to be logical variable, but put it as 0 or 1 in double now - if (allocated(RFvec)) deallocate(RFvec, stat=ierr) - allocate(RFvec(numWaves(iens,iSeg)),stat=ierr); RFvec=0_i4b - where (KROUTE(iens,iSeg)%KWAVE(:)%RF) RFvec=1_i4b - state(kinematicWave)%var(iVar)%array_3d_int(iSeg,1:numWaves(iens,iSeg),iens) = RFvec - state(kinematicWave)%var(iVar)%array_3d_int(iSeg,numWaves(iens,iSeg)+1:,iens) = integerMissing - case default; ierr=20; message1=trim(message1)//'unable to identify KWT routing state variable index'; return - end select - - enddo ! variable loop - enddo ! seg loop + do iSeg=1,nSeg + numWaves(iens,iseg) = size(RCHSTA(iens, iseg)%LKW_ROUTE%KWAVE) + do iVar=1,nVarsKWT + select case(iVar) + case(ixKWT%tentry) + state%var(iVar)%array_3d_dp(iSeg,1:numWaves(iens,iSeg),iens) = RCHSTA(iens, iSeg)%LKW_ROUTE%KWAVE(:)%TI + state%var(iVar)%array_3d_dp(iSeg,numWaves(iens,iSeg)+1:,iens) = realMissing + case(ixKWT%texit) + state%var(iVar)%array_3d_dp(iSeg,1:numWaves(iens,iSeg),iens) = RCHSTA(iens, iSeg)%LKW_ROUTE%KWAVE(:)%TR + state%var(iVar)%array_3d_dp(iSeg,numWaves(iens,iSeg)+1:,iens) = realMissing + case(ixKWT%qwave) + state%var(iVar)%array_3d_dp(iSeg,1:numWaves(iens,iSeg),iens) = RCHSTA(iens, iSeg)%LKW_ROUTE%KWAVE(:)%QF + state%var(iVar)%array_3d_dp(iSeg,numWaves(iens,iSeg)+1:,iens) = realMissing + case(ixKWT%qwave_mod) + state%var(iVar)%array_3d_dp(iSeg,1:numWaves(iens,iSeg),iens) = RCHSTA(iens, iSeg)%LKW_ROUTE%KWAVE(:)%QM + state%var(iVar)%array_3d_dp(iSeg,numWaves(iens,iSeg)+1:,iens) = realMissing + case(ixKWT%routed) ! this is suppposed to be logical variable, but put it as 0 or 1 in double now + if (allocated(RFvec)) deallocate(RFvec, stat=ierr) + allocate(RFvec(numWaves(iens,iSeg)),stat=ierr); RFvec=0_i4b + where (RCHSTA(iens, iSeg)%LKW_ROUTE%KWAVE(:)%RF) RFvec=1_i4b + state%var(iVar)%array_3d_int(iSeg,1:numWaves(iens,iSeg),iens) = RFvec + state%var(iVar)%array_3d_int(iSeg,numWaves(iens,iSeg)+1:,iens) = integerMissing + case default; ierr=20; message1=trim(message1)//'unable to identify KWT routing state variable index'; return + end select + enddo ! variable loop + enddo ! seg loop enddo ! ensemble loop ! Writing netCDF - call write_nc(ncid, 'numWaves', numWaves, (/1,1,iTime/), (/nSeg,nens,1/), ierr, cmessage) + call write_nc(ncid, 'numWaves', numWaves, (/1,1/), (/nSeg,nens/), ierr, cmessage) if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif do iVar=1,nVarsKWT - select case(iVar) case(ixKWT%routed) - call write_nc(ncid, trim(meta_kwt(iVar)%varName), state(kinematicWave)%var(iVar)%array_3d_int, (/1,1,1,iTime/), (/nSeg,nwave,nens,1/), ierr, cmessage) + call write_nc(ncid, trim(meta_kwt(iVar)%varName), state%var(iVar)%array_3d_int, (/1,1,1/), (/nSeg,nwave,nens/), ierr, cmessage) case(ixKWT%tentry, ixKWT%texit, ixKWT%qwave, ixKWT%qwave_mod) - call write_nc(ncid, trim(meta_kwt(iVar)%varName), state(kinematicWave)%var(iVar)%array_3d_dp, (/1,1,1,iTime/), (/nSeg,nwave,nens,1/), ierr, cmessage) + call write_nc(ncid, trim(meta_kwt(iVar)%varName), state%var(iVar)%array_3d_dp, (/1,1,1/), (/nSeg,nwave,nens/), ierr, cmessage) case default; ierr=20; message1=trim(message1)//'unable to identify IRF variable index for nc writing'; return end select - if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif - + if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif end do end associate @@ -711,26 +989,29 @@ END SUBROUTINE write_KWT_state ! IRF writing procedures SUBROUTINE write_IRF_state(ierr, message1) - ! external module - USE globalData, ONLY: meta_irf ! IRF routing + + USE globalData, ONLY: meta_irf + USE globalData, ONLY: idxIRF USE var_lookup, ONLY: ixIRF, nVarsIRF - USE globalData, ONLY: RCHFLX ! To get q future for basin IRF and IRF (these should not be in this data strucuture) USE globalData, ONLY: NETOPO ! To get UH (this should not be in this data strucuture) + implicit none + ! output integer(i4b), intent(out) :: ierr ! error code character(*), intent(out) :: message1 ! error message ! local variables + type(states) :: state ! temporal state data structures integer(i4b) :: iVar,iens,iSeg ! index loops for variables, ensembles and segments respectively integer(i4b), allocatable :: numQF(:,:) ! number of future Q time steps for each ensemble and segment - ! initialize error control + ierr=0; message1='write_IRF_state/' associate(nSeg => meta_stateDims(ixStateDims%seg)%dimLength, & nens => meta_stateDims(ixStateDims%ens)%dimLength, & ntdh_irf => meta_stateDims(ixStateDims%tdh_irf)%dimLength) ! maximum future q time steps among reaches - allocate(state(impulseResponseFunc)%var(nVarsIRF), stat=ierr, errmsg=cmessage) + allocate(state%var(nVarsIRF), stat=ierr, errmsg=cmessage) if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif ! array to store number of wave per segment and ensemble @@ -738,55 +1019,233 @@ SUBROUTINE write_IRF_state(ierr, message1) if(ierr/=0)then; message1=trim(message1)//'problem allocating space for numQF'; return; endif do iVar=1,nVarsIRF - select case(iVar) - case(ixIRF%qfuture); allocate(state(impulseResponseFunc)%var(iVar)%array_3d_dp(nSeg, ntdh_irf, nens), stat=ierr) - case(ixIRF%irfVol); allocate(state(impulseResponseFunc)%var(iVar)%array_2d_dp(nSeg, nens), stat=ierr) - case default; ierr=20; message1=trim(message1)//'unable to identify variable index'; return - end select - if(ierr/=0)then; message1=trim(message1)//'problem allocating space for IRF routing state '//trim(meta_irf(iVar)%varName); return; endif + select case(iVar) + case(ixIRF%qfuture); allocate(state%var(iVar)%array_3d_dp(nSeg, ntdh_irf, nens), stat=ierr) + case(ixIRF%irfVol); allocate(state%var(iVar)%array_2d_dp(nSeg, nens), stat=ierr) + case default; ierr=20; message1=trim(message1)//'unable to identify variable index'; return + end select + if(ierr/=0)then; message1=trim(message1)//'problem allocating space for IRF routing state '//trim(meta_irf(iVar)%varName); return; endif end do ! --Convert data structures to arrays do iens=1,nens - do iSeg=1,nSeg - - numQF(iens,iseg) = size(NETOPO(iSeg)%UH) + do iSeg=1,nSeg + numQF(iens,iseg) = size(NETOPO(iSeg)%UH) + do iVar=1,nVarsIRF + select case(iVar) + case(ixIRF%qfuture) + state%var(iVar)%array_3d_dp(iSeg,1:numQF(iens,iSeg),iens) = RCHFLX(iens,iSeg)%QFUTURE_IRF + state%var(iVar)%array_3d_dp(iSeg,numQF(iens,iSeg)+1:ntdh_irf,iens) = realMissing + case(ixIRF%irfVol) + state%var(iVar)%array_2d_dp(iSeg,iens) = RCHFLX(iens,iSeg)%ROUTE(idxIRF)%REACH_VOL(1) + case default; ierr=20; message1=trim(message1)//'unable to identify variable index'; return + end select + enddo ! variable loop + enddo ! seg loop + enddo ! ensemble loop - do iVar=1,nVarsIRF + ! writing netcdf + call write_nc(ncid, 'numQF', numQF, (/1,1/), (/nSeg,nens/), ierr, cmessage) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif - select case(iVar) + do iVar=1,nVarsIRF + select case(iVar) case(ixIRF%qfuture) - state(impulseResponseFunc)%var(iVar)%array_3d_dp(iSeg,1:numQF(iens,iSeg),iens) = RCHFLX(iens,iSeg)%QFUTURE_IRF - state(impulseResponseFunc)%var(iVar)%array_3d_dp(iSeg,numQF(iens,iSeg)+1:ntdh_irf,iens) = realMissing + call write_nc(ncid, trim(meta_irf(iVar)%varName), state%var(iVar)%array_3d_dp, (/1,1,1/), (/nSeg,ntdh_irf,nens/), ierr, cmessage) case(ixIRF%irfVol) - state(impulseResponseFunc)%var(iVar)%array_2d_dp(iSeg,iens) = RCHFLX(iens,iSeg)%REACH_VOL(1) - case default; ierr=20; message1=trim(message1)//'unable to identify variable index'; return - end select + call write_nc(ncid, trim(meta_irf(iVar)%varName), state%var(iVar)%array_2d_dp, (/1,1/), (/nSeg,nens/), ierr, cmessage) + case default; ierr=20; message1=trim(message1)//'unable to identify IRF variable index for nc writing'; return + if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif + end select + end do - enddo ! variable loop - enddo ! seg loop - enddo ! ensemble loop + end associate - ! writing netcdf - call write_nc(ncid, 'numQF', numQF, (/1,1,iTime/), (/nSeg,nens,1/), ierr, cmessage) - if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif + END SUBROUTINE write_IRF_state - do iVar=1,nVarsIRF + ! KW writing procedures + SUBROUTINE write_KW_state(ierr, message1) - select case(iVar) - case(ixIRF%qfuture) - call write_nc(ncid, trim(meta_irf(iVar)%varName), state(impulseResponseFunc)%var(iVar)%array_3d_dp, (/1,1,1,iTime/), (/nSeg,ntdh_irf,nens,1/), ierr, cmessage) - case(ixIRF%irfVol) - call write_nc(ncid, trim(meta_irf(iVar)%varName), state(impulseResponseFunc)%var(iVar)%array_2d_dp, (/1,1,iTime/), (/nSeg,nens,1/), ierr, cmessage) - case default; ierr=20; message1=trim(message1)//'unable to identify IRF variable index for nc writing'; return + USE globalData, ONLY: meta_kw + USE var_lookup, ONLY: ixKW, nVarsKW + + implicit none + + ! output + integer(i4b), intent(out) :: ierr ! error code + character(*), intent(out) :: message1 ! error message + ! local variables + type(states) :: state ! temporal state data structures -currently 2 river routing scheme + basin IRF routing + integer(i4b) :: iVar,iens,iSeg ! index loops for variables, ensembles and segments respectively + + ierr=0; message1='write_KW_state/' + + associate(nSeg => size(RCHFLX), & + nEns => meta_stateDims(ixStateDims%ens)%dimLength, & + nMesh => meta_stateDims(ixStateDims%mol_kw)%dimLength) ! number of computing molecule used for finite difference + + allocate(state%var(nVarsKW), stat=ierr, errmsg=cmessage) if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif - end select - end do + do iVar=1,nVarsKW + select case(iVar) + case(ixKW%qsub) + allocate(state%var(iVar)%array_3d_dp(nSeg, nMesh, nEns), stat=ierr) + case default; ierr=20; message1=trim(message1)//'unable to identify variable index'; return + end select + if(ierr/=0)then; message1=trim(message1)//'problem allocating space for KW routing state '//trim(meta_kw(iVar)%varName); return; endif + end do + + ! --Convert data structures to arrays + do iens=1,nEns + do iSeg=1,nSeg + do iVar=1,nVarsKW + select case(iVar) + case(ixKW%qsub) + state%var(iVar)%array_3d_dp(iSeg,1:nMesh,iens) = RCHSTA(iens, iSeg)%KW_ROUTE%molecule%Q(1:nMesh) + case default; ierr=20; message1=trim(message1)//'unable to identify KW routing state variable index'; return + end select + enddo ! variable loop + enddo ! seg loop + enddo ! ensemble loop + + ! Writing netCDF + do iVar=1,nVarsKW + select case(iVar) + case(ixKW%qsub) + call write_nc(ncid, trim(meta_kw(iVar)%varName), state%var(iVar)%array_3d_dp, (/1,1,1/), (/nSeg,nMesh,nens/), ierr, cmessage) + case default; ierr=20; message1=trim(message1)//'unable to identify KW variable index for nc writing'; return + end select + if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif - end associate + end do - END SUBROUTINE write_IRF_state + end associate + + END SUBROUTINE write_KW_state + + ! MC writing procedures + SUBROUTINE write_MC_state(ierr, message1) + + USE globalData, ONLY: meta_mc + USE var_lookup, ONLY: ixMC, nVarsMC + + implicit none + + ! output + integer(i4b), intent(out) :: ierr ! error code + character(*), intent(out) :: message1 ! error message + ! local variables + type(states) :: state ! temporal state data structures + integer(i4b) :: iVar,iens,iSeg ! index loops for variables, ensembles and segments respectively + + ierr=0; message1='write_MC_state/' + + associate(nSeg => size(RCHFLX), & + nEns => meta_stateDims(ixStateDims%ens)%dimLength, & + nMesh => meta_stateDims(ixStateDims%mol_mc)%dimLength) ! number of computing molecule used for finite difference + + allocate(state%var(nVarsMC), stat=ierr, errmsg=cmessage) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif + + do iVar=1,nVarsMC + select case(iVar) + case(ixMC%qsub) + allocate(state%var(iVar)%array_3d_dp(nSeg, nMesh, nEns), stat=ierr) + case default; ierr=20; message1=trim(message1)//'unable to identify variable index'; return + end select + if(ierr/=0)then; message1=trim(message1)//'problem allocating space for MC routing state '//trim(meta_mc(iVar)%varName); return; endif + end do + + ! --Convert data structures to arrays + do iens=1,nEns + do iSeg=1,nSeg + do iVar=1,nVarsMC + select case(iVar) + case(ixMC%qsub) + state%var(iVar)%array_3d_dp(iSeg,1:nMesh,iens) = RCHSTA(iens, iSeg)%MC_ROUTE%molecule%Q(1:nMesh) + case default; ierr=20; message1=trim(message1)//'unable to identify MC routing state variable index'; return + end select + enddo ! variable loop + enddo ! seg loop + enddo ! ensemble loop + + ! Writing netCDF + do iVar=1,nVarsMC + select case(iVar) + case(ixMC%qsub) + call write_nc(ncid, trim(meta_mc(iVar)%varName), state%var(iVar)%array_3d_dp, (/1,1,1/), (/nSeg,nMesh,nens/), ierr, cmessage) + case default; ierr=20; message1=trim(message1)//'unable to identify MC variable index for nc writing'; return + end select + if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif + + end do + + end associate + + END SUBROUTINE write_MC_state + + + ! DW writing procedures + SUBROUTINE write_DW_state(ierr, message1) + + USE globalData, ONLY: meta_dw + USE var_lookup, ONLY: ixDW, nVarsDW + + implicit none + + ! output + integer(i4b), intent(out) :: ierr ! error code + character(*), intent(out) :: message1 ! error message + ! local variables + type(states) :: state ! temporal state data structures + integer(i4b) :: iVar,iens,iSeg ! index loops for variables, ensembles and segments respectively + + ierr=0; message1='write_DW_state/' + + associate(nSeg => size(RCHFLX), & + nEns => meta_stateDims(ixStateDims%ens)%dimLength, & + nMesh => meta_stateDims(ixStateDims%mol_dw)%dimLength) ! number of computing molecule used for finite difference + + allocate(state%var(nVarsDW), stat=ierr, errmsg=cmessage) + if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif + + do iVar=1,nVarsDW + select case(iVar) + case(ixDW%qsub) + allocate(state%var(iVar)%array_3d_dp(nSeg, nMesh, nEns), stat=ierr) + case default; ierr=20; message1=trim(message1)//'unable to identify variable index'; return + end select + if(ierr/=0)then; message1=trim(message1)//'problem allocating space for DW routing state '//trim(meta_dw(iVar)%varName); return; endif + end do + + ! --Convert data structures to arrays + do iens=1,nEns + do iSeg=1,nSeg + do iVar=1,nVarsDW + select case(iVar) + case(ixDW%qsub) + state%var(iVar)%array_3d_dp(iSeg,1:nMesh,iens) = RCHSTA(iens, iSeg)%DW_ROUTE%molecule%Q(1:nMesh) + case default; ierr=20; message1=trim(message1)//'unable to identify DW routing state variable index'; return + end select + enddo ! variable loop + enddo ! seg loop + enddo ! ensemble loop + + ! Writing netCDF + do iVar=1,nVarsDW + select case(iVar) + case(ixDW%qsub) + call write_nc(ncid, trim(meta_dw(iVar)%varName), state%var(iVar)%array_3d_dp, (/1,1,1/), (/nSeg,nMesh,nens/), ierr, cmessage) + case default; ierr=20; message1=trim(message1)//'unable to identify DW variable index for nc writing'; return + end select + if(ierr/=0)then; message1=trim(message1)//trim(cmessage); return; endif + + end do + + end associate + + END SUBROUTINE write_DW_state END SUBROUTINE write_state_nc diff --git a/route/build/src/write_simoutput.f90 b/route/build/src/write_simoutput.f90 index bb2d6d1b..d191c4d8 100644 --- a/route/build/src/write_simoutput.f90 +++ b/route/build/src/write_simoutput.f90 @@ -5,14 +5,9 @@ MODULE write_simoutput USE var_lookup,only: ixRFLX, nVarsRFLX USE public_var,only: iulog USE public_var,only: integerMissing -USE public_var,only: routOpt ! routing scheme options 0-> both, 1->IRF, 2->KWT, otherwise error -USE public_var,only: doesBasinRoute ! basin routing options 0-> no, 1->IRF, otherwise error -USE public_var,only: doesAccumRunoff ! option to delayed runoff accumulation over all the upstream reaches. 0->no, 1->yes -USE public_var,only: kinematicWave ! kinematic wave -USE public_var,only: impulseResponseFunc ! impulse response function -USE public_var,only: allRoutingMethods ! all routing methods USE globalData,only: meta_rflx USE globalData,only: simout_nc +USE globalData,only: idxSUM, idxIRF, idxKWT, idxKW, idxMC, idxDW USE io_netcdf, only: ncd_int USE io_netcdf, only: ncd_float, ncd_double USE io_netcdf, only: ncd_unlimited @@ -53,6 +48,8 @@ SUBROUTINE output(ierr, message) ! out: error control integer(i4b), intent(out) :: ierr ! error code character(*), intent(out) :: message ! error message ! local variables + real(dp), allocatable :: array_temp(:) + integer(i4b) :: ix ! loop index integer(i4b) :: iens ! temporal character(len=strLen) :: cmessage ! error message of downwind routine @@ -61,6 +58,9 @@ SUBROUTINE output(ierr, message) ! out: error control iens = 1 + allocate(array_temp(nRch), stat=ierr, errmsg=cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage)//' [array_temp]'; return; endif + ! write time -- note time is just carried across from the input call write_nc(simout_nc%ncid, 'time', (/runoff_data%time/), (/jTime/), (/1/), ierr, cmessage) if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif @@ -84,22 +84,52 @@ SUBROUTINE output(ierr, message) ! out: error control endif if (meta_rflx(ixRFLX%sumUpstreamRunoff)%varFile) then - ! write accumulated runoff (m3/s) - call write_nc(simout_nc%ncid, 'sumUpstreamRunoff', RCHFLX(iens,:)%UPSTREAM_QI, (/1,jTime/), (/nRch,1/), ierr, cmessage) - if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + do ix=1,nRCH + array_temp(ix) = RCHFLX(iens, ix)%ROUTE(idxSUM)%REACH_Q + end do + call write_nc(simout_nc%ncid, 'sumUpstreamRunoff', array_temp, (/1,jTime/), (/nRch,1/), ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif endif if (meta_rflx(ixRFLX%KWTroutedRunoff)%varFile) then - ! write routed runoff (m3/s) - call write_nc(simout_nc%ncid, 'KWTroutedRunoff', RCHFLX(iens,:)%REACH_Q, (/1,jTime/), (/nRch,1/), ierr, cmessage) - if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif - endif + do ix=1,nRCH + array_temp(ix) = RCHFLX(iens, ix)%ROUTE(idxKWT)%REACH_Q + end do + call write_nc(simout_nc%ncid, 'KWTroutedRunoff', array_temp, (/1,jTime/), (/nRch,1/), ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + end if if (meta_rflx(ixRFLX%IRFroutedRunoff)%varFile) then - ! write routed runoff (m3/s) - call write_nc(simout_nc%ncid, 'IRFroutedRunoff', RCHFLX(iens,:)%REACH_Q_IRF, (/1,jTime/), (/nRch,1/), ierr, cmessage) - if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif - endif + do ix=1,nRCH + array_temp(ix) = RCHFLX(iens, ix)%ROUTE(idxIRF)%REACH_Q + end do + call write_nc(simout_nc%ncid, 'IRFroutedRunoff', array_temp, (/1,jTime/), (/nRch,1/), ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + end if + + if (meta_rflx(ixRFLX%KWroutedRunoff)%varFile) then + do ix=1,nRCH + array_temp(ix) = RCHFLX(iens, ix)%ROUTE(idxKW)%REACH_Q + end do + call write_nc(simout_nc%ncid, 'KWroutedRunoff', array_temp, (/1,jTime/), (/nRch,1/), ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + end if + + if (meta_rflx(ixRFLX%MCroutedRunoff)%varFile) then + do ix=1,nRCH + array_temp(ix) = RCHFLX(iens, ix)%ROUTE(idxMC)%REACH_Q + end do + call write_nc(simout_nc%ncid, 'MCroutedRunoff', array_temp, (/1,jTime/), (/nRch,1/), ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + end if + + if (meta_rflx(ixRFLX%DWroutedRunoff)%varFile) then + do ix=1,nRCH + array_temp(ix) = RCHFLX(iens, ix)%ROUTE(idxDW)%REACH_Q + end do + call write_nc(simout_nc%ncid, 'DWroutedRunoff', array_temp(1:nRch), (/1,jTime/), (/nRch,1/), ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + end if END SUBROUTINE output @@ -109,6 +139,7 @@ END SUBROUTINE output ! ********************************************************************* SUBROUTINE prep_output(ierr, message) ! out: error control + USE ascii_util_module, ONLY: lower ! saved public variables (usually parameters, or values not modified) USE public_var, only : output_dir ! output directory USE public_var, only : case_name ! simulation name ==> output filename head @@ -138,12 +169,12 @@ SUBROUTINE prep_output(ierr, message) ! out: error control write(iulog,'(a,I4,4(x,I4))') new_line('a'), modTime(1)%year(), modTime(1)%month(), modTime(1)%day(), modTime(1)%hour(), modTime(1)%minute() ! check need for the new file - select case(trim(newFileFrequency)) + select case(lower(trim(newFileFrequency))) case('single'); defNewOutputFile=(modTime(0)%year() ==integerMissing) - case('annual'); defNewOutputFile=(modTime(1)%year() /=modTime(0)%year()) - case('month'); defNewOutputFile=(modTime(1)%month()/=modTime(0)%month()) - case('day'); defNewOutputFile=(modTime(1)%day() /=modTime(0)%day()) - case default; ierr=20; message=trim(message)//'unable to identify the option to define new output files'; return + case('yearly'); defNewOutputFile=(modTime(1)%year() /=modTime(0)%year()) + case('monthly'); defNewOutputFile=(modTime(1)%month()/=modTime(0)%month()) + case('daily'); defNewOutputFile=(modTime(1)%day() /=modTime(0)%day()) + case default; ierr=20; message=trim(message)//'Accepted options (case-insensitive): single yearly, monthly, or daily '; return end select ! define new file @@ -179,8 +210,10 @@ SUBROUTINE prep_output(ierr, message) ! out: error control simout_nc%status = 2 - call write_nc(simout_nc%ncid, 'basinID', int(basinID,kind(i4b)), (/1/), (/nHRU/), ierr, cmessage) - if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + if (meta_rflx(ixRFLX%basRunoff)%varFile) then + call write_nc(simout_nc%ncid, 'basinID', int(basinID,kind(i4b)), (/1/), (/nHRU/), ierr, cmessage) + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + end if call write_nc(simout_nc%ncid, 'reachID', reachID, (/1/), (/nRch/), ierr, cmessage) if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif @@ -238,22 +271,6 @@ SUBROUTINE defineFile(fname, & ! input: filename meta_qDims(ixQdims%hru)%dimLength = nHRU_in meta_qDims(ixQdims%ens)%dimLength = nEns_in - ! Modify write option - ! Routing option - if (routOpt==kinematicWave) then - meta_rflx(ixRFLX%IRFroutedRunoff)%varFile = .false. - elseif (routOpt==impulseResponseFunc) then - meta_rflx(ixRFLX%KWTroutedRunoff)%varFile = .false. - endif - ! runoff accumulation option - if (doesAccumRunoff==0) then - meta_rflx(ixRFLX%sumUpstreamRunoff)%varFile = .false. - endif - ! basin runoff routing option - if (doesBasinRoute==0) then - meta_rflx(ixRFLX%instRunoff)%varFile = .false. - endif - ! -------------------- ! define file ! -------------------- @@ -262,11 +279,15 @@ SUBROUTINE defineFile(fname, & ! input: filename do jDim =1,nQdims if (jDim ==ixQdims%time) then ! time dimension (unlimited) - call def_dim(ncid, trim(meta_qDims(jDim)%dimName), ncd_unlimited, meta_qDims(jDim)%dimId, ierr, cmessage) + call def_dim(ncid, trim(meta_qDims(jDim)%dimName), ncd_unlimited, meta_qDims(jDim)%dimId, ierr, cmessage) + else if (jDim==ixQdims%hru) then + if (meta_rflx(ixRFLX%basRunoff)%varFile) then + call def_dim(ncid, trim(meta_qDims(jDim)%dimName), meta_qDims(jDim)%dimLength ,meta_qDims(jDim)%dimId, ierr, cmessage) + end if else - call def_dim(ncid, trim(meta_qDims(jDim)%dimName), meta_qDims(jDim)%dimLength ,meta_qDims(jDim)%dimId, ierr, cmessage) + call def_dim(ncid, trim(meta_qDims(jDim)%dimName), meta_qDims(jDim)%dimLength ,meta_qDims(jDim)%dimId, ierr, cmessage) endif - if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif end do ! Define coordinate variable for time @@ -277,8 +298,10 @@ SUBROUTINE defineFile(fname, & ! input: filename call def_var(ncid, 'reachID', (/meta_qDims(ixQdims%seg)%dimName/), ncd_int, ierr, cmessage, vdesc='reach ID', vunit='-') if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif - call def_var(ncid, 'basinID', (/meta_qDims(ixQdims%hru)%dimName/), ncd_int, ierr, cmessage, vdesc='basin ID', vunit='-') - if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + if (meta_rflx(ixRFLX%basRunoff)%varFile) then + call def_var(ncid, 'basinID', (/meta_qDims(ixQdims%hru)%dimName/), ncd_int, ierr, cmessage, vdesc='basin ID', vunit='-') + if(ierr/=0)then; message=trim(message)//trim(cmessage); return; endif + end if ! define variables do iVar=1, nVarsRFLX diff --git a/route/settings/SAMPLE.control b/route/settings/SAMPLE.control index 81631a92..201e454c 100644 --- a/route/settings/SAMPLE.control +++ b/route/settings/SAMPLE.control @@ -21,10 +21,10 @@ CASE_NAME ! name of simulation yyyy-mm-dd hh:mm:ss ! time of simulation start (00:00:00 if hh:mm:ss is not included) yyyy-mm-dd hh:mm:ss ! time of simulation end (00:00:00 if hh:mm:ss is not included) - 0 ! option for routing schemes 0-> both, 1->IRF, 2->KWT otherwise error - 1 ! basin routing options 0-> no, 1->IRF, otherwise error - 1 ! option to delayed runoff accumulation over all the upstream reaches. 0->no, 1->yes - Never ! restart write options. options: N[n]ever, L[l]ast, S[s]pecified + 0 ! river routing options: 0-> accumRunoff, 1->IRF, 2->KWT, 3-> KW, 4->MC, 5->DW + 1 ! basin routing options: 0-> no, 1->IRF, otherwise error + yearly ! frequency for new output options (case-insensitive): daily, monthly, yearly, or single + never ! restart write option (case-insensitive): never, last, specified, yearly, monthly, or daily yyyy-mm-dd hh:mm:ss ! restart date. activated only if is "specified" INPUT_RESTART_NC ! input restart netCDF name. remove for run without any particular initial channel states ! ****************************************************************************************************************************