Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
HYCAR-Hydro
airGR
Commits
0ada9d71
Commit
0ada9d71
authored
Jun 16, 2021
by
Dorchies David
Browse files
feat: use .GetOutputsModel for all RunModel functions
+ bug correction on DatesR item of .GetOutputsModel Refs
#129
parent
329591eb
Pipeline
#24003
failed with stages
in 32 minutes and 21 seconds
Changes
13
Pipelines
1
Hide whitespace changes
Inline
Side-by-side
R/RunModel_CemaNeigeGR4H.R
View file @
0ada9d71
...
...
@@ -6,7 +6,6 @@ RunModel_CemaNeigeGR4H <- function(InputsModel, RunOptions, Param) {
NParam
<-
ifelse
(
test
=
IsHyst
,
yes
=
8L
,
no
=
6L
)
NParamCN
<-
NParam
-
4L
NStates
<-
4L
FortranOutputs
<-
.FortranOutputs
(
GR
=
"GR4H"
,
isCN
=
TRUE
)
## Arguments check
...
...
@@ -76,9 +75,9 @@ RunModel_CemaNeigeGR4H <- function(InputsModel, RunOptions, Param) {
## CemaNeige________________________________________________________________________________
if
(
inherits
(
RunOptions
,
"CemaNeige"
))
{
if
(
"all"
%in%
RunOptions
$
Outputs_Sim
)
{
IndOutputsCemaNeige
<-
as.integer
(
1
:
length
(
FortranOutputs
$
CN
))
IndOutputsCemaNeige
<-
as.integer
(
1
:
length
(
RunOptions
$
FortranOutputs
$
CN
))
}
else
{
IndOutputsCemaNeige
<-
which
(
FortranOutputs
$
CN
%in%
RunOptions
$
Outputs_Sim
)
IndOutputsCemaNeige
<-
which
(
RunOptions
$
FortranOutputs
$
CN
%in%
RunOptions
$
Outputs_Sim
)
}
CemaNeigeLayers
<-
list
()
CemaNeigeStateEnd
<-
NULL
...
...
@@ -116,7 +115,7 @@ RunModel_CemaNeigeGR4H <- function(InputsModel, RunOptions, Param) {
## Data storage
CemaNeigeLayers
[[
iLayer
]]
<-
lapply
(
seq_len
(
RESULTS
$
NOutputs
),
function
(
i
)
RESULTS
$
Outputs
[
IndPeriod2
,
i
])
names
(
CemaNeigeLayers
[[
iLayer
]])
<-
FortranOutputs
$
CN
[
IndOutputsCemaNeige
]
names
(
CemaNeigeLayers
[[
iLayer
]])
<-
RunOptions
$
FortranOutputs
$
CN
[
IndOutputsCemaNeige
]
IndPliqAndMelt
<-
which
(
names
(
CemaNeigeLayers
[[
iLayer
]])
==
"PliqAndMelt"
)
if
(
iLayer
==
1
)
{
CatchMeltAndPliq
<-
RESULTS
$
Outputs
[,
IndPliqAndMelt
]
/
NLayers
...
...
@@ -142,9 +141,9 @@ RunModel_CemaNeigeGR4H <- function(InputsModel, RunOptions, Param) {
## GR model
if
(
"all"
%in%
RunOptions
$
Outputs_Sim
)
{
IndOutputsMod
<-
as.integer
(
1
:
length
(
FortranOutputs
$
GR
))
IndOutputsMod
<-
as.integer
(
1
:
length
(
RunOptions
$
FortranOutputs
$
GR
))
}
else
{
IndOutputsMod
<-
which
(
FortranOutputs
$
GR
%in%
RunOptions
$
Outputs_Sim
)
IndOutputsMod
<-
which
(
RunOptions
$
FortranOutputs
$
GR
%in%
RunOptions
$
Outputs_Sim
)
}
## Use of IniResLevels
...
...
@@ -186,45 +185,14 @@ RunModel_CemaNeigeGR4H <- function(InputsModel, RunOptions, Param) {
}
if
(
inherits
(
RunOptions
,
"CemaNeige"
)
&
"Precip"
%in%
RunOptions
$
Outputs_Sim
)
{
RESULTS
$
Outputs
[,
which
(
FortranOutputs
$
GR
[
IndOutputsMod
]
==
"Precip"
)]
<-
InputsModel
$
Precip
[
IndPeriod1
]
RESULTS
$
Outputs
[,
which
(
RunOptions
$
FortranOutputs
$
GR
[
IndOutputsMod
]
==
"Precip"
)]
<-
InputsModel
$
Precip
[
IndPeriod1
]
}
## Output data preparation
## OutputsModel only
if
(
!
ExportDatesR
&
!
ExportStateEnd
)
{
OutputsModel
<-
c
(
lapply
(
seq_len
(
RESULTS
$
NOutputs
),
function
(
i
)
RESULTS
$
Outputs
[
IndPeriod2
,
i
]),
list
(
CemaNeigeLayers
))
names
(
OutputsModel
)
<-
c
(
FortranOutputs
$
GR
[
IndOutputsMod
],
NameCemaNeigeLayers
)
}
## DatesR and OutputsModel only
if
(
ExportDatesR
&
!
ExportStateEnd
)
{
OutputsModel
<-
c
(
list
(
InputsModel
$
DatesR
[
RunOptions
$
IndPeriod_Run
]),
lapply
(
seq_len
(
RESULTS
$
NOutputs
),
function
(
i
)
RESULTS
$
Outputs
[
IndPeriod2
,
i
]),
list
(
CemaNeigeLayers
))
names
(
OutputsModel
)
<-
c
(
"DatesR"
,
FortranOutputs
$
GR
[
IndOutputsMod
],
NameCemaNeigeLayers
)
}
## OutputsModel and StateEnd only
if
(
!
ExportDatesR
&
ExportStateEnd
)
{
OutputsModel
<-
c
(
lapply
(
seq_len
(
RESULTS
$
NOutputs
),
function
(
i
)
RESULTS
$
Outputs
[
IndPeriod2
,
i
]),
list
(
CemaNeigeLayers
),
list
(
RESULTS
$
StateEnd
))
names
(
OutputsModel
)
<-
c
(
FortranOutputs
$
GR
[
IndOutputsMod
],
NameCemaNeigeLayers
,
"StateEnd"
)
}
## DatesR and OutputsModel and StateEnd
if
(
ExportDatesR
&
ExportStateEnd
)
{
OutputsModel
<-
c
(
list
(
InputsModel
$
DatesR
[
RunOptions
$
IndPeriod_Run
]),
lapply
(
seq_len
(
RESULTS
$
NOutputs
),
function
(
i
)
RESULTS
$
Outputs
[
IndPeriod2
,
i
]),
list
(
CemaNeigeLayers
),
list
(
RESULTS
$
StateEnd
))
names
(
OutputsModel
)
<-
c
(
"DatesR"
,
FortranOutputs
$
GR
[
IndOutputsMod
],
NameCemaNeigeLayers
,
"StateEnd"
)
}
## End
rm
(
RESULTS
)
class
(
OutputsModel
)
<-
c
(
"OutputsModel"
,
"hourly"
,
"GR"
,
"CemaNeige"
)
if
(
IsHyst
)
{
class
(
OutputsModel
)
<-
c
(
class
(
OutputsModel
),
"hysteresis"
)
}
return
(
OutputsModel
)
## OutputsModel generation
.GetOutputsModel
(
InputsModel
,
RunOptions
,
RESULTS
,
LInputSeries
,
CemaNeigeLayers
)
}
R/RunModel_CemaNeigeGR4J.R
View file @
0ada9d71
RunModel_CemaNeigeGR4J
<-
function
(
InputsModel
,
RunOptions
,
Param
)
{
## Initialization of variables
IsHyst
<-
inherits
(
RunOptions
,
"hysteresis"
)
NParam
<-
ifelse
(
test
=
IsHyst
,
yes
=
8L
,
no
=
6L
)
NParamCN
<-
NParam
-
4L
NStates
<-
4L
FortranOutputs
<-
.FortranOutputs
(
GR
=
"GR4J"
,
isCN
=
TRUE
)
## Arguments check
if
(
!
inherits
(
InputsModel
,
"InputsModel"
))
{
stop
(
"'InputsModel' must be of class 'InputsModel'"
)
...
...
@@ -38,7 +37,7 @@ RunModel_CemaNeigeGR4J <- function(InputsModel, RunOptions, Param) {
stop
(
paste
(
"'Param' must be a vector of length"
,
NParam
,
"and contain no NA"
))
}
Param
<-
as.double
(
Param
)
Param_X1X3_threshold
<-
1e-2
Param_X4_threshold
<-
0.5
...
...
@@ -53,8 +52,8 @@ RunModel_CemaNeigeGR4J <- function(InputsModel, RunOptions, Param) {
if
(
Param
[
4L
]
<
Param_X4_threshold
)
{
warning
(
sprintf
(
"Param[4] (X4: unit hydrograph time constant [d]) < %.2f\n X4 set to %.2f"
,
Param_X4_threshold
,
Param_X4_threshold
))
Param
[
4L
]
<-
Param_X4_threshold
}
}
## Input data preparation
if
(
identical
(
RunOptions
$
IndPeriod_WarmUp
,
0L
))
{
RunOptions
$
IndPeriod_WarmUp
<-
NULL
...
...
@@ -71,20 +70,20 @@ RunModel_CemaNeigeGR4J <- function(InputsModel, RunOptions, Param) {
## Output data preparation
ExportDatesR
<-
"DatesR"
%in%
RunOptions
$
Outputs_Sim
ExportStateEnd
<-
"StateEnd"
%in%
RunOptions
$
Outputs_Sim
## CemaNeige________________________________________________________________________________
if
(
inherits
(
RunOptions
,
"CemaNeige"
))
{
if
(
"all"
%in%
RunOptions
$
Outputs_Sim
)
{
IndOutputsCemaNeige
<-
as.integer
(
1
:
length
(
FortranOutputs
$
CN
))
IndOutputsCemaNeige
<-
as.integer
(
1
:
length
(
RunOptions
$
FortranOutputs
$
CN
))
}
else
{
IndOutputsCemaNeige
<-
which
(
FortranOutputs
$
CN
%in%
RunOptions
$
Outputs_Sim
)
IndOutputsCemaNeige
<-
which
(
RunOptions
$
FortranOutputs
$
CN
%in%
RunOptions
$
Outputs_Sim
)
}
CemaNeigeLayers
<-
list
()
CemaNeigeStateEnd
<-
NULL
NameCemaNeigeLayers
<-
"CemaNeigeLayers"
## Call CemaNeige Fortran_________________________
for
(
iLayer
in
1
:
NLayers
)
{
if
(
!
IsHyst
)
{
...
...
@@ -92,7 +91,7 @@ RunModel_CemaNeigeGR4J <- function(InputsModel, RunOptions, Param) {
}
else
{
StateStartCemaNeige
<-
RunOptions
$
IniStates
[(
7
+
20
+
40
)
+
c
(
iLayer
,
iLayer
+
NLayers
,
iLayer
+2
*
NLayers
,
iLayer
+3
*
NLayers
)]
}
RESULTS
<-
.Fortran
(
"frun_cemaneige"
,
PACKAGE
=
"airGR"
,
RESULTS
<-
.Fortran
(
"frun_cemaneige"
,
PACKAGE
=
"airGR"
,
## inputs
LInputs
=
LInputSeries
,
### length of input and output series
InputsPrecip
=
InputsModel
$
LayerPrecip
[[
iLayer
]][
IndPeriod1
],
### input series of total precipitation [mm/d]
...
...
@@ -106,16 +105,16 @@ RunModel_CemaNeigeGR4J <- function(InputsModel, RunOptions, Param) {
IsHyst
=
as.integer
(
IsHyst
),
### use of hysteresis
NOutputs
=
as.integer
(
length
(
IndOutputsCemaNeige
)),
### number of output series
IndOutputs
=
IndOutputsCemaNeige
,
### indices of output series
## outputs
## outputs
Outputs
=
matrix
(
as.double
(
-99e9
),
nrow
=
LInputSeries
,
ncol
=
length
(
IndOutputsCemaNeige
)),
### output series [mm, mm/d or degC]
StateEnd
=
rep
(
as.double
(
-99e9
),
as.integer
(
NStates
))
### state variables at the end of the model run
)
RESULTS
$
Outputs
[
RESULTS
$
Outputs
<=
-99e8
]
<-
NA
RESULTS
$
StateEnd
[
RESULTS
$
StateEnd
<=
-99e8
]
<-
NA
## Data storage
CemaNeigeLayers
[[
iLayer
]]
<-
lapply
(
seq_len
(
RESULTS
$
NOutputs
),
function
(
i
)
RESULTS
$
Outputs
[
IndPeriod2
,
i
])
names
(
CemaNeigeLayers
[[
iLayer
]])
<-
FortranOutputs
$
CN
[
IndOutputsCemaNeige
]
names
(
CemaNeigeLayers
[[
iLayer
]])
<-
RunOptions
$
FortranOutputs
$
CN
[
IndOutputsCemaNeige
]
IndPliqAndMelt
<-
which
(
names
(
CemaNeigeLayers
[[
iLayer
]])
==
"PliqAndMelt"
)
if
(
iLayer
==
1
)
{
CatchMeltAndPliq
<-
RESULTS
$
Outputs
[,
IndPliqAndMelt
]
/
NLayers
...
...
@@ -136,24 +135,24 @@ RunModel_CemaNeigeGR4J <- function(InputsModel, RunOptions, Param) {
NameCemaNeigeLayers
<-
NULL
CatchMeltAndPliq
<-
InputsModel
$
Precip
[
IndPeriod1
]
}
## GR model______________________________________________________________________________________
if
(
"all"
%in%
RunOptions
$
Outputs_Sim
)
{
IndOutputsMod
<-
as.integer
(
1
:
length
(
FortranOutputs
$
GR
))
IndOutputsMod
<-
as.integer
(
1
:
length
(
RunOptions
$
FortranOutputs
$
GR
))
}
else
{
IndOutputsMod
<-
which
(
FortranOutputs
$
GR
%in%
RunOptions
$
Outputs_Sim
)
IndOutputsMod
<-
which
(
RunOptions
$
FortranOutputs
$
GR
%in%
RunOptions
$
Outputs_Sim
)
}
## Use of IniResLevels
if
(
!
is.null
(
RunOptions
$
IniResLevels
))
{
RunOptions
$
IniStates
[
1
]
<-
RunOptions
$
IniResLevels
[
1
]
*
ParamMod
[
1
]
### production store level (mm)
RunOptions
$
IniStates
[
2
]
<-
RunOptions
$
IniResLevels
[
2
]
*
ParamMod
[
3
]
### routing store level (mm)
}
## Call GR model Fortan
RESULTS
<-
.Fortran
(
"frun_gr4j"
,
PACKAGE
=
"airGR"
,
RESULTS
<-
.Fortran
(
"frun_gr4j"
,
PACKAGE
=
"airGR"
,
## inputs
LInputs
=
LInputSeries
,
### length of input and output series
InputsPrecip
=
CatchMeltAndPliq
,
### input series of total precipitation [mm/d]
...
...
@@ -164,7 +163,7 @@ RunModel_CemaNeigeGR4J <- function(InputsModel, RunOptions, Param) {
StateStart
=
RunOptions
$
IniStates
[
1
:
NStatesMod
],
### state variables used when the model run starts
NOutputs
=
as.integer
(
length
(
IndOutputsMod
)),
### number of output series
IndOutputs
=
IndOutputsMod
,
### indices of output series
## outputs
## outputs
Outputs
=
matrix
(
as.double
(
-99e9
),
nrow
=
LInputSeries
,
ncol
=
length
(
IndOutputsMod
)),
### output series [mm or mm/d]
StateEnd
=
rep
(
as.double
(
-99e9
),
NStatesMod
)
### state variables at the end of the model run
)
...
...
@@ -173,57 +172,26 @@ RunModel_CemaNeigeGR4J <- function(InputsModel, RunOptions, Param) {
if
(
ExportStateEnd
)
{
RESULTS
$
StateEnd
[
-3L
]
<-
ifelse
(
RESULTS
$
StateEnd
[
-3L
]
<
0
,
0
,
RESULTS
$
StateEnd
[
-3L
])
### remove negative values except for the ExpStore location
idNStates
<-
seq_len
(
NStates
*
NLayers
)
%%
NStates
RESULTS
$
StateEnd
<-
CreateIniStates
(
FUN_MOD
=
RunModel_CemaNeigeGR4J
,
InputsModel
=
InputsModel
,
IsHyst
=
IsHyst
,
ProdStore
=
RESULTS
$
StateEnd
[
1L
],
RoutStore
=
RESULTS
$
StateEnd
[
2L
],
ExpStore
=
NULL
,
RESULTS
$
StateEnd
<-
CreateIniStates
(
FUN_MOD
=
RunModel_CemaNeigeGR4J
,
InputsModel
=
InputsModel
,
IsHyst
=
IsHyst
,
ProdStore
=
RESULTS
$
StateEnd
[
1L
],
RoutStore
=
RESULTS
$
StateEnd
[
2L
],
ExpStore
=
NULL
,
UH1
=
RESULTS
$
StateEnd
[(
1
:
20
)
+
7
],
UH2
=
RESULTS
$
StateEnd
[(
1
:
40
)
+
(
7+20
)],
GCemaNeigeLayers
=
CemaNeigeStateEnd
[
seq_len
(
NStates
*
NLayers
)[
idNStates
==
1
]],
eTGCemaNeigeLayers
=
CemaNeigeStateEnd
[
seq_len
(
NStates
*
NLayers
)[
idNStates
==
2
]],
GthrCemaNeigeLayers
=
CemaNeigeStateEnd
[
seq_len
(
NStates
*
NLayers
)[
idNStates
==
3
]],
GlocmaxCemaNeigeLayers
=
CemaNeigeStateEnd
[
seq_len
(
NStates
*
NLayers
)[
idNStates
==
0
]],
UH2
=
RESULTS
$
StateEnd
[(
1
:
40
)
+
(
7+20
)],
GCemaNeigeLayers
=
CemaNeigeStateEnd
[
seq_len
(
NStates
*
NLayers
)[
idNStates
==
1
]],
eTGCemaNeigeLayers
=
CemaNeigeStateEnd
[
seq_len
(
NStates
*
NLayers
)[
idNStates
==
2
]],
GthrCemaNeigeLayers
=
CemaNeigeStateEnd
[
seq_len
(
NStates
*
NLayers
)[
idNStates
==
3
]],
GlocmaxCemaNeigeLayers
=
CemaNeigeStateEnd
[
seq_len
(
NStates
*
NLayers
)[
idNStates
==
0
]],
verbose
=
FALSE
)
}
if
(
inherits
(
RunOptions
,
"CemaNeige"
)
&
"Precip"
%in%
RunOptions
$
Outputs_Sim
)
{
RESULTS
$
Outputs
[,
which
(
FortranOutputs
$
GR
[
IndOutputsMod
]
==
"Precip"
)]
<-
InputsModel
$
Precip
[
IndPeriod1
]
RESULTS
$
Outputs
[,
which
(
RunOptions
$
FortranOutputs
$
GR
[
IndOutputsMod
]
==
"Precip"
)]
<-
InputsModel
$
Precip
[
IndPeriod1
]
}
## Output data preparation
## OutputsModel only
if
(
!
ExportDatesR
&
!
ExportStateEnd
)
{
OutputsModel
<-
c
(
lapply
(
seq_len
(
RESULTS
$
NOutputs
),
function
(
i
)
RESULTS
$
Outputs
[
IndPeriod2
,
i
]),
list
(
CemaNeigeLayers
))
names
(
OutputsModel
)
<-
c
(
FortranOutputs
$
GR
[
IndOutputsMod
],
NameCemaNeigeLayers
)
}
## DatesR and OutputsModel only
if
(
ExportDatesR
&
!
ExportStateEnd
)
{
OutputsModel
<-
c
(
list
(
InputsModel
$
DatesR
[
RunOptions
$
IndPeriod_Run
]),
lapply
(
seq_len
(
RESULTS
$
NOutputs
),
function
(
i
)
RESULTS
$
Outputs
[
IndPeriod2
,
i
]),
list
(
CemaNeigeLayers
))
names
(
OutputsModel
)
<-
c
(
"DatesR"
,
FortranOutputs
$
GR
[
IndOutputsMod
],
NameCemaNeigeLayers
)
}
## OutputsModel and StateEnd only
if
(
!
ExportDatesR
&
ExportStateEnd
)
{
OutputsModel
<-
c
(
lapply
(
seq_len
(
RESULTS
$
NOutputs
),
function
(
i
)
RESULTS
$
Outputs
[
IndPeriod2
,
i
]),
list
(
CemaNeigeLayers
),
list
(
RESULTS
$
StateEnd
))
names
(
OutputsModel
)
<-
c
(
FortranOutputs
$
GR
[
IndOutputsMod
],
NameCemaNeigeLayers
,
"StateEnd"
)
}
## DatesR and OutputsModel and StateEnd
if
(
ExportDatesR
&
ExportStateEnd
)
{
OutputsModel
<-
c
(
list
(
InputsModel
$
DatesR
[
RunOptions
$
IndPeriod_Run
]),
lapply
(
seq_len
(
RESULTS
$
NOutputs
),
function
(
i
)
RESULTS
$
Outputs
[
IndPeriod2
,
i
]),
list
(
CemaNeigeLayers
),
list
(
RESULTS
$
StateEnd
))
names
(
OutputsModel
)
<-
c
(
"DatesR"
,
FortranOutputs
$
GR
[
IndOutputsMod
],
NameCemaNeigeLayers
,
"StateEnd"
)
}
## End
rm
(
RESULTS
)
class
(
OutputsModel
)
<-
c
(
"OutputsModel"
,
"daily"
,
"GR"
,
"CemaNeige"
)
if
(
IsHyst
)
{
class
(
OutputsModel
)
<-
c
(
class
(
OutputsModel
),
"hysteresis"
)
}
return
(
OutputsModel
)
## OutputsModel generation
.GetOutputsModel
(
InputsModel
,
RunOptions
,
RESULTS
,
LInputSeries
,
CemaNeigeLayers
)
}
R/RunModel_CemaNeigeGR5H.R
View file @
0ada9d71
RunModel_CemaNeigeGR5H
<-
function
(
InputsModel
,
RunOptions
,
Param
)
{
## Initialization of variables
IsHyst
<-
inherits
(
RunOptions
,
"hysteresis"
)
NParam
<-
ifelse
(
test
=
IsHyst
,
yes
=
9L
,
no
=
7L
)
NParamCN
<-
NParam
-
5L
NStates
<-
4L
FortranOutputs
<-
.FortranOutputs
(
GR
=
"GR5H"
,
isCN
=
TRUE
)
IsIntStore
<-
inherits
(
RunOptions
,
"interception"
)
if
(
IsIntStore
)
{
Imax
<-
RunOptions
$
Imax
}
else
{
Imax
<-
-99
}
## Arguments check
if
(
!
inherits
(
InputsModel
,
"InputsModel"
))
{
stop
(
"'InputsModel' must be of class 'InputsModel'"
)
...
...
@@ -44,8 +43,8 @@ RunModel_CemaNeigeGR5H <- function(InputsModel, RunOptions, Param) {
stop
(
paste
(
"'Param' must be a vector of length"
,
NParam
,
"and contain no NA"
))
}
Param
<-
as.double
(
Param
)
Param_X1X3_threshold
<-
1e-2
Param_X4_threshold
<-
0.5
if
(
Param
[
1L
]
<
Param_X1X3_threshold
)
{
...
...
@@ -59,8 +58,8 @@ RunModel_CemaNeigeGR5H <- function(InputsModel, RunOptions, Param) {
if
(
Param
[
4L
]
<
Param_X4_threshold
)
{
warning
(
sprintf
(
"Param[4] (X4: unit hydrograph time constant [h]) < %.2f\n X4 set to %.2f"
,
Param_X4_threshold
,
Param_X4_threshold
))
Param
[
4L
]
<-
Param_X4_threshold
}
}
## Input data preparation
if
(
identical
(
RunOptions
$
IndPeriod_WarmUp
,
0L
))
{
RunOptions
$
IndPeriod_WarmUp
<-
NULL
...
...
@@ -73,24 +72,24 @@ RunModel_CemaNeigeGR5H <- function(InputsModel, RunOptions, Param) {
ParamMod
<-
Param
[
1
:
NParamMod
]
NLayers
<-
length
(
InputsModel
$
LayerPrecip
)
NStatesMod
<-
as.integer
(
length
(
RunOptions
$
IniStates
)
-
NStates
*
NLayers
)
## Output data preparation
ExportDatesR
<-
"DatesR"
%in%
RunOptions
$
Outputs_Sim
ExportStateEnd
<-
"StateEnd"
%in%
RunOptions
$
Outputs_Sim
## CemaNeige________________________________________________________________________________
if
(
inherits
(
RunOptions
,
"CemaNeige"
))
{
if
(
"all"
%in%
RunOptions
$
Outputs_Sim
)
{
IndOutputsCemaNeige
<-
as.integer
(
1
:
length
(
FortranOutputs
$
CN
))
IndOutputsCemaNeige
<-
as.integer
(
1
:
length
(
RunOptions
$
FortranOutputs
$
CN
))
}
else
{
IndOutputsCemaNeige
<-
which
(
FortranOutputs
$
CN
%in%
RunOptions
$
Outputs_Sim
)
IndOutputsCemaNeige
<-
which
(
RunOptions
$
FortranOutputs
$
CN
%in%
RunOptions
$
Outputs_Sim
)
}
CemaNeigeLayers
<-
list
()
CemaNeigeStateEnd
<-
NULL
NameCemaNeigeLayers
<-
"CemaNeigeLayers"
## Call CemaNeige Fortran_________________________
for
(
iLayer
in
1
:
NLayers
)
{
...
...
@@ -113,16 +112,16 @@ RunModel_CemaNeigeGR5H <- function(InputsModel, RunOptions, Param) {
IsHyst
=
as.integer
(
IsHyst
),
### use of hysteresis
NOutputs
=
as.integer
(
length
(
IndOutputsCemaNeige
)),
### number of output series
IndOutputs
=
IndOutputsCemaNeige
,
### indices of output series
## outputs
## outputs
Outputs
=
matrix
(
as.double
(
-99e9
),
nrow
=
LInputSeries
,
ncol
=
length
(
IndOutputsCemaNeige
)),
### output series [mm, mm/h or degC]
StateEnd
=
rep
(
as.double
(
-99e9
),
as.integer
(
NStates
))
### state variables at the end of the model run
)
RESULTS
$
Outputs
[
RESULTS
$
Outputs
<=
-99e8
]
<-
NA
RESULTS
$
StateEnd
[
RESULTS
$
StateEnd
<=
-99e8
]
<-
NA
## Data storage
CemaNeigeLayers
[[
iLayer
]]
<-
lapply
(
seq_len
(
RESULTS
$
NOutputs
),
function
(
i
)
RESULTS
$
Outputs
[
IndPeriod2
,
i
])
names
(
CemaNeigeLayers
[[
iLayer
]])
<-
FortranOutputs
$
CN
[
IndOutputsCemaNeige
]
names
(
CemaNeigeLayers
[[
iLayer
]])
<-
RunOptions
$
FortranOutputs
$
CN
[
IndOutputsCemaNeige
]
IndPliqAndMelt
<-
which
(
names
(
CemaNeigeLayers
[[
iLayer
]])
==
"PliqAndMelt"
)
if
(
iLayer
==
1
)
{
CatchMeltAndPliq
<-
RESULTS
$
Outputs
[,
IndPliqAndMelt
]
/
NLayers
...
...
@@ -148,9 +147,9 @@ RunModel_CemaNeigeGR5H <- function(InputsModel, RunOptions, Param) {
## GR model
if
(
"all"
%in%
RunOptions
$
Outputs_Sim
)
{
IndOutputsMod
<-
as.integer
(
1
:
length
(
FortranOutputs
$
GR
))
IndOutputsMod
<-
as.integer
(
1
:
length
(
RunOptions
$
FortranOutputs
$
GR
))
}
else
{
IndOutputsMod
<-
which
(
FortranOutputs
$
GR
%in%
RunOptions
$
Outputs_Sim
)
IndOutputsMod
<-
which
(
RunOptions
$
FortranOutputs
$
GR
%in%
RunOptions
$
Outputs_Sim
)
}
## Use of IniResLevels
...
...
@@ -191,54 +190,20 @@ RunModel_CemaNeigeGR5H <- function(InputsModel, RunOptions, Param) {
UH2
=
RESULTS
$
StateEnd
[(
1
:
(
40
*
24
))
+
(
7+20
*
24
)],
GCemaNeigeLayers
=
CemaNeigeStateEnd
[
seq_len
(
NStates
*
NLayers
)[
idNStates
==
1
]],
eTGCemaNeigeLayers
=
CemaNeigeStateEnd
[
seq_len
(
NStates
*
NLayers
)[
idNStates
==
2
]],
GthrCemaNeigeLayers
=
CemaNeigeStateEnd
[
seq_len
(
NStates
*
NLayers
)[
idNStates
==
3
]],
GthrCemaNeigeLayers
=
CemaNeigeStateEnd
[
seq_len
(
NStates
*
NLayers
)[
idNStates
==
3
]],
GlocmaxCemaNeigeLayers
=
CemaNeigeStateEnd
[
seq_len
(
NStates
*
NLayers
)[
idNStates
==
0
]],
verbose
=
FALSE
)
}
if
(
inherits
(
RunOptions
,
"CemaNeige"
)
&
"Precip"
%in%
RunOptions
$
Outputs_Sim
)
{
RESULTS
$
Outputs
[,
which
(
FortranOutputs
$
GR
[
IndOutputsMod
]
==
"Precip"
)]
<-
InputsModel
$
Precip
[
IndPeriod1
]
RESULTS
$
Outputs
[,
which
(
RunOptions
$
FortranOutputs
$
GR
[
IndOutputsMod
]
==
"Precip"
)]
<-
InputsModel
$
Precip
[
IndPeriod1
]
}
## Output data preparation
## OutputsModel only
if
(
!
ExportDatesR
&
!
ExportStateEnd
)
{
OutputsModel
<-
c
(
lapply
(
seq_len
(
RESULTS
$
NOutputs
),
function
(
i
)
RESULTS
$
Outputs
[
IndPeriod2
,
i
]),
list
(
CemaNeigeLayers
))
names
(
OutputsModel
)
<-
c
(
FortranOutputs
$
GR
[
IndOutputsMod
],
NameCemaNeigeLayers
)
}
## DatesR and OutputsModel only
if
(
ExportDatesR
&
!
ExportStateEnd
)
{
OutputsModel
<-
c
(
list
(
InputsModel
$
DatesR
[
RunOptions
$
IndPeriod_Run
]),
lapply
(
seq_len
(
RESULTS
$
NOutputs
),
function
(
i
)
RESULTS
$
Outputs
[
IndPeriod2
,
i
]),
list
(
CemaNeigeLayers
))
names
(
OutputsModel
)
<-
c
(
"DatesR"
,
FortranOutputs
$
GR
[
IndOutputsMod
],
NameCemaNeigeLayers
)
}
## OutputsModel and StateEnd only
if
(
!
ExportDatesR
&
ExportStateEnd
)
{
OutputsModel
<-
c
(
lapply
(
seq_len
(
RESULTS
$
NOutputs
),
function
(
i
)
RESULTS
$
Outputs
[
IndPeriod2
,
i
]),
list
(
CemaNeigeLayers
),
list
(
RESULTS
$
StateEnd
))
names
(
OutputsModel
)
<-
c
(
FortranOutputs
$
GR
[
IndOutputsMod
],
NameCemaNeigeLayers
,
"StateEnd"
)
}
## DatesR and OutputsModel and StateEnd
if
(
ExportDatesR
&
ExportStateEnd
)
{
OutputsModel
<-
c
(
list
(
InputsModel
$
DatesR
[
RunOptions
$
IndPeriod_Run
]),
lapply
(
seq_len
(
RESULTS
$
NOutputs
),
function
(
i
)
RESULTS
$
Outputs
[
IndPeriod2
,
i
]),
list
(
CemaNeigeLayers
),
list
(
RESULTS
$
StateEnd
))
names
(
OutputsModel
)
<-
c
(
"DatesR"
,
FortranOutputs
$
GR
[
IndOutputsMod
],
NameCemaNeigeLayers
,
"StateEnd"
)
}
## End
rm
(
RESULTS
)
class
(
OutputsModel
)
<-
c
(
"OutputsModel"
,
"hourly"
,
"GR"
,
"CemaNeige"
)
if
(
IsHyst
)
{
class
(
OutputsModel
)
<-
c
(
class
(
OutputsModel
),
"hysteresis"
)
}
if
(
IsIntStore
)
{
class
(
OutputsModel
)
<-
c
(
class
(
OutputsModel
),
"interception"
)
}
return
(
OutputsModel
)
## OutputsModel generation
.GetOutputsModel
(
InputsModel
,
RunOptions
,
RESULTS
,
LInputSeries
,
CemaNeigeLayers
)
}
R/RunModel_CemaNeigeGR5J.R
View file @
0ada9d71
RunModel_CemaNeigeGR5J
<-
function
(
InputsModel
,
RunOptions
,
Param
)
{
## Initialization of variables
IsHyst
<-
inherits
(
RunOptions
,
"hysteresis"
)
NParam
<-
ifelse
(
test
=
IsHyst
,
yes
=
9L
,
no
=
7L
)
NParamCN
<-
NParam
-
5L
NStates
<-
4L
FortranOutputs
<-
.FortranOutputs
(
GR
=
"GR5J"
,
isCN
=
TRUE
)
## Arguments check
if
(
!
inherits
(
InputsModel
,
"InputsModel"
))
{
stop
(
"'InputsModel' must be of class 'InputsModel'"
)
...
...
@@ -38,8 +37,8 @@ RunModel_CemaNeigeGR5J <- function(InputsModel, RunOptions, Param) {
stop
(
paste
(
"'Param' must be a vector of length"
,
NParam
,
"and contain no NA"
))
}
Param
<-
as.double
(
Param
)
Param_X1X3_threshold
<-
1e-2
Param_X4_threshold
<-
0.5
if
(
Param
[
1L
]
<
Param_X1X3_threshold
)
{
...
...
@@ -53,8 +52,8 @@ RunModel_CemaNeigeGR5J <- function(InputsModel, RunOptions, Param) {
if
(
Param
[
4L
]
<
Param_X4_threshold
)
{
warning
(
sprintf
(
"Param[4] (X4: unit hydrograph time constant [d]) < %.2f\n X4 set to %.2f"
,
Param_X4_threshold
,
Param_X4_threshold
))
Param
[
4L
]
<-
Param_X4_threshold
}
}
## Input data preparation
if
(
identical
(
RunOptions
$
IndPeriod_WarmUp
,
0L
))
{
RunOptions
$
IndPeriod_WarmUp
<-
NULL
...
...
@@ -69,20 +68,20 @@ RunModel_CemaNeigeGR5J <- function(InputsModel, RunOptions, Param) {
NStatesMod
<-
as.integer
(
length
(
RunOptions
$
IniStates
)
-
NStates
*
NLayers
)
ExportDatesR
<-
"DatesR"
%in%
RunOptions
$
Outputs_Sim
ExportStateEnd
<-
"StateEnd"
%in%
RunOptions
$
Outputs_Sim
## CemaNeige________________________________________________________________________________
if
(
inherits
(
RunOptions
,
"CemaNeige"
))
{
if
(
"all"
%in%
RunOptions
$
Outputs_Sim
)
{
IndOutputsCemaNeige
<-
as.integer
(
1
:
length
(
FortranOutputs
$
CN
))
IndOutputsCemaNeige
<-
as.integer
(
1
:
length
(
RunOptions
$
FortranOutputs
$
CN
))
}
else
{
IndOutputsCemaNeige
<-
which
(
FortranOutputs
$
CN
%in%
RunOptions
$
Outputs_Sim
)
IndOutputsCemaNeige
<-
which
(
RunOptions
$
FortranOutputs
$
CN
%in%
RunOptions
$
Outputs_Sim
)
}
CemaNeigeLayers
<-
list
()
CemaNeigeStateEnd
<-
NULL
NameCemaNeigeLayers
<-
"CemaNeigeLayers"
## Call CemaNeige Fortran_________________________
for
(
iLayer
in
1
:
NLayers
)
{
if
(
!
IsHyst
)
{
...
...
@@ -104,16 +103,16 @@ RunModel_CemaNeigeGR5J <- function(InputsModel, RunOptions, Param) {
IsHyst
=
as.integer
(
IsHyst
),
### use of hysteresis
NOutputs
=
as.integer
(
length
(
IndOutputsCemaNeige
)),
### number of output series
IndOutputs
=
IndOutputsCemaNeige
,
### indices of output series
## outputs
## outputs
Outputs
=
matrix
(
as.double
(
-99e9
),
nrow
=
LInputSeries
,
ncol
=
length
(
IndOutputsCemaNeige
)),
### output series [mm, mm/d or degC]
StateEnd
=
rep
(
as.double
(
-99e9
),
as.integer
(
NStates
))
### state variables at the end of the model run
)
RESULTS
$
Outputs
[
RESULTS
$
Outputs
<=
-99e8
]
<-
NA
RESULTS
$
StateEnd
[
RESULTS
$
StateEnd
<=
-99e8
]
<-
NA
## Data storage
CemaNeigeLayers
[[
iLayer
]]
<-
lapply
(
seq_len
(
RESULTS
$
NOutputs
),
function
(
i
)
RESULTS
$
Outputs
[
IndPeriod2
,
i
])
names
(
CemaNeigeLayers
[[
iLayer
]])
<-
FortranOutputs
$
CN
[
IndOutputsCemaNeige
]
names
(
CemaNeigeLayers
[[
iLayer
]])
<-
RunOptions
$
FortranOutputs
$
CN
[
IndOutputsCemaNeige
]
IndPliqAndMelt
<-
which
(
names
(
CemaNeigeLayers
[[
iLayer
]])
==
"PliqAndMelt"
)
if
(
iLayer
==
1
)
{
CatchMeltAndPliq
<-
RESULTS
$
Outputs
[,
IndPliqAndMelt
]
/
NLayers
...
...
@@ -134,22 +133,22 @@ RunModel_CemaNeigeGR5J <- function(InputsModel, RunOptions, Param) {
NameCemaNeigeLayers
<-
NULL
CatchMeltAndPliq
<-
InputsModel
$
Precip
[
IndPeriod1
]
}
## GR model______________________________________________________________________________________
if
(
"all"
%in%
RunOptions
$
Outputs_Sim
)
{
IndOutputsMod
<-
as.integer
(
1
:
length
(
FortranOutputs
$
GR
))
IndOutputsMod
<