RunModel_CemaNeige <- function(InputsModel, RunOptions, Param) { NParam <- 2L FortranOutputsCemaNeige <- c("Pliq", "Psol", "SnowPack", "ThermalState", "Gratio", "PotMelt", "Melt", "PliqAndMelt", "Temp") ## Arguments_check if (!inherits(InputsModel, "InputsModel")) { stop("'InputsModel' must be of class 'InputsModel'") return(NULL) } if (!inherits(InputsModel, "daily")) { stop("'InputsModel' must be of class 'daily'") return(NULL) } if (!inherits(InputsModel, "CemaNeige")) { stop("'InputsModel' must be of class 'CemaNeige'") return(NULL) } if (!inherits(RunOptions, "RunOptions")) { stop("'RunOptions' must be of class 'RunOptions'") return(NULL) } if (!inherits(RunOptions, "CemaNeige")) { stop("'RunOptions' must be of class 'CemaNeige'") return(NULL) } if (!is.vector(Param) | !is.numeric(Param)) { stop("'Param' must be a numeric vector") return(NULL) } if (sum(!is.na(Param)) != NParam) { stop(sprintf("'Param' must be a vector of length %i and contain no NA", NParam)) return(NULL) } ## Input_data_preparation if (identical(RunOptions$IndPeriod_WarmUp, 0)) { RunOptions$IndPeriod_WarmUp <- NULL } IndPeriod1 <- c(RunOptions$IndPeriod_WarmUp, RunOptions$IndPeriod_Run) IndPeriod2 <- (length(RunOptions$IndPeriod_WarmUp) + 1):length(IndPeriod1) ExportDatesR <- "DatesR" %in% RunOptions$Outputs_Sim ExportStateEnd <- "StateEnd" %in% RunOptions$Outputs_Sim ## SNOW_MODULE________________________________________________________________________________ ParamCemaNeige <- Param NLayers <- length(InputsModel$LayerPrecip) if (sum(is.na(ParamCemaNeige)) != 0) { stop("Param contains missing values") return(NULL) } if ("all" %in% RunOptions$Outputs_Sim) { IndOutputsCemaNeige <- 1:length(FortranOutputsCemaNeige) } else { IndOutputsCemaNeige <- which(FortranOutputsCemaNeige %in% RunOptions$Outputs_Sim) } CemaNeigeLayers <- list() CemaNeigeStateEnd <- NULL NameCemaNeigeLayers <- "CemaNeigeLayers" ## Call_DLL_CemaNeige_________________________ for (iLayer in 1:NLayers) { StateStartCemaNeige <- RunOptions$IniStates[(7 + 20 + 40) + c(iLayer, iLayer + NLayers)] RESULTS <- .Fortran("frun_CemaNeige", PACKAGE = "airGR", ## inputs LInputs = as.integer(length(IndPeriod1)), ### length of input and output series InputsPrecip = InputsModel$LayerPrecip[[iLayer]][IndPeriod1], ### input series of total precipitation [mm/d] InputsFracSolidPrecip = InputsModel$LayerFracSolidPrecip[[iLayer]][IndPeriod1], ### input series of fraction of solid precipitation [0-1] InputsTemp = InputsModel$LayerTemp[[iLayer]][IndPeriod1], ### input series of air mean temperature [degC] MeanAnSolidPrecip = RunOptions$MeanAnSolidPrecip[iLayer], ### value of annual mean solid precip [mm/y] NParam = as.integer(2), ### number of model parameter = 2 Param = as.double(ParamCemaNeige), ### parameter set NStates = as.integer(2), ### number of state variables used for model initialising = 2 StateStart = StateStartCemaNeige, ### state variables used when the model run starts NOutputs = as.integer(length(IndOutputsCemaNeige)), ### number of output series IndOutputs = IndOutputsCemaNeige, ### indices of output series ## outputs Outputs = matrix(-999.999, ### output series [mm] nrow = length(IndPeriod1), ncol = length(IndOutputsCemaNeige)), StateEnd = rep(-999.999, 2) ### state variables at the end of the model run (reservoir levels [mm] and HU) ) RESULTS$Outputs[round(RESULTS$Outputs , 3) == (-999.999)] <- NA RESULTS$StateEnd[round(RESULTS$StateEnd, 3) == (-999.999)] <- NA ## Data_storage CemaNeigeLayers[[iLayer]] <- lapply(seq_len(RESULTS$NOutputs), function(i) RESULTS$Outputs[IndPeriod2, i]) names(CemaNeigeLayers[[iLayer]]) <- FortranOutputsCemaNeige[IndOutputsCemaNeige] if (ExportStateEnd) { CemaNeigeStateEnd <- c(CemaNeigeStateEnd, RESULTS$StateEnd) } rm(RESULTS) } ### ENDFOR_iLayer names(CemaNeigeLayers) <- paste("Layer", formatC(1:NLayers, width = 2, flag = "0"), sep = "") if (ExportStateEnd) { CemaNeigeStateEnd <- CreateIniStates(FUN_MOD = RunModel_CemaNeige, InputsModel = InputsModel, ProdStore = NULL, RoutStore = NULL, ExpStore = NULL, UH1 = NULL, UH2 = NULL, GCemaNeigeLayers = CemaNeigeStateEnd[seq_len(2*NLayers)[seq_len(2*NLayers) %% 2 == 1]], eTGCemaNeigeLayers = CemaNeigeStateEnd[seq_len(2*NLayers)[seq_len(2*NLayers) %% 2 == 0]], verbose = FALSE) } ## Output_data_preparation if (!ExportDatesR & !ExportStateEnd) { OutputsModel <- list(CemaNeigeLayers) names(OutputsModel) <- NameCemaNeigeLayers } if (ExportDatesR & !ExportStateEnd) { OutputsModel <- c(list(InputsModel$DatesR[RunOptions$IndPeriod_Run]), list(CemaNeigeLayers)) names(OutputsModel) <- c("DatesR", NameCemaNeigeLayers) } if (!ExportDatesR & ExportStateEnd) { OutputsModel <- c(list(CemaNeigeLayers), list(CemaNeigeStateEnd)) names(OutputsModel) <- c(NameCemaNeigeLayers, "StateEnd") } if (ExportDatesR & ExportStateEnd) { OutputsModel <- c(list(InputsModel$DatesR[RunOptions$IndPeriod_Run]), list(CemaNeigeLayers), list(CemaNeigeStateEnd)) names(OutputsModel) <- c("DatesR", NameCemaNeigeLayers, "StateEnd") } ## End class(OutputsModel) <- c("OutputsModel", "daily", "CemaNeige") return(OutputsModel) }