diff --git a/R/RunModel_Lag.R b/R/RunModel_Lag.R
index be71d890fc117ec75e3a6c0461bd937eb7911ef8..dea36093c0ba94564c16d8e721963847bc2751b8 100644
--- a/R/RunModel_Lag.R
+++ b/R/RunModel_Lag.R
@@ -1,7 +1,7 @@
RunModel_Lag <- function(InputsModel, RunOptions, Param, QcontribDown) {
NParam <- 1
- ##Arguments_check
+ ## argument check
if (!inherits(InputsModel, "InputsModel")) {
stop("'InputsModel' must be of class 'InputsModel'")
}
@@ -21,35 +21,49 @@ RunModel_Lag <- function(InputsModel, RunOptions, Param, QcontribDown) {
if (is.null(QcontribDown$Qsim)) {
stop("'QcontribDown' should contain a key 'Qsim' containing the output of the runoff of the downstream subcatchment")
}
- OutputsModel <- QcontribDown
- OutputsModel$QsimDown <- OutputsModel$Qsim
+ if (length(QcontribDown$Qsim) != length(RunOptions$IndPeriod_Run)) {
+ stop("Time series Qsim in 'QcontribDown' should have the same lenght as 'RunOptions$IndPeriod_Run'")
+ }
+ if (!is.null(QcontribDown$WarmUpQsim) &&
+ length(QcontribDown$WarmUpQsim) != length(RunOptions$IndPeriod_WarmUp) &&
+ RunOptions$IndPeriod_WarmUp != 0L) {
+ stop("Time series WarmUpQsim in 'QcontribDown' should have the same lenght as 'RunOptions$IndPeriod_WarmUp'")
+ }
} else if (is.vector(QcontribDown) && is.numeric(QcontribDown)) {
- OutputsModel <- list()
- class(OutputsModel) <- c("OutputsModel", class(OutputsModel))
- OutputsModel$QsimDown <- QcontribDown
+ if (length(QcontribDown) != length(RunOptions$IndPeriod_Run)) {
+ stop("'QcontribDown' should have the same lenght as 'RunOptions$IndPeriod_Run'")
+ }
} else {
stop("'QcontribDown' must be a numeric vector or a 'OutputsModel' object")
}
- if (length(OutputsModel$QsimDown) != length(RunOptions$IndPeriod_Run)) {
- stop("Time series in 'QcontribDown' should have the same lenght as 'RunOptions$IndPeriod_Run'")
+
+ # data set up
+ NbUpBasins <- length(InputsModel$LengthHydro)
+ if (identical(RunOptions$IndPeriod_WarmUp, 0L)) {
+ RunOptions$IndPeriod_WarmUp <- NULL
}
+ IndPeriod1 <- c(RunOptions$IndPeriod_WarmUp, RunOptions$IndPeriod_Run)
+ LInputSeries <- as.integer(length(IndPeriod1))
+ IndPeriod2 <- (length(RunOptions$IndPeriod_WarmUp)+1):LInputSeries
- if (inherits(InputsModel, "hourly")) {
- TimeStep <- 60 * 60
- } else if (inherits(InputsModel, "daily")) {
- TimeStep <- 60 * 60 * 24
- } else {
- stop("'InputsModel' should be of class \"daily\" or \"hourly\"")
+ if (inherits(QcontribDown, "OutputsModel")) {
+ OutputsModel <- QcontribDown
+ if (is.null(OutputsModel$WarmUpQsim)) {
+ OutputsModel$WarmUpQsim <- rep(NA, length(RunOptions$IndPeriod_WarmUp))
+ }
+ QsimDown <- c(OutputsModel$WarmUpQsim, OutputsModel$Qsim)
+ } else if (is.vector(QcontribDown) && is.numeric(QcontribDown)) {
+ OutputsModel <- list()
+ class(OutputsModel) <- c("OutputsModel", class(RunOptions)[-1])
+ QsimDown <- c(rep(NA, length(RunOptions$IndPeriod_WarmUp)),
+ QcontribDown)
}
- # propagation time from upstream meshes to outlet
- PT <- InputsModel$LengthHydro * 1e3 / Param[1L] / TimeStep
+ ## propagation time from upstream meshes to outlet
+ PT <- InputsModel$LengthHydro * 1e3 / Param[1L] / RunOptions$FeatFUN_MOD$TimeStep
HUTRANS <- rbind(1 - (PT - floor(PT)), PT - floor(PT))
- NbUpBasins <- length(InputsModel$LengthHydro)
- LengthTs <- length(OutputsModel$QsimDown)
- OutputsModel$Qsim_m3 <- OutputsModel$QsimDown * InputsModel$BasinAreas[length(InputsModel$BasinAreas)] * 1e3
-
+ ## set up initial states
IniSD <- RunOptions$IniStates[grep("SD", names(RunOptions$IniStates))]
if (length(IniSD) > 0) {
if (sum(floor(PT)) + NbUpBasins != length(IniSD)) {
@@ -66,15 +80,15 @@ RunModel_Lag <- function(InputsModel, RunOptions, Param, QcontribDown) {
if (x > 1) {
iStart <- iStart + sum(floor(PT[1:x - 1]) + 1)
}
- IniSD[iStart:(iStart + PT[x])]
+ as.vector(IniSD[iStart:(iStart + PT[x])])
})
} else {
IniStates <- lapply(
seq_len(NbUpBasins),
function(iUpBasins) {
iWarmUp <- seq.int(
- from = max(1, RunOptions$IndPeriod_WarmUp[length(RunOptions$IndPeriod_WarmUp)] - floor(PT[iUpBasins])),
- to = max(1, RunOptions$IndPeriod_WarmUp[length(RunOptions$IndPeriod_WarmUp)])
+ from = max(1, IndPeriod1[1] - floor(PT[iUpBasins]) - 1),
+ to = max(1, IndPeriod1[1] - 1)
)
ini <- InputsModel$Qupstream[iWarmUp, iUpBasins]
if (length(ini) != floor(PT[iUpBasins] + 1)) {
@@ -85,19 +99,30 @@ RunModel_Lag <- function(InputsModel, RunOptions, Param, QcontribDown) {
}
)
}
- # message("Initstates: ", paste(IniStates, collapse = ", "))
+ # message("IniStates: ", paste(IniStates, collapse = ", "))
+
+ ## Lag model computation
+ Qsim_m3 <- QsimDown *
+ InputsModel$BasinAreas[length(InputsModel$BasinAreas)] * 1e3
for (upstream_basin in seq_len(NbUpBasins)) {
Qupstream <- c(IniStates[[upstream_basin]],
- InputsModel$Qupstream[RunOptions$IndPeriod_Run, upstream_basin])
+ InputsModel$Qupstream[IndPeriod1, upstream_basin])
# message("Qupstream[", upstream_basin, "]: ", paste(Qupstream, collapse = ", "))
- OutputsModel$Qsim_m3 <- OutputsModel$Qsim_m3 +
- Qupstream[2:(1 + LengthTs)] * HUTRANS[1, upstream_basin] +
- Qupstream[1:LengthTs] * HUTRANS[2, upstream_basin]
+ Qsim_m3 <- Qsim_m3 +
+ Qupstream[2:(1 + LInputSeries)] * HUTRANS[1, upstream_basin] +
+ Qupstream[1:LInputSeries] * HUTRANS[2, upstream_basin]
+ }
+
+ ## OutputsModel
+
+ OutputsModel$Qsim_m3 <- Qsim_m3[IndPeriod2]
+
+ if ("Qsim" %in% RunOptions$Outputs_Sim) {
+ # Convert back Qsim to mm
+ OutputsModel$Qsim <- OutputsModel$Qsim_m3 / sum(InputsModel$BasinAreas, na.rm = TRUE) / 1e3
+ # message("Qsim: ", paste(OutputsModel$Qsim, collapse = ", "))
}
- # Convert back Qsim to mm
- OutputsModel$Qsim <- OutputsModel$Qsim_m3 / sum(InputsModel$BasinAreas, na.rm = TRUE) / 1e3
- # message("Qsim: ", paste(OutputsModel$Qsim, collapse = ", "))
# Warning for negative flows or NAs only in extended outputs
if (length(RunOptions$Outputs_Sim) > 2) {
@@ -112,12 +137,20 @@ RunModel_Lag <- function(InputsModel, RunOptions, Param, QcontribDown) {
}
if ("StateEnd" %in% RunOptions$Outputs_Sim) {
- OutputsModel$StateEnd$SD <- lapply(seq(NbUpBasins), function(x) {
+ SD <- lapply(seq(NbUpBasins), function(x) {
lastTS <- RunOptions$IndPeriod_Run[length(RunOptions$IndPeriod_Run)]
InputsModel$Qupstream[(lastTS - floor(PT[x])):lastTS, x]
})
+ if(is.null(OutputsModel$StateEnd)) {
+ OutputsModel$StateEnd <- CreateIniStates(RunModel_Lag, InputsModel, SD = SD)
+ } else {
+ OutputsModel$StateEnd$SD <- SD
+ }
# message("StateEnd: ", paste(OutputsModel$StateEnd$SD, collapse = ", "))
}
+ if ("WarmUpQsim" %in% RunOptions$Outputs_Sim) {
+ OutputsModel$WarmUpQsim <- Qsim_m3[seq_len(length(RunOptions$IndPeriod_WarmUp))]
+ }
if ("Param" %in% RunOptions$Outputs_Sim) {
OutputsModel$Param <- c(Param, OutputsModel$Param)