From 84f3c2508005cf96a72f696cd3a659f3a2c25d70 Mon Sep 17 00:00:00 2001 From: istfer Date: Sat, 8 Jun 2019 13:37:29 -0400 Subject: [PATCH 01/56] started new read state function --- models/lpjguess/R/read_state.R | 53 ++++++++++++++++++++++++++++++++++ 1 file changed, 53 insertions(+) create mode 100644 models/lpjguess/R/read_state.R diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R new file mode 100644 index 00000000000..e8a1b2c08c2 --- /dev/null +++ b/models/lpjguess/R/read_state.R @@ -0,0 +1,53 @@ +library(stringr) + +# this fcn is for potential natural vegetation only +# when there is landcover, there will be more stand types + +# also for cohort mode only + +# Gridcell: Top-level object containing all dynamic and static data for a particular gridcell +# Gridcellpft: Object containing data common to all individuals of a particular PFT in a particular gridcell +# Gridcellst : Object containing data common to all stands of a particular stand type (ST) in a particular gridcell +# Climate : Contains all static and dynamic data relating to the overall environmental properties, other than soil properties, of a gridcell +# Soiltype : Stores soil static parameters. One object of class Soiltype is defined for each gridcell. +# Stand : Object containing all dynamic and static data for a particular stand +# Patch : Stores data specific to a patch. In cohort and individual modes, replicate patches are required in each stand to accommodate stochastic variation across the site. +# Patchpft : Object containing data common to all individuals of a particular PFT in a particular patch, including litter pools. +# Vegetation : A dynamic list of Individual objects, representing the vegetation of a particular patch +# Soil : Stores state variables for soils and the snow pack. One object of class Soil is defined for each patch. +# Fluxes : The Fluxes class stores accumulated monthly and annual fluxes. One object of type Fluxes is defined for each patch. +# Individual : Stores state variables for an average individual plant. In cohort mode, it is the average individual of a cohort of plants approximately the same age and from the same patch. + +# maybe put guess.h and guess.cpp for each model version into the model package +guesscpp_loc <- "/fs/data5/pecan.models/LPJ-GUESS/framework/guess.cpp" +guessh_loc <- "/fs/data5/pecan.models/LPJ-GUESS/framework/guess.h" + +# guess.cpp has the info of what is being written +guesscpp_in <- readLines(guesscpp_loc) +# guess.h has the types so that we know what streamsize to read +guessh_in <- readLines(guessh_loc) +################################ check class compatibility ################################ +# between model versions we don't expect major classes or hierarchy to change +# but give check and fail if necessary +LPJ_GUESS_CLASSES <- c("Gridcell", "Climate", "Gridcellpft", "Stand", "Standpft", "Patch", "Patchpft", + "Individual", "Soil", "Sompool", "Fluxes", "Vegetation") + +lpjguess_classes <- list() +ctr <- 1 +for(i in seq_along(guessh_in)){ + # search for "class XXX : public Serializable {" + res <- str_match(guessh_in[i], "class (.*?) : public Serializable") + if(is.na(res[,2])){ + # try "class XXX : public ..., public Serializable {" pattern + res <- str_match(guessh_in[i], "class (.*?) : public .* Serializable") + } + if(!is.na(res[,2])){ + lpjguess_classes[[ctr]] <- res[,2] + ctr <- ctr + 1 + } +} + +# all match? +if(!setequal(unlist(lpjguess_classes), LPJ_GUESS_CLASSES)){ + PEcAn.logger::logger.severe("This function can only read the following class objects: ", paste(LPJ_GUESS_CLASSES, collapse="--")) +} From 1c96f7d2266f1f6a94b29db99dcee4738a98384f Mon Sep 17 00:00:00 2001 From: istfer Date: Sat, 8 Jun 2019 14:12:56 -0400 Subject: [PATCH 02/56] add helper function that locates function --- models/lpjguess/R/read_state.R | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index e8a1b2c08c2..93da7fc29a7 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -34,6 +34,7 @@ LPJ_GUESS_CLASSES <- c("Gridcell", "Climate", "Gridcellpft", "Stand", "Standpft" lpjguess_classes <- list() ctr <- 1 +# NOTE THAT THESE PATTERNS ASSUME SOME CODING STYLE, thanks to LPJ-GUESS developers this might not be an issue in the future for(i in seq_along(guessh_in)){ # search for "class XXX : public Serializable {" res <- str_match(guessh_in[i], "class (.*?) : public Serializable") @@ -51,3 +52,24 @@ for(i in seq_along(guessh_in)){ if(!setequal(unlist(lpjguess_classes), LPJ_GUESS_CLASSES)){ PEcAn.logger::logger.severe("This function can only read the following class objects: ", paste(LPJ_GUESS_CLASSES, collapse="--")) } + +# Gridcell is the top-level container, start parsing from there +beg_end <- serialize_starts_ends(file_in = guesscpp_in, pattern = "void Gridcell::serialize") + +# now we will parse the stuff between these lines + +# helper function that scans LPJ-GUESS that returns the beginning and the ending lines of serialized object +serialize_starts_ends <- function(file_in, pattern = "void Gridcell::serialize"){ + # find the starting line from the given pattern + starting_line <- which(!is.na(str_match(file_in, pattern))) + + # screen for the closing curly bracket after function started + # closing bracket it i its own line without any tabs, note that this again assumes a certain coding style + ending_line <- starting_line + repeat{ + ending_line <- ending_line + 1 + if(file_in[ending_line] == "}") break + } + + return(c(starting_line, ending_line)) +} From 2747330990d57dedf6479136857b84591d1ba8fe Mon Sep 17 00:00:00 2001 From: istfer Date: Sat, 8 Jun 2019 16:42:07 -0400 Subject: [PATCH 03/56] add helper function that finds closing paranthesis --- models/lpjguess/R/read_state.R | 62 +++++++++++++++++++++++++++++++++- 1 file changed, 61 insertions(+), 1 deletion(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index 93da7fc29a7..fe53837a7c8 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -57,12 +57,51 @@ if(!setequal(unlist(lpjguess_classes), LPJ_GUESS_CLASSES)){ beg_end <- serialize_starts_ends(file_in = guesscpp_in, pattern = "void Gridcell::serialize") # now we will parse the stuff between these lines +# first find what is being written +find_stream <- function(file_in = guesscpp_in, line_nos = beg_end) + +# helper function that lists streamed variables, it just returns the names, types are checked by other fucntion +find_stream <- function(file_in, line_nos){ + + streaming_list <- list() + str.i <- 1 + arch_save <- FALSE + + for(i in line_nos[1]:line_nos[2]){ + + # some functions (Vegetation, Patch, Stand, Gridcell) have two modes: saving / reading + # we only need the stream that is saved + if(grepl("arch.save()", file_in[i])){ + arch_save <- TRUE + find_closing() + } + + # all streams start with arch & + if(grepl("arch & ", file_in[i])){ + # get variable name + streaming_list[[str.i]] <- sub(".*arch & ", "", file_in[i]) + str.i <- str.i + 1 + # check for ampersand for the subsequent variable names + repeat{ + i <- i + 1 + if(!grepl(".*& ", file_in[i])) break # ONLEY NEED TO READ arch.save()e + streaming_list[[str.i]] <- sub(".*& ", "", file_in[i]) + str.i <- str.i + 1 + } + } + sub("arch & ", "", file_in[1071]) + } +} + # helper function that scans LPJ-GUESS that returns the beginning and the ending lines of serialized object serialize_starts_ends <- function(file_in, pattern = "void Gridcell::serialize"){ # find the starting line from the given pattern starting_line <- which(!is.na(str_match(file_in, pattern))) - + if(length(starting_line) != 1){ # check what's going on + PEcAn.logger::logger.severe("Couldn't find the starting line with this pattern ***",pattern, "***.") + } + # screen for the closing curly bracket after function started # closing bracket it i its own line without any tabs, note that this again assumes a certain coding style ending_line <- starting_line @@ -71,5 +110,26 @@ serialize_starts_ends <- function(file_in, pattern = "void Gridcell::serialize") if(file_in[ending_line] == "}") break } + # probably a check is required, alternatively keep track of opening-closing brackets + return(c(starting_line, ending_line)) } + + +find_closing <- function(find = "}", line_no, file_in){ + opened <- 1 + closed <- 0 + if(find == "}"){ + start_char <- "{" + end_char <- "}" + }else{ + #there can be else-ifs, find closing paranthesis / square breacket etc + } + repeat{ + line_no <- line_no + 1 + if(grepl(start_char, file_in[line_no], fixed = TRUE)) opened <- opened + 1 + if(grepl(end_char, file_in[line_no], fixed = TRUE)) closed <- closed + 1 + if(opened == closed) break + } + return(line_no) +} \ No newline at end of file From 0518d2c283d81282c3c5914cd45e601998224a9c Mon Sep 17 00:00:00 2001 From: istfer Date: Mon, 10 Jun 2019 15:58:44 -0400 Subject: [PATCH 04/56] add function that finds stream --- models/lpjguess/R/read_state.R | 50 +++++++++++++++++++++++++++------- 1 file changed, 40 insertions(+), 10 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index fe53837a7c8..74d2ca4ef00 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -58,22 +58,33 @@ beg_end <- serialize_starts_ends(file_in = guesscpp_in, pattern = "void Gridcell # now we will parse the stuff between these lines # first find what is being written -find_stream <- function(file_in = guesscpp_in, line_nos = beg_end) +streamined_vars <- find_stream(file_in = guesscpp_in, line_nos = beg_end) + + # helper function that lists streamed variables, it just returns the names, types are checked by other fucntion find_stream <- function(file_in, line_nos){ streaming_list <- list() str.i <- 1 - arch_save <- FALSE + when_here <- NULL + not_skipping <- TRUE - for(i in line_nos[1]:line_nos[2]){ + i <- line_nos[1] + repeat{ + i <- i + 1 + if(!is.null(when_here)){ + if(i == when_here){ + i <- skip_to + when_here <- NULL + } + } # some functions (Vegetation, Patch, Stand, Gridcell) have two modes: saving / reading # we only need the stream that is saved if(grepl("arch.save()", file_in[i])){ - arch_save <- TRUE - find_closing() + when_here <- find_closing("}", i, file_in) + skip_to <- find_closing("}", i, file_in, if_else_check = TRUE) } # all streams start with arch & @@ -84,15 +95,23 @@ find_stream <- function(file_in, line_nos){ # check for ampersand for the subsequent variable names repeat{ i <- i + 1 - if(!grepl(".*& ", file_in[i])) break # ONLEY NEED TO READ arch.save()e + if(!is.null(when_here)){ + if(i == when_here){ + i <- skip_to + when_here <- NULL + } + } + if(!grepl(".*& ", file_in[i])) break # when there are no subsequent stream streaming_list[[str.i]] <- sub(".*& ", "", file_in[i]) str.i <- str.i + 1 } } - sub("arch & ", "", file_in[1071]) + if(i == line_nos[2]) break } + return(unlist(streaming_list)) } +######################## Helper functions ######################## # helper function that scans LPJ-GUESS that returns the beginning and the ending lines of serialized object serialize_starts_ends <- function(file_in, pattern = "void Gridcell::serialize"){ @@ -103,7 +122,7 @@ serialize_starts_ends <- function(file_in, pattern = "void Gridcell::serialize") } # screen for the closing curly bracket after function started - # closing bracket it i its own line without any tabs, note that this again assumes a certain coding style + # closing bracket it in its own line without any tab characters, note that this again assumes a certain coding style ending_line <- starting_line repeat{ ending_line <- ending_line + 1 @@ -111,12 +130,13 @@ serialize_starts_ends <- function(file_in, pattern = "void Gridcell::serialize") } # probably a check is required, alternatively keep track of opening-closing brackets + # ending_line <- find_closing(find = "}", starting_line, file_in) return(c(starting_line, ending_line)) } -find_closing <- function(find = "}", line_no, file_in){ +find_closing <- function(find = "}", line_no, file_in, if_else_check = FALSE){ opened <- 1 closed <- 0 if(find == "}"){ @@ -129,7 +149,17 @@ find_closing <- function(find = "}", line_no, file_in){ line_no <- line_no + 1 if(grepl(start_char, file_in[line_no], fixed = TRUE)) opened <- opened + 1 if(grepl(end_char, file_in[line_no], fixed = TRUE)) closed <- closed + 1 + if(if_else_check){ + else_found <- FALSE + same_line_check <- grepl("else", file_in[line_no], fixed = TRUE) #same line + next_line_check <- grepl("else", file_in[line_no + 1], fixed = TRUE) #next line + if(same_line_check | next_line_check){ + closed <- closed - 1 + if(next_line_check) line_no <- line_no + 1 + } + + } if(opened == closed) break } return(line_no) -} \ No newline at end of file +} From c8fc996abdab128ef022be7ae1190ceb629d1b2f Mon Sep 17 00:00:00 2001 From: istfer Date: Thu, 13 Jun 2019 13:33:05 -0400 Subject: [PATCH 05/56] start reading --- models/lpjguess/R/read_state.R | 70 ++++++++++++++++++++++++++++------ 1 file changed, 59 insertions(+), 11 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index 74d2ca4ef00..e75882ec281 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -58,12 +58,51 @@ beg_end <- serialize_starts_ends(file_in = guesscpp_in, pattern = "void Gridcell # now we will parse the stuff between these lines # first find what is being written -streamined_vars <- find_stream(file_in = guesscpp_in, line_nos = beg_end) +streamed_vars_gridcell <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + +# Now I can use streamed_vars_gridcell to loop over them +# We read everything in this loop, Gridcell list is going to be the top container +# the hierarchy will follow LPJ-GUESS architecture +Gridcell <- list() +for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts + + current_stream <- streamed_vars_gridcell[g_i] + current_stream_type <- find_stream_type(Gridcell, current_stream_var, LPJ_GUESS_CLASSES) + Gridcell[[length(Gridcell)+1]] <- current_stream_type$name + if(current_stream_type$type == "class"){ + beg_end <- serialize_starts_ends(file_in = guesscpp_in, + pattern = paste0("void ", + tools::toTitleCase(current_stream_type$name), + "::serialize")) + streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + } + +} # Gridcell-loop ends + +# helper function to decide the type of the stream +# this function relies on the architecture of LPJ-GUESS and has bunch of harcoded checks, see model documentation +find_stream_type <- function(Gridcell, current_stream_var, LPJ_GUESS_CLASSES){ + + # class or not? + if(current_stream %in% tolower(LPJ_GUESS_CLASSES)){ + stream_type <- "class" + stream_name <- current_stream + } + + + return(list(type = stream_type, name = stream_name)) +} # find_stream_type + + + + +######################## Helper functions ######################## + # helper function that lists streamed variables, it just returns the names, types are checked by other fucntion -find_stream <- function(file_in, line_nos){ +find_stream_var <- function(file_in, line_nos){ streaming_list <- list() str.i <- 1 @@ -90,7 +129,7 @@ find_stream <- function(file_in, line_nos){ # all streams start with arch & if(grepl("arch & ", file_in[i])){ # get variable name - streaming_list[[str.i]] <- sub(".*arch & ", "", file_in[i]) + streaming_list[[str.i]] <- sub(".*arch & ", "", file_in[i]) # always one var after arch? str.i <- str.i + 1 # check for ampersand for the subsequent variable names repeat{ @@ -102,16 +141,24 @@ find_stream <- function(file_in, line_nos){ } } if(!grepl(".*& ", file_in[i])) break # when there are no subsequent stream - streaming_list[[str.i]] <- sub(".*& ", "", file_in[i]) - str.i <- str.i + 1 + this_line <- gsub("[[:space:]]", "", strsplit(file_in[i], "& ")[[1]]) + for(var in this_line){ + if(var != ""){ + streaming_list[[str.i]] <- var + str.i <- str.i + 1 + } + } } } if(i == line_nos[2]) break } - return(unlist(streaming_list)) -} + + #unlist and nix the ; + returnin_stream <- gsub(";", "", unlist(streaming_list), fixed = TRUE) + return(returnin_stream) +} # find_stream_var + -######################## Helper functions ######################## # helper function that scans LPJ-GUESS that returns the beginning and the ending lines of serialized object serialize_starts_ends <- function(file_in, pattern = "void Gridcell::serialize"){ @@ -133,9 +180,9 @@ serialize_starts_ends <- function(file_in, pattern = "void Gridcell::serialize") # ending_line <- find_closing(find = "}", starting_line, file_in) return(c(starting_line, ending_line)) -} - +} # serialize_starts_ends +# helper function that finds the closing bracket, can work over if-else find_closing <- function(find = "}", line_no, file_in, if_else_check = FALSE){ opened <- 1 closed <- 0 @@ -162,4 +209,5 @@ find_closing <- function(find = "}", line_no, file_in, if_else_check = FALSE){ if(opened == closed) break } return(line_no) -} +} # find_closing + From 4ac65309887ed54f30042091139c084920d33585 Mon Sep 17 00:00:00 2001 From: istfer Date: Thu, 13 Jun 2019 14:57:57 -0400 Subject: [PATCH 06/56] first read --- models/lpjguess/R/read_state.R | 100 +++++++++++++++++++++++++++------ 1 file changed, 84 insertions(+), 16 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index e75882ec281..ca6b389961d 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -26,6 +26,13 @@ guessh_loc <- "/fs/data5/pecan.models/LPJ-GUESS/framework/guess.h" guesscpp_in <- readLines(guesscpp_loc) # guess.h has the types so that we know what streamsize to read guessh_in <- readLines(guessh_loc) + +############ open + +# open connection to the binary state file +zz <- file("0.state", "rb") + + ################################ check class compatibility ################################ # between model versions we don't expect major classes or hierarchy to change # but give check and fail if necessary @@ -62,38 +69,106 @@ streamed_vars_gridcell <- find_stream_var(file_in = guesscpp_in, line_nos = beg_ # Now I can use streamed_vars_gridcell to loop over them # We read everything in this loop, Gridcell list is going to be the top container -# the hierarchy will follow LPJ-GUESS architecture +# there will be nested loops, the hierarchy will follow LPJ-GUESS architecture Gridcell <- list() for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts current_stream <- streamed_vars_gridcell[g_i] - current_stream_type <- find_stream_type(Gridcell, current_stream_var, LPJ_GUESS_CLASSES) + current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, guessh_in) - Gridcell[[length(Gridcell)+1]] <- current_stream_type$name + Gridcell[[length(Gridcell)+1]] <- list() + names(Gridcell)[length(Gridcell)] <- current_stream_type$name if(current_stream_type$type == "class"){ + # CLASS beg_end <- serialize_starts_ends(file_in = guesscpp_in, pattern = paste0("void ", tools::toTitleCase(current_stream_type$name), "::serialize")) streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + + + for(sv_i in seq_along(streamed_vars)){ + current_stream <- streamed_vars[sv_i] #it's OK to overwrite + current_stream_type <- find_stream_type(current_stream_type$name, current_stream, LPJ_GUESS_CLASSES, guessh_in) + if(current_stream_type$type == "class"){ + + }else{ + current_stream_specs <- find_stream_size(current_stream_type, guessh_in) + # and read! + Gridcell[[length(Gridcell)]][[current_stream_type$name]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + } + } + }else{ + # NOT CLASS } } # Gridcell-loop ends +# helper function that determines the stream size to read +find_stream_size <- function(current_stream_type, guessh_in){ + + specs <- list() + specs$what <- current_stream_type$type + + beg_end <- current_stream_type$beg_end + + sub_string <- current_stream_type$substring + + #is there a ; immediately after? + if(grepl(paste0(current_stream_type$type, " ", current_stream_type$name, ";"), sub_string, fixed = TRUE)){ + # this is only length 1 + specs$n <- 1 + if(current_stream_type$type == "double"){ + specs$what <- "double" + specs$size <- 8 + }else if(current_stream_type$type == "integer"){ + specs$what <- "integer" + specs$size <- 4 + } + + }else{ + # other things gonna happen + } + + return(specs) +} # find_stream_size + + # helper function to decide the type of the stream # this function relies on the architecture of LPJ-GUESS and has bunch of harcoded checks, see model documentation -find_stream_type <- function(Gridcell, current_stream_var, LPJ_GUESS_CLASSES){ +find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES, guessh_in){ + # it might be difficult to extract the "type" before the varname + # there are not that many to check + possible_types <- c("class", "double", "bool", "int", "Historic") + + beg_end <- NULL # not going to need it always + # class or not? - if(current_stream %in% tolower(LPJ_GUESS_CLASSES)){ + if(current_stream_var %in% tolower(LPJ_GUESS_CLASSES)){ stream_type <- "class" - stream_name <- current_stream + stream_name <- current_stream_var + }else {# find type from guess.h + beg_end <- serialize_starts_ends(file_in = guessh_in, + pattern = paste0("class ", + tools::toTitleCase(class), + " : public ")) + # subset + sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var, ";"), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] + # clean from tabs + sub_string <- gsub("\t", "", sub_string) + # clean from commented out lines + stream_type <- possible_types[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + stream_name <- current_stream_var } - return(list(type = stream_type, name = stream_name)) + return(list(type = stream_type, name = stream_name, substring = sub_string)) } # find_stream_type @@ -169,15 +244,8 @@ serialize_starts_ends <- function(file_in, pattern = "void Gridcell::serialize") } # screen for the closing curly bracket after function started - # closing bracket it in its own line without any tab characters, note that this again assumes a certain coding style - ending_line <- starting_line - repeat{ - ending_line <- ending_line + 1 - if(file_in[ending_line] == "}") break - } - - # probably a check is required, alternatively keep track of opening-closing brackets - # ending_line <- find_closing(find = "}", starting_line, file_in) + # keep track of opening-closing brackets + ending_line <- find_closing(find = "}", starting_line, file_in) return(c(starting_line, ending_line)) } # serialize_starts_ends From 6e92048ab4dca72236bf4cc9df9b68f63b0c7fbe Mon Sep 17 00:00:00 2001 From: istfer Date: Thu, 13 Jun 2019 15:48:47 -0400 Subject: [PATCH 07/56] extract typedef enums --- models/lpjguess/R/read_state.R | 34 +++++++++++++++++++++++++++++++--- 1 file changed, 31 insertions(+), 3 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index ca6b389961d..801f23c9f93 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -60,6 +60,21 @@ if(!setequal(unlist(lpjguess_classes), LPJ_GUESS_CLASSES)){ PEcAn.logger::logger.severe("This function can only read the following class objects: ", paste(LPJ_GUESS_CLASSES, collapse="--")) } +# there are couple of LPJ-GUESS specific types that we'll need below +lpjguess_types <- list() +ctr <- 1 +# NOTE THAT THESE PATTERNS ASSUME SOME CODING STYLE, thanks to LPJ-GUESS developers this might not be an issue in the future +for(i in seq_along(guessh_in)){ + if(grepl("typedef enum {", guessh_in[i], fixed = TRUE)){ + this_line <- find_closing("}", i, guessh_in) + l_type <- gsub(".*}(.*?);.*", "\\1", guessh_in[this_line]) + l_type <- gsub(" ", "", l_type) + lpjguess_types[[ctr]] <- l_type + ctr <- ctr + 1 + } +} +LPJ_GUESS_TYPES <- unlist(lpjguess_types) + # Gridcell is the top-level container, start parsing from there beg_end <- serialize_starts_ends(file_in = guesscpp_in, pattern = "void Gridcell::serialize") @@ -79,7 +94,10 @@ for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts Gridcell[[length(Gridcell)+1]] <- list() names(Gridcell)[length(Gridcell)] <- current_stream_type$name if(current_stream_type$type == "class"){ + # CLASS + class_name <- current_stream_type$name + beg_end <- serialize_starts_ends(file_in = guesscpp_in, pattern = paste0("void ", tools::toTitleCase(current_stream_type$name), @@ -89,9 +107,12 @@ for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts for(sv_i in seq_along(streamed_vars)){ current_stream <- streamed_vars[sv_i] #it's OK to overwrite - current_stream_type <- find_stream_type(current_stream_type$name, current_stream, LPJ_GUESS_CLASSES, guessh_in) + current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, guessh_in) if(current_stream_type$type == "class"){ + # CLASS + class_name <- current_stream_type$name + }else{ current_stream_specs <- find_stream_size(current_stream_type, guessh_in) # and read! @@ -141,12 +162,16 @@ find_stream_size <- function(current_stream_type, guessh_in){ # helper function to decide the type of the stream # this function relies on the architecture of LPJ-GUESS and has bunch of harcoded checks, see model documentation -find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES, guessh_in){ +find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in){ # it might be difficult to extract the "type" before the varname # there are not that many to check possible_types <- c("class", "double", "bool", "int", "Historic") + + + guessh_in, "typedef enum {*} " + beg_end <- NULL # not going to need it always # class or not? @@ -260,6 +285,10 @@ find_closing <- function(find = "}", line_no, file_in, if_else_check = FALSE){ }else{ #there can be else-ifs, find closing paranthesis / square breacket etc } + + # check the immediate line and return if closed there already + if(grepl(end_char, file_in[line_no], fixed = TRUE)) return(line_no) + repeat{ line_no <- line_no + 1 if(grepl(start_char, file_in[line_no], fixed = TRUE)) opened <- opened + 1 @@ -272,7 +301,6 @@ find_closing <- function(find = "}", line_no, file_in, if_else_check = FALSE){ closed <- closed - 1 if(next_line_check) line_no <- line_no + 1 } - } if(opened == closed) break } From 6d2bac5dddf5db842f866afcdecee54a4414dc6b Mon Sep 17 00:00:00 2001 From: istfer Date: Thu, 13 Jun 2019 15:55:34 -0400 Subject: [PATCH 08/56] read typedef enum --- models/lpjguess/R/read_state.R | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index 801f23c9f93..e3049f05151 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -89,7 +89,7 @@ Gridcell <- list() for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts current_stream <- streamed_vars_gridcell[g_i] - current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, guessh_in) + current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) Gridcell[[length(Gridcell)+1]] <- list() names(Gridcell)[length(Gridcell)] <- current_stream_type$name @@ -107,14 +107,14 @@ for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts for(sv_i in seq_along(streamed_vars)){ current_stream <- streamed_vars[sv_i] #it's OK to overwrite - current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, guessh_in) + current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) if(current_stream_type$type == "class"){ # CLASS class_name <- current_stream_type$name }else{ - current_stream_specs <- find_stream_size(current_stream_type, guessh_in) + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES) # and read! Gridcell[[length(Gridcell)]][[current_stream_type$name]] <- readBin(con = zz, what = current_stream_specs$what, @@ -131,7 +131,7 @@ for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts } # Gridcell-loop ends # helper function that determines the stream size to read -find_stream_size <- function(current_stream_type, guessh_in){ +find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES){ specs <- list() specs$what <- current_stream_type$type @@ -150,6 +150,9 @@ find_stream_size <- function(current_stream_type, guessh_in){ }else if(current_stream_type$type == "integer"){ specs$what <- "integer" specs$size <- 4 + }else if(current_stream_type$type %in% LPJ_GUESS_TYPES){ + specs$what <- "integer" + specs$size <- 4 } }else{ @@ -168,9 +171,7 @@ find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES # there are not that many to check possible_types <- c("class", "double", "bool", "int", "Historic") - - - guessh_in, "typedef enum {*} " + possible_types <- c(possible_types, LPJ_GUESS_TYPES) beg_end <- NULL # not going to need it always From 4221e09cd125e1a1f68fa2b49a5942b31ac39568 Mon Sep 17 00:00:00 2001 From: istfer Date: Thu, 13 Jun 2019 17:17:49 -0400 Subject: [PATCH 09/56] read Historic --- models/lpjguess/R/read_state.R | 100 +++++++++++++++++++++++++-------- 1 file changed, 76 insertions(+), 24 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index e3049f05151..e2110ac7a49 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -104,8 +104,8 @@ for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts "::serialize")) streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - - for(sv_i in seq_along(streamed_vars)){ + #for(sv_i in seq_along(streamed_vars)){ + for(sv_i in 11:17){ current_stream <- streamed_vars[sv_i] #it's OK to overwrite current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) if(current_stream_type$type == "class"){ @@ -116,10 +116,20 @@ for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts }else{ current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES) # and read! - Gridcell[[length(Gridcell)]][[current_stream_type$name]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) + if(specs$single){ + Gridcell[[length(Gridcell)]][[current_stream_type$name]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + }else{ + for(css.i in seq_along(current_stream_specs$what)){ + Gridcell[[length(Gridcell)]][[current_stream_specs$name[css.i]]] <- readBin(con = zz, + what = current_stream_specs$what[css.i], + n = current_stream_specs$n[css.i], + size = current_stream_specs$size[css.i]) + } + } + } } }else{ @@ -133,10 +143,12 @@ for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts # helper function that determines the stream size to read find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES){ - specs <- list() - specs$what <- current_stream_type$type + possible_types <- c("double", "bool", "int") + possible_types <- c(possible_types, LPJ_GUESS_TYPES) + n_sizes <- c(8, 1, 4, rep(1, length(LPJ_GUESS_TYPES) )) + rbin_tbl <- c("double", "logical", "integer", rep("integer", length(LPJ_GUESS_TYPES))) - beg_end <- current_stream_type$beg_end + specs <- list() sub_string <- current_stream_type$substring @@ -144,19 +156,52 @@ find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES){ if(grepl(paste0(current_stream_type$type, " ", current_stream_type$name, ";"), sub_string, fixed = TRUE)){ # this is only length 1 specs$n <- 1 - if(current_stream_type$type == "double"){ - specs$what <- "double" - specs$size <- 8 - }else if(current_stream_type$type == "integer"){ - specs$what <- "integer" - specs$size <- 4 - }else if(current_stream_type$type %in% LPJ_GUESS_TYPES){ - specs$what <- "integer" - specs$size <- 4 - } + specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + specs$single <- TRUE + # if(current_stream_type$type == "double"){ + # specs$what <- "double" + # specs$size <- 8 + # }else if(current_stream_type$type == "int"){ + # specs$what <- "integer" + # specs$size <- 4 + # }else if(current_stream_type$type == "bool"){ + # specs$what <- "logical" + # specs$size <- 1 + # }else if(current_stream_type$type %in% LPJ_GUESS_TYPES){ + # specs$what <- "integer" + # specs$size <- 4 + # } + + }else if(current_stream_type$type == "Historic"){ + # Historic types are special to LPJ-GUESS + # They have stored values, current index, and a boolean in that order + specs$n <- specs$what <- specs$size <- specs$names <- rep(NA, 3) + # always three, this is a type defined in guessmath.h + specs$what[1] <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] # I haven't seen any Historic that doesn't store double but... + specs$size[1] <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + specs$name[1] <- current_stream_type$name + # n is tricky, it can be hardcoded it can be one of the const ints + to_read <- str_match(sub_string, paste0("Historic<", specs$what[1], ", (.*?)>.*"))[,2] + #if(to_read %in% LPJ_GUESS_CONST_INTS){ + + #}else{ + specs$n[1] <- as.numeric(to_read) + #} + specs$what[2] <- "integer" + specs$size[2] <- 4 + specs$n[2] <- 1 + specs$name[2] <- "current_index" + + specs$what[3] <- "logical" + specs$size[3] <- 1 + specs$n[3] <- 1 + specs$name[3] <- "full" + specs$single <- FALSE }else{ # other things gonna happen + specs$single <- FALSE } return(specs) @@ -169,7 +214,7 @@ find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES # it might be difficult to extract the "type" before the varname # there are not that many to check - possible_types <- c("class", "double", "bool", "int", "Historic") + possible_types <- c("class", "double", "bool", "int") possible_types <- c(possible_types, LPJ_GUESS_TYPES) @@ -185,15 +230,22 @@ find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES tools::toTitleCase(class), " : public ")) # subset - sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var, ";"), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] + sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] # clean from tabs sub_string <- gsub("\t", "", sub_string) # clean from commented out lines - stream_type <- possible_types[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - stream_name <- current_stream_var + + if(grepl("Historic", sub_string, fixed = TRUE)){ + # Historic types has the form Historic& data) + stream_type <- "Historic" + stream_name <- current_stream_var + }else{ + stream_type <- possible_types[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + stream_name <- current_stream_var + } + } - return(list(type = stream_type, name = stream_name, substring = sub_string)) } # find_stream_type From d477ca7be40901a474d3b544001c76a63045ca99 Mon Sep 17 00:00:00 2001 From: istfer Date: Thu, 13 Jun 2019 17:52:43 -0400 Subject: [PATCH 10/56] read vector --- models/lpjguess/R/read_state.R | 51 +++++++++++++++++----------------- 1 file changed, 25 insertions(+), 26 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index e2110ac7a49..1df5ad75ac2 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -105,7 +105,7 @@ for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) #for(sv_i in seq_along(streamed_vars)){ - for(sv_i in 11:17){ + for(sv_i in 1:26){ current_stream <- streamed_vars[sv_i] #it's OK to overwrite current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) if(current_stream_type$type == "class"){ @@ -116,14 +116,14 @@ for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts }else{ current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES) # and read! - if(specs$single){ + if(current_stream_specs$single){ Gridcell[[length(Gridcell)]][[current_stream_type$name]] <- readBin(con = zz, what = current_stream_specs$what, n = current_stream_specs$n, size = current_stream_specs$size) }else{ for(css.i in seq_along(current_stream_specs$what)){ - Gridcell[[length(Gridcell)]][[current_stream_specs$name[css.i]]] <- readBin(con = zz, + Gridcell[[length(Gridcell)]][[current_stream_specs$names[css.i]]] <- readBin(con = zz, what = current_stream_specs$what[css.i], n = current_stream_specs$n[css.i], size = current_stream_specs$size[css.i]) @@ -145,7 +145,7 @@ find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES){ possible_types <- c("double", "bool", "int") possible_types <- c(possible_types, LPJ_GUESS_TYPES) - n_sizes <- c(8, 1, 4, rep(1, length(LPJ_GUESS_TYPES) )) + n_sizes <- c(8, 1, 4, rep(4, length(LPJ_GUESS_TYPES) )) rbin_tbl <- c("double", "logical", "integer", rep("integer", length(LPJ_GUESS_TYPES))) specs <- list() @@ -159,19 +159,6 @@ find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES){ specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] specs$single <- TRUE - # if(current_stream_type$type == "double"){ - # specs$what <- "double" - # specs$size <- 8 - # }else if(current_stream_type$type == "int"){ - # specs$what <- "integer" - # specs$size <- 4 - # }else if(current_stream_type$type == "bool"){ - # specs$what <- "logical" - # specs$size <- 1 - # }else if(current_stream_type$type %in% LPJ_GUESS_TYPES){ - # specs$what <- "integer" - # specs$size <- 4 - # } }else if(current_stream_type$type == "Historic"){ # Historic types are special to LPJ-GUESS @@ -180,7 +167,7 @@ find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES){ # always three, this is a type defined in guessmath.h specs$what[1] <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] # I haven't seen any Historic that doesn't store double but... specs$size[1] <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$name[1] <- current_stream_type$name + specs$names[1] <- current_stream_type$name # n is tricky, it can be hardcoded it can be one of the const ints to_read <- str_match(sub_string, paste0("Historic<", specs$what[1], ", (.*?)>.*"))[,2] #if(to_read %in% LPJ_GUESS_CONST_INTS){ @@ -188,22 +175,26 @@ find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES){ #}else{ specs$n[1] <- as.numeric(to_read) #} - specs$what[2] <- "integer" - specs$size[2] <- 4 + specs$what[2] <- "integer" #need to check what size_t is + specs$size[2] <- 8 specs$n[2] <- 1 - specs$name[2] <- "current_index" + specs$names[2] <- "current_index" specs$what[3] <- "logical" specs$size[3] <- 1 specs$n[3] <- 1 - specs$name[3] <- "full" + specs$names[3] <- "full" + specs$single <- FALSE }else{ - # other things gonna happen - specs$single <- FALSE + # reading a vector + specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + specs$n <- as.numeric(sub(".*\\[(.*)\\].*", "\\1", sub_string, perl=TRUE) ) + specs$single <- TRUE } - + return(specs) } # find_stream_size @@ -224,13 +215,21 @@ find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES if(current_stream_var %in% tolower(LPJ_GUESS_CLASSES)){ stream_type <- "class" stream_name <- current_stream_var + sub_string <- NULL }else {# find type from guess.h beg_end <- serialize_starts_ends(file_in = guessh_in, pattern = paste0("class ", tools::toTitleCase(class), " : public ")) # subset - sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] + sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var, ";"), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] + if(length(sub_string) == 0){ + sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] + } + if(length(sub_string) > 1){ + PEcAn.logger::logger.severe("Check this out.") + } + # clean from tabs sub_string <- gsub("\t", "", sub_string) # clean from commented out lines From b1bf79e20724af30d6e8700106f6191309bbccc7 Mon Sep 17 00:00:00 2001 From: istfer Date: Fri, 14 Jun 2019 14:38:11 -0400 Subject: [PATCH 11/56] read vector with const int --- models/lpjguess/R/read_state.R | 57 +++++++++++++++++++++++++--------- 1 file changed, 43 insertions(+), 14 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index 1df5ad75ac2..04d2c660c68 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -63,7 +63,6 @@ if(!setequal(unlist(lpjguess_classes), LPJ_GUESS_CLASSES)){ # there are couple of LPJ-GUESS specific types that we'll need below lpjguess_types <- list() ctr <- 1 -# NOTE THAT THESE PATTERNS ASSUME SOME CODING STYLE, thanks to LPJ-GUESS developers this might not be an issue in the future for(i in seq_along(guessh_in)){ if(grepl("typedef enum {", guessh_in[i], fixed = TRUE)){ this_line <- find_closing("}", i, guessh_in) @@ -75,6 +74,26 @@ for(i in seq_along(guessh_in)){ } LPJ_GUESS_TYPES <- unlist(lpjguess_types) + +lpjguess_consts <- list() +ctr <- 1 +for(i in seq_along(guessh_in)){ + if(grepl("const int ", guessh_in[i], fixed = TRUE)){ # probably won't need "const double"s + cnst_val <- gsub(".*=(.*?);.*", "\\1", guessh_in[i]) + cnst_val <- gsub(" ", "", cnst_val) # get rid of the space if there is one + cnst_nam <- gsub(".*int(.*?)=.*", "\\1", guessh_in[i]) + cnst_nam <- gsub(" ", "", cnst_nam) + lpjguess_consts[[ctr]] <- cnst_val + names(lpjguess_consts)[ctr] <- cnst_nam + ctr <- ctr + 1 + } +} +# few cleaning +dont_need <- c("COLDEST_DAY_NHEMISPHERE", "COLDEST_DAY_SHEMISPHERE", "WARMEST_DAY_NHEMISPHERE", "WARMEST_DAY_SHEMISPHERE", "data[]") +lpjguess_consts[match(dont_need, names(lpjguess_consts))] <- NULL +LPJ_GUESS_CONST_INTS <- data.frame(var = names(lpjguess_consts), val = as.numeric(unlist(lpjguess_consts)), stringsAsFactors = FALSE) + + # Gridcell is the top-level container, start parsing from there beg_end <- serialize_starts_ends(file_in = guesscpp_in, pattern = "void Gridcell::serialize") @@ -105,7 +124,7 @@ for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) #for(sv_i in seq_along(streamed_vars)){ - for(sv_i in 1:26){ + for(sv_i in 33:37){ current_stream <- streamed_vars[sv_i] #it's OK to overwrite current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) if(current_stream_type$type == "class"){ @@ -114,7 +133,7 @@ for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts class_name <- current_stream_type$name }else{ - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES) + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) # and read! if(current_stream_specs$single){ Gridcell[[length(Gridcell)]][[current_stream_type$name]] <- readBin(con = zz, @@ -141,7 +160,7 @@ for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts } # Gridcell-loop ends # helper function that determines the stream size to read -find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES){ +find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS){ possible_types <- c("double", "bool", "int") possible_types <- c(possible_types, LPJ_GUESS_TYPES) @@ -165,8 +184,8 @@ find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES){ # They have stored values, current index, and a boolean in that order specs$n <- specs$what <- specs$size <- specs$names <- rep(NA, 3) # always three, this is a type defined in guessmath.h - specs$what[1] <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] # I haven't seen any Historic that doesn't store double but... - specs$size[1] <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + specs$what[1] <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] # I haven't seen any Historic that doesn't store double but... + specs$size[1] <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] specs$names[1] <- current_stream_type$name # n is tricky, it can be hardcoded it can be one of the const ints to_read <- str_match(sub_string, paste0("Historic<", specs$what[1], ", (.*?)>.*"))[,2] @@ -175,14 +194,14 @@ find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES){ #}else{ specs$n[1] <- as.numeric(to_read) #} - specs$what[2] <- "integer" #need to check what size_t is - specs$size[2] <- 8 - specs$n[2] <- 1 + specs$what[2] <- "integer" #need to check what size_t is + specs$size[2] <- 8 + specs$n[2] <- 1 specs$names[2] <- "current_index" - specs$what[3] <- "logical" - specs$size[3] <- 1 - specs$n[3] <- 1 + specs$what[3] <- "logical" + specs$size[3] <- 1 + specs$n[3] <- 1 specs$names[3] <- "full" specs$single <- FALSE @@ -191,7 +210,12 @@ find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES){ # reading a vector specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$n <- as.numeric(sub(".*\\[(.*)\\].*", "\\1", sub_string, perl=TRUE) ) + if(any(sapply(LPJ_GUESS_CONST_INTS$var, grepl, sub_string, fixed = TRUE))){ # uses one of the constant ints + specs$n <- LPJ_GUESS_CONST_INTS$val[sapply(LPJ_GUESS_CONST_INTS$var, grepl, sub_string, fixed = TRUE)] + }else{ + specs$n <- as.numeric(sub(".*\\[(.*)\\].*", "\\1", sub_string, perl=TRUE)) + } + specs$single <- TRUE } @@ -227,7 +251,12 @@ find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] } if(length(sub_string) > 1){ - PEcAn.logger::logger.severe("Check this out.") + # some varnames are very common characters unfortunately like u, v... check if [] comes after + if(any(grepl(paste0(" ", current_stream_var, "["), sub_string, fixed = TRUE))){ + sub_string <- sub_string[grepl(paste0(" ", current_stream_var, "["), sub_string, fixed = TRUE)] + }else{ + PEcAn.logger::logger.severe("Check this out.") + } } # clean from tabs From 7faffa8d8a26ef0769a5e94a9229badf647ea265 Mon Sep 17 00:00:00 2001 From: istfer Date: Fri, 14 Jun 2019 15:12:21 -0400 Subject: [PATCH 12/56] read in parameters header too --- models/lpjguess/R/read_state.R | 37 +++++++++++++++++++++++++--------- 1 file changed, 27 insertions(+), 10 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index 04d2c660c68..d7951e6e838 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -21,11 +21,14 @@ library(stringr) # maybe put guess.h and guess.cpp for each model version into the model package guesscpp_loc <- "/fs/data5/pecan.models/LPJ-GUESS/framework/guess.cpp" guessh_loc <- "/fs/data5/pecan.models/LPJ-GUESS/framework/guess.h" +paramh_loc <- "/fs/data5/pecan.models/LPJ-GUESS/framework/parameters.h" # guess.cpp has the info of what is being written guesscpp_in <- readLines(guesscpp_loc) # guess.h has the types so that we know what streamsize to read guessh_in <- readLines(guessh_loc) +# parameters.h has some more types +paramh_in <- readLines(paramh_loc) ############ open @@ -72,6 +75,15 @@ for(i in seq_along(guessh_in)){ ctr <- ctr + 1 } } +for(i in seq_along(paramh_in)){ #do same for parameters.h + if(grepl("typedef enum {", paramh_in[i], fixed = TRUE)){ + this_line <- find_closing("}", i, paramh_in) + l_type <- gsub(".*}(.*?);.*", "\\1", paramh_in[this_line]) + l_type <- gsub(" ", "", l_type) + lpjguess_types[[ctr]] <- l_type + ctr <- ctr + 1 + } +} LPJ_GUESS_TYPES <- unlist(lpjguess_types) @@ -123,8 +135,7 @@ for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts "::serialize")) streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - #for(sv_i in seq_along(streamed_vars)){ - for(sv_i in 33:37){ + for(sv_i in seq_along(streamed_vars)){ current_stream <- streamed_vars[sv_i] #it's OK to overwrite current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) if(current_stream_type$type == "class"){ @@ -148,11 +159,11 @@ for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts size = current_stream_specs$size[css.i]) } } - } } }else{ # NOT CLASS + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) } @@ -241,12 +252,18 @@ find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES stream_name <- current_stream_var sub_string <- NULL }else {# find type from guess.h - beg_end <- serialize_starts_ends(file_in = guessh_in, - pattern = paste0("class ", - tools::toTitleCase(class), - " : public ")) - # subset - sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var, ";"), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] + + if(is.null(class)){ + sub_string <- guessh_in[grepl(paste0(" ", current_stream_var), guessh_in, fixed = TRUE)] + }else{ + beg_end <- serialize_starts_ends(file_in = guessh_in, + pattern = paste0("class ", + tools::toTitleCase(class), + " : public ")) + # subset + sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var, ";"), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] + } + if(length(sub_string) == 0){ sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] } @@ -261,7 +278,7 @@ find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES # clean from tabs sub_string <- gsub("\t", "", sub_string) - # clean from commented out lines + # clean from commented out lines? if(grepl("Historic", sub_string, fixed = TRUE)){ # Historic types has the form Historic& data) From 3921cc35bde1e9f4596d40fefbf4c697d2b31d04 Mon Sep 17 00:00:00 2001 From: istfer Date: Fri, 14 Jun 2019 15:44:04 -0400 Subject: [PATCH 13/56] case fo seed --- models/lpjguess/R/read_state.R | 25 ++++++++++++++++++++++--- 1 file changed, 22 insertions(+), 3 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index d7951e6e838..656e208fb19 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -103,6 +103,8 @@ for(i in seq_along(guessh_in)){ # few cleaning dont_need <- c("COLDEST_DAY_NHEMISPHERE", "COLDEST_DAY_SHEMISPHERE", "WARMEST_DAY_NHEMISPHERE", "WARMEST_DAY_SHEMISPHERE", "data[]") lpjguess_consts[match(dont_need, names(lpjguess_consts))] <- NULL +# this probably needs to be extracted from parameters.h:48-49 or somewhere else, but hardcoding for now +lpjguess_consts$NLANDCOVERTYPES <- 6 LPJ_GUESS_CONST_INTS <- data.frame(var = names(lpjguess_consts), val = as.numeric(unlist(lpjguess_consts)), stringsAsFactors = FALSE) @@ -164,6 +166,19 @@ for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts }else{ # NOT CLASS current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) + # and read! + if(current_stream_specs$single){ + Gridcell[[length(Gridcell)]][[current_stream_type$name]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + }else{ + for(css.i in seq_along(current_stream_specs$what)){ + Gridcell[[length(Gridcell)]][[current_stream_specs$names[css.i]]] <- readBin(con = zz, + what = current_stream_specs$what[css.i], + n = current_stream_specs$n[css.i], + size = current_stream_specs$size[css.i]) + } } @@ -173,10 +188,10 @@ for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts # helper function that determines the stream size to read find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS){ - possible_types <- c("double", "bool", "int") + possible_types <- c("double", "bool", "int", "long") possible_types <- c(possible_types, LPJ_GUESS_TYPES) - n_sizes <- c(8, 1, 4, rep(4, length(LPJ_GUESS_TYPES) )) - rbin_tbl <- c("double", "logical", "integer", rep("integer", length(LPJ_GUESS_TYPES))) + n_sizes <- c(8, 1, 4, 8, rep(4, length(LPJ_GUESS_TYPES) )) + rbin_tbl <- c("double", "logical", "integer", "integer", rep("integer", length(LPJ_GUESS_TYPES))) specs <- list() @@ -238,6 +253,10 @@ find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LP # this function relies on the architecture of LPJ-GUESS and has bunch of harcoded checks, see model documentation find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in){ + if(current_stream_var == "seed"){ + return(list(type = "long", name = "seed", substring = "long seed;")) + } + # it might be difficult to extract the "type" before the varname # there are not that many to check possible_types <- c("class", "double", "bool", "int") From 2f8bbda53cd00eb546227c21855463ad61d0f708 Mon Sep 17 00:00:00 2001 From: istfer Date: Sat, 15 Jun 2019 11:49:16 -0400 Subject: [PATCH 14/56] ready to loop over stands --- models/lpjguess/R/read_state.R | 96 ++++++++++++++++++++++------------ 1 file changed, 63 insertions(+), 33 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index 656e208fb19..895c2970057 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -35,6 +35,7 @@ paramh_in <- readLines(paramh_loc) # open connection to the binary state file zz <- file("0.state", "rb") +npft <- 11 # read from params.ins ################################ check class compatibility ################################ # between model versions we don't expect major classes or hierarchy to change @@ -119,9 +120,26 @@ streamed_vars_gridcell <- find_stream_var(file_in = guesscpp_in, line_nos = beg_ # We read everything in this loop, Gridcell list is going to be the top container # there will be nested loops, the hierarchy will follow LPJ-GUESS architecture Gridcell <- list() -for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts - +level <- "Gridcell" +#for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts +for(g_i in 1:8){ current_stream <- streamed_vars_gridcell[g_i] + if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard + if(grepl(glob2rx("(*this)[*].landcover"), current_stream)){ # s counter might change, using wildcard + # not sure how to handle this better. If we see this, it means we are now looping over Stands + # this function considers "NATURAL" vegetation only, so there is only one stand + # this is an integer that tells us which landcover type this stand is + # so it should be the indice of NATURAL in typedef enum landcovertype (I believe indexing starts from 0) + + num_stnd <- as.numeric(Gridcell$nstands) + Gridcell[["Stand"]] <- vector("list", num_stnd) + + # note that this is streamed under Gridcell, not Stand in guess.cpp, + # but I think this info needs to go together with the Stand sublist + # so find_stream_var will prepend landcover to the streamed_vars + + next + } current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) Gridcell[[length(Gridcell)+1]] <- list() @@ -136,33 +154,44 @@ for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts tools::toTitleCase(current_stream_type$name), "::serialize")) streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) + + for(varname in streamed_vars){ + Gridcell[[length(Gridcell)]][[varname]] <- varname + Gridcell[[length(Gridcell)]][[varname]] <- vector("list", num_pft) + } - for(sv_i in seq_along(streamed_vars)){ - current_stream <- streamed_vars[sv_i] #it's OK to overwrite - current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - if(current_stream_type$type == "class"){ - - # CLASS - class_name <- current_stream_type$name - - }else{ - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - # and read! - if(current_stream_specs$single){ - Gridcell[[length(Gridcell)]][[current_stream_type$name]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) + for(pft_i in seq_len(num_pft)){ + for(sv_i in seq_along(streamed_vars)){ + #for(sv_i in 21:37){ + current_stream <- streamed_vars[sv_i] #it's OK to overwrite + current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + + if(current_stream_type$type == "class"){ + + # CLASS + class_name <- current_stream_type$name + }else{ - for(css.i in seq_along(current_stream_specs$what)){ - Gridcell[[length(Gridcell)]][[current_stream_specs$names[css.i]]] <- readBin(con = zz, - what = current_stream_specs$what[css.i], - n = current_stream_specs$n[css.i], - size = current_stream_specs$size[css.i]) + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) + # and read! + if(current_stream_specs$single){ + Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + }else{ + for(css.i in seq_along(current_stream_specs$what)){ + Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, + what = current_stream_specs$what[css.i], + n = current_stream_specs$n[css.i], + size = current_stream_specs$size[css.i]) + } } } - } - } + } # streamed_vars-loop ends + } # pft-loop ends + }else{ # NOT CLASS current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) @@ -172,17 +201,15 @@ for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts what = current_stream_specs$what, n = current_stream_specs$n, size = current_stream_specs$size) - }else{ + }else{ # probably don't need this but let's keep for(css.i in seq_along(current_stream_specs$what)){ Gridcell[[length(Gridcell)]][[current_stream_specs$names[css.i]]] <- readBin(con = zz, what = current_stream_specs$what[css.i], n = current_stream_specs$n[css.i], size = current_stream_specs$size[css.i]) } - } - - - + } + }# if-class } # Gridcell-loop ends # helper function that determines the stream size to read @@ -253,10 +280,13 @@ find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LP # this function relies on the architecture of LPJ-GUESS and has bunch of harcoded checks, see model documentation find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in){ - if(current_stream_var == "seed"){ + if(current_stream_var == "seed"){ # a bit of a special case return(list(type = "long", name = "seed", substring = "long seed;")) } - + + if(current_stream_var == "nstands"){ # a bit of a special case, it is read by guess.cpp + return(list(type = "int", name = "nstands", substring = "int nstands;")) #there is not substring like that in guess.h + } # it might be difficult to extract the "type" before the varname # there are not that many to check possible_types <- c("class", "double", "bool", "int") @@ -266,7 +296,7 @@ find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES beg_end <- NULL # not going to need it always # class or not? - if(current_stream_var %in% tolower(LPJ_GUESS_CLASSES)){ + if(tools::toTitleCase(current_stream_var) %in% LPJ_GUESS_CLASSES){ stream_type <- "class" stream_name <- current_stream_var sub_string <- NULL From b3b00258e123699597b942ef714e33b58977aa56 Mon Sep 17 00:00:00 2001 From: istfer Date: Sat, 15 Jun 2019 15:28:34 -0400 Subject: [PATCH 15/56] start looping over patches --- models/lpjguess/R/read_state.R | 359 +++++++++++++++++++++++++++------ 1 file changed, 302 insertions(+), 57 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index 895c2970057..645030b42d0 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -35,7 +35,9 @@ paramh_in <- readLines(paramh_loc) # open connection to the binary state file zz <- file("0.state", "rb") -npft <- 11 # read from params.ins +### these are the values read from params.ins, passed to this fcn +npft <- 11 +npatches <- 5 ################################ check class compatibility ################################ # between model versions we don't expect major classes or hierarchy to change @@ -116,6 +118,8 @@ beg_end <- serialize_starts_ends(file_in = guesscpp_in, pattern = "void Gridcell # first find what is being written streamed_vars_gridcell <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) +################################## CAUTION : THE FOLLOWING IS A MONSTROUS NESTED-LOOP ################################## + # Now I can use streamed_vars_gridcell to loop over them # We read everything in this loop, Gridcell list is going to be the top container # there will be nested loops, the hierarchy will follow LPJ-GUESS architecture @@ -136,80 +140,316 @@ for(g_i in 1:8){ # note that this is streamed under Gridcell, not Stand in guess.cpp, # but I think this info needs to go together with the Stand sublist - # so find_stream_var will prepend landcover to the streamed_vars + # so prepend landcovertype to the streamed_vars_stand next } - current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - Gridcell[[length(Gridcell)+1]] <- list() - names(Gridcell)[length(Gridcell)] <- current_stream_type$name - if(current_stream_type$type == "class"){ - - # CLASS - class_name <- current_stream_type$name + # "(*this)[*]" points to different things under different levels, here it is stand + if(grepl(glob2rx("(*this)[*]"), current_stream)){ # note that first else-part will be evaluated considering the order in guess.cpp + + # STAND + level <- "Stand" + current_stream <- "Stand" + current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) beg_end <- serialize_starts_ends(file_in = guesscpp_in, pattern = paste0("void ", tools::toTitleCase(current_stream_type$name), "::serialize")) - streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) - - for(varname in streamed_vars){ - Gridcell[[length(Gridcell)]][[varname]] <- varname - Gridcell[[length(Gridcell)]][[varname]] <- vector("list", num_pft) - } + streamed_vars_stand <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + streamed_vars_stand <- c("landcover", streamed_vars_stand) # prepending landcovertype to the streamed_vars_stand - for(pft_i in seq_len(num_pft)){ - for(sv_i in seq_along(streamed_vars)){ - #for(sv_i in 21:37){ - current_stream <- streamed_vars[sv_i] #it's OK to overwrite - current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - - if(current_stream_type$type == "class"){ + + for(stnd_i in seq_len(num_stnd)){ #looping over the stands + for(svs_i in seq_along(streamed_vars_stand)){ #looping over the streamed stand vars + + current_stream <- streamed_vars_stand[svs_i] + if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard + + if(current_stream == "nobj" & level == "Stand"){ + # nobj points to different things under different levels, here it is the number of patches + # number of patches is set through insfiles, read by write.configs and passed to this fcn + # but it's also written to the state file, need to move bytes + nofpatch <- readBin(zz, integer(), 1, size = 4) + if(npatches == nofpatch){ # also not a bad place to check if everything is going fine so far + Gridcell[["Stand"]][[stnd_i]]$npatches <- npatches + #Gridcell[["Stand"]] <- vector("list", npatches) + }else{ + PEcAn.logger::logger.severe("The number of patches set through the instruction file does not match the number read from the state files. Probably a bug in the read.state function! Terminating.") + } + next + } + + # "(*this)[*]" points to different things under different levels, here it is patch + if(grepl(glob2rx("(*this)[*]"), current_stream)){ + # PATCH + level <- "Patch" + current_stream <- "Patch" + current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - # CLASS - class_name <- current_stream_type$name + beg_end <- serialize_starts_ends(file_in = guesscpp_in, + pattern = paste0("void ", + tools::toTitleCase(current_stream_type$name), + "::serialize")) + streamed_vars_patch <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + + Gridcell[["Stand"]][[stnd_i]][["Patch"]] <- vector("list", npatches) + + for(ptch_i in seq_len(npatches)){ #looping over the patches + for(svp_i in seq_along(streamed_vars_patch)){ #looping over the streamed patch vars + current_stream <- streamed_vars_patch[svp_i] + if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard + + current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[length(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])+1]] <- list() + names(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])[length(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])] <- current_stream_type$name + + if(current_stream_type$type == "class"){ + + # CLASS + class_name <- current_stream_type$name + + beg_end <- serialize_starts_ends(file_in = guesscpp_in, + pattern = paste0("void ", + tools::toTitleCase(current_stream_type$name), + "::serialize")) + + + if(class_name == "vegetation"){ + # VEGETATION + # Vegetation class has a bit of a different structure, it has one more depth, see model documentation + streamed_vars_veg <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + for(svv_i in seq_along(streamed_vars_veg)){ + current_stream <- streamed_vars_veg[svv_i] + if(current_stream == "nobj"){ + # nobj points to different things under different levels, here it is the number of individuals + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["number_of_individuals"]] <- readBin(zz, integer(), 1, size = 4) + next + } + current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + + } # end for-loop over streamed_vars_veg + + }else{ + # NOT VEGETATION + streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) + + for(varname in streamed_vars){ + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[current_stream_type$name]][[varname]] <- vector("list", num_pft) + } + + # maybe try modifying this bit later to make it a function + for(pft_i in seq_len(num_pft)){ + for(sv_i in seq_along(streamed_vars)){ + current_stream <- streamed_vars[sv_i] #it's OK to overwrite + current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + + if(current_stream_type$type == "class"){ + + # CLASS, NOT EVER GOING HERE? + class_name <- current_stream_type$name + + }else{ + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) + # and read! + if(current_stream_specs$single){ + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[length( Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + }else{ # only for historic type? + for(css.i in seq_along(current_stream_specs$what)){ + Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, + what = current_stream_specs$what[css.i], + n = current_stream_specs$n[css.i], + size = current_stream_specs$size[css.i]) + } + } + } + } # streamed_vars-loop ends + } # pft-loop ends + } + + + }else{ + # NOT CLASS + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) + # and read! + if(current_stream_specs$single){ + Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + }else{ # probably don't need this but let's keep + for(css_i in seq_along(current_stream_specs$what)){ + Gridcell[[length(Gridcell)]][[current_stream_specs$names[css_i]]] <- readBin(con = zz, + what = current_stream_specs$what[css_i], + n = current_stream_specs$n[css_i], + size = current_stream_specs$size[css_i]) + } + } + }# end if-class within Patch + } + } }else{ - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - # and read! - if(current_stream_specs$single){ - Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) + # NOT PATCH + + current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + + Gridcell[["Stand"]][[stnd_i]][[length(Gridcell[["Stand"]][[stnd_i]])+1]] <- list() + names(Gridcell[["Stand"]][[stnd_i]])[length(Gridcell[["Stand"]][[stnd_i]])] <- current_stream_type$name + + if(current_stream_type$type == "class"){ + + # CLASS + class_name <- current_stream_type$name + + beg_end <- serialize_starts_ends(file_in = guesscpp_in, + pattern = paste0("void ", + tools::toTitleCase(current_stream_type$name), + "::serialize")) + streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) + + for(varname in streamed_vars){ + Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]][[varname]] <- varname + Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]][[varname]] <- vector("list", num_pft) + } + + for(pft_i in seq_len(num_pft)){ + for(sv_i in seq_along(streamed_vars)){ + current_stream <- streamed_vars[sv_i] #it's OK to overwrite + current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + + if(current_stream_type$type == "class"){ + + # CLASS, NOT EVER GOING HERE? + class_name <- current_stream_type$name + + }else{ + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) + # and read! + if(current_stream_specs$single){ + Gridcell[["Stand"]][[stnd_i]][[length(Gridcell[["Stand"]][[stnd_i]])]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + }else{ + for(css.i in seq_along(current_stream_specs$what)){ + Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, + what = current_stream_specs$what[css.i], + n = current_stream_specs$n[css.i], + size = current_stream_specs$size[css.i]) + } + } + } + } # streamed_vars-loop ends + } # pft-loop ends + + }else{ + # NOT CLASS + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) + # and read! + if(current_stream_specs$single){ + Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + }else{ # probably don't need this but let's keep + for(css_i in seq_along(current_stream_specs$what)){ + Gridcell[[length(Gridcell)]][[current_stream_specs$names[css_i]]] <- readBin(con = zz, + what = current_stream_specs$what[css_i], + n = current_stream_specs$n[css_i], + size = current_stream_specs$size[css_i]) + } + } + }# end if-class within Stand + } # end patch-if + + + }# end for-loop over the streamed stand vars + }# end for-loop over the stands + + }else{ #not reading in Stand variables + + # NOT STAND + + current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + + Gridcell[[length(Gridcell)+1]] <- list() + names(Gridcell)[length(Gridcell)] <- current_stream_type$name + if(current_stream_type$type == "class"){ + + # CLASS + class_name <- current_stream_type$name + + beg_end <- serialize_starts_ends(file_in = guesscpp_in, + pattern = paste0("void ", + tools::toTitleCase(current_stream_type$name), + "::serialize")) + streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) + + for(varname in streamed_vars){ + Gridcell[[length(Gridcell)]][[varname]] <- varname + Gridcell[[length(Gridcell)]][[varname]] <- vector("list", num_pft) + } + + for(pft_i in seq_len(num_pft)){ + for(sv_i in seq_along(streamed_vars)){ + #for(sv_i in 21:37){ + current_stream <- streamed_vars[sv_i] #it's OK to overwrite + current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + + if(current_stream_type$type == "class"){ + + # CLASS, NOT EVER GOING HERE? + class_name <- current_stream_type$name + }else{ - for(css.i in seq_along(current_stream_specs$what)){ - Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, - what = current_stream_specs$what[css.i], - n = current_stream_specs$n[css.i], - size = current_stream_specs$size[css.i]) + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) + # and read! + if(current_stream_specs$single){ + Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + }else{ + for(css.i in seq_along(current_stream_specs$what)){ + Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, + what = current_stream_specs$what[css.i], + n = current_stream_specs$n[css.i], + size = current_stream_specs$size[css.i]) + } } } + } # streamed_vars-loop ends + } # pft-loop ends + + }else{ + # NOT CLASS + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) + # and read! + if(current_stream_specs$single){ + Gridcell[[length(Gridcell)]][[current_stream_type$name]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + }else{ # probably don't need this but let's keep + for(css_i in seq_along(current_stream_specs$what)){ + Gridcell[[length(Gridcell)]][[current_stream_specs$names[css_i]]] <- readBin(con = zz, + what = current_stream_specs$what[css_i], + n = current_stream_specs$n[css_i], + size = current_stream_specs$size[css_i]) } - } # streamed_vars-loop ends - } # pft-loop ends - - }else{ - # NOT CLASS - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - # and read! - if(current_stream_specs$single){ - Gridcell[[length(Gridcell)]][[current_stream_type$name]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ # probably don't need this but let's keep - for(css.i in seq_along(current_stream_specs$what)){ - Gridcell[[length(Gridcell)]][[current_stream_specs$names[css.i]]] <- readBin(con = zz, - what = current_stream_specs$what[css.i], - n = current_stream_specs$n[css.i], - size = current_stream_specs$size[css.i]) } - } - }# if-class + }# end if-class within Gridcell + + } # Stand if-else ends } # Gridcell-loop ends # helper function that determines the stream size to read @@ -287,6 +527,11 @@ find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES if(current_stream_var == "nstands"){ # a bit of a special case, it is read by guess.cpp return(list(type = "int", name = "nstands", substring = "int nstands;")) #there is not substring like that in guess.h } + + if(current_stream_var == "landcover"){ # a bit of a special case + return(list(type = "landcovertype", name = "landcover", substring = "landcovertype landcover;")) + } + # it might be difficult to extract the "type" before the varname # there are not that many to check possible_types <- c("class", "double", "bool", "int") From 45970e5834305e468e9e27ed87b467742bf62650 Mon Sep 17 00:00:00 2001 From: istfer Date: Sat, 15 Jun 2019 16:57:44 -0400 Subject: [PATCH 16/56] reading individual class --- models/lpjguess/R/read_state.R | 63 +++++++++++++++++++++++++++++----- 1 file changed, 54 insertions(+), 9 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index 645030b42d0..33ea63b1d6f 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -221,16 +221,59 @@ for(g_i in 1:8){ # VEGETATION # Vegetation class has a bit of a different structure, it has one more depth, see model documentation streamed_vars_veg <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - for(svv_i in seq_along(streamed_vars_veg)){ - current_stream <- streamed_vars_veg[svv_i] - if(current_stream == "nobj"){ - # nobj points to different things under different levels, here it is the number of individuals - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["number_of_individuals"]] <- readBin(zz, integer(), 1, size = 4) - next - } - current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + + # NOTE : Unlike other parts, this bit is a lot less generalized!!! + # I'm gonna asumme Vegetation class won't change much in the future + # indiv.pft.id and indiv needs to be looped over nobj times + if(!setequal(streamed_vars_veg, c("nobj", "indiv.pft.id", "indiv"))){ + PEcAn.logger::logger.severe("Vegetation class object changed in this model version, you need to fix read.state") + } + + # nobj points to different things under different levels, here it is the number of individuals + number_of_individuals <- readBin(zz, integer(), 1, size = 4) + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["number_of_individuals"]] <- number_of_individuals + if(number_of_individuals < 1){ + # if number of individuals is 0 it's a bit suspicious. Not sure if ever will get negative but that'd definitely be wrong + PEcAn.logger::logger.warn("Number of individuals under vegetation is", number_of_individuals) + } + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["Individuals"]] <- vector("list", number_of_individuals) + + beg_end <- serialize_starts_ends(file_in = guesscpp_in, + pattern = paste0("void Individual::serialize")) + streamed_vars_indv <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + + # loop over nobj + for(indv_i in seq_len(number_of_individuals)){ + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["Individuals"]][[indv_i]] <- list() + # which PFT is this? + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["Individuals"]][[indv_i]][["indiv.pft.id"]] <- readBin(zz, integer(), 1, size = 4) + # read all the individual class + for(svi_i in 1:11){ # seq_along(streamed_vars_indv) + current_stream <- streamed_vars_indv[svi_i] + + current_stream_type <- find_stream_type("individual", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) + + if(current_stream_specs$single){ + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["Individuals"]][[indv_i]][[current_stream_type$name]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + }else{ + for(css.i in seq_along(current_stream_specs$what)){ + Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, + what = current_stream_specs$what[css.i], + n = current_stream_specs$n[css.i], + size = current_stream_specs$size[css.i]) + } + } + + }# end loop over stream vars individual + } # end loop over number_of_individuals + - } # end for-loop over streamed_vars_veg + + }else{ # NOT VEGETATION @@ -565,6 +608,8 @@ find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES # some varnames are very common characters unfortunately like u, v... check if [] comes after if(any(grepl(paste0(" ", current_stream_var, "["), sub_string, fixed = TRUE))){ sub_string <- sub_string[grepl(paste0(" ", current_stream_var, "["), sub_string, fixed = TRUE)] + }else if(any(grepl(paste0("double ", current_stream_var), sub_string, fixed = TRUE))){ # just fishing, double is the most common type + sub_string <- sub_string[grepl(paste0("double ", current_stream_var), sub_string, fixed = TRUE)] }else{ PEcAn.logger::logger.severe("Check this out.") } From d6ef1ec9559427b9f1686724324c63bf3d781816 Mon Sep 17 00:00:00 2001 From: istfer Date: Sun, 16 Jun 2019 17:14:03 -0400 Subject: [PATCH 17/56] first pass at read individual --- models/lpjguess/R/read_state.R | 31 +++++++++++++++++-------------- 1 file changed, 17 insertions(+), 14 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index 33ea63b1d6f..1d420f86b44 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -126,7 +126,7 @@ streamed_vars_gridcell <- find_stream_var(file_in = guesscpp_in, line_nos = beg_ Gridcell <- list() level <- "Gridcell" #for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts -for(g_i in 1:8){ +for(g_i in 1:9){ current_stream <- streamed_vars_gridcell[g_i] if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard if(grepl(glob2rx("(*this)[*].landcover"), current_stream)){ # s counter might change, using wildcard @@ -162,7 +162,7 @@ for(g_i in 1:8){ for(stnd_i in seq_len(num_stnd)){ #looping over the stands - for(svs_i in seq_along(streamed_vars_stand)){ #looping over the streamed stand vars + for(svs_i in seq_along(streamed_vars_stand)){ # looping over the streamed stand vars current_stream <- streamed_vars_stand[svs_i] if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard @@ -248,7 +248,7 @@ for(g_i in 1:8){ # which PFT is this? Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["Individuals"]][[indv_i]][["indiv.pft.id"]] <- readBin(zz, integer(), 1, size = 4) # read all the individual class - for(svi_i in 1:11){ # seq_along(streamed_vars_indv) + for(svi_i in seq_along(streamed_vars_indv)){ # current_stream <- streamed_vars_indv[svi_i] current_stream_type <- find_stream_type("individual", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) @@ -261,7 +261,7 @@ for(g_i in 1:8){ size = current_stream_specs$size) }else{ for(css.i in seq_along(current_stream_specs$what)){ - Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["Individuals"]][[indv_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, what = current_stream_specs$what[css.i], n = current_stream_specs$n[css.i], size = current_stream_specs$size[css.i]) @@ -414,8 +414,8 @@ for(g_i in 1:8){ } # end patch-if - }# end for-loop over the streamed stand vars - }# end for-loop over the stands + }# end for-loop over the streamed stand vars (svs_i, L.165) + }# end for-loop over the stands (stnd_i, L.164) }else{ #not reading in Stand variables @@ -498,7 +498,7 @@ for(g_i in 1:8){ # helper function that determines the stream size to read find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS){ - possible_types <- c("double", "bool", "int", "long") + possible_types <- c("double ", "bool ", "int " , "long ") # space because these can be part of other words possible_types <- c(possible_types, LPJ_GUESS_TYPES) n_sizes <- c(8, 1, 4, 8, rep(4, length(LPJ_GUESS_TYPES) )) rbin_tbl <- c("double", "logical", "integer", "integer", rep("integer", length(LPJ_GUESS_TYPES))) @@ -516,20 +516,23 @@ find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LP specs$single <- TRUE }else if(current_stream_type$type == "Historic"){ + possible_types <- c("double", "bool", "int" , "long") # # I haven't seen any Historic that doesn't store double but... historic has a comma after type: double, + possible_types <- c(possible_types, LPJ_GUESS_TYPES) + # Historic types are special to LPJ-GUESS # They have stored values, current index, and a boolean in that order specs$n <- specs$what <- specs$size <- specs$names <- rep(NA, 3) # always three, this is a type defined in guessmath.h - specs$what[1] <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] # I haven't seen any Historic that doesn't store double but... + specs$what[1] <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] specs$size[1] <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] specs$names[1] <- current_stream_type$name # n is tricky, it can be hardcoded it can be one of the const ints to_read <- str_match(sub_string, paste0("Historic<", specs$what[1], ", (.*?)>.*"))[,2] - #if(to_read %in% LPJ_GUESS_CONST_INTS){ - - #}else{ + if(to_read %in% LPJ_GUESS_CONST_INTS$var){ + specs$n <- LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var == to_read] + }else{ specs$n[1] <- as.numeric(to_read) - #} + } specs$what[2] <- "integer" #need to check what size_t is specs$size[2] <- 8 specs$n[2] <- 1 @@ -577,7 +580,7 @@ find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES # it might be difficult to extract the "type" before the varname # there are not that many to check - possible_types <- c("class", "double", "bool", "int") + possible_types <- c("class ", "double ", "bool ", "int ") possible_types <- c(possible_types, LPJ_GUESS_TYPES) @@ -630,7 +633,7 @@ find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES } - return(list(type = stream_type, name = stream_name, substring = sub_string)) + return(list(type = gsub(" ", "", stream_type), name = stream_name, substring = sub_string)) } # find_stream_type From d58848d79fe0335dc9eb37631baf82fa811c6732 Mon Sep 17 00:00:00 2001 From: istfer Date: Mon, 17 Jun 2019 10:18:23 -0400 Subject: [PATCH 18/56] finish individual --- models/lpjguess/R/read_state.R | 29 +++++++++++++++++++++-------- 1 file changed, 21 insertions(+), 8 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index 1d420f86b44..52609c17d1f 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -126,7 +126,7 @@ streamed_vars_gridcell <- find_stream_var(file_in = guesscpp_in, line_nos = beg_ Gridcell <- list() level <- "Gridcell" #for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts -for(g_i in 1:9){ +for(g_i in 1:8){ current_stream <- streamed_vars_gridcell[g_i] if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard if(grepl(glob2rx("(*this)[*].landcover"), current_stream)){ # s counter might change, using wildcard @@ -162,7 +162,7 @@ for(g_i in 1:9){ for(stnd_i in seq_len(num_stnd)){ #looping over the stands - for(svs_i in seq_along(streamed_vars_stand)){ # looping over the streamed stand vars + for(svs_i in 1:3){#seq_along(streamed_vars_stand)){ # looping over the streamed stand vars current_stream <- streamed_vars_stand[svs_i] if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard @@ -197,7 +197,7 @@ for(g_i in 1:9){ Gridcell[["Stand"]][[stnd_i]][["Patch"]] <- vector("list", npatches) for(ptch_i in seq_len(npatches)){ #looping over the patches - for(svp_i in seq_along(streamed_vars_patch)){ #looping over the streamed patch vars + for(svp_i in 1){#seq_along(streamed_vars_patch)){ #looping over the streamed patch vars current_stream <- streamed_vars_patch[svp_i] if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard @@ -232,9 +232,11 @@ for(g_i in 1:9){ # nobj points to different things under different levels, here it is the number of individuals number_of_individuals <- readBin(zz, integer(), 1, size = 4) Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["number_of_individuals"]] <- number_of_individuals - if(number_of_individuals < 1){ + + # few checks for sensible vals + if(number_of_individuals < 1 | number_of_individuals > 10000){ # should there be an upper limit here too? # if number of individuals is 0 it's a bit suspicious. Not sure if ever will get negative but that'd definitely be wrong - PEcAn.logger::logger.warn("Number of individuals under vegetation is", number_of_individuals) + PEcAn.logger::logger.warn("Number of individuals under vegetation is", number_of_individuals) } Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["Individuals"]] <- vector("list", number_of_individuals) @@ -680,12 +682,23 @@ find_stream_var <- function(file_in, line_nos){ when_here <- NULL } } - if(!grepl(".*& ", file_in[i])) break # when there are no subsequent stream + check1 <- !grepl(".*& ", file_in[i]) # when there are no subsequent stream + check2 <- !grepl(".*& ", file_in[i+1]) # sometimes following line is empty or commented, check the next one too + if(check1 & !check2) i <- i+1 + if(check1 & check2) break # looks like there are no subsequent stream this_line <- gsub("[[:space:]]", "", strsplit(file_in[i], "& ")[[1]]) for(var in this_line){ if(var != ""){ - streaming_list[[str.i]] <- var - str.i <- str.i + 1 + if(var != "arch"){ + streaming_list[[str.i]] <- var + str.i <- str.i + 1 + } + } + } + if(!is.null(when_here)){ # now that increased i check this just in case + if(i == when_here){ + i <- skip_to + when_here <- NULL } } } From 3ab63d91dbcff9ddc9fb91f89c6520530f6794e0 Mon Sep 17 00:00:00 2001 From: istfer Date: Mon, 17 Jun 2019 16:39:43 -0400 Subject: [PATCH 19/56] few more flexibility --- models/lpjguess/R/read_state.R | 21 +++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index 52609c17d1f..afceec40ced 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -32,11 +32,15 @@ paramh_in <- readLines(paramh_loc) ############ open +# test path +out.path = "/fs/data2/output/PEcAn_1000002393/out/1000458390" +setwd(out.path) + # open connection to the binary state file zz <- file("0.state", "rb") ### these are the values read from params.ins, passed to this fcn -npft <- 11 +n_pft <- 11 npatches <- 5 ################################ check class compatibility ################################ @@ -197,7 +201,7 @@ for(g_i in 1:8){ Gridcell[["Stand"]][[stnd_i]][["Patch"]] <- vector("list", npatches) for(ptch_i in seq_len(npatches)){ #looping over the patches - for(svp_i in 1){#seq_along(streamed_vars_patch)){ #looping over the streamed patch vars + for(svp_i in 2){#seq_along(streamed_vars_patch)){ #looping over the streamed patch vars current_stream <- streamed_vars_patch[svp_i] if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard @@ -288,7 +292,7 @@ for(g_i in 1:8){ # maybe try modifying this bit later to make it a function for(pft_i in seq_len(num_pft)){ - for(sv_i in seq_along(streamed_vars)){ + for(sv_i in 1:16){#seq_along(streamed_vars)){ current_stream <- streamed_vars[sv_i] #it's OK to overwrite current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) @@ -510,7 +514,8 @@ find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LP sub_string <- current_stream_type$substring #is there a ; immediately after? - if(grepl(paste0(current_stream_type$type, " ", current_stream_type$name, ";"), sub_string, fixed = TRUE)){ + if(grepl(paste0(current_stream_type$type, " ", current_stream_type$name, ";"), sub_string, fixed = TRUE) | + grepl(paste0(current_stream_type$type, " ", current_stream_type$name, ","), sub_string, fixed = TRUE)){ # e.g. "double alag, exp_alag;" # this is only length 1 specs$n <- 1 specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] @@ -547,6 +552,14 @@ find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LP specs$single <- FALSE + }else if(grepl(glob2rx(paste0(current_stream_type$type, "*", current_stream_type$name, ";")), sub_string)){ + + # this is only length 1 + specs$n <- 1 + specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + specs$single <- TRUE + }else{ # reading a vector specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] From 83b996b6c405ebf84af5fd3bbb996e5915c2e268 Mon Sep 17 00:00:00 2001 From: istfer Date: Mon, 17 Jun 2019 17:25:49 -0400 Subject: [PATCH 20/56] read matrix --- models/lpjguess/R/read_state.R | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index afceec40ced..1b25a51c275 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -292,7 +292,7 @@ for(g_i in 1:8){ # maybe try modifying this bit later to make it a function for(pft_i in seq_len(num_pft)){ - for(sv_i in 1:16){#seq_along(streamed_vars)){ + for(sv_i in 1:19){#seq_along(streamed_vars)){ current_stream <- streamed_vars[sv_i] #it's OK to overwrite current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) @@ -560,6 +560,23 @@ find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LP specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] specs$single <- TRUE + }else if(length(regmatches(sub_string, gregexpr("\\[.+?\\]", sub_string))[[1]]) > 1){ + #looks like we have a matrix + spec_dims <- regmatches(sub_string, gregexpr("\\[.+?\\]", sub_string))[[1]] + spec_dims <- gsub("\\].*", "", gsub(".*\\[", "", spec_dims)) + for(spec_dims_i in seq_along(spec_dims)){ + if(any(sapply(LPJ_GUESS_CONST_INTS$var, grepl, spec_dims[spec_dims_i], fixed = TRUE))){ # uses one of the constant ints + spec_dims[spec_dims_i] <- LPJ_GUESS_CONST_INTS$val[sapply(LPJ_GUESS_CONST_INTS$var, grepl, spec_dims[spec_dims_i], fixed = TRUE)] + }else{ + spec_dims[spec_dims_i] <- as.numeric(sub(".*\\[(.*)\\].*", "\\1", spec_dims[spec_dims_i], perl=TRUE)) + } + } + spec_dims <- as.numeric(spec_dims) + + specs$n <- prod(spec_dims) + specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + specs$single <- TRUE }else{ # reading a vector specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] From f66c54a2dcff1787e6461e8901afe2503d03c12a Mon Sep 17 00:00:00 2001 From: istfer Date: Mon, 17 Jun 2019 18:02:59 -0400 Subject: [PATCH 21/56] getting ready to read sompool --- models/lpjguess/R/read_state.R | 43 ++++++++++++++++++++++++++++++++-- 1 file changed, 41 insertions(+), 2 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index 1b25a51c275..efd28d5f646 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -292,15 +292,43 @@ for(g_i in 1:8){ # maybe try modifying this bit later to make it a function for(pft_i in seq_len(num_pft)){ - for(sv_i in 1:19){#seq_along(streamed_vars)){ + for(sv_i in 1:24){#seq_along(streamed_vars)){ current_stream <- streamed_vars[sv_i] #it's OK to overwrite current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) if(current_stream_type$type == "class"){ - # CLASS, NOT EVER GOING HERE? + # ONLY SOMPOOL HERE SO FAR ****************************************************************** class_name <- current_stream_type$name + beg_end <- serialize_starts_ends(file_in = guesscpp_in, + pattern = paste0("void ", + tools::toTitleCase(current_stream_type$name), + "::serialize")) + streamed_vars_sompool <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + + ###################### LOOP OVER class_name + for(sv_sompool_i in seq_along(streamed_vars_sompool)){ # + current_stream <- streamed_vars_indv[sv_sompool_i] + + current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) + + if(current_stream_specs$single){ + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[class_name]][[current_stream_type$name]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + }else{ + for(css.i in seq_along(current_stream_specs$what)){ + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["Individuals"]][[indv_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, + what = current_stream_specs$what[css.i], + n = current_stream_specs$n[css.i], + size = current_stream_specs$size[css.i]) + } + } + + } }else{ current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) # and read! @@ -639,6 +667,17 @@ find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES if(length(sub_string) == 0){ sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] } + # e.g. "sompool[i]" in guess.cpp, Sompool sompool[NSOMPOOL]; in guess.h + if(length(sub_string) == 0){ + current_stream_var <- gsub("\\[|.\\]", "", current_stream_var) + sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] + if(tools::toTitleCase(current_stream_var) %in% LPJ_GUESS_CLASSES){ + stream_type <- "class" + stream_name <- current_stream_var + sub_string <- NULL + return(list(type = gsub(" ", "", stream_type), name = stream_name, substring = sub_string)) + } + } if(length(sub_string) > 1){ # some varnames are very common characters unfortunately like u, v... check if [] comes after if(any(grepl(paste0(" ", current_stream_var, "["), sub_string, fixed = TRUE))){ From 4a6ea5a22aded59993a8dbd9c046543955337b01 Mon Sep 17 00:00:00 2001 From: istfer Date: Tue, 18 Jun 2019 10:04:33 -0400 Subject: [PATCH 22/56] catch one more case --- models/lpjguess/R/read_state.R | 49 +++++++++++++++++++++------------- 1 file changed, 30 insertions(+), 19 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index efd28d5f646..04bd24485d1 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -112,6 +112,8 @@ dont_need <- c("COLDEST_DAY_NHEMISPHERE", "COLDEST_DAY_SHEMISPHERE", "WARMEST_DA lpjguess_consts[match(dont_need, names(lpjguess_consts))] <- NULL # this probably needs to be extracted from parameters.h:48-49 or somewhere else, but hardcoding for now lpjguess_consts$NLANDCOVERTYPES <- 6 +# this probably needs to be extracted from parameters.h:94 , but hardcoding for now +lpjguess_consts$NSOMPOOL <- 12 LPJ_GUESS_CONST_INTS <- data.frame(var = names(lpjguess_consts), val = as.numeric(unlist(lpjguess_consts)), stringsAsFactors = FALSE) @@ -298,6 +300,9 @@ for(g_i in 1:8){ if(current_stream_type$type == "class"){ + if(current_stream_type$name != "sompool"){ + PEcAn.logger::logger.debug("Classes other than sompool enter here.") + } # ONLY SOMPOOL HERE SO FAR ****************************************************************** class_name <- current_stream_type$name @@ -307,28 +312,31 @@ for(g_i in 1:8){ "::serialize")) streamed_vars_sompool <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - ###################### LOOP OVER class_name - for(sv_sompool_i in seq_along(streamed_vars_sompool)){ # - current_stream <- streamed_vars_indv[sv_sompool_i] - - current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - - if(current_stream_specs$single){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[class_name]][[current_stream_type$name]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ - for(css.i in seq_along(current_stream_specs$what)){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["Individuals"]][[indv_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, - what = current_stream_specs$what[css.i], - n = current_stream_specs$n[css.i], - size = current_stream_specs$size[css.i]) + nsompool <- LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var == "NSOMPOOL"] + + for(varname in streamed_vars_sompool){ + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["soil"]][["sompool"]][[varname]] <- vector("list", nsompool) + } + + ###################### LOOP OVER NSOMPOOL + for(som_i in seq_len(nsompool)){ + for(sv_sompool_i in seq_along(streamed_vars_sompool)){ + current_stream <- streamed_vars_sompool[sv_sompool_i] + + current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) + + if(current_stream_specs$single){ + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["soil"]][["sompool"]][[current_stream_type$name]][[som_i]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + }else{ + PEcAn.logger::logger.debug("Historic under sompool.") } } - } + }else{ current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) # and read! @@ -678,6 +686,9 @@ find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES return(list(type = gsub(" ", "", stream_type), name = stream_name, substring = sub_string)) } } + if(length(sub_string) == 0){ + sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(",", current_stream_var), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] + } if(length(sub_string) > 1){ # some varnames are very common characters unfortunately like u, v... check if [] comes after if(any(grepl(paste0(" ", current_stream_var, "["), sub_string, fixed = TRUE))){ From 1bb8b8706806021d70b50838aecd34cf9920a801 Mon Sep 17 00:00:00 2001 From: istfer Date: Tue, 18 Jun 2019 10:49:13 -0400 Subject: [PATCH 23/56] finished soil --- models/lpjguess/R/read_state.R | 35 +++++++++++++++++++++++++++------- 1 file changed, 28 insertions(+), 7 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index 04bd24485d1..2b8d8e4ca86 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -203,7 +203,7 @@ for(g_i in 1:8){ Gridcell[["Stand"]][[stnd_i]][["Patch"]] <- vector("list", npatches) for(ptch_i in seq_len(npatches)){ #looping over the patches - for(svp_i in 2){#seq_along(streamed_vars_patch)){ #looping over the streamed patch vars + for(svp_i in 1:3){#seq_along(streamed_vars_patch)){ #looping over the streamed patch vars current_stream <- streamed_vars_patch[svp_i] if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard @@ -294,7 +294,7 @@ for(g_i in 1:8){ # maybe try modifying this bit later to make it a function for(pft_i in seq_len(num_pft)){ - for(sv_i in 1:24){#seq_along(streamed_vars)){ + for(sv_i in seq_along(streamed_vars)){ current_stream <- streamed_vars[sv_i] #it's OK to overwrite current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) @@ -304,7 +304,7 @@ for(g_i in 1:8){ PEcAn.logger::logger.debug("Classes other than sompool enter here.") } # ONLY SOMPOOL HERE SO FAR ****************************************************************** - class_name <- current_stream_type$name + #class_name <- # don't overwrite class_name beg_end <- serialize_starts_ends(file_in = guesscpp_in, pattern = paste0("void ", @@ -323,7 +323,7 @@ for(g_i in 1:8){ for(sv_sompool_i in seq_along(streamed_vars_sompool)){ current_stream <- streamed_vars_sompool[sv_sompool_i] - current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + current_stream_type <- find_stream_type(current_stream_type$name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) if(current_stream_specs$single){ @@ -340,14 +340,14 @@ for(g_i in 1:8){ }else{ current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) # and read! - if(current_stream_specs$single){ + if(current_stream_specs$single){ # maybe use current_stream in sublist names to find correct place Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[length( Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, what = current_stream_specs$what, n = current_stream_specs$n, size = current_stream_specs$size) }else{ # only for historic type? - for(css.i in seq_along(current_stream_specs$what)){ - Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, + for(css.i in seq_along(current_stream_specs$what)){ # maybe use current_stream in sublist names to find correct place + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[length( Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, what = current_stream_specs$what[css.i], n = current_stream_specs$n[css.i], size = current_stream_specs$size[css.i]) @@ -588,6 +588,24 @@ find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LP specs$single <- FALSE + }else if(current_stream_type$type == "struct"){ + if(current_stream_type$name != "solvesom"){ + PEcAn.logger::logger.debug("Another struct type.") + } + #for now hardcoding this will be back + specs$n <- specs$what <- specs$size <- specs$names <- rep(NA, 2) + specs$what[1] <- "double" + specs$size[1] <- 8 + specs$names[1] <- "clitter" + specs$n[1] <- 12 #NSOMPOOL + + specs$what[2] <- "double" + specs$size[2] <- 8 + specs$names[2] <- "nlitter" + specs$n[2] <- 12 #NSOMPOOL + + specs$single <- FALSE + }else if(grepl(glob2rx(paste0(current_stream_type$type, "*", current_stream_type$name, ";")), sub_string)){ # this is only length 1 @@ -708,6 +726,9 @@ find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES # Historic types has the form Historic& data) stream_type <- "Historic" stream_name <- current_stream_var + }else if(grepl("std::vector", sub_string, fixed = TRUE)){ + stream_type <- "struct" + stream_name <- current_stream_var }else{ stream_type <- possible_types[sapply(possible_types, grepl, sub_string, fixed = TRUE)] stream_name <- current_stream_var From d84f80fa78ff8afe6bc2c0102619b2ece0abd27c Mon Sep 17 00:00:00 2001 From: istfer Date: Tue, 18 Jun 2019 14:50:22 -0400 Subject: [PATCH 24/56] adding more hardcoded constants for now --- models/lpjguess/R/read_state.R | 66 ++++++++++++++++++++-------------- 1 file changed, 40 insertions(+), 26 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index 2b8d8e4ca86..57e07c6d854 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -110,10 +110,14 @@ for(i in seq_along(guessh_in)){ # few cleaning dont_need <- c("COLDEST_DAY_NHEMISPHERE", "COLDEST_DAY_SHEMISPHERE", "WARMEST_DAY_NHEMISPHERE", "WARMEST_DAY_SHEMISPHERE", "data[]") lpjguess_consts[match(dont_need, names(lpjguess_consts))] <- NULL -# this probably needs to be extracted from parameters.h:48-49 or somewhere else, but hardcoding for now +# this needs to be extracted from parameters.h:48-49 or somewhere else, but hardcoding for now lpjguess_consts$NLANDCOVERTYPES <- 6 -# this probably needs to be extracted from parameters.h:94 , but hardcoding for now +# this needs to be extracted from guess.h:94 , but hardcoding for now lpjguess_consts$NSOMPOOL <- 12 +# this needs to be extracted from guess.h:644 , but hardcoding for now NOTE that new versions has 13 flux types +lpjguess_consts$PerPatchFluxType <- 12 +# this needs to be extracted from guess.h:659 , but hardcoding for now +lpjguess_consts$PerPFTFluxType <- 5 LPJ_GUESS_CONST_INTS <- data.frame(var = names(lpjguess_consts), val = as.numeric(unlist(lpjguess_consts)), stringsAsFactors = FALSE) @@ -223,7 +227,7 @@ for(g_i in 1:8){ "::serialize")) - if(class_name == "vegetation"){ + if(class_name == "Vegetation"){ # VEGETATION # Vegetation class has a bit of a different structure, it has one more depth, see model documentation streamed_vars_veg <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) @@ -237,14 +241,14 @@ for(g_i in 1:8){ # nobj points to different things under different levels, here it is the number of individuals number_of_individuals <- readBin(zz, integer(), 1, size = 4) - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["number_of_individuals"]] <- number_of_individuals + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["number_of_individuals"]] <- number_of_individuals # few checks for sensible vals if(number_of_individuals < 1 | number_of_individuals > 10000){ # should there be an upper limit here too? # if number of individuals is 0 it's a bit suspicious. Not sure if ever will get negative but that'd definitely be wrong PEcAn.logger::logger.warn("Number of individuals under vegetation is", number_of_individuals) } - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["Individuals"]] <- vector("list", number_of_individuals) + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]] <- vector("list", number_of_individuals) beg_end <- serialize_starts_ends(file_in = guesscpp_in, pattern = paste0("void Individual::serialize")) @@ -252,9 +256,9 @@ for(g_i in 1:8){ # loop over nobj for(indv_i in seq_len(number_of_individuals)){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["Individuals"]][[indv_i]] <- list() + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]] <- list() # which PFT is this? - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["Individuals"]][[indv_i]][["indiv.pft.id"]] <- readBin(zz, integer(), 1, size = 4) + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][["indiv.pft.id"]] <- readBin(zz, integer(), 1, size = 4) # read all the individual class for(svi_i in seq_along(streamed_vars_indv)){ # current_stream <- streamed_vars_indv[svi_i] @@ -263,13 +267,13 @@ for(g_i in 1:8){ current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) if(current_stream_specs$single){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["Individuals"]][[indv_i]][[current_stream_type$name]] <- readBin(con = zz, + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][[current_stream_type$name]] <- readBin(con = zz, what = current_stream_specs$what, n = current_stream_specs$n, size = current_stream_specs$size) }else{ for(css.i in seq_along(current_stream_specs$what)){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["Individuals"]][[indv_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, what = current_stream_specs$what[css.i], n = current_stream_specs$n[css.i], size = current_stream_specs$size[css.i]) @@ -304,7 +308,8 @@ for(g_i in 1:8){ PEcAn.logger::logger.debug("Classes other than sompool enter here.") } # ONLY SOMPOOL HERE SO FAR ****************************************************************** - #class_name <- # don't overwrite class_name + # code below is very sompool specific + # class_name <- # don't overwrite class_name beg_end <- serialize_starts_ends(file_in = guesscpp_in, pattern = paste0("void ", @@ -315,24 +320,26 @@ for(g_i in 1:8){ nsompool <- LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var == "NSOMPOOL"] for(varname in streamed_vars_sompool){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["soil"]][["sompool"]][[varname]] <- vector("list", nsompool) + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Soil"]][["sompool[i]"]][[varname]] <- vector("list", nsompool) } + + names( Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Soil"]])[names( Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Soil"]]) == "sompool[i]"] <- "Sompool" ###################### LOOP OVER NSOMPOOL for(som_i in seq_len(nsompool)){ for(sv_sompool_i in seq_along(streamed_vars_sompool)){ current_stream <- streamed_vars_sompool[sv_sompool_i] - current_stream_type <- find_stream_type(current_stream_type$name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + current_stream_type <- find_stream_type("Sompool", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) if(current_stream_specs$single){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["soil"]][["sompool"]][[current_stream_type$name]][[som_i]] <- readBin(con = zz, + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Soil"]][["Sompool"]][[current_stream_type$name]][[som_i]] <- readBin(con = zz, what = current_stream_specs$what, n = current_stream_specs$n, size = current_stream_specs$size) }else{ - PEcAn.logger::logger.debug("Historic under sompool.") + PEcAn.logger::logger.severe("Historic under sompool.") # Not expecting any } } } @@ -593,18 +600,25 @@ find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LP PEcAn.logger::logger.debug("Another struct type.") } #for now hardcoding this will be back - specs$n <- specs$what <- specs$size <- specs$names <- rep(NA, 2) - specs$what[1] <- "double" - specs$size[1] <- 8 - specs$names[1] <- "clitter" - specs$n[1] <- 12 #NSOMPOOL - - specs$what[2] <- "double" - specs$size[2] <- 8 - specs$names[2] <- "nlitter" - specs$n[2] <- 12 #NSOMPOOL + # specs$n <- specs$what <- specs$size <- specs$names <- rep(NA, 2) + # specs$what[1] <- "double" + # specs$size[1] <- 8 + # specs$names[1] <- "clitter" + # specs$n[1] <- 12 #NSOMPOOL + # + # specs$what[2] <- "double" + # specs$size[2] <- 8 + # specs$names[2] <- "nlitter" + # specs$n[2] <- 12 #NSOMPOOL + # + # LOOKS LIKE THIS ONE IS NOT SERIALIZED PROPERLY + # just return 8 - specs$single <- FALSE + + specs$n <- 1 + specs$what <- "double" + specs$size <- 8 + specs$single <- TRUE }else if(grepl(glob2rx(paste0(current_stream_type$type, "*", current_stream_type$name, ";")), sub_string)){ @@ -675,7 +689,7 @@ find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES # class or not? if(tools::toTitleCase(current_stream_var) %in% LPJ_GUESS_CLASSES){ stream_type <- "class" - stream_name <- current_stream_var + stream_name <- tools::toTitleCase(current_stream_var) sub_string <- NULL }else {# find type from guess.h From f9899dd05ce997ef2319d3c851a24cc67aa7319c Mon Sep 17 00:00:00 2001 From: istfer Date: Tue, 18 Jun 2019 15:43:05 -0400 Subject: [PATCH 25/56] getting ready to read fluxes --- models/lpjguess/R/read_state.R | 32 ++++++++++++++++++++++++++++++-- 1 file changed, 30 insertions(+), 2 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index 57e07c6d854..711624d34e5 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -287,8 +287,36 @@ for(g_i in 1:8){ + }else if(class_name == "Fluxes"){ + # FLUXES + # this is not generalized at all + streamed_vars_flux <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + + if(!setequal(streamed_vars_flux, c("annual_fluxes_per_pft", "monthly_fluxes_patch", "monthly_fluxes_pft"))){ + PEcAn.logger::logger.severe("Fluxes class object changed in this model version, you need to fix read.state") + } + + # annual_fluxes_per_pft loops over + # parse from guess.h + PerPFTFluxType <- c("NPP", "GPP", "RA", "ISO", "MON") + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]] <- list() + key1 <- readBin(zz, "integer", 1, 8) + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]][["key1"]] <- key1 + for(fpft_i in seq_len(key1)){ # key1 11 PFTs + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]][[fpft_i]] <- list() + key2 <- readBin(zz, "integer", 1, 8) + if(key2 > 10000){ #make sure you dind't read a weird number, this is supposed to be number of fluxes per pft, can't have too many + PEcAn.logger::logger.severe("Number of fluxes per pft read from the state file is too high. Check read.state function") + } + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]][[fpft_i]][["key2"]] <- key2 + for(flux_i in seq_len(key2)){ + # is this double? + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]][[fpft_i]][[PerPFTFluxType[flux_i]]] <- readBin(zz, "double", 1, 8) + } + } + }else{ - # NOT VEGETATION + # NOT VEGETATION OR FLUX streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) @@ -616,7 +644,7 @@ find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LP specs$n <- 1 - specs$what <- "double" + specs$what <- "integer" specs$size <- 8 specs$single <- TRUE From af59c40703eaed84fe03f94246a63cd06f12fd4a Mon Sep 17 00:00:00 2001 From: istfer Date: Tue, 18 Jun 2019 16:52:12 -0400 Subject: [PATCH 26/56] finished patch --- models/lpjguess/R/read_state.R | 40 ++++++++++++++++++++++++++++------ 1 file changed, 33 insertions(+), 7 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index 711624d34e5..23fae4162c8 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -207,11 +207,16 @@ for(g_i in 1:8){ Gridcell[["Stand"]][[stnd_i]][["Patch"]] <- vector("list", npatches) for(ptch_i in seq_len(npatches)){ #looping over the patches - for(svp_i in 1:3){#seq_along(streamed_vars_patch)){ #looping over the streamed patch vars + for(svp_i in seq_along(streamed_vars_patch)){ #looping over the streamed patch vars current_stream <- streamed_vars_patch[svp_i] if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard - current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + if(tools::toTitleCase(current_stream) %in% LPJ_GUESS_CLASSES){ + current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + }else{ + current_stream_type <- find_stream_type("Patch", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + } + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[length(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])+1]] <- list() names(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])[length(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])] <- current_stream_type$name @@ -301,7 +306,7 @@ for(g_i in 1:8){ PerPFTFluxType <- c("NPP", "GPP", "RA", "ISO", "MON") Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]] <- list() key1 <- readBin(zz, "integer", 1, 8) - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]][["key1"]] <- key1 + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]][["n_pft"]] <- key1 for(fpft_i in seq_len(key1)){ # key1 11 PFTs Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]][[fpft_i]] <- list() key2 <- readBin(zz, "integer", 1, 8) @@ -314,7 +319,19 @@ for(g_i in 1:8){ Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]][[fpft_i]][[PerPFTFluxType[flux_i]]] <- readBin(zz, "double", 1, 8) } } - + + # monthly_fluxes_patch read as a vector at once + # double monthly_fluxes_patch[12][NPERPATCHFLUXTYPES]; + # maybe read this as a matrix? + n_monthly_fluxes_patch <- 12 * LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var =="PerPatchFluxType"] + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["monthly_fluxes_patch"]] <- readBin(zz, "double", n_monthly_fluxes_patch, 8) + + # monthly_fluxes_pft read as a vector at once + # double monthly_fluxes_pft[12][NPERPFTFLUXTYPES]; + # maybe read this as a matrix? + n_monthly_fluxes_pft <- 12 * LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var =="PerPFTFluxType"] + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["monthly_fluxes_pft"]] <- readBin(zz, "double", n_monthly_fluxes_pft, 8) + }else{ # NOT VEGETATION OR FLUX streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) @@ -399,13 +416,15 @@ for(g_i in 1:8){ current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) # and read! if(current_stream_specs$single){ - Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]] <- readBin(con = zz, + + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[current_stream_type$name]] <- readBin(con = zz, what = current_stream_specs$what, n = current_stream_specs$n, size = current_stream_specs$size) }else{ # probably don't need this but let's keep for(css_i in seq_along(current_stream_specs$what)){ - Gridcell[[length(Gridcell)]][[current_stream_specs$names[css_i]]] <- readBin(con = zz, + # CHANGE ALL THESE HISTORIC TYPES SO THAT cirrent_index and full goes together with the variable + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[current_stream_specs$names[css_i]]] <- readBin(con = zz, what = current_stream_specs$what[css_i], n = current_stream_specs$n[css_i], size = current_stream_specs$size[css_i]) @@ -750,14 +769,21 @@ find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(",", current_stream_var), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] } if(length(sub_string) > 1){ + # some varnames are very common characters unfortunately like u, v... check if [] comes after if(any(grepl(paste0(" ", current_stream_var, "["), sub_string, fixed = TRUE))){ sub_string <- sub_string[grepl(paste0(" ", current_stream_var, "["), sub_string, fixed = TRUE)] }else if(any(grepl(paste0("double ", current_stream_var), sub_string, fixed = TRUE))){ # just fishing, double is the most common type sub_string <- sub_string[grepl(paste0("double ", current_stream_var), sub_string, fixed = TRUE)] + }else if(any(grepl("///", sub_string, fixed = TRUE))){ # three slashes are very common in commented out code + sub_string <- sub_string[!grepl("///", sub_string, fixed = TRUE)] + } + + if(length(unique(sub_string)) == 1){ + sub_string <- unique(sub_string) }else{ PEcAn.logger::logger.severe("Check this out.") - } + } } # clean from tabs From 4e42c6c34afc393e8430398cec461c2ea06e5bf4 Mon Sep 17 00:00:00 2001 From: istfer Date: Tue, 18 Jun 2019 17:11:30 -0400 Subject: [PATCH 27/56] finished reading all - first pass --- models/lpjguess/R/read_state.R | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index 23fae4162c8..459218091e5 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -135,8 +135,7 @@ streamed_vars_gridcell <- find_stream_var(file_in = guesscpp_in, line_nos = beg_ # there will be nested loops, the hierarchy will follow LPJ-GUESS architecture Gridcell <- list() level <- "Gridcell" -#for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts -for(g_i in 1:8){ +for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts current_stream <- streamed_vars_gridcell[g_i] if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard if(grepl(glob2rx("(*this)[*].landcover"), current_stream)){ # s counter might change, using wildcard @@ -172,7 +171,7 @@ for(g_i in 1:8){ for(stnd_i in seq_len(num_stnd)){ #looping over the stands - for(svs_i in 1:3){#seq_along(streamed_vars_stand)){ # looping over the streamed stand vars + for(svs_i in seq_along(streamed_vars_stand)){ # looping over the streamed stand vars current_stream <- streamed_vars_stand[svs_i] if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard @@ -437,7 +436,11 @@ for(g_i in 1:8){ }else{ # NOT PATCH - current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + if(tools::toTitleCase(current_stream) %in% LPJ_GUESS_CLASSES){ + current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + }else{ + current_stream_type <- find_stream_type("Stand", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + } Gridcell[["Stand"]][[stnd_i]][[length(Gridcell[["Stand"]][[stnd_i]])+1]] <- list() names(Gridcell[["Stand"]][[stnd_i]])[length(Gridcell[["Stand"]][[stnd_i]])] <- current_stream_type$name From 94d304c07fa9377edc7b1e7b2caca548e29b38cc Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Tue, 18 Jun 2019 17:51:34 -0400 Subject: [PATCH 28/56] Added allometry and allocation functions from LPJ-GUESS. Also summing variables to a per-gridcells basis, and first start on updating the state. --- models/lpjguess/DESCRIPTION | 4 +- models/lpjguess/NAMESPACE | 4 + models/lpjguess/R/allocation.LPJGUESS.R | 5 + models/lpjguess/R/allocation.LPJGUESS.cpp | 638 ++++++ models/lpjguess/R/allometry.LPJGUESS.R | 254 +++ ...calculateGridcellVariablePerPFT.LPJGUESS.R | 90 + models/lpjguess/R/read_state.R | 1726 ++++++++--------- models/lpjguess/R/updateIndividual.LPJGUESS.R | 185 ++ models/lpjguess/man/allometry.Rd | 14 + .../man/calculateGridcellVariablePerPFT.Rd | 26 + models/lpjguess/man/updateState.LPJGUESS.Rd | 41 + 11 files changed, 2123 insertions(+), 864 deletions(-) create mode 100644 models/lpjguess/R/allocation.LPJGUESS.R create mode 100644 models/lpjguess/R/allocation.LPJGUESS.cpp create mode 100644 models/lpjguess/R/allometry.LPJGUESS.R create mode 100644 models/lpjguess/R/calculateGridcellVariablePerPFT.LPJGUESS.R create mode 100644 models/lpjguess/R/updateIndividual.LPJGUESS.R create mode 100644 models/lpjguess/man/allometry.Rd create mode 100644 models/lpjguess/man/calculateGridcellVariablePerPFT.Rd create mode 100644 models/lpjguess/man/updateState.LPJGUESS.Rd diff --git a/models/lpjguess/DESCRIPTION b/models/lpjguess/DESCRIPTION index ad0518e6656..4a7ed6a4fcc 100644 --- a/models/lpjguess/DESCRIPTION +++ b/models/lpjguess/DESCRIPTION @@ -14,7 +14,9 @@ Imports: PEcAn.logger, PEcAn.remote, lubridate (>= 1.6.0), - ncdf4 (>= 1.15) + ncdf4 (>= 1.15), + Rcpp (>= 0.11.0) +LinkingTo: Rcpp Suggests: testthat (>= 1.0.2) SystemRequirements: LPJ-GUESS model diff --git a/models/lpjguess/NAMESPACE b/models/lpjguess/NAMESPACE index d0e5771159c..507663237b3 100644 --- a/models/lpjguess/NAMESPACE +++ b/models/lpjguess/NAMESPACE @@ -1,11 +1,15 @@ # Generated by roxygen2: do not edit by hand +export() +export(calculateGridcellVariablePerPFT) export(met2model.LPJGUESS) export(model2netcdf.LPJGUESS) export(pecan2lpjguess) export(readStateBinary) +export(updateState.LPJGUESS) export(write.config.LPJGUESS) export(write.insfile.LPJGUESS) +importFrom(Rcpp,sourceCpp) importFrom(ncdf4,nc_close) importFrom(ncdf4,ncatt_get) importFrom(ncdf4,ncatt_put) diff --git a/models/lpjguess/R/allocation.LPJGUESS.R b/models/lpjguess/R/allocation.LPJGUESS.R new file mode 100644 index 00000000000..9fe65c80f05 --- /dev/null +++ b/models/lpjguess/R/allocation.LPJGUESS.R @@ -0,0 +1,5 @@ +#' @importFrom Rcpp sourceCpp +#' @export + +# compile the LPJ-GUESS allocation function using Rcpp +sourceCpp("~/Projects/PalEON/LPJ-GUESS/allocation.cpp") \ No newline at end of file diff --git a/models/lpjguess/R/allocation.LPJGUESS.cpp b/models/lpjguess/R/allocation.LPJGUESS.cpp new file mode 100644 index 00000000000..11ad5c5b3b0 --- /dev/null +++ b/models/lpjguess/R/allocation.LPJGUESS.cpp @@ -0,0 +1,638 @@ +#include +using namespace Rcpp; + +/************************************************************************/ +/************************ NASTY HARD CODING *****************************/ +/************************************************************************/ + + +bool ifcdebt = true; + + +/************************************************************************/ +/************************ HELPER FUNCTIONS *****************************/ +/************************************************************************/ + + +inline bool largerthanzero(double dval, int limit = 0) { + // Returns true if |dval| < EPSILON, otherwise false + return limit ? dval > pow(10.0, limit) : dval > 1.0e-30; +} + + + + + +/** + * @brief This does what you think it does. + * @ingroup sorting_algorithms + * @param __a A thing of arbitrary type. + * @param __b Another thing of arbitrary type. + * @return The lesser of the parameters. + * + * This is the simple classic generic implementation. It will work on + * temporary expressions, since they are only evaluated once, unlike a + * preprocessor macro. + */ +template +_GLIBCXX14_CONSTEXPR + inline const _Tp& + min(const _Tp& __a, const _Tp& __b) + { + // concept requirements + __glibcxx_function_requires(_LessThanComparableConcept<_Tp>) + //return __b < __a ? __b : __a; + if (__b < __a) + return __b; + return __a; + } + +/** +* @brief This does what you think it does. +* @ingroup sorting_algorithms +* @param __a A thing of arbitrary type. +* @param __b Another thing of arbitrary type. +* @return The greater of the parameters. +* +* This is the simple classic generic implementation. It will work on +* temporary expressions, since they are only evaluated once, unlike a +* preprocessor macro. +*/ +template +_GLIBCXX14_CONSTEXPR + inline const _Tp& + max(const _Tp& __a, const _Tp& __b) + { + // concept requirements + __glibcxx_function_requires(_LessThanComparableConcept<_Tp>) + //return __a < __b ? __b : __a; + if (__a < __b) + return __b; + return __a; + } + +/** +* @brief This does what you think it does. +* @ingroup sorting_algorithms +* @param __a A thing of arbitrary type. +* @param __b Another thing of arbitrary type. +* @param __comp A @link comparison_functors comparison functor@endlink. +* @return The lesser of the parameters. +* +* This will work on temporary expressions, since they are only evaluated +* once, unlike a preprocessor macro. +*/ +template +_GLIBCXX14_CONSTEXPR + inline const _Tp& + min(const _Tp& __a, const _Tp& __b, _Compare __comp) + { + //return __comp(__b, __a) ? __b : __a; + if (__comp(__b, __a)) + return __b; + return __a; + } + +/** + * @brief This does what you think it does. + * @ingroup sorting_algorithms + * @param __a A thing of arbitrary type. + * @param __b Another thing of arbitrary type. + * @param __comp A @link comparison_functors comparison functor@endlink. + * @return The greater of the parameters. + * + * This will work on temporary expressions, since they are only evaluated + * once, unlike a preprocessor macro. + */ +template +_GLIBCXX14_CONSTEXPR + inline const _Tp& + max(const _Tp& __a, const _Tp& __b, _Compare __comp) + { + //return __comp(__a, __b) ? __b : __a; + if (__comp(__a, __b)) + return __b; + return __a; + } + +/////////////////////////////////////////////////////////////////////////////////////// +// ALLOCATION +// Function allocation is an internal function (do not call directly from framework); +// function allocation_init may be called to distribute initial biomass among tissues +// for a new individual. + +// File scope global variables: used by function f below (see function allocation) + +static double k1, k2, k3, b; +static double ltor_g; +static double cmass_heart_g; +static double cmass_leaf_g; + +inline double f(double& cmass_leaf_inc) { + + // Returns value of f(cmass_leaf_inc), given by: + // + // f(cmass_leaf_inc) = 0 = + // k1 * (b - cmass_leaf_inc - cmass_leaf_inc/ltor + cmass_heart) - + // [ (b - cmass_leaf_inc - cmass_leaf_inc/ltor) + // / (cmass_leaf + cmass_leaf_inc )*k3 ] ** k2 + // + // See function allocation (below), Eqn (13) + + return k1 * (b - cmass_leaf_inc - cmass_leaf_inc / ltor_g + cmass_heart_g) - + pow((b - cmass_leaf_inc - cmass_leaf_inc / ltor_g) / (cmass_leaf_g + cmass_leaf_inc) * k3, + k2); +} + + + +// [[Rcpp::export]] +List allocation(double bminc,double cmass_leaf,double cmass_root,double cmass_sap, + double cmass_debt,double cmass_heart,double ltor,double height,double sla, + double wooddens,int lifeform,double k_latosa,double k_allom2, + double k_allom3,double& cmass_leaf_inc,double& cmass_root_inc, + double& cmass_sap_inc, + double& cmass_debt_inc, + double& cmass_heart_inc,double& litter_leaf_inc, + double& litter_root_inc,double& exceeds_cmass) { + + // DESCRIPTION + // Calculates changes in C compartment sizes (leaves, roots, sapwood, heartwood) + // and litter for a plant individual as a result of allocation of biomass increment. + // Assumed allometric relationships are given in function allometry below. + + // INPUT PARAMETERS + // bminc = biomass increment this time period on individual basis (kgC) + // cmass_leaf = leaf C biomass for last time period on individual basis (kgC) + // cmass_root = root C biomass for last time period on individual basis (kgC) + // cmass_sap = sapwood C biomass for last time period on individual basis (kgC) + // cmass_heart = heartwood C biomass for last time period on individual basis (kgC) + // ltor = leaf to root mass ratio following allocation + // height = individual height (m) + // sla = specific leaf area (PFT-specific constant) (m2/kgC) + // wooddens = wood density (PFT-specific constant) (kgC/m3) + // lifeform = life form class (TREE or GRASS) + // k_latosa = ratio of leaf area to sapwood cross-sectional area (PFT-specific + // constant) + // k_allom2 = constant in allometry equations + // k_allom3 = constant in allometry equations + + // OUTPUT PARAMETERS + // cmass_leaf_inc = increment (may be negative) in leaf C biomass following + // allocation (kgC) + // cmass_root_inc = increment (may be negative) in root C biomass following + // allocation (kgC) + // cmass_sap_inc = increment (may be negative) in sapwood C biomass following + // allocation (kgC) + // cmass_heart_inc = increment in heartwood C biomass following allocation (kgC) + // litter_leaf_inc = increment in leaf litter following allocation, on individual + // basis (kgC) + // litter_root_inc = increment in root litter following allocation, on individual + // basis (kgC) + // exceeds_cmass = negative increment that exceeds existing biomass (kgC) + + // MATHEMATICAL DERIVATION FOR TREE ALLOCATION + // Allocation attempts to distribute biomass increment (bminc) among the living + // tissue compartments, i.e. + // (1) bminc = cmass_leaf_inc + cmass_root_inc + cmass_sap_inc + // while satisfying the allometric relationships (Shinozaki et al. 1964a,b; Waring + // et al 1982, Huang et al 1992; see also function allometry, below) [** = + // raised to the power of]: + // (2) (leaf area) = k_latosa * (sapwood xs area) + // (3) cmass_leaf = ltor * cmass_root + // (4) height = k_allom2 * (stem diameter) ** k_allom3 + // From (1) and (3), + // (5) cmass_sap_inc = bminc - cmass_leaf_inc - + // (cmass_leaf + cmass_leaf_inc) / ltor + cmass_root + // Let diam_new and height_new be stem diameter and height following allocation. + // Then (see allometry), + // (6) diam_new = 2 * [ ( cmass_sap + cmass_sap_inc + cmass_heart ) + // / wooddens / height_new / PI ]**(1/2) + // From (4), (6) and (5), + // (7) height_new**(1+2/k_allom3) = + // k_allom2**(2/k_allom3) * 4 * [cmass_sap + bminc - cmass_leaf_inc + // - (cmass_leaf + cmass_leaf_inc) / ltor + cmass_root + cmass_heart] + // / wooddens / PI + // Now, + // (8) wooddens = cmass_sap / height / (sapwood xs area) + // From (8) and (2), + // (9) wooddens = cmass_sap / height / sla / cmass_leaf * k_latosa + // From (9) and (1), + // (10) wooddens = (cmass_sap + bminc - cmass_leaf_inc - + // (cmass_leaf + cmass_leaf_inc) / ltor + cmass_root) + // / height_new / sla / (cmass_leaf + cmass_leaf_inc) * k_latosa + // From (10), + // (11) height_new**(1+2/k_allom3) = + // [ (cmass_sap + bminc - cmass_leaf_inc - (cmass_leaf + cmass_leaf_inc) + // / ltor + cmass_root) / wooddens / sla + // / (cmass_leaf + cmass_leaf_inc ) * k_latosa ] ** (1+2/k_allom3) + // + // Combining (7) and (11) gives a function of the unknown cmass_leaf_inc: + // + // (12) f(cmass_leaf_inc) = 0 = + // k_allom2**(2/k_allom3) * 4/PI * [cmass_sap + bminc - cmass_leaf_inc + // - (cmass_leaf + cmass_leaf_inc) / ltor + cmass_root + cmass_heart] + // / wooddens - + // [ (cmass_sap + bminc - cmass_leaf_inc - (cmass_leaf + cmass_leaf_inc) + // / ltor + cmass_root) / (cmass_leaf + cmass_leaf_inc) + // / wooddens / sla * k_latosa] ** (1+2/k_allom3) + // + // Let k1 = k_allom2**(2/k_allom3) * 4/PI / wooddens + // k2 = 1+2/k_allom3 + // k3 = k_latosa / wooddens / sla + // b = cmass_sap + bminc - cmass_leaf/ltor + cmass_root + // + // Then, + // (13) f(cmass_leaf_inc) = 0 = + // k1 * (b - cmass_leaf_inc - cmass_leaf_inc/ltor + cmass_heart) - + // [ (b - cmass_leaf_inc - cmass_leaf_inc/ltor) + // / (cmass_leaf + cmass_leaf_inc )*k3 ] ** k2 + // + // Numerical methods are used to solve Eqn (13) for cmass_leaf_inc + + const int NSEG=20; // number of segments (parameter in numerical methods) + const int JMAX=40; // maximum number of iterations (in numerical methods) + const double XACC=0.0001; // threshold x-axis precision of allocation solution + const double YACC=1.0e-10; // threshold y-axis precision of allocation solution + const double CDEBT_MAXLOAN_DEFICIT=0.8; // maximum loan as a fraction of deficit + const double CDEBT_MAXLOAN_MASS=0.2; // maximum loan as a fraction of (sapwood-cdebt) + + double cmass_leaf_inc_min; + double cmass_root_inc_min; + double x1,x2,dx,xmid,fx1,fmid,rtbis,sign; + int j; + double cmass_deficit,cmass_loan; + + // initialise + litter_leaf_inc = 0.0; + litter_root_inc = 0.0; + exceeds_cmass = 0.0; + cmass_leaf_inc = 0.0; + cmass_root_inc = 0.0; + cmass_sap_inc = 0.0; + cmass_heart_inc = 0.0; + cmass_debt_inc = 0.0; + + if (!largerthanzero(ltor, -10)) { + + // No leaf production possible - put all biomass into roots + // (Individual will die next time period) + + cmass_leaf_inc = 0.0; + + // Make sure we don't end up with negative cmass_root + if (bminc < -cmass_root) { + exceeds_cmass = -(cmass_root + bminc); + cmass_root_inc = -cmass_root; + } + else { + cmass_root_inc=bminc; + } + + if (lifeform==1) { + cmass_sap_inc=-cmass_sap; + cmass_heart_inc=-cmass_sap_inc; + } + } + else if (lifeform==1) { + + // TREE ALLOCATION + + cmass_heart_inc=0.0; + + // Calculate minimum leaf increment to maintain current sapwood biomass + // Given Eqn (2) + + if (height>0.0) + cmass_leaf_inc_min=k_latosa*cmass_sap/(wooddens*height*sla)-cmass_leaf; + else + cmass_leaf_inc_min=0.0; + + // Calculate minimum root increment to support minimum resulting leaf biomass + // Eqn (3) + + if (height>0.0) + cmass_root_inc_min=k_latosa*cmass_sap/(wooddens*height*sla*ltor)- + cmass_root; + else + cmass_root_inc_min=0.0; + + if (cmass_root_inc_min<0.0) { // some roots would have to be killed + + cmass_leaf_inc_min=cmass_root*ltor-cmass_leaf; + cmass_root_inc_min=0.0; + } + + // BLARP! C debt stuff + if (ifcdebt) { + cmass_deficit=cmass_leaf_inc_min+cmass_root_inc_min-bminc; + if (cmass_deficit>0.0) { + cmass_loan=max(min(cmass_deficit*CDEBT_MAXLOAN_DEFICIT, + (cmass_sap-cmass_debt)*CDEBT_MAXLOAN_MASS),0.0); + bminc+=cmass_loan; + cmass_debt_inc=cmass_loan; + } + else cmass_debt_inc=0.0; + } + else cmass_debt_inc=0.0; + + if ( (cmass_root_inc_min >= 0.0 && cmass_leaf_inc_min >= 0.0 && + cmass_root_inc_min + cmass_leaf_inc_min <= bminc) || bminc<=0.0) { + + // Normal allocation (positive increment to all living C compartments) + + // Calculation of leaf mass increment (lminc_ind) satisfying Eqn (13) + // using bisection method (Press et al 1986) + + // Set values for global variables for reuse by function f + + k1 = pow(k_allom2, 2.0 / k_allom3) * 4.0 / PI / wooddens; + k2 = 1.0 + 2 / k_allom3; + k3 = k_latosa / wooddens / sla; + b = cmass_sap + bminc - cmass_leaf / ltor + cmass_root; + ltor_g = ltor; + cmass_leaf_g = cmass_leaf; + cmass_heart_g = cmass_heart; + + x1 = 0.0; + x2 = (bminc - (cmass_leaf / ltor - cmass_root)) / (1.0 + 1.0 / ltor); + dx = (x2 - x1) / (double)NSEG; + + if (cmass_leaf < 1.0e-10) x1 += dx; // to avoid division by zero + + // Evaluate f(x1), i.e. Eqn (13) at cmass_leaf_inc = x1 + + fx1 = f(x1); + + // Find approximate location of leftmost root on the interval + // (x1,x2). Subdivide (x1,x2) into nseg equal segments seeking + // change in sign of f(xmid) relative to f(x1). + + fmid = f(x1); + + xmid = x1; + + while (fmid * fx1 > 0.0 && xmid < x2) { + + xmid += dx; + fmid = f(xmid); + } + + x1 = xmid - dx; + x2 = xmid; + + // Apply bisection to find root on new interval (x1,x2) + + if (f(x1) >= 0.0) sign = -1.0; + else sign = 1.0; + + rtbis = x1; + dx = x2 - x1; + + // Bisection loop + // Search iterates on value of xmid until xmid lies within + // xacc of the root, i.e. until |xmid-x|= XACC && fabs(fmid) > YACC && j <= JMAX) { + + dx *= 0.5; + xmid = rtbis + dx; + + fmid = f(xmid); + + if (fmid * sign <= 0.0) rtbis = xmid; + j++; + } + + // Now rtbis contains numerical solution for cmass_leaf_inc given Eqn (13) + + cmass_leaf_inc = rtbis; + + // Calculate increments in other compartments + + cmass_root_inc = (cmass_leaf_inc + cmass_leaf) / ltor - cmass_root; // Eqn (3) + cmass_sap_inc = bminc - cmass_leaf_inc - cmass_root_inc; // Eqn (1) + + // guess2008 - extra check - abnormal allocation can still happen if ltor is very small + if ((cmass_root_inc > 50 || cmass_root_inc < -50) && ltor < 0.0001) { + cmass_leaf_inc = 0.0; + cmass_root_inc = bminc; + cmass_sap_inc = -cmass_sap; + cmass_heart_inc = -cmass_sap_inc; + } + + // Negative sapwood increment larger than existing sapwood or + // if debt becomes larger than existing woody biomass + if (cmass_sap < -cmass_sap_inc || cmass_sap + cmass_sap_inc + cmass_heart < cmass_debt + cmass_debt_inc) { + + // Abnormal allocation: reduction in some biomass compartment(s) to + // satisfy allometry + + // Attempt to distribute this year's production among leaves and roots only + // Eqn (3) + + cmass_leaf_inc = (bminc - cmass_leaf / ltor + cmass_root) / (1.0 + 1.0 / ltor); + cmass_root_inc = bminc - cmass_leaf_inc; + + // Make sure we don't end up with negative cmass_leaf + cmass_leaf_inc = max(-cmass_leaf, cmass_leaf_inc); + + // Make sure we don't end up with negative cmass_root + cmass_root_inc = max(-cmass_root, cmass_root_inc); + + // If biomass of roots and leafs can't meet biomass decrease then + // sapwood also needs to decrease + cmass_sap_inc = bminc - cmass_leaf_inc - cmass_root_inc; + + // No sapwood turned into heartwood + cmass_heart_inc = 0.0; + + // Make sure we don't end up with negative cmass_sap + if (cmass_sap_inc < -cmass_sap) { + exceeds_cmass = -(cmass_sap + cmass_sap_inc); + cmass_sap_inc = -cmass_sap; + } + + // Comment: Can happen that biomass decrease is larger than biomass in all compartments. + // Then bminc is more negative than there is biomass to respire + } + } +else { + + // Abnormal allocation: reduction in some biomass compartment(s) to + // satisfy allometry + + // Attempt to distribute this year's production among leaves and roots only + // Eqn (3) + + cmass_leaf_inc = (bminc - cmass_leaf / ltor + cmass_root) / (1.0 + 1.0 / ltor); + + if (cmass_leaf_inc > 0.0) { + + // Positive allocation to leaves + + cmass_root_inc = bminc - cmass_leaf_inc; // Eqn (1) + + // Add killed roots (if any) to litter + + // guess2008 - back to LPJF method in this case + // if (cmass_root_inc<0.0) litter_root_inc=-cmass_root_inc; + if (cmass_root_inc < 0.0) { + cmass_leaf_inc = bminc; + cmass_root_inc = (cmass_leaf_inc + cmass_leaf) / ltor - cmass_root; // Eqn (3) + } + + } + else { + + // Negative or zero allocation to leaves + // Eqns (1), (3) + + cmass_root_inc = bminc; + cmass_leaf_inc = (cmass_root + cmass_root_inc) * ltor - cmass_leaf; + } + + // Make sure we don't end up with negative cmass_leaf + if (cmass_leaf_inc < -cmass_leaf) { + exceeds_cmass += -(cmass_leaf + cmass_leaf_inc); + cmass_leaf_inc = -cmass_leaf; + } + + // Make sure we don't end up with negative cmass_root + if (cmass_root_inc < -cmass_root) { + exceeds_cmass += -(cmass_root + cmass_root_inc); + cmass_root_inc = -cmass_root; + } + + // Add killed leaves to litter + litter_leaf_inc = max(-cmass_leaf_inc, 0.0); + + // Add killed roots to litter + litter_root_inc = max(-cmass_root_inc, 0.0); + + // Calculate increase in sapwood mass (which must be negative) + // Eqn (2) + cmass_sap_inc = (cmass_leaf_inc + cmass_leaf) * wooddens * height * sla / k_latosa - + cmass_sap; + + // Make sure we don't end up with negative cmass_sap + if (cmass_sap_inc < -cmass_sap) { + exceeds_cmass += -(cmass_sap + cmass_sap_inc); + cmass_sap_inc = -cmass_sap; + } + + // Convert killed sapwood to heartwood + cmass_heart_inc = -cmass_sap_inc; +} +} +else if (lifeform == 2) { + + // GRASS ALLOCATION + // Allocation attempts to distribute biomass increment (bminc) among leaf + // and root compartments, i.e. + // (14) bminc = cmass_leaf_inc + cmass_root_inc + // while satisfying Eqn(3) + + cmass_leaf_inc = (bminc - cmass_leaf / ltor + cmass_root) / (1.0 + 1.0 / ltor); + cmass_root_inc = bminc - cmass_leaf_inc; + + if (bminc >= 0.0) { + + // Positive biomass increment + + if (cmass_leaf_inc < 0.0) { + + // Positive bminc, but ltor causes negative allocation to leaves, + // put all of bminc into roots + + cmass_root_inc = bminc; + cmass_leaf_inc = (cmass_root + cmass_root_inc) * ltor - cmass_leaf; // Eqn (3) + } + else if (cmass_root_inc < 0.0) { + + // Positive bminc, but ltor causes negative allocation to roots, + // put all of bminc into leaves + + cmass_leaf_inc = bminc; + cmass_root_inc = (cmass_leaf + bminc) / ltor - cmass_root; + } + + // Make sure we don't end up with negative cmass_leaf + if (cmass_leaf_inc < -cmass_leaf) { + exceeds_cmass += -(cmass_leaf + cmass_leaf_inc); + cmass_leaf_inc = -cmass_leaf; + } + + // Make sure we don't end up with negative cmass_root + if (cmass_root_inc < -cmass_root) { + exceeds_cmass += -(cmass_root + cmass_root_inc); + cmass_root_inc = -cmass_root; + } + + // Add killed leaves to litter + litter_leaf_inc = max(-cmass_leaf_inc, 0.0); + + // Add killed roots to litter + litter_root_inc = max(-cmass_root_inc, 0.0); + } + else if (bminc < 0) { + + // Abnormal allocation: negative biomass increment + + // Negative increment is respiration (neg bminc) or/and increment in other + // compartments leading to no litter production + + if (bminc < -(cmass_leaf + cmass_root)) { + + // Biomass decrease is larger than existing biomass + + exceeds_cmass = -(bminc + cmass_leaf + cmass_root); + + cmass_leaf_inc = -cmass_leaf; + cmass_root_inc = -cmass_root; + } + else if (cmass_root_inc < 0.0) { + + // Negative allocation to root + // Make sure we don't end up with negative cmass_root + + if (cmass_root < -cmass_root_inc) { + cmass_leaf_inc = bminc + cmass_root; + cmass_root_inc = -cmass_root; + } + } + else if (cmass_leaf_inc < 0.0) { + + // Negative allocation to leaf + // Make sure we don't end up with negative cmass_leaf + + if (cmass_leaf < -cmass_leaf_inc) { + cmass_root_inc = bminc + cmass_leaf; + cmass_leaf_inc = -cmass_leaf; + } + } + } + } + +// Check C budget after allocation + +// maximum carbon mismatch +double EPS = 1.0e-12; + +assert(fabs(bminc + exceeds_cmass - (cmass_leaf_inc + cmass_root_inc + cmass_sap_inc + cmass_heart_inc + litter_leaf_inc + litter_root_inc)) < EPS); + +List ret; +ret["cmass_leaf_inc"] = cmass_leaf_inc; +ret["cmass_root_inc"] = cmass_root_inc; +ret["cmass_sap_inc"] = cmass_sap_inc; +ret["cmass_debt_inc"] = cmass_debt_inc; +ret["cmass_heart_inc"] = cmass_heart_inc; +ret["litter_leaf_inc"] = litter_leaf_inc; +ret["litter_root_inc"] = litter_root_inc; +ret["exceeds_cmass"] = exceeds_cmass; +return ret; + +} \ No newline at end of file diff --git a/models/lpjguess/R/allometry.LPJGUESS.R b/models/lpjguess/R/allometry.LPJGUESS.R new file mode 100644 index 00000000000..d92e69bcc67 --- /dev/null +++ b/models/lpjguess/R/allometry.LPJGUESS.R @@ -0,0 +1,254 @@ +## Matthew Forrest 2019-06-19 Simple helper function transcribed from the LPJ-GUESS C++ to support the allocation funcrion below + +# NEGLIGABLE +# Returns true if |dval| < exp(limit), otherwise false +#' @keywords internal +negligible <- function(dval, limit = -30) { + if(abs(dval) < exp(limit)) return(TRUE) + else return(FALSE) +} + +# LAMBERT-BEER +#' @keywords internal +lambertbeer <- function(lai) { + return(exp(-.5 * lai)) +} + + + +## Matthew Forrest 2019-06-19 This function was transcribed from LPJ-GUESS (v4.0) C++ to R for the purpose of nudging the LPJ-GUESS state offline. +## The idea id of course to use the output from the analysis step from an SDA routine to provide the nudged values, although that isn't +## relevant to the following code. +## +## Since the original C++ code took as its only argument an LPJ-GUESS C++ class of type 'Individual' there was no way (to my knowledge) +## of directly compiling using Rcpp (unlike for allocation.cpp/allocation.R. which was easy to compile from the native C++ using +## Rcpp with very few changes). +## +## As noted in the original function header taken from the the C++ code below, this function should be run after its biomass values +## have been updated. In this case that means after the allocation() function has been applied to an individual. +## +## This function can return FALSE for following reasons: +## 1. The individual has negligible leaf biomass. +## 2. The +## +## +## In LPJ-GUESS this individual would be killed as a result of any of these happening. +## What to do in such a case with SDA in PEcAn is not immediately clear. + + +#' LPJ-GUESS allometry +#' +#' +#' +#' +#' @keywords internal +#' + +###########################################/ +# ALLOMETRY +# Should be called to update allometry, FPC and FPC increment whenever biomass values +# for a vegetation individual change. +allometry <- function( + # initial allometry/pools + lifeform = "TREE", + cmass_leaf, + cmass_sap, + cmass_heart, + densindiv, + age, + fpc, + deltafpc, + # parameter values + sla, + k_latosa, + k_rp, + k_allom1, + k_allom2, + k_allom3, + wooddens, + crownarea_max) { + + # DESCRIPTION + # Calculates tree allometry (height and crown area) and fractional projective + # given carbon biomass in various compartments for an individual. + + # Returns true if the allometry is normal, otherwise false - guess2008 + + # TREE ALLOMETRY + # Trees aboveground allometry is modelled by a cylindrical stem comprising an + # inner cylinder of heartwood surrounded by a zone of sapwood of constant radius, + # and a crown (i.e. foliage) cylinder of known diameter. Sapwood and heartwood are + # assumed to have the same, constant, density (wooddens). Tree height is related + # to sapwood cross-sectional area by the relation: + # (1) height = cmass_sap / (sapwood xs area) + # Sapwood cross-sectional area is also assumed to be a constant proportion of + # total leaf area (following the "pipe model"; Shinozaki et al. 1964a,b; Waring + # et al 1982), i.e. + # (2) (leaf area) = k_latosa * (sapwood xs area) + # Leaf area is related to leaf biomass by specific leaf area: + # (3) (leaf area) = sla * cmass_leaf + # From (1), (2), (3), + # (4) height = cmass_sap / wooddens / sla / cmass_leaf * k_latosa + # Tree height is related to stem diameter by the relation (Huang et al 1992) + # [** = raised to the power of]: + # (5) height = k_allom2 * diam ** k_allom3 + # Crown area may be derived from stem diameter by the relation (Zeide 1993): + # (6) crownarea = min ( k_allom1 * diam ** k_rp , crownarea_max ) + # Bole height (individual/cohort mode only; currently set to 0): + # (7) boleht = 0 + + # FOLIAR PROJECTIVE COVER (FPC) + # The same formulation for FPC (Eqn 8 below) is now applied in all vegetation + # modes (Ben Smith 2002-07-23). FPC is equivalent to fractional patch/grid cell + # coverage for the purposes of canopy exchange calculations and, in population + # mode, vegetation dynamics calculations. + # + # FPC on the modelled area (stand, patch, "grid-cell") basis is related to mean + # individual leaf area index (LAI) by the Lambert-Beer law (Monsi & Saeki 1953, + # Prentice et al 1993) based on the assumption that success of a PFT population + # in competition for space will be proportional to competitive ability for light + # in the vertical profile of the forest canopy: + # (8) fpc = crownarea * densindiv * ( 1.0 - exp ( -0.5 * lai_ind ) ) + # where + # (9) lai_ind = cmass_leaf/densindiv * sla / crownarea + # + # For grasses, + # (10) fpc = ( 1.0 - exp ( -0.5 * lai_ind ) ) + # (11) lai_ind = cmass_leaf * sla + + diam = 0.0 # stem diameter (m) + fpc_new = 0.0 # updated FPC + + # guess2008 - max tree height allowed (metre). + HEIGHT_MAX = 150.0 + + + # MF - added for providing the error code + error.string <- "OK" + + if (lifeform == "TREE") { + + # TREES + + # Height (Eqn 4) + + # guess2008 - new allometry check + if (!negligible(cmass_leaf)) { + + height = cmass_sap / cmass_leaf / sla * k_latosa / wooddens + + # Stem diameter (Eqn 5) + #diam = pow(height / k_allom2, 1.0 / k_allom3) + diam = (height / k_allom2) ^ (1.0 / k_allom3) + + # Stem volume + vol = height * pi * diam * diam * 0.25 + + if (age > 0 & (cmass_heart + cmass_sap) / densindiv / vol < wooddens * 0.9) { + error.string <- "LowWoodDensity" + } + } + else { + height = 0.0 + diam = 0.0 + error.string <- "NegligibleLeafMass" + } + + + # guess2008 - extra height check + if (height > HEIGHT_MAX) { + height = 0.0 + diam = 0.0 + error.string <- "MaxHeightExceeded" + } + + + # Crown area (Eqn 6) + crownarea = min(k_allom1 * (diam ^ k_rp), crownarea_max) + + if (!negligible(crownarea)) { + + # Individual LAI (Eqn 9) + lai_indiv = cmass_leaf / densindiv * sla / crownarea + + # FPC (Eqn 8) + + fpc_new = crownarea * densindiv * + (1.0 - lambertbeer(lai_indiv)) + + # Increment deltafpc + deltafpc = deltafpc + fpc_new - fpc + fpc = fpc_new + } + else { + lai_indiv = 0.0 + fpc = 0.0 + } + + # Bole height (Eqn 7) + boleht = 0.0 + + # Stand-level LAI + lai = cmass_leaf * sla + } + + # + else if (lifeform == "GRASS") { + + # GRASSES + + # MF ignore land cover + #if(indiv.pft.landcover != CROPLAND) { + + # guess2008 - bugfix - added if + if (!negligible(cmass_leaf)) { + + # Grass "individual" LAI (Eqn 11) + lai_indiv = cmass_leaf * sla + + # FPC (Eqn 10) + fpc = 1.0 - lambertbeer(lai_indiv) + + # Stand-level LAI + lai = lai_indiv + + # MF extra returns not normally defined for grasses but needed for the return list below + vol =0 + height = 0 + diam = 0 + crownarea = 0 + deltafpc = 0 + boleht = 0 + + } + else { + error.string <- "NegligibleLeafMass" + } + } + # MF ignore land cover + #else { + + # True crops use cmass_leaf_max, cover-crop grass uses lai of stands with whole-year grass growth + #allometry_crop(indiv) + #} + #} + + # guess2008 - new return value (was void) + # MF: return a list of the updated allometric state of this individual + # this should be manually copied into the representation of the LPJ-GUESS state + return( + list( + error.string = error.string, + vol = vol, + height = height, + diam =diam, + crownarea = crownarea, + lai_indiv = lai_indiv, + lai = lai, + deltafpc = deltafpc, + fpc = fpc, + boleht = boleht) + ) + +} + diff --git a/models/lpjguess/R/calculateGridcellVariablePerPFT.LPJGUESS.R b/models/lpjguess/R/calculateGridcellVariablePerPFT.LPJGUESS.R new file mode 100644 index 00000000000..063020a80f7 --- /dev/null +++ b/models/lpjguess/R/calculateGridcellVariablePerPFT.LPJGUESS.R @@ -0,0 +1,90 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2012 University of Illinois, NCSA. +# All rights reserved. This program and the accompanying materials +# are made available under the terms of the +# University of Illinois/NCSA Open Source License +# which accompanies this distribution, and is available at +# http://opensource.ncsa.illinois.edu/license.html +#------------------------------------------------------------------------------- + + +#' @title calculateGridcellVariablePerPFT +#' +#' @description Calculates a per-PFT, gridcell-summed quantity from the LPJ-GUESS state, correctly averaging over patches. +#' This should be put into the SDA procedure. +#' +#' +#' @param model.state A large multiply-nested list containing the entire LPJ-GUESS state as read by +#' function \code{readStateBinary.LPJGUESS} +#' @param variable A character string specifying what variable to extract. This can be chosen based on the LPJ-GUESS variable name +#' as recorded in the big list of list (that represents describes the model state in R). Once special case is "biomass" which +#' returns the sum of "cmass_leaf", "cmass_root", "cmass_sap" and "cmass_heart" +#' @return A numeric vector, with one entry per PFT +#' @export +#' @author Matthew Forrest +calculateGridcellVariablePerPFT <- function(model.state, variable) { + + # nstands - should always be 1 but lets make sure + nstands <- unlist(model.state$nstands) + if(nstands != 1) warning("More than one Stand found in LPJ-GUESS state. This possibly implies that land use has been enabled + which the PEcAn code might not be robust against.") + + # + for(stand.counter in 1:nstands) { + + # get the number of patches for weighting across patches + npatches <- model.state$Stand[[stand.counter]]$npatches + + # get list of all the PFTs included in this stand + active.PFTs <- c() + for(stand.pft.id in 1:length(model.state$Stand[[stand.counter]]$Standpft$active)) { + if(model.state$Stand[[stand.counter]]$Standpft$active[[stand.pft.id]]) active.PFTs <- append(active.PFTs, stand.pft.id -1) + } + + + # arrays to store the aggregated gridcell level properties + gc.sum <- numeric(length(model.state$Stand[[stand.counter]]$Standpft$active)) + + + # loop through each patch + for(patch.counter in 1:npatches) { + + this.patch <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]] + + # pull out the number of individuals and a list of them + nindividuals <- this.patch$Vegetation$number_of_individuals + all.individuals <- this.patch$Vegetation$Individuals + + # for each individual + for(individual.counter in 1:length(all.individuals)) { + this.individual <- all.individuals[[individual.counter]] + + if(this.individual$alive) { + + this.pft.id <- this.individual$indiv.pft.id + + if(!this.pft.id %in% active.PFTs) stop(paste0("Found individual of PFT id = ",this.pft.id, + " but this doesn't seem to be active in the LPJ-GUESS run")) + # calculate the total cmass and density of individuals per PFT + if(variable == "biomass") { + gc.sum[this.pft.id+1] <- gc.sum[this.pft.id+1] + ((this.individual$cmass_leaf+this.individual$cmass_root+ + this.individual$cmass_heart+this.individual$cmass_sap)/npatches) + } + else gc.sum[this.pft.id+1] <- gc.sum[this.pft.id+1] + (this.individual[[variable]]/npatches) + + } + + } + + + + } + + + return(gc.sum) + + } + +} + + diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index 2b8d8e4ca86..b24f5e94a58 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -1,863 +1,863 @@ -library(stringr) - -# this fcn is for potential natural vegetation only -# when there is landcover, there will be more stand types - -# also for cohort mode only - -# Gridcell: Top-level object containing all dynamic and static data for a particular gridcell -# Gridcellpft: Object containing data common to all individuals of a particular PFT in a particular gridcell -# Gridcellst : Object containing data common to all stands of a particular stand type (ST) in a particular gridcell -# Climate : Contains all static and dynamic data relating to the overall environmental properties, other than soil properties, of a gridcell -# Soiltype : Stores soil static parameters. One object of class Soiltype is defined for each gridcell. -# Stand : Object containing all dynamic and static data for a particular stand -# Patch : Stores data specific to a patch. In cohort and individual modes, replicate patches are required in each stand to accommodate stochastic variation across the site. -# Patchpft : Object containing data common to all individuals of a particular PFT in a particular patch, including litter pools. -# Vegetation : A dynamic list of Individual objects, representing the vegetation of a particular patch -# Soil : Stores state variables for soils and the snow pack. One object of class Soil is defined for each patch. -# Fluxes : The Fluxes class stores accumulated monthly and annual fluxes. One object of type Fluxes is defined for each patch. -# Individual : Stores state variables for an average individual plant. In cohort mode, it is the average individual of a cohort of plants approximately the same age and from the same patch. - -# maybe put guess.h and guess.cpp for each model version into the model package -guesscpp_loc <- "/fs/data5/pecan.models/LPJ-GUESS/framework/guess.cpp" -guessh_loc <- "/fs/data5/pecan.models/LPJ-GUESS/framework/guess.h" -paramh_loc <- "/fs/data5/pecan.models/LPJ-GUESS/framework/parameters.h" - -# guess.cpp has the info of what is being written -guesscpp_in <- readLines(guesscpp_loc) -# guess.h has the types so that we know what streamsize to read -guessh_in <- readLines(guessh_loc) -# parameters.h has some more types -paramh_in <- readLines(paramh_loc) - -############ open - -# test path -out.path = "/fs/data2/output/PEcAn_1000002393/out/1000458390" -setwd(out.path) - -# open connection to the binary state file -zz <- file("0.state", "rb") - -### these are the values read from params.ins, passed to this fcn -n_pft <- 11 -npatches <- 5 - -################################ check class compatibility ################################ -# between model versions we don't expect major classes or hierarchy to change -# but give check and fail if necessary -LPJ_GUESS_CLASSES <- c("Gridcell", "Climate", "Gridcellpft", "Stand", "Standpft", "Patch", "Patchpft", - "Individual", "Soil", "Sompool", "Fluxes", "Vegetation") - -lpjguess_classes <- list() -ctr <- 1 -# NOTE THAT THESE PATTERNS ASSUME SOME CODING STYLE, thanks to LPJ-GUESS developers this might not be an issue in the future -for(i in seq_along(guessh_in)){ - # search for "class XXX : public Serializable {" - res <- str_match(guessh_in[i], "class (.*?) : public Serializable") - if(is.na(res[,2])){ - # try "class XXX : public ..., public Serializable {" pattern - res <- str_match(guessh_in[i], "class (.*?) : public .* Serializable") - } - if(!is.na(res[,2])){ - lpjguess_classes[[ctr]] <- res[,2] - ctr <- ctr + 1 - } -} - -# all match? -if(!setequal(unlist(lpjguess_classes), LPJ_GUESS_CLASSES)){ - PEcAn.logger::logger.severe("This function can only read the following class objects: ", paste(LPJ_GUESS_CLASSES, collapse="--")) -} - -# there are couple of LPJ-GUESS specific types that we'll need below -lpjguess_types <- list() -ctr <- 1 -for(i in seq_along(guessh_in)){ - if(grepl("typedef enum {", guessh_in[i], fixed = TRUE)){ - this_line <- find_closing("}", i, guessh_in) - l_type <- gsub(".*}(.*?);.*", "\\1", guessh_in[this_line]) - l_type <- gsub(" ", "", l_type) - lpjguess_types[[ctr]] <- l_type - ctr <- ctr + 1 - } -} -for(i in seq_along(paramh_in)){ #do same for parameters.h - if(grepl("typedef enum {", paramh_in[i], fixed = TRUE)){ - this_line <- find_closing("}", i, paramh_in) - l_type <- gsub(".*}(.*?);.*", "\\1", paramh_in[this_line]) - l_type <- gsub(" ", "", l_type) - lpjguess_types[[ctr]] <- l_type - ctr <- ctr + 1 - } -} -LPJ_GUESS_TYPES <- unlist(lpjguess_types) - - -lpjguess_consts <- list() -ctr <- 1 -for(i in seq_along(guessh_in)){ - if(grepl("const int ", guessh_in[i], fixed = TRUE)){ # probably won't need "const double"s - cnst_val <- gsub(".*=(.*?);.*", "\\1", guessh_in[i]) - cnst_val <- gsub(" ", "", cnst_val) # get rid of the space if there is one - cnst_nam <- gsub(".*int(.*?)=.*", "\\1", guessh_in[i]) - cnst_nam <- gsub(" ", "", cnst_nam) - lpjguess_consts[[ctr]] <- cnst_val - names(lpjguess_consts)[ctr] <- cnst_nam - ctr <- ctr + 1 - } -} -# few cleaning -dont_need <- c("COLDEST_DAY_NHEMISPHERE", "COLDEST_DAY_SHEMISPHERE", "WARMEST_DAY_NHEMISPHERE", "WARMEST_DAY_SHEMISPHERE", "data[]") -lpjguess_consts[match(dont_need, names(lpjguess_consts))] <- NULL -# this probably needs to be extracted from parameters.h:48-49 or somewhere else, but hardcoding for now -lpjguess_consts$NLANDCOVERTYPES <- 6 -# this probably needs to be extracted from parameters.h:94 , but hardcoding for now -lpjguess_consts$NSOMPOOL <- 12 -LPJ_GUESS_CONST_INTS <- data.frame(var = names(lpjguess_consts), val = as.numeric(unlist(lpjguess_consts)), stringsAsFactors = FALSE) - - -# Gridcell is the top-level container, start parsing from there -beg_end <- serialize_starts_ends(file_in = guesscpp_in, pattern = "void Gridcell::serialize") - -# now we will parse the stuff between these lines -# first find what is being written -streamed_vars_gridcell <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - -################################## CAUTION : THE FOLLOWING IS A MONSTROUS NESTED-LOOP ################################## - -# Now I can use streamed_vars_gridcell to loop over them -# We read everything in this loop, Gridcell list is going to be the top container -# there will be nested loops, the hierarchy will follow LPJ-GUESS architecture -Gridcell <- list() -level <- "Gridcell" -#for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts -for(g_i in 1:8){ - current_stream <- streamed_vars_gridcell[g_i] - if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard - if(grepl(glob2rx("(*this)[*].landcover"), current_stream)){ # s counter might change, using wildcard - # not sure how to handle this better. If we see this, it means we are now looping over Stands - # this function considers "NATURAL" vegetation only, so there is only one stand - # this is an integer that tells us which landcover type this stand is - # so it should be the indice of NATURAL in typedef enum landcovertype (I believe indexing starts from 0) - - num_stnd <- as.numeric(Gridcell$nstands) - Gridcell[["Stand"]] <- vector("list", num_stnd) - - # note that this is streamed under Gridcell, not Stand in guess.cpp, - # but I think this info needs to go together with the Stand sublist - # so prepend landcovertype to the streamed_vars_stand - - next - } - - # "(*this)[*]" points to different things under different levels, here it is stand - if(grepl(glob2rx("(*this)[*]"), current_stream)){ # note that first else-part will be evaluated considering the order in guess.cpp - - # STAND - level <- "Stand" - current_stream <- "Stand" - current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void ", - tools::toTitleCase(current_stream_type$name), - "::serialize")) - streamed_vars_stand <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - streamed_vars_stand <- c("landcover", streamed_vars_stand) # prepending landcovertype to the streamed_vars_stand - - - for(stnd_i in seq_len(num_stnd)){ #looping over the stands - for(svs_i in 1:3){#seq_along(streamed_vars_stand)){ # looping over the streamed stand vars - - current_stream <- streamed_vars_stand[svs_i] - if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard - - if(current_stream == "nobj" & level == "Stand"){ - # nobj points to different things under different levels, here it is the number of patches - # number of patches is set through insfiles, read by write.configs and passed to this fcn - # but it's also written to the state file, need to move bytes - nofpatch <- readBin(zz, integer(), 1, size = 4) - if(npatches == nofpatch){ # also not a bad place to check if everything is going fine so far - Gridcell[["Stand"]][[stnd_i]]$npatches <- npatches - #Gridcell[["Stand"]] <- vector("list", npatches) - }else{ - PEcAn.logger::logger.severe("The number of patches set through the instruction file does not match the number read from the state files. Probably a bug in the read.state function! Terminating.") - } - next - } - - # "(*this)[*]" points to different things under different levels, here it is patch - if(grepl(glob2rx("(*this)[*]"), current_stream)){ - # PATCH - level <- "Patch" - current_stream <- "Patch" - current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void ", - tools::toTitleCase(current_stream_type$name), - "::serialize")) - streamed_vars_patch <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - - Gridcell[["Stand"]][[stnd_i]][["Patch"]] <- vector("list", npatches) - - for(ptch_i in seq_len(npatches)){ #looping over the patches - for(svp_i in 1:3){#seq_along(streamed_vars_patch)){ #looping over the streamed patch vars - current_stream <- streamed_vars_patch[svp_i] - if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard - - current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[length(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])+1]] <- list() - names(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])[length(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])] <- current_stream_type$name - - if(current_stream_type$type == "class"){ - - # CLASS - class_name <- current_stream_type$name - - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void ", - tools::toTitleCase(current_stream_type$name), - "::serialize")) - - - if(class_name == "vegetation"){ - # VEGETATION - # Vegetation class has a bit of a different structure, it has one more depth, see model documentation - streamed_vars_veg <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - - # NOTE : Unlike other parts, this bit is a lot less generalized!!! - # I'm gonna asumme Vegetation class won't change much in the future - # indiv.pft.id and indiv needs to be looped over nobj times - if(!setequal(streamed_vars_veg, c("nobj", "indiv.pft.id", "indiv"))){ - PEcAn.logger::logger.severe("Vegetation class object changed in this model version, you need to fix read.state") - } - - # nobj points to different things under different levels, here it is the number of individuals - number_of_individuals <- readBin(zz, integer(), 1, size = 4) - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["number_of_individuals"]] <- number_of_individuals - - # few checks for sensible vals - if(number_of_individuals < 1 | number_of_individuals > 10000){ # should there be an upper limit here too? - # if number of individuals is 0 it's a bit suspicious. Not sure if ever will get negative but that'd definitely be wrong - PEcAn.logger::logger.warn("Number of individuals under vegetation is", number_of_individuals) - } - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["Individuals"]] <- vector("list", number_of_individuals) - - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void Individual::serialize")) - streamed_vars_indv <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - - # loop over nobj - for(indv_i in seq_len(number_of_individuals)){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["Individuals"]][[indv_i]] <- list() - # which PFT is this? - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["Individuals"]][[indv_i]][["indiv.pft.id"]] <- readBin(zz, integer(), 1, size = 4) - # read all the individual class - for(svi_i in seq_along(streamed_vars_indv)){ # - current_stream <- streamed_vars_indv[svi_i] - - current_stream_type <- find_stream_type("individual", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - - if(current_stream_specs$single){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["Individuals"]][[indv_i]][[current_stream_type$name]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ - for(css.i in seq_along(current_stream_specs$what)){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["Individuals"]][[indv_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, - what = current_stream_specs$what[css.i], - n = current_stream_specs$n[css.i], - size = current_stream_specs$size[css.i]) - } - } - - }# end loop over stream vars individual - } # end loop over number_of_individuals - - - - - - }else{ - # NOT VEGETATION - streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) - - for(varname in streamed_vars){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[current_stream_type$name]][[varname]] <- vector("list", num_pft) - } - - # maybe try modifying this bit later to make it a function - for(pft_i in seq_len(num_pft)){ - for(sv_i in seq_along(streamed_vars)){ - current_stream <- streamed_vars[sv_i] #it's OK to overwrite - current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - - if(current_stream_type$type == "class"){ - - if(current_stream_type$name != "sompool"){ - PEcAn.logger::logger.debug("Classes other than sompool enter here.") - } - # ONLY SOMPOOL HERE SO FAR ****************************************************************** - #class_name <- # don't overwrite class_name - - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void ", - tools::toTitleCase(current_stream_type$name), - "::serialize")) - streamed_vars_sompool <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - - nsompool <- LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var == "NSOMPOOL"] - - for(varname in streamed_vars_sompool){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["soil"]][["sompool"]][[varname]] <- vector("list", nsompool) - } - - ###################### LOOP OVER NSOMPOOL - for(som_i in seq_len(nsompool)){ - for(sv_sompool_i in seq_along(streamed_vars_sompool)){ - current_stream <- streamed_vars_sompool[sv_sompool_i] - - current_stream_type <- find_stream_type(current_stream_type$name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - - if(current_stream_specs$single){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["soil"]][["sompool"]][[current_stream_type$name]][[som_i]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ - PEcAn.logger::logger.debug("Historic under sompool.") - } - } - } - - }else{ - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - # and read! - if(current_stream_specs$single){ # maybe use current_stream in sublist names to find correct place - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[length( Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ # only for historic type? - for(css.i in seq_along(current_stream_specs$what)){ # maybe use current_stream in sublist names to find correct place - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[length( Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, - what = current_stream_specs$what[css.i], - n = current_stream_specs$n[css.i], - size = current_stream_specs$size[css.i]) - } - } - } - } # streamed_vars-loop ends - } # pft-loop ends - } - - - }else{ - # NOT CLASS - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - # and read! - if(current_stream_specs$single){ - Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ # probably don't need this but let's keep - for(css_i in seq_along(current_stream_specs$what)){ - Gridcell[[length(Gridcell)]][[current_stream_specs$names[css_i]]] <- readBin(con = zz, - what = current_stream_specs$what[css_i], - n = current_stream_specs$n[css_i], - size = current_stream_specs$size[css_i]) - } - } - }# end if-class within Patch - } - } - - }else{ - # NOT PATCH - - current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - - Gridcell[["Stand"]][[stnd_i]][[length(Gridcell[["Stand"]][[stnd_i]])+1]] <- list() - names(Gridcell[["Stand"]][[stnd_i]])[length(Gridcell[["Stand"]][[stnd_i]])] <- current_stream_type$name - - if(current_stream_type$type == "class"){ - - # CLASS - class_name <- current_stream_type$name - - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void ", - tools::toTitleCase(current_stream_type$name), - "::serialize")) - streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) - - for(varname in streamed_vars){ - Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]][[varname]] <- varname - Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]][[varname]] <- vector("list", num_pft) - } - - for(pft_i in seq_len(num_pft)){ - for(sv_i in seq_along(streamed_vars)){ - current_stream <- streamed_vars[sv_i] #it's OK to overwrite - current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - - if(current_stream_type$type == "class"){ - - # CLASS, NOT EVER GOING HERE? - class_name <- current_stream_type$name - - }else{ - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - # and read! - if(current_stream_specs$single){ - Gridcell[["Stand"]][[stnd_i]][[length(Gridcell[["Stand"]][[stnd_i]])]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ - for(css.i in seq_along(current_stream_specs$what)){ - Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, - what = current_stream_specs$what[css.i], - n = current_stream_specs$n[css.i], - size = current_stream_specs$size[css.i]) - } - } - } - } # streamed_vars-loop ends - } # pft-loop ends - - }else{ - # NOT CLASS - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - # and read! - if(current_stream_specs$single){ - Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ # probably don't need this but let's keep - for(css_i in seq_along(current_stream_specs$what)){ - Gridcell[[length(Gridcell)]][[current_stream_specs$names[css_i]]] <- readBin(con = zz, - what = current_stream_specs$what[css_i], - n = current_stream_specs$n[css_i], - size = current_stream_specs$size[css_i]) - } - } - }# end if-class within Stand - } # end patch-if - - - }# end for-loop over the streamed stand vars (svs_i, L.165) - }# end for-loop over the stands (stnd_i, L.164) - - }else{ #not reading in Stand variables - - # NOT STAND - - current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - - Gridcell[[length(Gridcell)+1]] <- list() - names(Gridcell)[length(Gridcell)] <- current_stream_type$name - if(current_stream_type$type == "class"){ - - # CLASS - class_name <- current_stream_type$name - - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void ", - tools::toTitleCase(current_stream_type$name), - "::serialize")) - streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) - - for(varname in streamed_vars){ - Gridcell[[length(Gridcell)]][[varname]] <- varname - Gridcell[[length(Gridcell)]][[varname]] <- vector("list", num_pft) - } - - for(pft_i in seq_len(num_pft)){ - for(sv_i in seq_along(streamed_vars)){ - #for(sv_i in 21:37){ - current_stream <- streamed_vars[sv_i] #it's OK to overwrite - current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - - if(current_stream_type$type == "class"){ - - # CLASS, NOT EVER GOING HERE? - class_name <- current_stream_type$name - - }else{ - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - # and read! - if(current_stream_specs$single){ - Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ - for(css.i in seq_along(current_stream_specs$what)){ - Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, - what = current_stream_specs$what[css.i], - n = current_stream_specs$n[css.i], - size = current_stream_specs$size[css.i]) - } - } - } - } # streamed_vars-loop ends - } # pft-loop ends - - }else{ - # NOT CLASS - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - # and read! - if(current_stream_specs$single){ - Gridcell[[length(Gridcell)]][[current_stream_type$name]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ # probably don't need this but let's keep - for(css_i in seq_along(current_stream_specs$what)){ - Gridcell[[length(Gridcell)]][[current_stream_specs$names[css_i]]] <- readBin(con = zz, - what = current_stream_specs$what[css_i], - n = current_stream_specs$n[css_i], - size = current_stream_specs$size[css_i]) - } - } - }# end if-class within Gridcell - - } # Stand if-else ends -} # Gridcell-loop ends - -# helper function that determines the stream size to read -find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS){ - - possible_types <- c("double ", "bool ", "int " , "long ") # space because these can be part of other words - possible_types <- c(possible_types, LPJ_GUESS_TYPES) - n_sizes <- c(8, 1, 4, 8, rep(4, length(LPJ_GUESS_TYPES) )) - rbin_tbl <- c("double", "logical", "integer", "integer", rep("integer", length(LPJ_GUESS_TYPES))) - - specs <- list() - - sub_string <- current_stream_type$substring - - #is there a ; immediately after? - if(grepl(paste0(current_stream_type$type, " ", current_stream_type$name, ";"), sub_string, fixed = TRUE) | - grepl(paste0(current_stream_type$type, " ", current_stream_type$name, ","), sub_string, fixed = TRUE)){ # e.g. "double alag, exp_alag;" - # this is only length 1 - specs$n <- 1 - specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$single <- TRUE - - }else if(current_stream_type$type == "Historic"){ - possible_types <- c("double", "bool", "int" , "long") # # I haven't seen any Historic that doesn't store double but... historic has a comma after type: double, - possible_types <- c(possible_types, LPJ_GUESS_TYPES) - - # Historic types are special to LPJ-GUESS - # They have stored values, current index, and a boolean in that order - specs$n <- specs$what <- specs$size <- specs$names <- rep(NA, 3) - # always three, this is a type defined in guessmath.h - specs$what[1] <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$size[1] <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$names[1] <- current_stream_type$name - # n is tricky, it can be hardcoded it can be one of the const ints - to_read <- str_match(sub_string, paste0("Historic<", specs$what[1], ", (.*?)>.*"))[,2] - if(to_read %in% LPJ_GUESS_CONST_INTS$var){ - specs$n <- LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var == to_read] - }else{ - specs$n[1] <- as.numeric(to_read) - } - specs$what[2] <- "integer" #need to check what size_t is - specs$size[2] <- 8 - specs$n[2] <- 1 - specs$names[2] <- "current_index" - - specs$what[3] <- "logical" - specs$size[3] <- 1 - specs$n[3] <- 1 - specs$names[3] <- "full" - - specs$single <- FALSE - - }else if(current_stream_type$type == "struct"){ - if(current_stream_type$name != "solvesom"){ - PEcAn.logger::logger.debug("Another struct type.") - } - #for now hardcoding this will be back - specs$n <- specs$what <- specs$size <- specs$names <- rep(NA, 2) - specs$what[1] <- "double" - specs$size[1] <- 8 - specs$names[1] <- "clitter" - specs$n[1] <- 12 #NSOMPOOL - - specs$what[2] <- "double" - specs$size[2] <- 8 - specs$names[2] <- "nlitter" - specs$n[2] <- 12 #NSOMPOOL - - specs$single <- FALSE - - }else if(grepl(glob2rx(paste0(current_stream_type$type, "*", current_stream_type$name, ";")), sub_string)){ - - # this is only length 1 - specs$n <- 1 - specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$single <- TRUE - - }else if(length(regmatches(sub_string, gregexpr("\\[.+?\\]", sub_string))[[1]]) > 1){ - #looks like we have a matrix - spec_dims <- regmatches(sub_string, gregexpr("\\[.+?\\]", sub_string))[[1]] - spec_dims <- gsub("\\].*", "", gsub(".*\\[", "", spec_dims)) - for(spec_dims_i in seq_along(spec_dims)){ - if(any(sapply(LPJ_GUESS_CONST_INTS$var, grepl, spec_dims[spec_dims_i], fixed = TRUE))){ # uses one of the constant ints - spec_dims[spec_dims_i] <- LPJ_GUESS_CONST_INTS$val[sapply(LPJ_GUESS_CONST_INTS$var, grepl, spec_dims[spec_dims_i], fixed = TRUE)] - }else{ - spec_dims[spec_dims_i] <- as.numeric(sub(".*\\[(.*)\\].*", "\\1", spec_dims[spec_dims_i], perl=TRUE)) - } - } - spec_dims <- as.numeric(spec_dims) - - specs$n <- prod(spec_dims) - specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$single <- TRUE - }else{ - # reading a vector - specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - if(any(sapply(LPJ_GUESS_CONST_INTS$var, grepl, sub_string, fixed = TRUE))){ # uses one of the constant ints - specs$n <- LPJ_GUESS_CONST_INTS$val[sapply(LPJ_GUESS_CONST_INTS$var, grepl, sub_string, fixed = TRUE)] - }else{ - specs$n <- as.numeric(sub(".*\\[(.*)\\].*", "\\1", sub_string, perl=TRUE)) - } - - specs$single <- TRUE - } - - return(specs) -} # find_stream_size - - -# helper function to decide the type of the stream -# this function relies on the architecture of LPJ-GUESS and has bunch of harcoded checks, see model documentation -find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in){ - - if(current_stream_var == "seed"){ # a bit of a special case - return(list(type = "long", name = "seed", substring = "long seed;")) - } - - if(current_stream_var == "nstands"){ # a bit of a special case, it is read by guess.cpp - return(list(type = "int", name = "nstands", substring = "int nstands;")) #there is not substring like that in guess.h - } - - if(current_stream_var == "landcover"){ # a bit of a special case - return(list(type = "landcovertype", name = "landcover", substring = "landcovertype landcover;")) - } - - # it might be difficult to extract the "type" before the varname - # there are not that many to check - possible_types <- c("class ", "double ", "bool ", "int ") - - possible_types <- c(possible_types, LPJ_GUESS_TYPES) - - beg_end <- NULL # not going to need it always - - # class or not? - if(tools::toTitleCase(current_stream_var) %in% LPJ_GUESS_CLASSES){ - stream_type <- "class" - stream_name <- current_stream_var - sub_string <- NULL - }else {# find type from guess.h - - if(is.null(class)){ - sub_string <- guessh_in[grepl(paste0(" ", current_stream_var), guessh_in, fixed = TRUE)] - }else{ - beg_end <- serialize_starts_ends(file_in = guessh_in, - pattern = paste0("class ", - tools::toTitleCase(class), - " : public ")) - # subset - sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var, ";"), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] - } - - if(length(sub_string) == 0){ - sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] - } - # e.g. "sompool[i]" in guess.cpp, Sompool sompool[NSOMPOOL]; in guess.h - if(length(sub_string) == 0){ - current_stream_var <- gsub("\\[|.\\]", "", current_stream_var) - sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] - if(tools::toTitleCase(current_stream_var) %in% LPJ_GUESS_CLASSES){ - stream_type <- "class" - stream_name <- current_stream_var - sub_string <- NULL - return(list(type = gsub(" ", "", stream_type), name = stream_name, substring = sub_string)) - } - } - if(length(sub_string) == 0){ - sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(",", current_stream_var), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] - } - if(length(sub_string) > 1){ - # some varnames are very common characters unfortunately like u, v... check if [] comes after - if(any(grepl(paste0(" ", current_stream_var, "["), sub_string, fixed = TRUE))){ - sub_string <- sub_string[grepl(paste0(" ", current_stream_var, "["), sub_string, fixed = TRUE)] - }else if(any(grepl(paste0("double ", current_stream_var), sub_string, fixed = TRUE))){ # just fishing, double is the most common type - sub_string <- sub_string[grepl(paste0("double ", current_stream_var), sub_string, fixed = TRUE)] - }else{ - PEcAn.logger::logger.severe("Check this out.") - } - } - - # clean from tabs - sub_string <- gsub("\t", "", sub_string) - # clean from commented out lines? - - if(grepl("Historic", sub_string, fixed = TRUE)){ - # Historic types has the form Historic& data) - stream_type <- "Historic" - stream_name <- current_stream_var - }else if(grepl("std::vector", sub_string, fixed = TRUE)){ - stream_type <- "struct" - stream_name <- current_stream_var - }else{ - stream_type <- possible_types[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - stream_name <- current_stream_var - } - - } - - return(list(type = gsub(" ", "", stream_type), name = stream_name, substring = sub_string)) -} # find_stream_type - - - - -######################## Helper functions ######################## - -# helper function that lists streamed variables, it just returns the names, types are checked by other fucntion -find_stream_var <- function(file_in, line_nos){ - - streaming_list <- list() - str.i <- 1 - when_here <- NULL - not_skipping <- TRUE - - i <- line_nos[1] - repeat{ - i <- i + 1 - if(!is.null(when_here)){ - if(i == when_here){ - i <- skip_to - when_here <- NULL - } - } - - # some functions (Vegetation, Patch, Stand, Gridcell) have two modes: saving / reading - # we only need the stream that is saved - if(grepl("arch.save()", file_in[i])){ - when_here <- find_closing("}", i, file_in) - skip_to <- find_closing("}", i, file_in, if_else_check = TRUE) - } - - # all streams start with arch & - if(grepl("arch & ", file_in[i])){ - # get variable name - streaming_list[[str.i]] <- sub(".*arch & ", "", file_in[i]) # always one var after arch? - str.i <- str.i + 1 - # check for ampersand for the subsequent variable names - repeat{ - i <- i + 1 - if(!is.null(when_here)){ - if(i == when_here){ - i <- skip_to - when_here <- NULL - } - } - check1 <- !grepl(".*& ", file_in[i]) # when there are no subsequent stream - check2 <- !grepl(".*& ", file_in[i+1]) # sometimes following line is empty or commented, check the next one too - if(check1 & !check2) i <- i+1 - if(check1 & check2) break # looks like there are no subsequent stream - this_line <- gsub("[[:space:]]", "", strsplit(file_in[i], "& ")[[1]]) - for(var in this_line){ - if(var != ""){ - if(var != "arch"){ - streaming_list[[str.i]] <- var - str.i <- str.i + 1 - } - } - } - if(!is.null(when_here)){ # now that increased i check this just in case - if(i == when_here){ - i <- skip_to - when_here <- NULL - } - } - } - } - if(i == line_nos[2]) break - } - - #unlist and nix the ; - returnin_stream <- gsub(";", "", unlist(streaming_list), fixed = TRUE) - return(returnin_stream) -} # find_stream_var - - - -# helper function that scans LPJ-GUESS that returns the beginning and the ending lines of serialized object -serialize_starts_ends <- function(file_in, pattern = "void Gridcell::serialize"){ - # find the starting line from the given pattern - starting_line <- which(!is.na(str_match(file_in, pattern))) - if(length(starting_line) != 1){ # check what's going on - PEcAn.logger::logger.severe("Couldn't find the starting line with this pattern ***",pattern, "***.") - } - - # screen for the closing curly bracket after function started - # keep track of opening-closing brackets - ending_line <- find_closing(find = "}", starting_line, file_in) - - return(c(starting_line, ending_line)) -} # serialize_starts_ends - -# helper function that finds the closing bracket, can work over if-else -find_closing <- function(find = "}", line_no, file_in, if_else_check = FALSE){ - opened <- 1 - closed <- 0 - if(find == "}"){ - start_char <- "{" - end_char <- "}" - }else{ - #there can be else-ifs, find closing paranthesis / square breacket etc - } - - # check the immediate line and return if closed there already - if(grepl(end_char, file_in[line_no], fixed = TRUE)) return(line_no) - - repeat{ - line_no <- line_no + 1 - if(grepl(start_char, file_in[line_no], fixed = TRUE)) opened <- opened + 1 - if(grepl(end_char, file_in[line_no], fixed = TRUE)) closed <- closed + 1 - if(if_else_check){ - else_found <- FALSE - same_line_check <- grepl("else", file_in[line_no], fixed = TRUE) #same line - next_line_check <- grepl("else", file_in[line_no + 1], fixed = TRUE) #next line - if(same_line_check | next_line_check){ - closed <- closed - 1 - if(next_line_check) line_no <- line_no + 1 - } - } - if(opened == closed) break - } - return(line_no) -} # find_closing - +# library(stringr) +# +# # this fcn is for potential natural vegetation only +# # when there is landcover, there will be more stand types +# +# # also for cohort mode only +# +# # Gridcell: Top-level object containing all dynamic and static data for a particular gridcell +# # Gridcellpft: Object containing data common to all individuals of a particular PFT in a particular gridcell +# # Gridcellst : Object containing data common to all stands of a particular stand type (ST) in a particular gridcell +# # Climate : Contains all static and dynamic data relating to the overall environmental properties, other than soil properties, of a gridcell +# # Soiltype : Stores soil static parameters. One object of class Soiltype is defined for each gridcell. +# # Stand : Object containing all dynamic and static data for a particular stand +# # Patch : Stores data specific to a patch. In cohort and individual modes, replicate patches are required in each stand to accommodate stochastic variation across the site. +# # Patchpft : Object containing data common to all individuals of a particular PFT in a particular patch, including litter pools. +# # Vegetation : A dynamic list of Individual objects, representing the vegetation of a particular patch +# # Soil : Stores state variables for soils and the snow pack. One object of class Soil is defined for each patch. +# # Fluxes : The Fluxes class stores accumulated monthly and annual fluxes. One object of type Fluxes is defined for each patch. +# # Individual : Stores state variables for an average individual plant. In cohort mode, it is the average individual of a cohort of plants approximately the same age and from the same patch. +# +# # maybe put guess.h and guess.cpp for each model version into the model package +# guesscpp_loc <- "/fs/data5/pecan.models/LPJ-GUESS/framework/guess.cpp" +# guessh_loc <- "/fs/data5/pecan.models/LPJ-GUESS/framework/guess.h" +# paramh_loc <- "/fs/data5/pecan.models/LPJ-GUESS/framework/parameters.h" +# +# # guess.cpp has the info of what is being written +# guesscpp_in <- readLines(guesscpp_loc) +# # guess.h has the types so that we know what streamsize to read +# guessh_in <- readLines(guessh_loc) +# # parameters.h has some more types +# paramh_in <- readLines(paramh_loc) +# +# ############ open +# +# # test path +# out.path = "/fs/data2/output/PEcAn_1000002393/out/1000458390" +# setwd(out.path) +# +# # open connection to the binary state file +# zz <- file("0.state", "rb") +# +# ### these are the values read from params.ins, passed to this fcn +# n_pft <- 11 +# npatches <- 5 +# +# ################################ check class compatibility ################################ +# # between model versions we don't expect major classes or hierarchy to change +# # but give check and fail if necessary +# LPJ_GUESS_CLASSES <- c("Gridcell", "Climate", "Gridcellpft", "Stand", "Standpft", "Patch", "Patchpft", +# "Individual", "Soil", "Sompool", "Fluxes", "Vegetation") +# +# lpjguess_classes <- list() +# ctr <- 1 +# # NOTE THAT THESE PATTERNS ASSUME SOME CODING STYLE, thanks to LPJ-GUESS developers this might not be an issue in the future +# for(i in seq_along(guessh_in)){ +# # search for "class XXX : public Serializable {" +# res <- str_match(guessh_in[i], "class (.*?) : public Serializable") +# if(is.na(res[,2])){ +# # try "class XXX : public ..., public Serializable {" pattern +# res <- str_match(guessh_in[i], "class (.*?) : public .* Serializable") +# } +# if(!is.na(res[,2])){ +# lpjguess_classes[[ctr]] <- res[,2] +# ctr <- ctr + 1 +# } +# } +# +# # all match? +# if(!setequal(unlist(lpjguess_classes), LPJ_GUESS_CLASSES)){ +# PEcAn.logger::logger.severe("This function can only read the following class objects: ", paste(LPJ_GUESS_CLASSES, collapse="--")) +# } +# +# # there are couple of LPJ-GUESS specific types that we'll need below +# lpjguess_types <- list() +# ctr <- 1 +# for(i in seq_along(guessh_in)){ +# if(grepl("typedef enum {", guessh_in[i], fixed = TRUE)){ +# this_line <- find_closing("}", i, guessh_in) +# l_type <- gsub(".*}(.*?);.*", "\\1", guessh_in[this_line]) +# l_type <- gsub(" ", "", l_type) +# lpjguess_types[[ctr]] <- l_type +# ctr <- ctr + 1 +# } +# } +# for(i in seq_along(paramh_in)){ #do same for parameters.h +# if(grepl("typedef enum {", paramh_in[i], fixed = TRUE)){ +# this_line <- find_closing("}", i, paramh_in) +# l_type <- gsub(".*}(.*?);.*", "\\1", paramh_in[this_line]) +# l_type <- gsub(" ", "", l_type) +# lpjguess_types[[ctr]] <- l_type +# ctr <- ctr + 1 +# } +# } +# LPJ_GUESS_TYPES <- unlist(lpjguess_types) +# +# +# lpjguess_consts <- list() +# ctr <- 1 +# for(i in seq_along(guessh_in)){ +# if(grepl("const int ", guessh_in[i], fixed = TRUE)){ # probably won't need "const double"s +# cnst_val <- gsub(".*=(.*?);.*", "\\1", guessh_in[i]) +# cnst_val <- gsub(" ", "", cnst_val) # get rid of the space if there is one +# cnst_nam <- gsub(".*int(.*?)=.*", "\\1", guessh_in[i]) +# cnst_nam <- gsub(" ", "", cnst_nam) +# lpjguess_consts[[ctr]] <- cnst_val +# names(lpjguess_consts)[ctr] <- cnst_nam +# ctr <- ctr + 1 +# } +# } +# # few cleaning +# dont_need <- c("COLDEST_DAY_NHEMISPHERE", "COLDEST_DAY_SHEMISPHERE", "WARMEST_DAY_NHEMISPHERE", "WARMEST_DAY_SHEMISPHERE", "data[]") +# lpjguess_consts[match(dont_need, names(lpjguess_consts))] <- NULL +# # this probably needs to be extracted from parameters.h:48-49 or somewhere else, but hardcoding for now +# lpjguess_consts$NLANDCOVERTYPES <- 6 +# # this probably needs to be extracted from parameters.h:94 , but hardcoding for now +# lpjguess_consts$NSOMPOOL <- 12 +# LPJ_GUESS_CONST_INTS <- data.frame(var = names(lpjguess_consts), val = as.numeric(unlist(lpjguess_consts)), stringsAsFactors = FALSE) +# +# +# # Gridcell is the top-level container, start parsing from there +# beg_end <- serialize_starts_ends(file_in = guesscpp_in, pattern = "void Gridcell::serialize") +# +# # now we will parse the stuff between these lines +# # first find what is being written +# streamed_vars_gridcell <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) +# +# ################################## CAUTION : THE FOLLOWING IS A MONSTROUS NESTED-LOOP ################################## +# +# # Now I can use streamed_vars_gridcell to loop over them +# # We read everything in this loop, Gridcell list is going to be the top container +# # there will be nested loops, the hierarchy will follow LPJ-GUESS architecture +# Gridcell <- list() +# level <- "Gridcell" +# #for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts +# for(g_i in 1:8){ +# current_stream <- streamed_vars_gridcell[g_i] +# if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard +# if(grepl(glob2rx("(*this)[*].landcover"), current_stream)){ # s counter might change, using wildcard +# # not sure how to handle this better. If we see this, it means we are now looping over Stands +# # this function considers "NATURAL" vegetation only, so there is only one stand +# # this is an integer that tells us which landcover type this stand is +# # so it should be the indice of NATURAL in typedef enum landcovertype (I believe indexing starts from 0) +# +# num_stnd <- as.numeric(Gridcell$nstands) +# Gridcell[["Stand"]] <- vector("list", num_stnd) +# +# # note that this is streamed under Gridcell, not Stand in guess.cpp, +# # but I think this info needs to go together with the Stand sublist +# # so prepend landcovertype to the streamed_vars_stand +# +# next +# } +# +# # "(*this)[*]" points to different things under different levels, here it is stand +# if(grepl(glob2rx("(*this)[*]"), current_stream)){ # note that first else-part will be evaluated considering the order in guess.cpp +# +# # STAND +# level <- "Stand" +# current_stream <- "Stand" +# current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) +# +# beg_end <- serialize_starts_ends(file_in = guesscpp_in, +# pattern = paste0("void ", +# tools::toTitleCase(current_stream_type$name), +# "::serialize")) +# streamed_vars_stand <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) +# streamed_vars_stand <- c("landcover", streamed_vars_stand) # prepending landcovertype to the streamed_vars_stand +# +# +# for(stnd_i in seq_len(num_stnd)){ #looping over the stands +# for(svs_i in 1:3){#seq_along(streamed_vars_stand)){ # looping over the streamed stand vars +# +# current_stream <- streamed_vars_stand[svs_i] +# if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard +# +# if(current_stream == "nobj" & level == "Stand"){ +# # nobj points to different things under different levels, here it is the number of patches +# # number of patches is set through insfiles, read by write.configs and passed to this fcn +# # but it's also written to the state file, need to move bytes +# nofpatch <- readBin(zz, integer(), 1, size = 4) +# if(npatches == nofpatch){ # also not a bad place to check if everything is going fine so far +# Gridcell[["Stand"]][[stnd_i]]$npatches <- npatches +# #Gridcell[["Stand"]] <- vector("list", npatches) +# }else{ +# PEcAn.logger::logger.severe("The number of patches set through the instruction file does not match the number read from the state files. Probably a bug in the read.state function! Terminating.") +# } +# next +# } +# +# # "(*this)[*]" points to different things under different levels, here it is patch +# if(grepl(glob2rx("(*this)[*]"), current_stream)){ +# # PATCH +# level <- "Patch" +# current_stream <- "Patch" +# current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) +# +# beg_end <- serialize_starts_ends(file_in = guesscpp_in, +# pattern = paste0("void ", +# tools::toTitleCase(current_stream_type$name), +# "::serialize")) +# streamed_vars_patch <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) +# +# Gridcell[["Stand"]][[stnd_i]][["Patch"]] <- vector("list", npatches) +# +# for(ptch_i in seq_len(npatches)){ #looping over the patches +# for(svp_i in 1:3){#seq_along(streamed_vars_patch)){ #looping over the streamed patch vars +# current_stream <- streamed_vars_patch[svp_i] +# if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard +# +# current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) +# +# Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[length(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])+1]] <- list() +# names(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])[length(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])] <- current_stream_type$name +# +# if(current_stream_type$type == "class"){ +# +# # CLASS +# class_name <- current_stream_type$name +# +# beg_end <- serialize_starts_ends(file_in = guesscpp_in, +# pattern = paste0("void ", +# tools::toTitleCase(current_stream_type$name), +# "::serialize")) +# +# +# if(class_name == "vegetation"){ +# # VEGETATION +# # Vegetation class has a bit of a different structure, it has one more depth, see model documentation +# streamed_vars_veg <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) +# +# # NOTE : Unlike other parts, this bit is a lot less generalized!!! +# # I'm gonna asumme Vegetation class won't change much in the future +# # indiv.pft.id and indiv needs to be looped over nobj times +# if(!setequal(streamed_vars_veg, c("nobj", "indiv.pft.id", "indiv"))){ +# PEcAn.logger::logger.severe("Vegetation class object changed in this model version, you need to fix read.state") +# } +# +# # nobj points to different things under different levels, here it is the number of individuals +# number_of_individuals <- readBin(zz, integer(), 1, size = 4) +# Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["number_of_individuals"]] <- number_of_individuals +# +# # few checks for sensible vals +# if(number_of_individuals < 1 | number_of_individuals > 10000){ # should there be an upper limit here too? +# # if number of individuals is 0 it's a bit suspicious. Not sure if ever will get negative but that'd definitely be wrong +# PEcAn.logger::logger.warn("Number of individuals under vegetation is", number_of_individuals) +# } +# Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["Individuals"]] <- vector("list", number_of_individuals) +# +# beg_end <- serialize_starts_ends(file_in = guesscpp_in, +# pattern = paste0("void Individual::serialize")) +# streamed_vars_indv <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) +# +# # loop over nobj +# for(indv_i in seq_len(number_of_individuals)){ +# Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["Individuals"]][[indv_i]] <- list() +# # which PFT is this? +# Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["Individuals"]][[indv_i]][["indiv.pft.id"]] <- readBin(zz, integer(), 1, size = 4) +# # read all the individual class +# for(svi_i in seq_along(streamed_vars_indv)){ # +# current_stream <- streamed_vars_indv[svi_i] +# +# current_stream_type <- find_stream_type("individual", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) +# current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) +# +# if(current_stream_specs$single){ +# Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["Individuals"]][[indv_i]][[current_stream_type$name]] <- readBin(con = zz, +# what = current_stream_specs$what, +# n = current_stream_specs$n, +# size = current_stream_specs$size) +# }else{ +# for(css.i in seq_along(current_stream_specs$what)){ +# Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["vegetation"]][["Individuals"]][[indv_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, +# what = current_stream_specs$what[css.i], +# n = current_stream_specs$n[css.i], +# size = current_stream_specs$size[css.i]) +# } +# } +# +# }# end loop over stream vars individual +# } # end loop over number_of_individuals +# +# +# +# +# +# }else{ +# # NOT VEGETATION +# streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) +# num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) +# +# for(varname in streamed_vars){ +# Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[current_stream_type$name]][[varname]] <- vector("list", num_pft) +# } +# +# # maybe try modifying this bit later to make it a function +# for(pft_i in seq_len(num_pft)){ +# for(sv_i in seq_along(streamed_vars)){ +# current_stream <- streamed_vars[sv_i] #it's OK to overwrite +# current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) +# +# if(current_stream_type$type == "class"){ +# +# if(current_stream_type$name != "sompool"){ +# PEcAn.logger::logger.debug("Classes other than sompool enter here.") +# } +# # ONLY SOMPOOL HERE SO FAR ****************************************************************** +# #class_name <- # don't overwrite class_name +# +# beg_end <- serialize_starts_ends(file_in = guesscpp_in, +# pattern = paste0("void ", +# tools::toTitleCase(current_stream_type$name), +# "::serialize")) +# streamed_vars_sompool <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) +# +# nsompool <- LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var == "NSOMPOOL"] +# +# for(varname in streamed_vars_sompool){ +# Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["soil"]][["sompool"]][[varname]] <- vector("list", nsompool) +# } +# +# ###################### LOOP OVER NSOMPOOL +# for(som_i in seq_len(nsompool)){ +# for(sv_sompool_i in seq_along(streamed_vars_sompool)){ +# current_stream <- streamed_vars_sompool[sv_sompool_i] +# +# current_stream_type <- find_stream_type(current_stream_type$name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) +# current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) +# +# if(current_stream_specs$single){ +# Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["soil"]][["sompool"]][[current_stream_type$name]][[som_i]] <- readBin(con = zz, +# what = current_stream_specs$what, +# n = current_stream_specs$n, +# size = current_stream_specs$size) +# }else{ +# PEcAn.logger::logger.debug("Historic under sompool.") +# } +# } +# } +# +# }else{ +# current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) +# # and read! +# if(current_stream_specs$single){ # maybe use current_stream in sublist names to find correct place +# Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[length( Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, +# what = current_stream_specs$what, +# n = current_stream_specs$n, +# size = current_stream_specs$size) +# }else{ # only for historic type? +# for(css.i in seq_along(current_stream_specs$what)){ # maybe use current_stream in sublist names to find correct place +# Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[length( Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, +# what = current_stream_specs$what[css.i], +# n = current_stream_specs$n[css.i], +# size = current_stream_specs$size[css.i]) +# } +# } +# } +# } # streamed_vars-loop ends +# } # pft-loop ends +# } +# +# +# }else{ +# # NOT CLASS +# current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) +# # and read! +# if(current_stream_specs$single){ +# Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]] <- readBin(con = zz, +# what = current_stream_specs$what, +# n = current_stream_specs$n, +# size = current_stream_specs$size) +# }else{ # probably don't need this but let's keep +# for(css_i in seq_along(current_stream_specs$what)){ +# Gridcell[[length(Gridcell)]][[current_stream_specs$names[css_i]]] <- readBin(con = zz, +# what = current_stream_specs$what[css_i], +# n = current_stream_specs$n[css_i], +# size = current_stream_specs$size[css_i]) +# } +# } +# }# end if-class within Patch +# } +# } +# +# }else{ +# # NOT PATCH +# +# current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) +# +# Gridcell[["Stand"]][[stnd_i]][[length(Gridcell[["Stand"]][[stnd_i]])+1]] <- list() +# names(Gridcell[["Stand"]][[stnd_i]])[length(Gridcell[["Stand"]][[stnd_i]])] <- current_stream_type$name +# +# if(current_stream_type$type == "class"){ +# +# # CLASS +# class_name <- current_stream_type$name +# +# beg_end <- serialize_starts_ends(file_in = guesscpp_in, +# pattern = paste0("void ", +# tools::toTitleCase(current_stream_type$name), +# "::serialize")) +# streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) +# num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) +# +# for(varname in streamed_vars){ +# Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]][[varname]] <- varname +# Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]][[varname]] <- vector("list", num_pft) +# } +# +# for(pft_i in seq_len(num_pft)){ +# for(sv_i in seq_along(streamed_vars)){ +# current_stream <- streamed_vars[sv_i] #it's OK to overwrite +# current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) +# +# if(current_stream_type$type == "class"){ +# +# # CLASS, NOT EVER GOING HERE? +# class_name <- current_stream_type$name +# +# }else{ +# current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) +# # and read! +# if(current_stream_specs$single){ +# Gridcell[["Stand"]][[stnd_i]][[length(Gridcell[["Stand"]][[stnd_i]])]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, +# what = current_stream_specs$what, +# n = current_stream_specs$n, +# size = current_stream_specs$size) +# }else{ +# for(css.i in seq_along(current_stream_specs$what)){ +# Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, +# what = current_stream_specs$what[css.i], +# n = current_stream_specs$n[css.i], +# size = current_stream_specs$size[css.i]) +# } +# } +# } +# } # streamed_vars-loop ends +# } # pft-loop ends +# +# }else{ +# # NOT CLASS +# current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) +# # and read! +# if(current_stream_specs$single){ +# Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]] <- readBin(con = zz, +# what = current_stream_specs$what, +# n = current_stream_specs$n, +# size = current_stream_specs$size) +# }else{ # probably don't need this but let's keep +# for(css_i in seq_along(current_stream_specs$what)){ +# Gridcell[[length(Gridcell)]][[current_stream_specs$names[css_i]]] <- readBin(con = zz, +# what = current_stream_specs$what[css_i], +# n = current_stream_specs$n[css_i], +# size = current_stream_specs$size[css_i]) +# } +# } +# }# end if-class within Stand +# } # end patch-if +# +# +# }# end for-loop over the streamed stand vars (svs_i, L.165) +# }# end for-loop over the stands (stnd_i, L.164) +# +# }else{ #not reading in Stand variables +# +# # NOT STAND +# +# current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) +# +# Gridcell[[length(Gridcell)+1]] <- list() +# names(Gridcell)[length(Gridcell)] <- current_stream_type$name +# if(current_stream_type$type == "class"){ +# +# # CLASS +# class_name <- current_stream_type$name +# +# beg_end <- serialize_starts_ends(file_in = guesscpp_in, +# pattern = paste0("void ", +# tools::toTitleCase(current_stream_type$name), +# "::serialize")) +# streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) +# num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) +# +# for(varname in streamed_vars){ +# Gridcell[[length(Gridcell)]][[varname]] <- varname +# Gridcell[[length(Gridcell)]][[varname]] <- vector("list", num_pft) +# } +# +# for(pft_i in seq_len(num_pft)){ +# for(sv_i in seq_along(streamed_vars)){ +# #for(sv_i in 21:37){ +# current_stream <- streamed_vars[sv_i] #it's OK to overwrite +# current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) +# +# if(current_stream_type$type == "class"){ +# +# # CLASS, NOT EVER GOING HERE? +# class_name <- current_stream_type$name +# +# }else{ +# current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) +# # and read! +# if(current_stream_specs$single){ +# Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, +# what = current_stream_specs$what, +# n = current_stream_specs$n, +# size = current_stream_specs$size) +# }else{ +# for(css.i in seq_along(current_stream_specs$what)){ +# Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, +# what = current_stream_specs$what[css.i], +# n = current_stream_specs$n[css.i], +# size = current_stream_specs$size[css.i]) +# } +# } +# } +# } # streamed_vars-loop ends +# } # pft-loop ends +# +# }else{ +# # NOT CLASS +# current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) +# # and read! +# if(current_stream_specs$single){ +# Gridcell[[length(Gridcell)]][[current_stream_type$name]] <- readBin(con = zz, +# what = current_stream_specs$what, +# n = current_stream_specs$n, +# size = current_stream_specs$size) +# }else{ # probably don't need this but let's keep +# for(css_i in seq_along(current_stream_specs$what)){ +# Gridcell[[length(Gridcell)]][[current_stream_specs$names[css_i]]] <- readBin(con = zz, +# what = current_stream_specs$what[css_i], +# n = current_stream_specs$n[css_i], +# size = current_stream_specs$size[css_i]) +# } +# } +# }# end if-class within Gridcell +# +# } # Stand if-else ends +# } # Gridcell-loop ends +# +# # helper function that determines the stream size to read +# find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS){ +# +# possible_types <- c("double ", "bool ", "int " , "long ") # space because these can be part of other words +# possible_types <- c(possible_types, LPJ_GUESS_TYPES) +# n_sizes <- c(8, 1, 4, 8, rep(4, length(LPJ_GUESS_TYPES) )) +# rbin_tbl <- c("double", "logical", "integer", "integer", rep("integer", length(LPJ_GUESS_TYPES))) +# +# specs <- list() +# +# sub_string <- current_stream_type$substring +# +# #is there a ; immediately after? +# if(grepl(paste0(current_stream_type$type, " ", current_stream_type$name, ";"), sub_string, fixed = TRUE) | +# grepl(paste0(current_stream_type$type, " ", current_stream_type$name, ","), sub_string, fixed = TRUE)){ # e.g. "double alag, exp_alag;" +# # this is only length 1 +# specs$n <- 1 +# specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] +# specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] +# specs$single <- TRUE +# +# }else if(current_stream_type$type == "Historic"){ +# possible_types <- c("double", "bool", "int" , "long") # # I haven't seen any Historic that doesn't store double but... historic has a comma after type: double, +# possible_types <- c(possible_types, LPJ_GUESS_TYPES) +# +# # Historic types are special to LPJ-GUESS +# # They have stored values, current index, and a boolean in that order +# specs$n <- specs$what <- specs$size <- specs$names <- rep(NA, 3) +# # always three, this is a type defined in guessmath.h +# specs$what[1] <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] +# specs$size[1] <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] +# specs$names[1] <- current_stream_type$name +# # n is tricky, it can be hardcoded it can be one of the const ints +# to_read <- str_match(sub_string, paste0("Historic<", specs$what[1], ", (.*?)>.*"))[,2] +# if(to_read %in% LPJ_GUESS_CONST_INTS$var){ +# specs$n <- LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var == to_read] +# }else{ +# specs$n[1] <- as.numeric(to_read) +# } +# specs$what[2] <- "integer" #need to check what size_t is +# specs$size[2] <- 8 +# specs$n[2] <- 1 +# specs$names[2] <- "current_index" +# +# specs$what[3] <- "logical" +# specs$size[3] <- 1 +# specs$n[3] <- 1 +# specs$names[3] <- "full" +# +# specs$single <- FALSE +# +# }else if(current_stream_type$type == "struct"){ +# if(current_stream_type$name != "solvesom"){ +# PEcAn.logger::logger.debug("Another struct type.") +# } +# #for now hardcoding this will be back +# specs$n <- specs$what <- specs$size <- specs$names <- rep(NA, 2) +# specs$what[1] <- "double" +# specs$size[1] <- 8 +# specs$names[1] <- "clitter" +# specs$n[1] <- 12 #NSOMPOOL +# +# specs$what[2] <- "double" +# specs$size[2] <- 8 +# specs$names[2] <- "nlitter" +# specs$n[2] <- 12 #NSOMPOOL +# +# specs$single <- FALSE +# +# }else if(grepl(glob2rx(paste0(current_stream_type$type, "*", current_stream_type$name, ";")), sub_string)){ +# +# # this is only length 1 +# specs$n <- 1 +# specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] +# specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] +# specs$single <- TRUE +# +# }else if(length(regmatches(sub_string, gregexpr("\\[.+?\\]", sub_string))[[1]]) > 1){ +# #looks like we have a matrix +# spec_dims <- regmatches(sub_string, gregexpr("\\[.+?\\]", sub_string))[[1]] +# spec_dims <- gsub("\\].*", "", gsub(".*\\[", "", spec_dims)) +# for(spec_dims_i in seq_along(spec_dims)){ +# if(any(sapply(LPJ_GUESS_CONST_INTS$var, grepl, spec_dims[spec_dims_i], fixed = TRUE))){ # uses one of the constant ints +# spec_dims[spec_dims_i] <- LPJ_GUESS_CONST_INTS$val[sapply(LPJ_GUESS_CONST_INTS$var, grepl, spec_dims[spec_dims_i], fixed = TRUE)] +# }else{ +# spec_dims[spec_dims_i] <- as.numeric(sub(".*\\[(.*)\\].*", "\\1", spec_dims[spec_dims_i], perl=TRUE)) +# } +# } +# spec_dims <- as.numeric(spec_dims) +# +# specs$n <- prod(spec_dims) +# specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] +# specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] +# specs$single <- TRUE +# }else{ +# # reading a vector +# specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] +# specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] +# if(any(sapply(LPJ_GUESS_CONST_INTS$var, grepl, sub_string, fixed = TRUE))){ # uses one of the constant ints +# specs$n <- LPJ_GUESS_CONST_INTS$val[sapply(LPJ_GUESS_CONST_INTS$var, grepl, sub_string, fixed = TRUE)] +# }else{ +# specs$n <- as.numeric(sub(".*\\[(.*)\\].*", "\\1", sub_string, perl=TRUE)) +# } +# +# specs$single <- TRUE +# } +# +# return(specs) +# } # find_stream_size +# +# +# # helper function to decide the type of the stream +# # this function relies on the architecture of LPJ-GUESS and has bunch of harcoded checks, see model documentation +# find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in){ +# +# if(current_stream_var == "seed"){ # a bit of a special case +# return(list(type = "long", name = "seed", substring = "long seed;")) +# } +# +# if(current_stream_var == "nstands"){ # a bit of a special case, it is read by guess.cpp +# return(list(type = "int", name = "nstands", substring = "int nstands;")) #there is not substring like that in guess.h +# } +# +# if(current_stream_var == "landcover"){ # a bit of a special case +# return(list(type = "landcovertype", name = "landcover", substring = "landcovertype landcover;")) +# } +# +# # it might be difficult to extract the "type" before the varname +# # there are not that many to check +# possible_types <- c("class ", "double ", "bool ", "int ") +# +# possible_types <- c(possible_types, LPJ_GUESS_TYPES) +# +# beg_end <- NULL # not going to need it always +# +# # class or not? +# if(tools::toTitleCase(current_stream_var) %in% LPJ_GUESS_CLASSES){ +# stream_type <- "class" +# stream_name <- current_stream_var +# sub_string <- NULL +# }else {# find type from guess.h +# +# if(is.null(class)){ +# sub_string <- guessh_in[grepl(paste0(" ", current_stream_var), guessh_in, fixed = TRUE)] +# }else{ +# beg_end <- serialize_starts_ends(file_in = guessh_in, +# pattern = paste0("class ", +# tools::toTitleCase(class), +# " : public ")) +# # subset +# sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var, ";"), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] +# } +# +# if(length(sub_string) == 0){ +# sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] +# } +# # e.g. "sompool[i]" in guess.cpp, Sompool sompool[NSOMPOOL]; in guess.h +# if(length(sub_string) == 0){ +# current_stream_var <- gsub("\\[|.\\]", "", current_stream_var) +# sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] +# if(tools::toTitleCase(current_stream_var) %in% LPJ_GUESS_CLASSES){ +# stream_type <- "class" +# stream_name <- current_stream_var +# sub_string <- NULL +# return(list(type = gsub(" ", "", stream_type), name = stream_name, substring = sub_string)) +# } +# } +# if(length(sub_string) == 0){ +# sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(",", current_stream_var), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] +# } +# if(length(sub_string) > 1){ +# # some varnames are very common characters unfortunately like u, v... check if [] comes after +# if(any(grepl(paste0(" ", current_stream_var, "["), sub_string, fixed = TRUE))){ +# sub_string <- sub_string[grepl(paste0(" ", current_stream_var, "["), sub_string, fixed = TRUE)] +# }else if(any(grepl(paste0("double ", current_stream_var), sub_string, fixed = TRUE))){ # just fishing, double is the most common type +# sub_string <- sub_string[grepl(paste0("double ", current_stream_var), sub_string, fixed = TRUE)] +# }else{ +# PEcAn.logger::logger.severe("Check this out.") +# } +# } +# +# # clean from tabs +# sub_string <- gsub("\t", "", sub_string) +# # clean from commented out lines? +# +# if(grepl("Historic", sub_string, fixed = TRUE)){ +# # Historic types has the form Historic& data) +# stream_type <- "Historic" +# stream_name <- current_stream_var +# }else if(grepl("std::vector", sub_string, fixed = TRUE)){ +# stream_type <- "struct" +# stream_name <- current_stream_var +# }else{ +# stream_type <- possible_types[sapply(possible_types, grepl, sub_string, fixed = TRUE)] +# stream_name <- current_stream_var +# } +# +# } +# +# return(list(type = gsub(" ", "", stream_type), name = stream_name, substring = sub_string)) +# } # find_stream_type +# +# +# +# +# ######################## Helper functions ######################## +# +# # helper function that lists streamed variables, it just returns the names, types are checked by other fucntion +# find_stream_var <- function(file_in, line_nos){ +# +# streaming_list <- list() +# str.i <- 1 +# when_here <- NULL +# not_skipping <- TRUE +# +# i <- line_nos[1] +# repeat{ +# i <- i + 1 +# if(!is.null(when_here)){ +# if(i == when_here){ +# i <- skip_to +# when_here <- NULL +# } +# } +# +# # some functions (Vegetation, Patch, Stand, Gridcell) have two modes: saving / reading +# # we only need the stream that is saved +# if(grepl("arch.save()", file_in[i])){ +# when_here <- find_closing("}", i, file_in) +# skip_to <- find_closing("}", i, file_in, if_else_check = TRUE) +# } +# +# # all streams start with arch & +# if(grepl("arch & ", file_in[i])){ +# # get variable name +# streaming_list[[str.i]] <- sub(".*arch & ", "", file_in[i]) # always one var after arch? +# str.i <- str.i + 1 +# # check for ampersand for the subsequent variable names +# repeat{ +# i <- i + 1 +# if(!is.null(when_here)){ +# if(i == when_here){ +# i <- skip_to +# when_here <- NULL +# } +# } +# check1 <- !grepl(".*& ", file_in[i]) # when there are no subsequent stream +# check2 <- !grepl(".*& ", file_in[i+1]) # sometimes following line is empty or commented, check the next one too +# if(check1 & !check2) i <- i+1 +# if(check1 & check2) break # looks like there are no subsequent stream +# this_line <- gsub("[[:space:]]", "", strsplit(file_in[i], "& ")[[1]]) +# for(var in this_line){ +# if(var != ""){ +# if(var != "arch"){ +# streaming_list[[str.i]] <- var +# str.i <- str.i + 1 +# } +# } +# } +# if(!is.null(when_here)){ # now that increased i check this just in case +# if(i == when_here){ +# i <- skip_to +# when_here <- NULL +# } +# } +# } +# } +# if(i == line_nos[2]) break +# } +# +# #unlist and nix the ; +# returnin_stream <- gsub(";", "", unlist(streaming_list), fixed = TRUE) +# return(returnin_stream) +# } # find_stream_var +# +# +# +# # helper function that scans LPJ-GUESS that returns the beginning and the ending lines of serialized object +# serialize_starts_ends <- function(file_in, pattern = "void Gridcell::serialize"){ +# # find the starting line from the given pattern +# starting_line <- which(!is.na(str_match(file_in, pattern))) +# if(length(starting_line) != 1){ # check what's going on +# PEcAn.logger::logger.severe("Couldn't find the starting line with this pattern ***",pattern, "***.") +# } +# +# # screen for the closing curly bracket after function started +# # keep track of opening-closing brackets +# ending_line <- find_closing(find = "}", starting_line, file_in) +# +# return(c(starting_line, ending_line)) +# } # serialize_starts_ends +# +# # helper function that finds the closing bracket, can work over if-else +# find_closing <- function(find = "}", line_no, file_in, if_else_check = FALSE){ +# opened <- 1 +# closed <- 0 +# if(find == "}"){ +# start_char <- "{" +# end_char <- "}" +# }else{ +# #there can be else-ifs, find closing paranthesis / square breacket etc +# } +# +# # check the immediate line and return if closed there already +# if(grepl(end_char, file_in[line_no], fixed = TRUE)) return(line_no) +# +# repeat{ +# line_no <- line_no + 1 +# if(grepl(start_char, file_in[line_no], fixed = TRUE)) opened <- opened + 1 +# if(grepl(end_char, file_in[line_no], fixed = TRUE)) closed <- closed + 1 +# if(if_else_check){ +# else_found <- FALSE +# same_line_check <- grepl("else", file_in[line_no], fixed = TRUE) #same line +# next_line_check <- grepl("else", file_in[line_no + 1], fixed = TRUE) #next line +# if(same_line_check | next_line_check){ +# closed <- closed - 1 +# if(next_line_check) line_no <- line_no + 1 +# } +# } +# if(opened == closed) break +# } +# return(line_no) +# } # find_closing +# diff --git a/models/lpjguess/R/updateIndividual.LPJGUESS.R b/models/lpjguess/R/updateIndividual.LPJGUESS.R new file mode 100644 index 00000000000..65bec3639f7 --- /dev/null +++ b/models/lpjguess/R/updateIndividual.LPJGUESS.R @@ -0,0 +1,185 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2012 University of Illinois, NCSA. +# All rights reserved. This program and the accompanying materials +# are made available under the terms of the +# University of Illinois/NCSA Open Source License +# which accompanies this distribution, and is available at +# http://opensource.ncsa.illinois.edu/license.html +#------------------------------------------------------------------------------- + +#' Adjust LPJ-GUESS state +#' +#' @title updateState.LPJGUESS +#' +#' @description +#' +#' +#' @param model.state A large multiply-nested list containing the entire LPJ-GUESS state as read by +#' function \code{readStateBinary.LPJGUESS} +#' @param dens.initial A numeric vector of the initial stand-level stem densities (indiv/m^2) as named numeric vector +#' with one entry per PFT/species, with the names being the PFT/species codes. These values should be produced +#' using state data assimilation from function XXXXXX. +#' @param dens.target A numeric vector of the target stand-level stem densities (indiv/m^2) as named numeric vector +#' with one entry per PFT/species, with the names being the PFT/species codes. These values should be produced +#' using state data assimilation from function XXXXXX +#' @param biomass.target A numeric vector of the target stand-level biomasses (kgC/m^2) as named numeric vector +#' with one entry per PFT/species, with the names being the PFT/species codes. These values should be produced +#' using state data assimilation from function XXXXXX +#' @param biomass.target A numeric vector of the target stand-level biomasses (kgC/m^2) as named numeric vector +#' with one entry per PFT/species, with the names being the PFT/species codes. These values should be produced +#' using state data assimilation from function XXXXXX +#' @return And updated model state (as a big old list o' lists) +#' @export +#' @author Matthew Forrest + + + +updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, biomass.initial, biomass.target) { + + + # calculate relative increases to be applied later on (per PFT) + dens.rel.change <- dens.target/dens.initial + biomass.rel.change <- biomass.target/biomass.initial + print(dens.rel.change) + print(biomass.rel.change) + + + # nstands - should always be 1 but lets make sure + nstands <- unlist(model.state$nstands) + if(nstands != 1) warning("More than one Stand found in LPJ-GUESS state. This possibly implies that land use has been enabled + which the PEcAn code might not be robust against.") + + # + for(stand.counter in 1:nstands) { + + # get the number of patches + npatches <- model.state$Stand[[stand.counter]]$npatches + # MF hack for now + #npatches <- 1 + + # get list of all the PFTs included in this stand + active.PFTs <- c() + for(stand.pft.id in 1:length(model.state$Stand[[stand.counter]]$Standpft$active)) { + if(model.state$Stand[[stand.counter]]$Standpft$active[[stand.pft.id]]) active.PFTs <- append(active.PFTs, stand.pft.id -1) + } + + + # loop through each patch + for(patch.counter in 1:npatches) { + + this.patch <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]] + + # pull out the number of individuals and a list of them + nindividuals <- this.patch$Vegetation$number_of_individuals + all.individuals <- this.patch$Vegetation$Individuals + + + # for each individual + for(individual.counter in 1:length(all.individuals)) { + + this.individual <- all.individuals[[individual.counter]] + + if(this.individual$alive) { + + this.pft.id <- this.individual$indiv.pft.id + print(paste("PFT id = ", this.pft.id)) + + if(!this.pft.id %in% active.PFTs) stop(paste0("Found individual of PFT id = ",this.pft.id, + " but this doesn't seem to be active in the LPJ-GUESS run")) + + # STEP 0 - store the initial C-N ratios which we will use to magic up some new N to maintain the C-N ratios of the initial state + cton_leaf <- this.individual$cmass_leaf/this.individual$nmass_leaf + print("leaf") + print(cton_leaf) + print(this.individual$cmass_leaf) + print(this.individual$nmass_leaf) + cton_root <- this.individual$cmass_root/this.individual$nmass_root + print("root") + print(cton_root) + print(this.individual$cmass_root) + print(this.individual$nmass_root) + cton_sap <- this.individual$cmass_sap/this.individual$nmass_sap + print("sap") + print(cton_sap) + print(this.individual$cmass_sap) + print(this.individual$nmass_sap) + cton_heart <- this.individual$cmass_heart/this.individual$nmass_heart + print("heart") + print(cton_heart) + print(this.individual$cmass_heart) + print(this.individual$nmass_heart) + + + + # STEP 1 - nudge density of stems by adjusting the "indiv.densindiv" and also scaling the biomass pools appropriately + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$densindiv <- this.individual$densindiv * dens.rel.change[this.pft.id+1] + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$cmass_leaf <- this.individual$cmass_leaf * dens.rel.change[this.pft.id+1] + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$nmass_leaf <- this.individual$nmass_leaf * dens.rel.change[this.pft.id+1] + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$cmass_root <- this.individual$cmass_root * dens.rel.change[this.pft.id+1] + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$nmass_root <- this.individual$nmass_root * dens.rel.change[this.pft.id+1] + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$cmass_sap <- this.individual$cmass_sap * dens.rel.change[this.pft.id+1] + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$nmass_sap <- this.individual$nmass_sap * dens.rel.change[this.pft.id+1] + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$cmass_heart <- this.individual$cmass_heart * dens.rel.change[this.pft.id+1] + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$nmass_hear <- this.individual$nmass_heart * dens.rel.change[this.pft.id+1] + + # STEP 2 - nudge biomass by performing the LPJ-GUESS allocation routine + + # calculate the total biomass + biomass.total <- this.individual$cmass_leaf+this.individual$cmass_root+this.individual$cmass_heart+this.individual$cmass_sap + biomass.inc <- (biomass.total * biomass.rel.change[this.pft.id+1]) - biomass.total + print(biomass.inc) + + cmass_root_inc <- 0 + cmass_sap_inc <- 0 + cmass_debt_inc <- 0 + cmass_heart_inc <- 0 + litter_leaf_inc <- 0 + litter_root_inc <- 0 + exceeds_cmass <- 0 + + # updated.pools <- allocation(bminc = as.numeric(biomass.inc), + # cmass_leaf = as.numeric(this.individual$cmass_leaf), , + # cmass_root = as.numeric(this.individual$cmass_sap), + # cmass_sap = as.numeric(this.individual$cmass_sap), + # cmass_debt = as.numeric(this.individual$cmass_heart), + # cmass_heart = as.numeric(this.individual$cmass_heart), + # ltor = as.numeric(this.individual$ltor), + # height = as.numeric(this.individual$height), + # sla = as.numeric(this.individual$sla), + # wooddens = as.numeric(this.individual$wooddens), + # lifeform = as.integer(1), # BLARP + # cmass_root_inc = as.numeric(cmass_root_inc), + # cmass_sap_inc = as.numeric(cmass_sap_inc), + # cmass_debt_inc = as.numeric(cmass_debt_inc), + # cmass_heart_inc = as.numeric(cmass_heart_inc), + # litter_leaf_inc = as.numeric(litter_leaf_inc), + # litter_root_inc = as.numeric(litter_root_inc), + # exceeds_cmass = as.numeric(exceeds_cmass)) + # print(updated.pools) + + + # STEP 3 - adjust the various associated C pools based on the results of the previous step + + # STEP 4 - update N compartments using the initial C-N ratios + + # STEP 5 - adjust the allometry of the individual based on the updated pools + # QUESTION: what to do if allometry returns FALSE? + + + + } + + } + + } + + } # for each stand + + + + # STEP 6 - introduce new individuals to represent PFTs present in data but not in the model output + + return(model.state) + +} + diff --git a/models/lpjguess/man/allometry.Rd b/models/lpjguess/man/allometry.Rd new file mode 100644 index 00000000000..3d95f2cad1d --- /dev/null +++ b/models/lpjguess/man/allometry.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/allometry.LPJGUESS.R +\name{allometry} +\alias{allometry} +\title{LPJ-GUESS allometry} +\usage{ +allometry(lifeform = "TREE", cmass_leaf, cmass_sap, cmass_heart, + densindiv, age, fpc, deltafpc, sla, k_latosa, k_rp, k_allom1, k_allom2, + k_allom3, wooddens, crownarea_max) +} +\description{ +LPJ-GUESS allometry +} +\keyword{internal} diff --git a/models/lpjguess/man/calculateGridcellVariablePerPFT.Rd b/models/lpjguess/man/calculateGridcellVariablePerPFT.Rd new file mode 100644 index 00000000000..c1ee757a343 --- /dev/null +++ b/models/lpjguess/man/calculateGridcellVariablePerPFT.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/calculateGridcellVariablePerPFT.LPJGUESS.R +\name{calculateGridcellVariablePerPFT} +\alias{calculateGridcellVariablePerPFT} +\title{calculateGridcellVariablePerPFT} +\usage{ +calculateGridcellVariablePerPFT(model.state, variable) +} +\arguments{ +\item{model.state}{A large multiply-nested list containing the entire LPJ-GUESS state as read by +function \code{readStateBinary.LPJGUESS}} + +\item{variable}{A character string specifying what variable to extract. This can be chosen based on the LPJ-GUESS variable name +as recorded in the big list of list (that represents describes the model state in R). Once special case is "biomass" which +returns the sum of "cmass_leaf", "cmass_root", "cmass_sap" and "cmass_heart"} +} +\value{ +A numeric vector, with one entry per PFT +} +\description{ +Calculates a per-PFT, gridcell-summed quantity from the LPJ-GUESS state, correctly averaging over patches. +This should be put into the SDA procedure. +} +\author{ +Matthew Forrest +} diff --git a/models/lpjguess/man/updateState.LPJGUESS.Rd b/models/lpjguess/man/updateState.LPJGUESS.Rd new file mode 100644 index 00000000000..b624d42e8c8 --- /dev/null +++ b/models/lpjguess/man/updateState.LPJGUESS.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/updateIndividual.LPJGUESS.R +\name{updateState.LPJGUESS} +\alias{updateState.LPJGUESS} +\title{updateState.LPJGUESS} +\usage{ +updateState.LPJGUESS(model.state, dens.initial, dens.target, + biomass.initial, biomass.target) +} +\arguments{ +\item{model.state}{A large multiply-nested list containing the entire LPJ-GUESS state as read by +function \code{readStateBinary.LPJGUESS}} + +\item{dens.initial}{A numeric vector of the initial stand-level stem densities (indiv/m^2) as named numeric vector +with one entry per PFT/species, with the names being the PFT/species codes. These values should be produced +using state data assimilation from function XXXXXX.} + +\item{dens.target}{A numeric vector of the target stand-level stem densities (indiv/m^2) as named numeric vector +with one entry per PFT/species, with the names being the PFT/species codes. These values should be produced +using state data assimilation from function XXXXXX} + +\item{biomass.target}{A numeric vector of the target stand-level biomasses (kgC/m^2) as named numeric vector +with one entry per PFT/species, with the names being the PFT/species codes. These values should be produced +using state data assimilation from function XXXXXX} + +\item{biomass.target}{A numeric vector of the target stand-level biomasses (kgC/m^2) as named numeric vector +with one entry per PFT/species, with the names being the PFT/species codes. These values should be produced +using state data assimilation from function XXXXXX} +} +\value{ +And updated model state (as a big old list o' lists) +} +\description{ + +} +\details{ +Adjust LPJ-GUESS state +} +\author{ +Matthew Forrest +} From cc3cceb6babfdf2f3c828e0f032fc77d9093eaf9 Mon Sep 17 00:00:00 2001 From: istfer Date: Wed, 19 Jun 2019 11:49:12 -0400 Subject: [PATCH 29/56] read meta.bin --- models/lpjguess/R/read_state.R | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index 459218091e5..1b0b47a4226 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -36,11 +36,27 @@ paramh_in <- readLines(paramh_loc) out.path = "/fs/data2/output/PEcAn_1000002393/out/1000458390" setwd(out.path) +###################################### +## read meta.bin +# not sure if the content will change under guessserializer.cpp +close(meta_bin_con) +meta_data <- list() +meta_bin_con <- file("meta.bin", "rb") +meta_data$num_processes <- readBin(meta_bin_con, integer(), 1, size = 4) +meta_data$vegmode <- readBin(meta_bin_con, integer(), 1, size = 4) +meta_data$npft <- readBin(meta_bin_con, integer(), 1, size = 4) +meta_data$pft <- list() +for(i in seq_len(meta_data$npft)){ + char_len <- readBin(meta_bin_con, integer(), 1, size = 8) + meta_data$pft[[i]] <- readChar(meta_bin_con, char_len) +} +close(meta_bin_con) + # open connection to the binary state file zz <- file("0.state", "rb") ### these are the values read from params.ins, passed to this fcn -n_pft <- 11 +n_pft <- meta_data$npft npatches <- 5 ################################ check class compatibility ################################ From b88b5294e41829c8210eec1eb352ffc21dbdf44c Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Wed, 19 Jun 2019 12:42:06 -0400 Subject: [PATCH 30/56] allocation() function now correctly included --- .gitignore | 3 ++ models/lpjguess/NAMESPACE | 2 +- models/lpjguess/R/RcppExports.R | 7 +++ models/lpjguess/R/allocation.LPJGUESS.R | 5 +- models/lpjguess/R/updateIndividual.LPJGUESS.R | 48 +++++++++++------- models/lpjguess/src/RcppExports.cpp | 49 +++++++++++++++++++ .../{R => src}/allocation.LPJGUESS.cpp | 1 - 7 files changed, 92 insertions(+), 23 deletions(-) create mode 100644 models/lpjguess/R/RcppExports.R create mode 100644 models/lpjguess/src/RcppExports.cpp rename models/lpjguess/{R => src}/allocation.LPJGUESS.cpp (99%) diff --git a/.gitignore b/.gitignore index 2942f835440..53c6c1a963c 100644 --- a/.gitignore +++ b/.gitignore @@ -21,6 +21,9 @@ PEcAnRTM_*.*tar.gz **/vignettes/pecan cache # Files generated by Rstudio +# MF - ignore C++ compiled files +*.o +*.so *.Rproj* book_source/**/*.html # files generated by fia2ed script diff --git a/models/lpjguess/NAMESPACE b/models/lpjguess/NAMESPACE index 507663237b3..f3715657a52 100644 --- a/models/lpjguess/NAMESPACE +++ b/models/lpjguess/NAMESPACE @@ -1,6 +1,5 @@ # Generated by roxygen2: do not edit by hand -export() export(calculateGridcellVariablePerPFT) export(met2model.LPJGUESS) export(model2netcdf.LPJGUESS) @@ -16,3 +15,4 @@ importFrom(ncdf4,ncatt_put) importFrom(ncdf4,ncdim_def) importFrom(ncdf4,ncvar_def) importFrom(ncdf4,ncvar_get) +useDynLib(PEcAn.LPJGUESS) diff --git a/models/lpjguess/R/RcppExports.R b/models/lpjguess/R/RcppExports.R new file mode 100644 index 00000000000..e1ab1e98d1a --- /dev/null +++ b/models/lpjguess/R/RcppExports.R @@ -0,0 +1,7 @@ +# Generated by using Rcpp::compileAttributes() -> do not edit by hand +# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 + +allocation <- function(bminc, cmass_leaf, cmass_root, cmass_sap, cmass_debt, cmass_heart, ltor, height, sla, wooddens, lifeform, k_latosa, k_allom2, k_allom3, cmass_leaf_inc, cmass_root_inc, cmass_sap_inc, cmass_debt_inc, cmass_heart_inc, litter_leaf_inc, litter_root_inc, exceeds_cmass) { + .Call('_PEcAn_LPJGUESS_allocation', PACKAGE = 'PEcAn.LPJGUESS', bminc, cmass_leaf, cmass_root, cmass_sap, cmass_debt, cmass_heart, ltor, height, sla, wooddens, lifeform, k_latosa, k_allom2, k_allom3, cmass_leaf_inc, cmass_root_inc, cmass_sap_inc, cmass_debt_inc, cmass_heart_inc, litter_leaf_inc, litter_root_inc, exceeds_cmass) +} + diff --git a/models/lpjguess/R/allocation.LPJGUESS.R b/models/lpjguess/R/allocation.LPJGUESS.R index 9fe65c80f05..def276d3de8 100644 --- a/models/lpjguess/R/allocation.LPJGUESS.R +++ b/models/lpjguess/R/allocation.LPJGUESS.R @@ -1,5 +1,6 @@ +#' @useDynLib PEcAn.LPJGUESS #' @importFrom Rcpp sourceCpp -#' @export +NULL # compile the LPJ-GUESS allocation function using Rcpp -sourceCpp("~/Projects/PalEON/LPJ-GUESS/allocation.cpp") \ No newline at end of file +sourceCpp("src/allocation.LPJGUESS.cpp") \ No newline at end of file diff --git a/models/lpjguess/R/updateIndividual.LPJGUESS.R b/models/lpjguess/R/updateIndividual.LPJGUESS.R index 65bec3639f7..57a8eb2f011 100644 --- a/models/lpjguess/R/updateIndividual.LPJGUESS.R +++ b/models/lpjguess/R/updateIndividual.LPJGUESS.R @@ -129,6 +129,7 @@ updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, biomass biomass.inc <- (biomass.total * biomass.rel.change[this.pft.id+1]) - biomass.total print(biomass.inc) + cmass_leaf_inc <- 0 cmass_root_inc <- 0 cmass_sap_inc <- 0 cmass_debt_inc <- 0 @@ -137,25 +138,34 @@ updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, biomass litter_root_inc <- 0 exceeds_cmass <- 0 - # updated.pools <- allocation(bminc = as.numeric(biomass.inc), - # cmass_leaf = as.numeric(this.individual$cmass_leaf), , - # cmass_root = as.numeric(this.individual$cmass_sap), - # cmass_sap = as.numeric(this.individual$cmass_sap), - # cmass_debt = as.numeric(this.individual$cmass_heart), - # cmass_heart = as.numeric(this.individual$cmass_heart), - # ltor = as.numeric(this.individual$ltor), - # height = as.numeric(this.individual$height), - # sla = as.numeric(this.individual$sla), - # wooddens = as.numeric(this.individual$wooddens), - # lifeform = as.integer(1), # BLARP - # cmass_root_inc = as.numeric(cmass_root_inc), - # cmass_sap_inc = as.numeric(cmass_sap_inc), - # cmass_debt_inc = as.numeric(cmass_debt_inc), - # cmass_heart_inc = as.numeric(cmass_heart_inc), - # litter_leaf_inc = as.numeric(litter_leaf_inc), - # litter_root_inc = as.numeric(litter_root_inc), - # exceeds_cmass = as.numeric(exceeds_cmass)) - # print(updated.pools) + #sourceCpp("~/Projects/PalEON/LPJ-GUESS/allocation.cpp") + print(str(allocation)) + + + updated.pools <- allocation(bminc = as.numeric(biomass.inc), + cmass_leaf = as.numeric(this.individual$cmass_leaf), + cmass_root = as.numeric(this.individual$cmass_sap), + cmass_sap = as.numeric(this.individual$cmass_sap), + cmass_debt = as.numeric(this.individual$cmass_heart), + cmass_heart = as.numeric(this.individual$cmass_heart), + ltor = as.numeric(this.individual$ltor), + height = as.numeric(this.individual$height), + sla = as.numeric(this.individual$sla), + wooddens = as.numeric(this.individual$wooddens), + lifeform = as.integer(1), # BLARP + k_latosa = as.numeric(this.individual$k_latosa), + k_allom2 = as.numeric(this.individual$k_allom2), + k_allom3 = as.numeric(this.individual$k_allom3), + cmass_leaf_inc = as.numeric(cmass_leaf_inc), + cmass_root_inc = as.numeric(cmass_root_inc), + cmass_sap_inc = as.numeric(cmass_sap_inc), + cmass_debt_inc = as.numeric(cmass_debt_inc), + cmass_heart_inc = as.numeric(cmass_heart_inc), + litter_leaf_inc = as.numeric(litter_leaf_inc), + litter_root_inc = as.numeric(litter_root_inc), + exceeds_cmass = as.numeric(exceeds_cmass)) + + print(updated.pools) # STEP 3 - adjust the various associated C pools based on the results of the previous step diff --git a/models/lpjguess/src/RcppExports.cpp b/models/lpjguess/src/RcppExports.cpp new file mode 100644 index 00000000000..f5b7bf93051 --- /dev/null +++ b/models/lpjguess/src/RcppExports.cpp @@ -0,0 +1,49 @@ +// Generated by using Rcpp::compileAttributes() -> do not edit by hand +// Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 + +#include + +using namespace Rcpp; + +// allocation +List allocation(double bminc, double cmass_leaf, double cmass_root, double cmass_sap, double cmass_debt, double cmass_heart, double ltor, double height, double sla, double wooddens, int lifeform, double k_latosa, double k_allom2, double k_allom3, double& cmass_leaf_inc, double& cmass_root_inc, double& cmass_sap_inc, double& cmass_debt_inc, double& cmass_heart_inc, double& litter_leaf_inc, double& litter_root_inc, double& exceeds_cmass); +RcppExport SEXP _PEcAn_LPJGUESS_allocation(SEXP bmincSEXP, SEXP cmass_leafSEXP, SEXP cmass_rootSEXP, SEXP cmass_sapSEXP, SEXP cmass_debtSEXP, SEXP cmass_heartSEXP, SEXP ltorSEXP, SEXP heightSEXP, SEXP slaSEXP, SEXP wooddensSEXP, SEXP lifeformSEXP, SEXP k_latosaSEXP, SEXP k_allom2SEXP, SEXP k_allom3SEXP, SEXP cmass_leaf_incSEXP, SEXP cmass_root_incSEXP, SEXP cmass_sap_incSEXP, SEXP cmass_debt_incSEXP, SEXP cmass_heart_incSEXP, SEXP litter_leaf_incSEXP, SEXP litter_root_incSEXP, SEXP exceeds_cmassSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< double >::type bminc(bmincSEXP); + Rcpp::traits::input_parameter< double >::type cmass_leaf(cmass_leafSEXP); + Rcpp::traits::input_parameter< double >::type cmass_root(cmass_rootSEXP); + Rcpp::traits::input_parameter< double >::type cmass_sap(cmass_sapSEXP); + Rcpp::traits::input_parameter< double >::type cmass_debt(cmass_debtSEXP); + Rcpp::traits::input_parameter< double >::type cmass_heart(cmass_heartSEXP); + Rcpp::traits::input_parameter< double >::type ltor(ltorSEXP); + Rcpp::traits::input_parameter< double >::type height(heightSEXP); + Rcpp::traits::input_parameter< double >::type sla(slaSEXP); + Rcpp::traits::input_parameter< double >::type wooddens(wooddensSEXP); + Rcpp::traits::input_parameter< int >::type lifeform(lifeformSEXP); + Rcpp::traits::input_parameter< double >::type k_latosa(k_latosaSEXP); + Rcpp::traits::input_parameter< double >::type k_allom2(k_allom2SEXP); + Rcpp::traits::input_parameter< double >::type k_allom3(k_allom3SEXP); + Rcpp::traits::input_parameter< double& >::type cmass_leaf_inc(cmass_leaf_incSEXP); + Rcpp::traits::input_parameter< double& >::type cmass_root_inc(cmass_root_incSEXP); + Rcpp::traits::input_parameter< double& >::type cmass_sap_inc(cmass_sap_incSEXP); + Rcpp::traits::input_parameter< double& >::type cmass_debt_inc(cmass_debt_incSEXP); + Rcpp::traits::input_parameter< double& >::type cmass_heart_inc(cmass_heart_incSEXP); + Rcpp::traits::input_parameter< double& >::type litter_leaf_inc(litter_leaf_incSEXP); + Rcpp::traits::input_parameter< double& >::type litter_root_inc(litter_root_incSEXP); + Rcpp::traits::input_parameter< double& >::type exceeds_cmass(exceeds_cmassSEXP); + rcpp_result_gen = Rcpp::wrap(allocation(bminc, cmass_leaf, cmass_root, cmass_sap, cmass_debt, cmass_heart, ltor, height, sla, wooddens, lifeform, k_latosa, k_allom2, k_allom3, cmass_leaf_inc, cmass_root_inc, cmass_sap_inc, cmass_debt_inc, cmass_heart_inc, litter_leaf_inc, litter_root_inc, exceeds_cmass)); + return rcpp_result_gen; +END_RCPP +} + +static const R_CallMethodDef CallEntries[] = { + {"_PEcAn_LPJGUESS_allocation", (DL_FUNC) &_PEcAn_LPJGUESS_allocation, 22}, + {NULL, NULL, 0} +}; + +RcppExport void R_init_PEcAn_LPJGUESS(DllInfo *dll) { + R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); + R_useDynamicSymbols(dll, FALSE); +} diff --git a/models/lpjguess/R/allocation.LPJGUESS.cpp b/models/lpjguess/src/allocation.LPJGUESS.cpp similarity index 99% rename from models/lpjguess/R/allocation.LPJGUESS.cpp rename to models/lpjguess/src/allocation.LPJGUESS.cpp index 11ad5c5b3b0..1ec01200aa7 100644 --- a/models/lpjguess/R/allocation.LPJGUESS.cpp +++ b/models/lpjguess/src/allocation.LPJGUESS.cpp @@ -145,7 +145,6 @@ inline double f(double& cmass_leaf_inc) { } - // [[Rcpp::export]] List allocation(double bminc,double cmass_leaf,double cmass_root,double cmass_sap, double cmass_debt,double cmass_heart,double ltor,double height,double sla, From 64fbdebc5a55ba9315c9f9ab91dd363326c94ba5 Mon Sep 17 00:00:00 2001 From: istfer Date: Wed, 19 Jun 2019 14:38:43 -0400 Subject: [PATCH 31/56] k_latosa is sapwood_ratio in pecan --- models/lpjguess/R/write.config.LPJGUESS.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/models/lpjguess/R/write.config.LPJGUESS.R b/models/lpjguess/R/write.config.LPJGUESS.R index cd64ef90423..b8a0d11b95a 100644 --- a/models/lpjguess/R/write.config.LPJGUESS.R +++ b/models/lpjguess/R/write.config.LPJGUESS.R @@ -270,7 +270,7 @@ pecan2lpjguess <- function(trait.values){ "alphar", "alphar", NA, NA, "greff_min", "greff_min", NA, NA, "k_allom1", "k_allom1", NA, NA, - "k_latosa", "k_latosa", NA, NA, + "sapwood_ratio", "k_latosa", NA, NA, "gcmin", "gmin", "m s-1", "mm s-1", "intc", "intc", NA, NA, "ga", "ga", NA, NA, From 58709a604684f232bad7d32d0c5c7d2b822becd5 Mon Sep 17 00:00:00 2001 From: istfer Date: Wed, 19 Jun 2019 15:45:30 -0400 Subject: [PATCH 32/56] small rearrangement for compilation --- models/lpjguess/NAMESPACE | 1 + models/lpjguess/R/read_state.R | 1555 ++++++++++++++++---------------- 2 files changed, 783 insertions(+), 773 deletions(-) diff --git a/models/lpjguess/NAMESPACE b/models/lpjguess/NAMESPACE index d0e5771159c..e2a150def61 100644 --- a/models/lpjguess/NAMESPACE +++ b/models/lpjguess/NAMESPACE @@ -1,5 +1,6 @@ # Generated by roxygen2: do not edit by hand +export(find_stream_size) export(met2model.LPJGUESS) export(model2netcdf.LPJGUESS) export(pecan2lpjguess) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index 1b0b47a4226..e567164f9b2 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -1,316 +1,658 @@ -library(stringr) - -# this fcn is for potential natural vegetation only -# when there is landcover, there will be more stand types - -# also for cohort mode only - -# Gridcell: Top-level object containing all dynamic and static data for a particular gridcell -# Gridcellpft: Object containing data common to all individuals of a particular PFT in a particular gridcell -# Gridcellst : Object containing data common to all stands of a particular stand type (ST) in a particular gridcell -# Climate : Contains all static and dynamic data relating to the overall environmental properties, other than soil properties, of a gridcell -# Soiltype : Stores soil static parameters. One object of class Soiltype is defined for each gridcell. -# Stand : Object containing all dynamic and static data for a particular stand -# Patch : Stores data specific to a patch. In cohort and individual modes, replicate patches are required in each stand to accommodate stochastic variation across the site. -# Patchpft : Object containing data common to all individuals of a particular PFT in a particular patch, including litter pools. -# Vegetation : A dynamic list of Individual objects, representing the vegetation of a particular patch -# Soil : Stores state variables for soils and the snow pack. One object of class Soil is defined for each patch. -# Fluxes : The Fluxes class stores accumulated monthly and annual fluxes. One object of type Fluxes is defined for each patch. -# Individual : Stores state variables for an average individual plant. In cohort mode, it is the average individual of a cohort of plants approximately the same age and from the same patch. - -# maybe put guess.h and guess.cpp for each model version into the model package -guesscpp_loc <- "/fs/data5/pecan.models/LPJ-GUESS/framework/guess.cpp" -guessh_loc <- "/fs/data5/pecan.models/LPJ-GUESS/framework/guess.h" -paramh_loc <- "/fs/data5/pecan.models/LPJ-GUESS/framework/parameters.h" - -# guess.cpp has the info of what is being written -guesscpp_in <- readLines(guesscpp_loc) -# guess.h has the types so that we know what streamsize to read -guessh_in <- readLines(guessh_loc) -# parameters.h has some more types -paramh_in <- readLines(paramh_loc) - -############ open -# test path -out.path = "/fs/data2/output/PEcAn_1000002393/out/1000458390" -setwd(out.path) +######################## Helper functions ######################## -###################################### -## read meta.bin -# not sure if the content will change under guessserializer.cpp -close(meta_bin_con) -meta_data <- list() -meta_bin_con <- file("meta.bin", "rb") -meta_data$num_processes <- readBin(meta_bin_con, integer(), 1, size = 4) -meta_data$vegmode <- readBin(meta_bin_con, integer(), 1, size = 4) -meta_data$npft <- readBin(meta_bin_con, integer(), 1, size = 4) -meta_data$pft <- list() -for(i in seq_len(meta_data$npft)){ - char_len <- readBin(meta_bin_con, integer(), 1, size = 8) - meta_data$pft[[i]] <- readChar(meta_bin_con, char_len) -} -close(meta_bin_con) -# open connection to the binary state file -zz <- file("0.state", "rb") +# helper function that lists streamed variables, it just returns the names, types are checked by other fucntion +find_stream_var <- function(file_in, line_nos){ + + streaming_list <- list() + str.i <- 1 + when_here <- NULL + not_skipping <- TRUE + + i <- line_nos[1] + repeat{ + i <- i + 1 + if(!is.null(when_here)){ + if(i == when_here){ + i <- skip_to + when_here <- NULL + } + } + + # some functions (Vegetation, Patch, Stand, Gridcell) have two modes: saving / reading + # we only need the stream that is saved + if(grepl("arch.save()", file_in[i])){ + when_here <- find_closing("}", i, file_in) + skip_to <- find_closing("}", i, file_in, if_else_check = TRUE) + } + + # all streams start with arch & + if(grepl("arch & ", file_in[i])){ + # get variable name + streaming_list[[str.i]] <- sub(".*arch & ", "", file_in[i]) # always one var after arch? + str.i <- str.i + 1 + # check for ampersand for the subsequent variable names + repeat{ + i <- i + 1 + if(!is.null(when_here)){ + if(i == when_here){ + i <- skip_to + when_here <- NULL + } + } + check1 <- !grepl(".*& ", file_in[i]) # when there are no subsequent stream + check2 <- !grepl(".*& ", file_in[i+1]) # sometimes following line is empty or commented, check the next one too + if(check1 & !check2) i <- i+1 + if(check1 & check2) break # looks like there are no subsequent stream + this_line <- gsub("[[:space:]]", "", strsplit(file_in[i], "& ")[[1]]) + for(var in this_line){ + if(var != ""){ + if(var != "arch"){ + streaming_list[[str.i]] <- var + str.i <- str.i + 1 + } + } + } + if(!is.null(when_here)){ # now that increased i check this just in case + if(i == when_here){ + i <- skip_to + when_here <- NULL + } + } + } + } + if(i == line_nos[2]) break + } + + #unlist and nix the ; + returnin_stream <- gsub(";", "", unlist(streaming_list), fixed = TRUE) + return(returnin_stream) +} # find_stream_var -### these are the values read from params.ins, passed to this fcn -n_pft <- meta_data$npft -npatches <- 5 -################################ check class compatibility ################################ -# between model versions we don't expect major classes or hierarchy to change -# but give check and fail if necessary -LPJ_GUESS_CLASSES <- c("Gridcell", "Climate", "Gridcellpft", "Stand", "Standpft", "Patch", "Patchpft", - "Individual", "Soil", "Sompool", "Fluxes", "Vegetation") -lpjguess_classes <- list() -ctr <- 1 -# NOTE THAT THESE PATTERNS ASSUME SOME CODING STYLE, thanks to LPJ-GUESS developers this might not be an issue in the future -for(i in seq_along(guessh_in)){ - # search for "class XXX : public Serializable {" - res <- str_match(guessh_in[i], "class (.*?) : public Serializable") - if(is.na(res[,2])){ - # try "class XXX : public ..., public Serializable {" pattern - res <- str_match(guessh_in[i], "class (.*?) : public .* Serializable") - } - if(!is.na(res[,2])){ - lpjguess_classes[[ctr]] <- res[,2] - ctr <- ctr + 1 +# helper function that scans LPJ-GUESS that returns the beginning and the ending lines of serialized object +serialize_starts_ends <- function(file_in, pattern = "void Gridcell::serialize"){ + # find the starting line from the given pattern + starting_line <- which(!is.na(str_match(file_in, pattern))) + if(length(starting_line) != 1){ # check what's going on + PEcAn.logger::logger.severe("Couldn't find the starting line with this pattern ***",pattern, "***.") } -} + + # screen for the closing curly bracket after function started + # keep track of opening-closing brackets + ending_line <- find_closing(find = "}", starting_line, file_in) + + return(c(starting_line, ending_line)) +} # serialize_starts_ends -# all match? -if(!setequal(unlist(lpjguess_classes), LPJ_GUESS_CLASSES)){ - PEcAn.logger::logger.severe("This function can only read the following class objects: ", paste(LPJ_GUESS_CLASSES, collapse="--")) -} -# there are couple of LPJ-GUESS specific types that we'll need below -lpjguess_types <- list() -ctr <- 1 -for(i in seq_along(guessh_in)){ - if(grepl("typedef enum {", guessh_in[i], fixed = TRUE)){ - this_line <- find_closing("}", i, guessh_in) - l_type <- gsub(".*}(.*?);.*", "\\1", guessh_in[this_line]) - l_type <- gsub(" ", "", l_type) - lpjguess_types[[ctr]] <- l_type - ctr <- ctr + 1 - } -} -for(i in seq_along(paramh_in)){ #do same for parameters.h - if(grepl("typedef enum {", paramh_in[i], fixed = TRUE)){ - this_line <- find_closing("}", i, paramh_in) - l_type <- gsub(".*}(.*?);.*", "\\1", paramh_in[this_line]) - l_type <- gsub(" ", "", l_type) - lpjguess_types[[ctr]] <- l_type - ctr <- ctr + 1 +# helper function that finds the closing bracket, can work over if-else +find_closing <- function(find = "}", line_no, file_in, if_else_check = FALSE){ + opened <- 1 + closed <- 0 + if(find == "}"){ + start_char <- "{" + end_char <- "}" + }else{ + #there can be else-ifs, find closing paranthesis / square breacket etc } -} -LPJ_GUESS_TYPES <- unlist(lpjguess_types) - - -lpjguess_consts <- list() -ctr <- 1 -for(i in seq_along(guessh_in)){ - if(grepl("const int ", guessh_in[i], fixed = TRUE)){ # probably won't need "const double"s - cnst_val <- gsub(".*=(.*?);.*", "\\1", guessh_in[i]) - cnst_val <- gsub(" ", "", cnst_val) # get rid of the space if there is one - cnst_nam <- gsub(".*int(.*?)=.*", "\\1", guessh_in[i]) - cnst_nam <- gsub(" ", "", cnst_nam) - lpjguess_consts[[ctr]] <- cnst_val - names(lpjguess_consts)[ctr] <- cnst_nam - ctr <- ctr + 1 + + # check the immediate line and return if closed there already + if(grepl(end_char, file_in[line_no], fixed = TRUE)) return(line_no) + + repeat{ + line_no <- line_no + 1 + if(grepl(start_char, file_in[line_no], fixed = TRUE)) opened <- opened + 1 + if(grepl(end_char, file_in[line_no], fixed = TRUE)) closed <- closed + 1 + if(if_else_check){ + else_found <- FALSE + same_line_check <- grepl("else", file_in[line_no], fixed = TRUE) #same line + next_line_check <- grepl("else", file_in[line_no + 1], fixed = TRUE) #next line + if(same_line_check | next_line_check){ + closed <- closed - 1 + if(next_line_check) line_no <- line_no + 1 + } + } + if(opened == closed) break } -} -# few cleaning -dont_need <- c("COLDEST_DAY_NHEMISPHERE", "COLDEST_DAY_SHEMISPHERE", "WARMEST_DAY_NHEMISPHERE", "WARMEST_DAY_SHEMISPHERE", "data[]") -lpjguess_consts[match(dont_need, names(lpjguess_consts))] <- NULL -# this needs to be extracted from parameters.h:48-49 or somewhere else, but hardcoding for now -lpjguess_consts$NLANDCOVERTYPES <- 6 -# this needs to be extracted from guess.h:94 , but hardcoding for now -lpjguess_consts$NSOMPOOL <- 12 -# this needs to be extracted from guess.h:644 , but hardcoding for now NOTE that new versions has 13 flux types -lpjguess_consts$PerPatchFluxType <- 12 -# this needs to be extracted from guess.h:659 , but hardcoding for now -lpjguess_consts$PerPFTFluxType <- 5 -LPJ_GUESS_CONST_INTS <- data.frame(var = names(lpjguess_consts), val = as.numeric(unlist(lpjguess_consts)), stringsAsFactors = FALSE) - - -# Gridcell is the top-level container, start parsing from there -beg_end <- serialize_starts_ends(file_in = guesscpp_in, pattern = "void Gridcell::serialize") - -# now we will parse the stuff between these lines -# first find what is being written -streamed_vars_gridcell <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + return(line_no) +} # find_closing -################################## CAUTION : THE FOLLOWING IS A MONSTROUS NESTED-LOOP ################################## -# Now I can use streamed_vars_gridcell to loop over them -# We read everything in this loop, Gridcell list is going to be the top container -# there will be nested loops, the hierarchy will follow LPJ-GUESS architecture -Gridcell <- list() -level <- "Gridcell" -for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts - current_stream <- streamed_vars_gridcell[g_i] - if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard - if(grepl(glob2rx("(*this)[*].landcover"), current_stream)){ # s counter might change, using wildcard - # not sure how to handle this better. If we see this, it means we are now looping over Stands - # this function considers "NATURAL" vegetation only, so there is only one stand - # this is an integer that tells us which landcover type this stand is - # so it should be the indice of NATURAL in typedef enum landcovertype (I believe indexing starts from 0) - - num_stnd <- as.numeric(Gridcell$nstands) - Gridcell[["Stand"]] <- vector("list", num_stnd) +#' @export +# helper function that determines the stream size to read +find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS){ + + possible_types <- c("double ", "bool ", "int " , "long ") # space because these can be part of other words + possible_types <- c(possible_types, LPJ_GUESS_TYPES) + n_sizes <- c(8, 1, 4, 8, rep(4, length(LPJ_GUESS_TYPES) )) + rbin_tbl <- c("double", "logical", "integer", "integer", rep("integer", length(LPJ_GUESS_TYPES))) + + specs <- list() + + sub_string <- current_stream_type$substring + + #is there a ; immediately after? + if(grepl(paste0(current_stream_type$type, " ", current_stream_type$name, ";"), sub_string, fixed = TRUE) | + grepl(paste0(current_stream_type$type, " ", current_stream_type$name, ","), sub_string, fixed = TRUE)){ # e.g. "double alag, exp_alag;" + # this is only length 1 + specs$n <- 1 + specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + specs$single <- TRUE - # note that this is streamed under Gridcell, not Stand in guess.cpp, - # but I think this info needs to go together with the Stand sublist - # so prepend landcovertype to the streamed_vars_stand + }else if(current_stream_type$type == "Historic"){ + possible_types <- c("double", "bool", "int" , "long") # # I haven't seen any Historic that doesn't store double but... historic has a comma after type: double, + possible_types <- c(possible_types, LPJ_GUESS_TYPES) - next - } - - # "(*this)[*]" points to different things under different levels, here it is stand - if(grepl(glob2rx("(*this)[*]"), current_stream)){ # note that first else-part will be evaluated considering the order in guess.cpp + # Historic types are special to LPJ-GUESS + # They have stored values, current index, and a boolean in that order + specs$n <- specs$what <- specs$size <- specs$names <- rep(NA, 3) + # always three, this is a type defined in guessmath.h + specs$what[1] <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + specs$size[1] <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + specs$names[1] <- current_stream_type$name + # n is tricky, it can be hardcoded it can be one of the const ints + to_read <- str_match(sub_string, paste0("Historic<", specs$what[1], ", (.*?)>.*"))[,2] + if(to_read %in% LPJ_GUESS_CONST_INTS$var){ + specs$n <- LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var == to_read] + }else{ + specs$n[1] <- as.numeric(to_read) + } + specs$what[2] <- "integer" #need to check what size_t is + specs$size[2] <- 8 + specs$n[2] <- 1 + specs$names[2] <- "current_index" - # STAND - level <- "Stand" - current_stream <- "Stand" - current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + specs$what[3] <- "logical" + specs$size[3] <- 1 + specs$n[3] <- 1 + specs$names[3] <- "full" - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void ", - tools::toTitleCase(current_stream_type$name), - "::serialize")) - streamed_vars_stand <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - streamed_vars_stand <- c("landcover", streamed_vars_stand) # prepending landcovertype to the streamed_vars_stand + specs$single <- FALSE + }else if(current_stream_type$type == "struct"){ + if(current_stream_type$name != "solvesom"){ + PEcAn.logger::logger.debug("Another struct type.") + } + #for now hardcoding this will be back + # specs$n <- specs$what <- specs$size <- specs$names <- rep(NA, 2) + # specs$what[1] <- "double" + # specs$size[1] <- 8 + # specs$names[1] <- "clitter" + # specs$n[1] <- 12 #NSOMPOOL + # + # specs$what[2] <- "double" + # specs$size[2] <- 8 + # specs$names[2] <- "nlitter" + # specs$n[2] <- 12 #NSOMPOOL + # + # LOOKS LIKE THIS ONE IS NOT SERIALIZED PROPERLY + # just return 8 - for(stnd_i in seq_len(num_stnd)){ #looping over the stands - for(svs_i in seq_along(streamed_vars_stand)){ # looping over the streamed stand vars - - current_stream <- streamed_vars_stand[svs_i] - if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard - - if(current_stream == "nobj" & level == "Stand"){ - # nobj points to different things under different levels, here it is the number of patches - # number of patches is set through insfiles, read by write.configs and passed to this fcn - # but it's also written to the state file, need to move bytes - nofpatch <- readBin(zz, integer(), 1, size = 4) - if(npatches == nofpatch){ # also not a bad place to check if everything is going fine so far - Gridcell[["Stand"]][[stnd_i]]$npatches <- npatches - #Gridcell[["Stand"]] <- vector("list", npatches) - }else{ - PEcAn.logger::logger.severe("The number of patches set through the instruction file does not match the number read from the state files. Probably a bug in the read.state function! Terminating.") - } - next - } - - # "(*this)[*]" points to different things under different levels, here it is patch - if(grepl(glob2rx("(*this)[*]"), current_stream)){ - # PATCH - level <- "Patch" - current_stream <- "Patch" - current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void ", - tools::toTitleCase(current_stream_type$name), - "::serialize")) - streamed_vars_patch <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - - Gridcell[["Stand"]][[stnd_i]][["Patch"]] <- vector("list", npatches) - - for(ptch_i in seq_len(npatches)){ #looping over the patches - for(svp_i in seq_along(streamed_vars_patch)){ #looping over the streamed patch vars - current_stream <- streamed_vars_patch[svp_i] - if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard - - if(tools::toTitleCase(current_stream) %in% LPJ_GUESS_CLASSES){ - current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - }else{ - current_stream_type <- find_stream_type("Patch", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - } - - - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[length(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])+1]] <- list() - names(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])[length(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])] <- current_stream_type$name - - if(current_stream_type$type == "class"){ - - # CLASS - class_name <- current_stream_type$name - - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void ", - tools::toTitleCase(current_stream_type$name), - "::serialize")) - - - if(class_name == "Vegetation"){ - # VEGETATION - # Vegetation class has a bit of a different structure, it has one more depth, see model documentation - streamed_vars_veg <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - - # NOTE : Unlike other parts, this bit is a lot less generalized!!! - # I'm gonna asumme Vegetation class won't change much in the future - # indiv.pft.id and indiv needs to be looped over nobj times - if(!setequal(streamed_vars_veg, c("nobj", "indiv.pft.id", "indiv"))){ - PEcAn.logger::logger.severe("Vegetation class object changed in this model version, you need to fix read.state") - } + + specs$n <- 1 + specs$what <- "integer" + specs$size <- 8 + specs$single <- TRUE + + }else if(grepl(glob2rx(paste0(current_stream_type$type, "*", current_stream_type$name, ";")), sub_string)){ + + # this is only length 1 + specs$n <- 1 + specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + specs$single <- TRUE + + }else if(length(regmatches(sub_string, gregexpr("\\[.+?\\]", sub_string))[[1]]) > 1){ + #looks like we have a matrix + spec_dims <- regmatches(sub_string, gregexpr("\\[.+?\\]", sub_string))[[1]] + spec_dims <- gsub("\\].*", "", gsub(".*\\[", "", spec_dims)) + for(spec_dims_i in seq_along(spec_dims)){ + if(any(sapply(LPJ_GUESS_CONST_INTS$var, grepl, spec_dims[spec_dims_i], fixed = TRUE))){ # uses one of the constant ints + spec_dims[spec_dims_i] <- LPJ_GUESS_CONST_INTS$val[sapply(LPJ_GUESS_CONST_INTS$var, grepl, spec_dims[spec_dims_i], fixed = TRUE)] + }else{ + spec_dims[spec_dims_i] <- as.numeric(sub(".*\\[(.*)\\].*", "\\1", spec_dims[spec_dims_i], perl=TRUE)) + } + } + spec_dims <- as.numeric(spec_dims) + + specs$n <- prod(spec_dims) + specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + specs$single <- TRUE + }else{ + # reading a vector + specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + if(any(sapply(LPJ_GUESS_CONST_INTS$var, grepl, sub_string, fixed = TRUE))){ # uses one of the constant ints + specs$n <- LPJ_GUESS_CONST_INTS$val[sapply(LPJ_GUESS_CONST_INTS$var, grepl, sub_string, fixed = TRUE)] + }else{ + specs$n <- as.numeric(sub(".*\\[(.*)\\].*", "\\1", sub_string, perl=TRUE)) + } + + specs$single <- TRUE + } + + return(specs) +} # find_stream_size - # nobj points to different things under different levels, here it is the number of individuals - number_of_individuals <- readBin(zz, integer(), 1, size = 4) - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["number_of_individuals"]] <- number_of_individuals - - # few checks for sensible vals - if(number_of_individuals < 1 | number_of_individuals > 10000){ # should there be an upper limit here too? - # if number of individuals is 0 it's a bit suspicious. Not sure if ever will get negative but that'd definitely be wrong - PEcAn.logger::logger.warn("Number of individuals under vegetation is", number_of_individuals) - } - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]] <- vector("list", number_of_individuals) - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void Individual::serialize")) - streamed_vars_indv <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - - # loop over nobj - for(indv_i in seq_len(number_of_individuals)){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]] <- list() - # which PFT is this? - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][["indiv.pft.id"]] <- readBin(zz, integer(), 1, size = 4) - # read all the individual class - for(svi_i in seq_along(streamed_vars_indv)){ # - current_stream <- streamed_vars_indv[svi_i] - - current_stream_type <- find_stream_type("individual", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - - if(current_stream_specs$single){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][[current_stream_type$name]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ - for(css.i in seq_along(current_stream_specs$what)){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, - what = current_stream_specs$what[css.i], - n = current_stream_specs$n[css.i], - size = current_stream_specs$size[css.i]) - } - } - - }# end loop over stream vars individual - } # end loop over number_of_individuals - - - - - - }else if(class_name == "Fluxes"){ - # FLUXES - # this is not generalized at all - streamed_vars_flux <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) +# helper function to decide the type of the stream +# this function relies on the architecture of LPJ-GUESS and has bunch of harcoded checks, see model documentation +find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in){ + + if(current_stream_var == "seed"){ # a bit of a special case + return(list(type = "long", name = "seed", substring = "long seed;")) + } + + if(current_stream_var == "nstands"){ # a bit of a special case, it is read by guess.cpp + return(list(type = "int", name = "nstands", substring = "int nstands;")) #there is not substring like that in guess.h + } + + if(current_stream_var == "landcover"){ # a bit of a special case + return(list(type = "landcovertype", name = "landcover", substring = "landcovertype landcover;")) + } + + # it might be difficult to extract the "type" before the varname + # there are not that many to check + possible_types <- c("class ", "double ", "bool ", "int ") + + possible_types <- c(possible_types, LPJ_GUESS_TYPES) + + beg_end <- NULL # not going to need it always + + # class or not? + if(tools::toTitleCase(current_stream_var) %in% LPJ_GUESS_CLASSES){ + stream_type <- "class" + stream_name <- tools::toTitleCase(current_stream_var) + sub_string <- NULL + }else {# find type from guess.h + + if(is.null(class)){ + sub_string <- guessh_in[grepl(paste0(" ", current_stream_var), guessh_in, fixed = TRUE)] + }else{ + beg_end <- serialize_starts_ends(file_in = guessh_in, + pattern = paste0("class ", + tools::toTitleCase(class), + " : public ")) + # subset + sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var, ";"), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] + } + + if(length(sub_string) == 0){ + sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] + } + # e.g. "sompool[i]" in guess.cpp, Sompool sompool[NSOMPOOL]; in guess.h + if(length(sub_string) == 0){ + current_stream_var <- gsub("\\[|.\\]", "", current_stream_var) + sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] + if(tools::toTitleCase(current_stream_var) %in% LPJ_GUESS_CLASSES){ + stream_type <- "class" + stream_name <- current_stream_var + sub_string <- NULL + return(list(type = gsub(" ", "", stream_type), name = stream_name, substring = sub_string)) + } + } + if(length(sub_string) == 0){ + sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(",", current_stream_var), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] + } + if(length(sub_string) > 1){ + + # some varnames are very common characters unfortunately like u, v... check if [] comes after + if(any(grepl(paste0(" ", current_stream_var, "["), sub_string, fixed = TRUE))){ + sub_string <- sub_string[grepl(paste0(" ", current_stream_var, "["), sub_string, fixed = TRUE)] + }else if(any(grepl(paste0("double ", current_stream_var), sub_string, fixed = TRUE))){ # just fishing, double is the most common type + sub_string <- sub_string[grepl(paste0("double ", current_stream_var), sub_string, fixed = TRUE)] + }else if(any(grepl("///", sub_string, fixed = TRUE))){ # three slashes are very common in commented out code + sub_string <- sub_string[!grepl("///", sub_string, fixed = TRUE)] + } + + if(length(unique(sub_string)) == 1){ + sub_string <- unique(sub_string) + }else{ + PEcAn.logger::logger.severe("Check this out.") + } + } + + # clean from tabs + sub_string <- gsub("\t", "", sub_string) + # clean from commented out lines? + + if(grepl("Historic", sub_string, fixed = TRUE)){ + # Historic types has the form Historic& data) + stream_type <- "Historic" + stream_name <- current_stream_var + }else if(grepl("std::vector", sub_string, fixed = TRUE)){ + stream_type <- "struct" + stream_name <- current_stream_var + }else{ + stream_type <- possible_types[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + stream_name <- current_stream_var + } + + } + + return(list(type = gsub(" ", "", stream_type), name = stream_name, substring = sub_string)) +} # find_stream_type + + +###################################### READ STATE + +library(stringr) + +# this fcn is for potential natural vegetation only +# when there is landcover, there will be more stand types + +# also for cohort mode only + +# Gridcell: Top-level object containing all dynamic and static data for a particular gridcell +# Gridcellpft: Object containing data common to all individuals of a particular PFT in a particular gridcell +# Gridcellst : Object containing data common to all stands of a particular stand type (ST) in a particular gridcell +# Climate : Contains all static and dynamic data relating to the overall environmental properties, other than soil properties, of a gridcell +# Soiltype : Stores soil static parameters. One object of class Soiltype is defined for each gridcell. +# Stand : Object containing all dynamic and static data for a particular stand +# Patch : Stores data specific to a patch. In cohort and individual modes, replicate patches are required in each stand to accommodate stochastic variation across the site. +# Patchpft : Object containing data common to all individuals of a particular PFT in a particular patch, including litter pools. +# Vegetation : A dynamic list of Individual objects, representing the vegetation of a particular patch +# Soil : Stores state variables for soils and the snow pack. One object of class Soil is defined for each patch. +# Fluxes : The Fluxes class stores accumulated monthly and annual fluxes. One object of type Fluxes is defined for each patch. +# Individual : Stores state variables for an average individual plant. In cohort mode, it is the average individual of a cohort of plants approximately the same age and from the same patch. + +# maybe put guess.h and guess.cpp for each model version into the model package +guesscpp_loc <- "/fs/data5/pecan.models/LPJ-GUESS/framework/guess.cpp" +guessh_loc <- "/fs/data5/pecan.models/LPJ-GUESS/framework/guess.h" +paramh_loc <- "/fs/data5/pecan.models/LPJ-GUESS/framework/parameters.h" + +# guess.cpp has the info of what is being written +guesscpp_in <- readLines(guesscpp_loc) +# guess.h has the types so that we know what streamsize to read +guessh_in <- readLines(guessh_loc) +# parameters.h has some more types +paramh_in <- readLines(paramh_loc) + +############ open + +# test path +out.path = "/fs/data2/output/PEcAn_1000002393/out/1000458390" +setwd(out.path) + +###################################### +## read meta.bin +# not sure if the content will change under guessserializer.cpp +meta_data <- list() +meta_bin_con <- file("meta.bin", "rb") +meta_data$num_processes <- readBin(meta_bin_con, integer(), 1, size = 4) +meta_data$vegmode <- readBin(meta_bin_con, integer(), 1, size = 4) +meta_data$npft <- readBin(meta_bin_con, integer(), 1, size = 4) +meta_data$pft <- list() +for(i in seq_len(meta_data$npft)){ + char_len <- readBin(meta_bin_con, integer(), 1, size = 8) + meta_data$pft[[i]] <- readChar(meta_bin_con, char_len) +} +close(meta_bin_con) + +# open connection to the binary state file +zz <- file("0.state", "rb") + +### these are the values read from params.ins, passed to this fcn +n_pft <- meta_data$npft +npatches <- 5 + +################################ check class compatibility ################################ +# between model versions we don't expect major classes or hierarchy to change +# but give check and fail if necessary +LPJ_GUESS_CLASSES <- c("Gridcell", "Climate", "Gridcellpft", "Stand", "Standpft", "Patch", "Patchpft", + "Individual", "Soil", "Sompool", "Fluxes", "Vegetation") + +lpjguess_classes <- list() +ctr <- 1 +# NOTE THAT THESE PATTERNS ASSUME SOME CODING STYLE, thanks to LPJ-GUESS developers this might not be an issue in the future +for(i in seq_along(guessh_in)){ + # search for "class XXX : public Serializable {" + res <- str_match(guessh_in[i], "class (.*?) : public Serializable") + if(is.na(res[,2])){ + # try "class XXX : public ..., public Serializable {" pattern + res <- str_match(guessh_in[i], "class (.*?) : public .* Serializable") + } + if(!is.na(res[,2])){ + lpjguess_classes[[ctr]] <- res[,2] + ctr <- ctr + 1 + } +} + +# all match? +if(!setequal(unlist(lpjguess_classes), LPJ_GUESS_CLASSES)){ + PEcAn.logger::logger.severe("This function can only read the following class objects: ", paste(LPJ_GUESS_CLASSES, collapse="--")) +} + +# there are couple of LPJ-GUESS specific types that we'll need below +lpjguess_types <- list() +ctr <- 1 +for(i in seq_along(guessh_in)){ + if(grepl("typedef enum {", guessh_in[i], fixed = TRUE)){ + this_line <- find_closing("}", i, guessh_in) + l_type <- gsub(".*}(.*?);.*", "\\1", guessh_in[this_line]) + l_type <- gsub(" ", "", l_type) + lpjguess_types[[ctr]] <- l_type + ctr <- ctr + 1 + } +} +for(i in seq_along(paramh_in)){ #do same for parameters.h + if(grepl("typedef enum {", paramh_in[i], fixed = TRUE)){ + this_line <- find_closing("}", i, paramh_in) + l_type <- gsub(".*}(.*?);.*", "\\1", paramh_in[this_line]) + l_type <- gsub(" ", "", l_type) + lpjguess_types[[ctr]] <- l_type + ctr <- ctr + 1 + } +} +LPJ_GUESS_TYPES <- unlist(lpjguess_types) + + +lpjguess_consts <- list() +ctr <- 1 +for(i in seq_along(guessh_in)){ + if(grepl("const int ", guessh_in[i], fixed = TRUE)){ # probably won't need "const double"s + cnst_val <- gsub(".*=(.*?);.*", "\\1", guessh_in[i]) + cnst_val <- gsub(" ", "", cnst_val) # get rid of the space if there is one + cnst_nam <- gsub(".*int(.*?)=.*", "\\1", guessh_in[i]) + cnst_nam <- gsub(" ", "", cnst_nam) + lpjguess_consts[[ctr]] <- cnst_val + names(lpjguess_consts)[ctr] <- cnst_nam + ctr <- ctr + 1 + } +} +# few cleaning +dont_need <- c("COLDEST_DAY_NHEMISPHERE", "COLDEST_DAY_SHEMISPHERE", "WARMEST_DAY_NHEMISPHERE", "WARMEST_DAY_SHEMISPHERE", "data[]") +lpjguess_consts[match(dont_need, names(lpjguess_consts))] <- NULL +# this needs to be extracted from parameters.h:48-49 or somewhere else, but hardcoding for now +lpjguess_consts$NLANDCOVERTYPES <- 6 +# this needs to be extracted from guess.h:94 , but hardcoding for now +lpjguess_consts$NSOMPOOL <- 12 +# this needs to be extracted from guess.h:644 , but hardcoding for now NOTE that new versions has 13 flux types +lpjguess_consts$PerPatchFluxType <- 12 +# this needs to be extracted from guess.h:659 , but hardcoding for now +lpjguess_consts$PerPFTFluxType <- 5 +LPJ_GUESS_CONST_INTS <- data.frame(var = names(lpjguess_consts), val = as.numeric(unlist(lpjguess_consts)), stringsAsFactors = FALSE) + + +# Gridcell is the top-level container, start parsing from there +beg_end <- serialize_starts_ends(file_in = guesscpp_in, pattern = "void Gridcell::serialize") + +# now we will parse the stuff between these lines +# first find what is being written +streamed_vars_gridcell <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + +################################## CAUTION : THE FOLLOWING IS A MONSTROUS NESTED-LOOP ################################## + +# Now I can use streamed_vars_gridcell to loop over them +# We read everything in this loop, Gridcell list is going to be the top container +# there will be nested loops, the hierarchy will follow LPJ-GUESS architecture +Gridcell <- list() +level <- "Gridcell" +for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts + current_stream <- streamed_vars_gridcell[g_i] + if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard + if(grepl(glob2rx("(*this)[*].landcover"), current_stream)){ # s counter might change, using wildcard + # not sure how to handle this better. If we see this, it means we are now looping over Stands + # this function considers "NATURAL" vegetation only, so there is only one stand + # this is an integer that tells us which landcover type this stand is + # so it should be the indice of NATURAL in typedef enum landcovertype (I believe indexing starts from 0) + + num_stnd <- as.numeric(Gridcell$nstands) + Gridcell[["Stand"]] <- vector("list", num_stnd) + + # note that this is streamed under Gridcell, not Stand in guess.cpp, + # but I think this info needs to go together with the Stand sublist + # so prepend landcovertype to the streamed_vars_stand + + next + } + + # "(*this)[*]" points to different things under different levels, here it is stand + if(grepl(glob2rx("(*this)[*]"), current_stream)){ # note that first else-part will be evaluated considering the order in guess.cpp + + # STAND + level <- "Stand" + current_stream <- "Stand" + current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + + beg_end <- serialize_starts_ends(file_in = guesscpp_in, + pattern = paste0("void ", + tools::toTitleCase(current_stream_type$name), + "::serialize")) + streamed_vars_stand <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + streamed_vars_stand <- c("landcover", streamed_vars_stand) # prepending landcovertype to the streamed_vars_stand + + + for(stnd_i in seq_len(num_stnd)){ #looping over the stands + for(svs_i in seq_along(streamed_vars_stand)){ # looping over the streamed stand vars + + current_stream <- streamed_vars_stand[svs_i] + if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard + + if(current_stream == "nobj" & level == "Stand"){ + # nobj points to different things under different levels, here it is the number of patches + # number of patches is set through insfiles, read by write.configs and passed to this fcn + # but it's also written to the state file, need to move bytes + nofpatch <- readBin(zz, integer(), 1, size = 4) + if(npatches == nofpatch){ # also not a bad place to check if everything is going fine so far + Gridcell[["Stand"]][[stnd_i]]$npatches <- npatches + #Gridcell[["Stand"]] <- vector("list", npatches) + }else{ + PEcAn.logger::logger.severe("The number of patches set through the instruction file does not match the number read from the state files. Probably a bug in the read.state function! Terminating.") + } + next + } + + # "(*this)[*]" points to different things under different levels, here it is patch + if(grepl(glob2rx("(*this)[*]"), current_stream)){ + # PATCH + level <- "Patch" + current_stream <- "Patch" + current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + + beg_end <- serialize_starts_ends(file_in = guesscpp_in, + pattern = paste0("void ", + tools::toTitleCase(current_stream_type$name), + "::serialize")) + streamed_vars_patch <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + + Gridcell[["Stand"]][[stnd_i]][["Patch"]] <- vector("list", npatches) + + for(ptch_i in seq_len(npatches)){ #looping over the patches + for(svp_i in seq_along(streamed_vars_patch)){ #looping over the streamed patch vars + current_stream <- streamed_vars_patch[svp_i] + if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard + + if(tools::toTitleCase(current_stream) %in% LPJ_GUESS_CLASSES){ + current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + }else{ + current_stream_type <- find_stream_type("Patch", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + } + + + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[length(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])+1]] <- list() + names(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])[length(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])] <- current_stream_type$name + + if(current_stream_type$type == "class"){ + + # CLASS + class_name <- current_stream_type$name + + beg_end <- serialize_starts_ends(file_in = guesscpp_in, + pattern = paste0("void ", + tools::toTitleCase(current_stream_type$name), + "::serialize")) + + + if(class_name == "Vegetation"){ + # VEGETATION + # Vegetation class has a bit of a different structure, it has one more depth, see model documentation + streamed_vars_veg <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + + # NOTE : Unlike other parts, this bit is a lot less generalized!!! + # I'm gonna asumme Vegetation class won't change much in the future + # indiv.pft.id and indiv needs to be looped over nobj times + if(!setequal(streamed_vars_veg, c("nobj", "indiv.pft.id", "indiv"))){ + PEcAn.logger::logger.severe("Vegetation class object changed in this model version, you need to fix read.state") + } + + # nobj points to different things under different levels, here it is the number of individuals + number_of_individuals <- readBin(zz, integer(), 1, size = 4) + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["number_of_individuals"]] <- number_of_individuals + + # few checks for sensible vals + if(number_of_individuals < 1 | number_of_individuals > 10000){ # should there be an upper limit here too? + # if number of individuals is 0 it's a bit suspicious. Not sure if ever will get negative but that'd definitely be wrong + PEcAn.logger::logger.warn("Number of individuals under vegetation is", number_of_individuals) + } + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]] <- vector("list", number_of_individuals) + + beg_end <- serialize_starts_ends(file_in = guesscpp_in, + pattern = paste0("void Individual::serialize")) + streamed_vars_indv <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + + # loop over nobj + for(indv_i in seq_len(number_of_individuals)){ + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]] <- list() + # which PFT is this? + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][["indiv.pft.id"]] <- readBin(zz, integer(), 1, size = 4) + # read all the individual class + for(svi_i in seq_along(streamed_vars_indv)){ # + current_stream <- streamed_vars_indv[svi_i] + + current_stream_type <- find_stream_type("individual", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) + + if(current_stream_specs$single){ + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][[current_stream_type$name]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + }else{ + for(css.i in seq_along(current_stream_specs$what)){ + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, + what = current_stream_specs$what[css.i], + n = current_stream_specs$n[css.i], + size = current_stream_specs$size[css.i]) + } + } + + }# end loop over stream vars individual + } # end loop over number_of_individuals + + + + + + }else if(class_name == "Fluxes"){ + # FLUXES + # this is not generalized at all + streamed_vars_flux <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) if(!setequal(streamed_vars_flux, c("annual_fluxes_per_pft", "monthly_fluxes_patch", "monthly_fluxes_pft"))){ PEcAn.logger::logger.severe("Fluxes class object changed in this model version, you need to fix read.state") @@ -446,505 +788,172 @@ for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts } } }# end if-class within Patch - } - } - - }else{ - # NOT PATCH - - if(tools::toTitleCase(current_stream) %in% LPJ_GUESS_CLASSES){ - current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - }else{ - current_stream_type <- find_stream_type("Stand", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - } - - Gridcell[["Stand"]][[stnd_i]][[length(Gridcell[["Stand"]][[stnd_i]])+1]] <- list() - names(Gridcell[["Stand"]][[stnd_i]])[length(Gridcell[["Stand"]][[stnd_i]])] <- current_stream_type$name - - if(current_stream_type$type == "class"){ - - # CLASS - class_name <- current_stream_type$name - - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void ", - tools::toTitleCase(current_stream_type$name), - "::serialize")) - streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) - - for(varname in streamed_vars){ - Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]][[varname]] <- varname - Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]][[varname]] <- vector("list", num_pft) - } - - for(pft_i in seq_len(num_pft)){ - for(sv_i in seq_along(streamed_vars)){ - current_stream <- streamed_vars[sv_i] #it's OK to overwrite - current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - - if(current_stream_type$type == "class"){ - - # CLASS, NOT EVER GOING HERE? - class_name <- current_stream_type$name - - }else{ - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - # and read! - if(current_stream_specs$single){ - Gridcell[["Stand"]][[stnd_i]][[length(Gridcell[["Stand"]][[stnd_i]])]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ - for(css.i in seq_along(current_stream_specs$what)){ - Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, - what = current_stream_specs$what[css.i], - n = current_stream_specs$n[css.i], - size = current_stream_specs$size[css.i]) - } - } - } - } # streamed_vars-loop ends - } # pft-loop ends - - }else{ - # NOT CLASS - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - # and read! - if(current_stream_specs$single){ - Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ # probably don't need this but let's keep - for(css_i in seq_along(current_stream_specs$what)){ - Gridcell[[length(Gridcell)]][[current_stream_specs$names[css_i]]] <- readBin(con = zz, - what = current_stream_specs$what[css_i], - n = current_stream_specs$n[css_i], - size = current_stream_specs$size[css_i]) - } - } - }# end if-class within Stand - } # end patch-if - - - }# end for-loop over the streamed stand vars (svs_i, L.165) - }# end for-loop over the stands (stnd_i, L.164) - - }else{ #not reading in Stand variables - - # NOT STAND - - current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - - Gridcell[[length(Gridcell)+1]] <- list() - names(Gridcell)[length(Gridcell)] <- current_stream_type$name - if(current_stream_type$type == "class"){ - - # CLASS - class_name <- current_stream_type$name - - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void ", - tools::toTitleCase(current_stream_type$name), - "::serialize")) - streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) - - for(varname in streamed_vars){ - Gridcell[[length(Gridcell)]][[varname]] <- varname - Gridcell[[length(Gridcell)]][[varname]] <- vector("list", num_pft) - } - - for(pft_i in seq_len(num_pft)){ - for(sv_i in seq_along(streamed_vars)){ - #for(sv_i in 21:37){ - current_stream <- streamed_vars[sv_i] #it's OK to overwrite - current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + } + } + + }else{ + # NOT PATCH + + if(tools::toTitleCase(current_stream) %in% LPJ_GUESS_CLASSES){ + current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + }else{ + current_stream_type <- find_stream_type("Stand", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + } + + Gridcell[["Stand"]][[stnd_i]][[length(Gridcell[["Stand"]][[stnd_i]])+1]] <- list() + names(Gridcell[["Stand"]][[stnd_i]])[length(Gridcell[["Stand"]][[stnd_i]])] <- current_stream_type$name if(current_stream_type$type == "class"){ - # CLASS, NOT EVER GOING HERE? + # CLASS class_name <- current_stream_type$name - }else{ - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - # and read! - if(current_stream_specs$single){ - Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ - for(css.i in seq_along(current_stream_specs$what)){ - Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, - what = current_stream_specs$what[css.i], - n = current_stream_specs$n[css.i], - size = current_stream_specs$size[css.i]) - } + beg_end <- serialize_starts_ends(file_in = guesscpp_in, + pattern = paste0("void ", + tools::toTitleCase(current_stream_type$name), + "::serialize")) + streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) + + for(varname in streamed_vars){ + Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]][[varname]] <- varname + Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]][[varname]] <- vector("list", num_pft) } - } - } # streamed_vars-loop ends - } # pft-loop ends - - }else{ - # NOT CLASS - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - # and read! - if(current_stream_specs$single){ - Gridcell[[length(Gridcell)]][[current_stream_type$name]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ # probably don't need this but let's keep - for(css_i in seq_along(current_stream_specs$what)){ - Gridcell[[length(Gridcell)]][[current_stream_specs$names[css_i]]] <- readBin(con = zz, - what = current_stream_specs$what[css_i], - n = current_stream_specs$n[css_i], - size = current_stream_specs$size[css_i]) - } - } - }# end if-class within Gridcell - - } # Stand if-else ends -} # Gridcell-loop ends - -# helper function that determines the stream size to read -find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS){ - - possible_types <- c("double ", "bool ", "int " , "long ") # space because these can be part of other words - possible_types <- c(possible_types, LPJ_GUESS_TYPES) - n_sizes <- c(8, 1, 4, 8, rep(4, length(LPJ_GUESS_TYPES) )) - rbin_tbl <- c("double", "logical", "integer", "integer", rep("integer", length(LPJ_GUESS_TYPES))) - - specs <- list() - - sub_string <- current_stream_type$substring - - #is there a ; immediately after? - if(grepl(paste0(current_stream_type$type, " ", current_stream_type$name, ";"), sub_string, fixed = TRUE) | - grepl(paste0(current_stream_type$type, " ", current_stream_type$name, ","), sub_string, fixed = TRUE)){ # e.g. "double alag, exp_alag;" - # this is only length 1 - specs$n <- 1 - specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$single <- TRUE - - }else if(current_stream_type$type == "Historic"){ - possible_types <- c("double", "bool", "int" , "long") # # I haven't seen any Historic that doesn't store double but... historic has a comma after type: double, - possible_types <- c(possible_types, LPJ_GUESS_TYPES) - - # Historic types are special to LPJ-GUESS - # They have stored values, current index, and a boolean in that order - specs$n <- specs$what <- specs$size <- specs$names <- rep(NA, 3) - # always three, this is a type defined in guessmath.h - specs$what[1] <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$size[1] <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$names[1] <- current_stream_type$name - # n is tricky, it can be hardcoded it can be one of the const ints - to_read <- str_match(sub_string, paste0("Historic<", specs$what[1], ", (.*?)>.*"))[,2] - if(to_read %in% LPJ_GUESS_CONST_INTS$var){ - specs$n <- LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var == to_read] - }else{ - specs$n[1] <- as.numeric(to_read) - } - specs$what[2] <- "integer" #need to check what size_t is - specs$size[2] <- 8 - specs$n[2] <- 1 - specs$names[2] <- "current_index" - - specs$what[3] <- "logical" - specs$size[3] <- 1 - specs$n[3] <- 1 - specs$names[3] <- "full" - - specs$single <- FALSE - - }else if(current_stream_type$type == "struct"){ - if(current_stream_type$name != "solvesom"){ - PEcAn.logger::logger.debug("Another struct type.") - } - #for now hardcoding this will be back - # specs$n <- specs$what <- specs$size <- specs$names <- rep(NA, 2) - # specs$what[1] <- "double" - # specs$size[1] <- 8 - # specs$names[1] <- "clitter" - # specs$n[1] <- 12 #NSOMPOOL - # - # specs$what[2] <- "double" - # specs$size[2] <- 8 - # specs$names[2] <- "nlitter" - # specs$n[2] <- 12 #NSOMPOOL - # - # LOOKS LIKE THIS ONE IS NOT SERIALIZED PROPERLY - # just return 8 - - - specs$n <- 1 - specs$what <- "integer" - specs$size <- 8 - specs$single <- TRUE - - }else if(grepl(glob2rx(paste0(current_stream_type$type, "*", current_stream_type$name, ";")), sub_string)){ - - # this is only length 1 - specs$n <- 1 - specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$single <- TRUE - - }else if(length(regmatches(sub_string, gregexpr("\\[.+?\\]", sub_string))[[1]]) > 1){ - #looks like we have a matrix - spec_dims <- regmatches(sub_string, gregexpr("\\[.+?\\]", sub_string))[[1]] - spec_dims <- gsub("\\].*", "", gsub(".*\\[", "", spec_dims)) - for(spec_dims_i in seq_along(spec_dims)){ - if(any(sapply(LPJ_GUESS_CONST_INTS$var, grepl, spec_dims[spec_dims_i], fixed = TRUE))){ # uses one of the constant ints - spec_dims[spec_dims_i] <- LPJ_GUESS_CONST_INTS$val[sapply(LPJ_GUESS_CONST_INTS$var, grepl, spec_dims[spec_dims_i], fixed = TRUE)] - }else{ - spec_dims[spec_dims_i] <- as.numeric(sub(".*\\[(.*)\\].*", "\\1", spec_dims[spec_dims_i], perl=TRUE)) - } - } - spec_dims <- as.numeric(spec_dims) - - specs$n <- prod(spec_dims) - specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$single <- TRUE - }else{ - # reading a vector - specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - if(any(sapply(LPJ_GUESS_CONST_INTS$var, grepl, sub_string, fixed = TRUE))){ # uses one of the constant ints - specs$n <- LPJ_GUESS_CONST_INTS$val[sapply(LPJ_GUESS_CONST_INTS$var, grepl, sub_string, fixed = TRUE)] - }else{ - specs$n <- as.numeric(sub(".*\\[(.*)\\].*", "\\1", sub_string, perl=TRUE)) - } - - specs$single <- TRUE - } - - return(specs) -} # find_stream_size - - -# helper function to decide the type of the stream -# this function relies on the architecture of LPJ-GUESS and has bunch of harcoded checks, see model documentation -find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in){ - - if(current_stream_var == "seed"){ # a bit of a special case - return(list(type = "long", name = "seed", substring = "long seed;")) - } - - if(current_stream_var == "nstands"){ # a bit of a special case, it is read by guess.cpp - return(list(type = "int", name = "nstands", substring = "int nstands;")) #there is not substring like that in guess.h - } - - if(current_stream_var == "landcover"){ # a bit of a special case - return(list(type = "landcovertype", name = "landcover", substring = "landcovertype landcover;")) - } - - # it might be difficult to extract the "type" before the varname - # there are not that many to check - possible_types <- c("class ", "double ", "bool ", "int ") - - possible_types <- c(possible_types, LPJ_GUESS_TYPES) - - beg_end <- NULL # not going to need it always - - # class or not? - if(tools::toTitleCase(current_stream_var) %in% LPJ_GUESS_CLASSES){ - stream_type <- "class" - stream_name <- tools::toTitleCase(current_stream_var) - sub_string <- NULL - }else {# find type from guess.h - - if(is.null(class)){ - sub_string <- guessh_in[grepl(paste0(" ", current_stream_var), guessh_in, fixed = TRUE)] - }else{ - beg_end <- serialize_starts_ends(file_in = guessh_in, - pattern = paste0("class ", - tools::toTitleCase(class), - " : public ")) - # subset - sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var, ";"), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] - } - - if(length(sub_string) == 0){ - sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] - } - # e.g. "sompool[i]" in guess.cpp, Sompool sompool[NSOMPOOL]; in guess.h - if(length(sub_string) == 0){ - current_stream_var <- gsub("\\[|.\\]", "", current_stream_var) - sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] - if(tools::toTitleCase(current_stream_var) %in% LPJ_GUESS_CLASSES){ - stream_type <- "class" - stream_name <- current_stream_var - sub_string <- NULL - return(list(type = gsub(" ", "", stream_type), name = stream_name, substring = sub_string)) - } - } - if(length(sub_string) == 0){ - sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(",", current_stream_var), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] - } - if(length(sub_string) > 1){ + + for(pft_i in seq_len(num_pft)){ + for(sv_i in seq_along(streamed_vars)){ + current_stream <- streamed_vars[sv_i] #it's OK to overwrite + current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + + if(current_stream_type$type == "class"){ + + # CLASS, NOT EVER GOING HERE? + class_name <- current_stream_type$name + + }else{ + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) + # and read! + if(current_stream_specs$single){ + Gridcell[["Stand"]][[stnd_i]][[length(Gridcell[["Stand"]][[stnd_i]])]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + }else{ + for(css.i in seq_along(current_stream_specs$what)){ + Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, + what = current_stream_specs$what[css.i], + n = current_stream_specs$n[css.i], + size = current_stream_specs$size[css.i]) + } + } + } + } # streamed_vars-loop ends + } # pft-loop ends + + }else{ + # NOT CLASS + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) + # and read! + if(current_stream_specs$single){ + Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + }else{ # probably don't need this but let's keep + for(css_i in seq_along(current_stream_specs$what)){ + Gridcell[[length(Gridcell)]][[current_stream_specs$names[css_i]]] <- readBin(con = zz, + what = current_stream_specs$what[css_i], + n = current_stream_specs$n[css_i], + size = current_stream_specs$size[css_i]) + } + } + }# end if-class within Stand + } # end patch-if - # some varnames are very common characters unfortunately like u, v... check if [] comes after - if(any(grepl(paste0(" ", current_stream_var, "["), sub_string, fixed = TRUE))){ - sub_string <- sub_string[grepl(paste0(" ", current_stream_var, "["), sub_string, fixed = TRUE)] - }else if(any(grepl(paste0("double ", current_stream_var), sub_string, fixed = TRUE))){ # just fishing, double is the most common type - sub_string <- sub_string[grepl(paste0("double ", current_stream_var), sub_string, fixed = TRUE)] - }else if(any(grepl("///", sub_string, fixed = TRUE))){ # three slashes are very common in commented out code - sub_string <- sub_string[!grepl("///", sub_string, fixed = TRUE)] - } - - if(length(unique(sub_string)) == 1){ - sub_string <- unique(sub_string) - }else{ - PEcAn.logger::logger.severe("Check this out.") - } - } + + }# end for-loop over the streamed stand vars (svs_i, L.165) + }# end for-loop over the stands (stnd_i, L.164) - # clean from tabs - sub_string <- gsub("\t", "", sub_string) - # clean from commented out lines? + }else{ #not reading in Stand variables - if(grepl("Historic", sub_string, fixed = TRUE)){ - # Historic types has the form Historic& data) - stream_type <- "Historic" - stream_name <- current_stream_var - }else if(grepl("std::vector", sub_string, fixed = TRUE)){ - stream_type <- "struct" - stream_name <- current_stream_var - }else{ - stream_type <- possible_types[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - stream_name <- current_stream_var - } - - } - - return(list(type = gsub(" ", "", stream_type), name = stream_name, substring = sub_string)) -} # find_stream_type - - - - -######################## Helper functions ######################## - -# helper function that lists streamed variables, it just returns the names, types are checked by other fucntion -find_stream_var <- function(file_in, line_nos){ - - streaming_list <- list() - str.i <- 1 - when_here <- NULL - not_skipping <- TRUE - - i <- line_nos[1] - repeat{ - i <- i + 1 - if(!is.null(when_here)){ - if(i == when_here){ - i <- skip_to - when_here <- NULL - } - } + # NOT STAND - # some functions (Vegetation, Patch, Stand, Gridcell) have two modes: saving / reading - # we only need the stream that is saved - if(grepl("arch.save()", file_in[i])){ - when_here <- find_closing("}", i, file_in) - skip_to <- find_closing("}", i, file_in, if_else_check = TRUE) - } + current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - # all streams start with arch & - if(grepl("arch & ", file_in[i])){ - # get variable name - streaming_list[[str.i]] <- sub(".*arch & ", "", file_in[i]) # always one var after arch? - str.i <- str.i + 1 - # check for ampersand for the subsequent variable names - repeat{ - i <- i + 1 - if(!is.null(when_here)){ - if(i == when_here){ - i <- skip_to - when_here <- NULL - } - } - check1 <- !grepl(".*& ", file_in[i]) # when there are no subsequent stream - check2 <- !grepl(".*& ", file_in[i+1]) # sometimes following line is empty or commented, check the next one too - if(check1 & !check2) i <- i+1 - if(check1 & check2) break # looks like there are no subsequent stream - this_line <- gsub("[[:space:]]", "", strsplit(file_in[i], "& ")[[1]]) - for(var in this_line){ - if(var != ""){ - if(var != "arch"){ - streaming_list[[str.i]] <- var - str.i <- str.i + 1 + Gridcell[[length(Gridcell)+1]] <- list() + names(Gridcell)[length(Gridcell)] <- current_stream_type$name + if(current_stream_type$type == "class"){ + + # CLASS + class_name <- current_stream_type$name + + beg_end <- serialize_starts_ends(file_in = guesscpp_in, + pattern = paste0("void ", + tools::toTitleCase(current_stream_type$name), + "::serialize")) + streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) + + for(varname in streamed_vars){ + Gridcell[[length(Gridcell)]][[varname]] <- varname + Gridcell[[length(Gridcell)]][[varname]] <- vector("list", num_pft) + } + + for(pft_i in seq_len(num_pft)){ + for(sv_i in seq_along(streamed_vars)){ + #for(sv_i in 21:37){ + current_stream <- streamed_vars[sv_i] #it's OK to overwrite + current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + + if(current_stream_type$type == "class"){ + + # CLASS, NOT EVER GOING HERE? + class_name <- current_stream_type$name + + }else{ + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) + # and read! + if(current_stream_specs$single){ + Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + }else{ + for(css.i in seq_along(current_stream_specs$what)){ + Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, + what = current_stream_specs$what[css.i], + n = current_stream_specs$n[css.i], + size = current_stream_specs$size[css.i]) + } } } - } - if(!is.null(when_here)){ # now that increased i check this just in case - if(i == when_here){ - i <- skip_to - when_here <- NULL - } + } # streamed_vars-loop ends + } # pft-loop ends + + }else{ + # NOT CLASS + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) + # and read! + if(current_stream_specs$single){ + Gridcell[[length(Gridcell)]][[current_stream_type$name]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + }else{ # probably don't need this but let's keep + for(css_i in seq_along(current_stream_specs$what)){ + Gridcell[[length(Gridcell)]][[current_stream_specs$names[css_i]]] <- readBin(con = zz, + what = current_stream_specs$what[css_i], + n = current_stream_specs$n[css_i], + size = current_stream_specs$size[css_i]) } } - } - if(i == line_nos[2]) break - } - - #unlist and nix the ; - returnin_stream <- gsub(";", "", unlist(streaming_list), fixed = TRUE) - return(returnin_stream) -} # find_stream_var - - - -# helper function that scans LPJ-GUESS that returns the beginning and the ending lines of serialized object -serialize_starts_ends <- function(file_in, pattern = "void Gridcell::serialize"){ - # find the starting line from the given pattern - starting_line <- which(!is.na(str_match(file_in, pattern))) - if(length(starting_line) != 1){ # check what's going on - PEcAn.logger::logger.severe("Couldn't find the starting line with this pattern ***",pattern, "***.") - } + }# end if-class within Gridcell - # screen for the closing curly bracket after function started - # keep track of opening-closing brackets - ending_line <- find_closing(find = "}", starting_line, file_in) + } # Stand if-else ends +} # Gridcell-loop ends - return(c(starting_line, ending_line)) -} # serialize_starts_ends -# helper function that finds the closing bracket, can work over if-else -find_closing <- function(find = "}", line_no, file_in, if_else_check = FALSE){ - opened <- 1 - closed <- 0 - if(find == "}"){ - start_char <- "{" - end_char <- "}" - }else{ - #there can be else-ifs, find closing paranthesis / square breacket etc - } - # check the immediate line and return if closed there already - if(grepl(end_char, file_in[line_no], fixed = TRUE)) return(line_no) - repeat{ - line_no <- line_no + 1 - if(grepl(start_char, file_in[line_no], fixed = TRUE)) opened <- opened + 1 - if(grepl(end_char, file_in[line_no], fixed = TRUE)) closed <- closed + 1 - if(if_else_check){ - else_found <- FALSE - same_line_check <- grepl("else", file_in[line_no], fixed = TRUE) #same line - next_line_check <- grepl("else", file_in[line_no + 1], fixed = TRUE) #next line - if(same_line_check | next_line_check){ - closed <- closed - 1 - if(next_line_check) line_no <- line_no + 1 - } - } - if(opened == closed) break - } - return(line_no) -} # find_closing + From c27d10f1fb5976a540163d6c96449095b6817455 Mon Sep 17 00:00:00 2001 From: istfer Date: Wed, 19 Jun 2019 16:40:08 -0400 Subject: [PATCH 33/56] add new par minmoist_est --- models/lpjguess/inst/lpjguess_params.Rdata | Bin 2280 -> 2316 bytes models/lpjguess/inst/pecan.ins | 1 + 2 files changed, 1 insertion(+) diff --git a/models/lpjguess/inst/lpjguess_params.Rdata b/models/lpjguess/inst/lpjguess_params.Rdata index 887e5566008fdca91685f1f0da6fa31d64c2017f..28c040edd6d042ad5f224c9e5b9163b03e90a29a 100644 GIT binary patch delta 65 zcmaDM*dsK-meFaWoi)qk1x##{{aLssSF(t(GcX7+Ffcf6p2FhGBF)0U3FPqPX6EJQ QXBL;lrxuq0`Tsx|03I3;WdHyG delta 37 rcmeAXdLcN$meFyeoi)qkP8Jb%CI$fp1_sB?OIUna*cll90XhEwxjP9G diff --git a/models/lpjguess/inst/pecan.ins b/models/lpjguess/inst/pecan.ins index 2c4fa18651d..c7931c244fa 100755 --- a/models/lpjguess/inst/pecan.ins +++ b/models/lpjguess/inst/pecan.ins @@ -218,5 +218,6 @@ pft "@pft@" ( seas_iso @seas_iso@ eps_mon @eps_mon@ storfrac_mon @storfrac_mon@ + minmoist_est @minmoist_est@ ) From 645bb7db386c443f72157503fbb0e32600c5f3dd Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Wed, 19 Jun 2019 17:23:23 -0400 Subject: [PATCH 34/56] Allocation of biomass now also works. It seems to fail when scaling biomass down ~0.55 or less. cmass_debt is not included in the calculation and scaled like the other pools. --- ...calculateGridcellVariablePerPFT.LPJGUESS.R | 2 +- ...dual.LPJGUESS.R => updateState.LPJGUESS.R} | 168 ++++++++++++------ models/lpjguess/man/updateState.LPJGUESS.Rd | 2 +- 3 files changed, 117 insertions(+), 55 deletions(-) rename models/lpjguess/R/{updateIndividual.LPJGUESS.R => updateState.LPJGUESS.R} (50%) diff --git a/models/lpjguess/R/calculateGridcellVariablePerPFT.LPJGUESS.R b/models/lpjguess/R/calculateGridcellVariablePerPFT.LPJGUESS.R index 063020a80f7..4cb63b9ad6a 100644 --- a/models/lpjguess/R/calculateGridcellVariablePerPFT.LPJGUESS.R +++ b/models/lpjguess/R/calculateGridcellVariablePerPFT.LPJGUESS.R @@ -68,7 +68,7 @@ calculateGridcellVariablePerPFT <- function(model.state, variable) { # calculate the total cmass and density of individuals per PFT if(variable == "biomass") { gc.sum[this.pft.id+1] <- gc.sum[this.pft.id+1] + ((this.individual$cmass_leaf+this.individual$cmass_root+ - this.individual$cmass_heart+this.individual$cmass_sap)/npatches) + this.individual$cmass_heart+this.individual$cmass_sap-this.individual$cmass_debt)/npatches) } else gc.sum[this.pft.id+1] <- gc.sum[this.pft.id+1] + (this.individual[[variable]]/npatches) diff --git a/models/lpjguess/R/updateIndividual.LPJGUESS.R b/models/lpjguess/R/updateState.LPJGUESS.R similarity index 50% rename from models/lpjguess/R/updateIndividual.LPJGUESS.R rename to models/lpjguess/R/updateState.LPJGUESS.R index 57a8eb2f011..091cc6ab0ab 100644 --- a/models/lpjguess/R/updateIndividual.LPJGUESS.R +++ b/models/lpjguess/R/updateState.LPJGUESS.R @@ -40,8 +40,37 @@ updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, biomass # calculate relative increases to be applied later on (per PFT) dens.rel.change <- dens.target/dens.initial biomass.rel.change <- biomass.target/biomass.initial - print(dens.rel.change) - print(biomass.rel.change) + #print(dens.rel.change) + #print(biomass.rel.change) + + + # hard coded veg parameters for testing + wooddens <- rep(200, 11) + lifeform <- c(1,1,1,1,1,1,1,1,1,2,2) + k_latosa <- c(5000, 5000, 5000, 6000, 6000, 6000, 6000,6000, 6000, 6000, 6000) + k_allom2 <- rep(60, 11) + k_allom3 <- rep(0.67, 11) + leaflong <- c() + leafphysiognomy <- c() + + # get proper SLA + leaflong <- c(3, 3, 0.5, 0.5, 0.5, 3, 2, 2, 0.5, 0.5, 0.5) + leafphysiognomy <- c("NEEDLELEAF", "NEEDLELEAF", "NEEDLELEAF", "BROADLEAF", "BROADLEAF", "BROADLEAF", "BROADLEAF","BROADLEAF", "BROADLEAF", "BROADLEAF", "BROADLEAF") + sla <- c() + getSLA <- function(leaflong, leafphysiognomy) { + if (leafphysiognomy == "BROADLEAF") { + sla = 0.2 * 10.0^(2.41 - 0.38 * log10(12.0 * leaflong)) + } + else if (leafphysiognomy == "NEEDLELEAF") { + sla = 0.2 * 10.0^(2.29 - 0.4 * log10(12.0 * leaflong)) + } + return(sla) + } + + for(temp_counter in 1:length(leaflong)){ + sla <- append(sla, getSLA(leaflong[temp_counter], leafphysiognomy[temp_counter])) + } + # nstands - should always be 1 but lets make sure @@ -69,47 +98,22 @@ updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, biomass this.patch <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]] - # pull out the number of individuals and a list of them - nindividuals <- this.patch$Vegetation$number_of_individuals - all.individuals <- this.patch$Vegetation$Individuals - # for each individual - for(individual.counter in 1:length(all.individuals)) { + for(individual.counter in 1:this.patch$Vegetation$number_of_individuals) { - this.individual <- all.individuals[[individual.counter]] + # IMPORTANT: note that this is for convenience to *read* variables from an individual but not write to + # it also needs to be updated after the main state (model.state) is updated + this.individual <- this.patch$Vegetation$Individuals[[individual.counter]] if(this.individual$alive) { this.pft.id <- this.individual$indiv.pft.id - print(paste("PFT id = ", this.pft.id)) + #print(paste("PFT id = ", this.pft.id)) if(!this.pft.id %in% active.PFTs) stop(paste0("Found individual of PFT id = ",this.pft.id, " but this doesn't seem to be active in the LPJ-GUESS run")) - # STEP 0 - store the initial C-N ratios which we will use to magic up some new N to maintain the C-N ratios of the initial state - cton_leaf <- this.individual$cmass_leaf/this.individual$nmass_leaf - print("leaf") - print(cton_leaf) - print(this.individual$cmass_leaf) - print(this.individual$nmass_leaf) - cton_root <- this.individual$cmass_root/this.individual$nmass_root - print("root") - print(cton_root) - print(this.individual$cmass_root) - print(this.individual$nmass_root) - cton_sap <- this.individual$cmass_sap/this.individual$nmass_sap - print("sap") - print(cton_sap) - print(this.individual$cmass_sap) - print(this.individual$nmass_sap) - cton_heart <- this.individual$cmass_heart/this.individual$nmass_heart - print("heart") - print(cton_heart) - print(this.individual$cmass_heart) - print(this.individual$nmass_heart) - - # STEP 1 - nudge density of stems by adjusting the "indiv.densindiv" and also scaling the biomass pools appropriately model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$densindiv <- this.individual$densindiv * dens.rel.change[this.pft.id+1] @@ -120,14 +124,18 @@ updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, biomass model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$cmass_sap <- this.individual$cmass_sap * dens.rel.change[this.pft.id+1] model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$nmass_sap <- this.individual$nmass_sap * dens.rel.change[this.pft.id+1] model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$cmass_heart <- this.individual$cmass_heart * dens.rel.change[this.pft.id+1] - model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$nmass_hear <- this.individual$nmass_heart * dens.rel.change[this.pft.id+1] + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$nmass_heart <- this.individual$nmass_heart * dens.rel.change[this.pft.id+1] + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$cmass_debt <- this.individual$cmass_debt * dens.rel.change[this.pft.id+1] + + # IMPORTANT: update the this.individual to include the density adjustments above + this.individual <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]] + # STEP 2 - nudge biomass by performing the LPJ-GUESS allocation routine - # calculate the total biomass - biomass.total <- this.individual$cmass_leaf+this.individual$cmass_root+this.individual$cmass_heart+this.individual$cmass_sap + # calculate the total biomass and the absolute change based on this + biomass.total <- this.individual$cmass_leaf+this.individual$cmass_root+this.individual$cmass_heart+this.individual$cmass_sap-this.individual$cmass_debt biomass.inc <- (biomass.total * biomass.rel.change[this.pft.id+1]) - biomass.total - print(biomass.inc) cmass_leaf_inc <- 0 cmass_root_inc <- 0 @@ -138,24 +146,27 @@ updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, biomass litter_root_inc <- 0 exceeds_cmass <- 0 - #sourceCpp("~/Projects/PalEON/LPJ-GUESS/allocation.cpp") - print(str(allocation)) + #print(this.individual$cmass_leaf/) - updated.pools <- allocation(bminc = as.numeric(biomass.inc), - cmass_leaf = as.numeric(this.individual$cmass_leaf), - cmass_root = as.numeric(this.individual$cmass_sap), - cmass_sap = as.numeric(this.individual$cmass_sap), - cmass_debt = as.numeric(this.individual$cmass_heart), - cmass_heart = as.numeric(this.individual$cmass_heart), + updated.pools <- allocation( + # vegetation state + bminc = as.numeric(biomass.inc/this.individual$densindiv), + cmass_leaf = as.numeric(this.individual$cmass_leaf/this.individual$densindiv), + cmass_root = as.numeric(this.individual$cmass_root/this.individual$densindiv), + cmass_sap = as.numeric(this.individual$cmass_sap/this.individual$densindiv), + cmass_debt = as.numeric(this.individual$cmass_debt/this.individual$densindiv), + cmass_heart = as.numeric(this.individual$cmass_heart/this.individual$densindiv), ltor = as.numeric(this.individual$ltor), height = as.numeric(this.individual$height), - sla = as.numeric(this.individual$sla), - wooddens = as.numeric(this.individual$wooddens), - lifeform = as.integer(1), # BLARP - k_latosa = as.numeric(this.individual$k_latosa), - k_allom2 = as.numeric(this.individual$k_allom2), - k_allom3 = as.numeric(this.individual$k_allom3), + # PFT parameters + sla = as.numeric(sla[this.pft.id+1]), + wooddens = as.numeric(wooddens[this.pft.id+1]), + lifeform = as.integer(lifeform[this.pft.id+1]), # BLARP + k_latosa = as.numeric(k_latosa[this.pft.id+1]), + k_allom2 = as.numeric(k_allom2[this.pft.id+1]), + k_allom3 = as.numeric(k_allom3[this.pft.id+1]), + # calculated increments (not actually used, see values returned in the updated.pools list) cmass_leaf_inc = as.numeric(cmass_leaf_inc), cmass_root_inc = as.numeric(cmass_root_inc), cmass_sap_inc = as.numeric(cmass_sap_inc), @@ -165,12 +176,63 @@ updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, biomass litter_root_inc = as.numeric(litter_root_inc), exceeds_cmass = as.numeric(exceeds_cmass)) - print(updated.pools) + # STEP 3 - adjust the various associated C (and N) pools based on the results of the previous step + + # leaf + original.cmass_leaf <- this.individual$cmass_leaf + new.cmass_leaf <- this.individual$cmass_leaf + (updated.pools[["cmass_leaf_inc"]] * this.individual$densindiv) + leaf.scaling <- new.cmass_leaf / original.cmass_leaf + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$cmass_leaf <- new.cmass_leaf + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$nmass_leaf <- this.individual$nmass_leaf * leaf.scaling + + # root + original.cmass_root <- this.individual$cmass_root + new.cmass_root <- this.individual$cmass_root + (updated.pools[["cmass_root_inc"]] * this.individual$densindiv) + root.scaling <- new.cmass_root / original.cmass_root + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$cmass_root <- new.cmass_root + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$nmass_root <- this.individual$nmass_root * root.scaling + + # sap + original.cmass_sap <- this.individual$cmass_sap + new.cmass_sap <- this.individual$cmass_sap + (updated.pools[["cmass_sap_inc"]] * this.individual$densindiv) + sap.scaling <- new.cmass_sap / original.cmass_sap + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$cmass_sap <- new.cmass_sap + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$nmass_sap <- this.individual$nmass_sap * sap.scaling + + + # heart + original.cmass_heart <- this.individual$cmass_heart + new.cmass_heart <- this.individual$cmass_heart + (updated.pools[["cmass_heart_inc"]] * this.individual$densindiv) + heart.scaling <- new.cmass_heart / original.cmass_heart + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$cmass_heart <- new.cmass_heart + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$nmass_heart <- this.individual$nmass_heart * heart.scaling + + # debt - no equivalant n debt + original.cmass_debt <- this.individual$cmass_debt + new.cmass_debt <- this.individual$cmass_debt + (updated.pools[["cmass_debt_inc"]] * this.individual$densindiv) + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$cmass_debt <- new.cmass_debt + + # IMPORTANT: update the this.individual to after biomass changes above before the checks + this.individual <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]] - # STEP 3 - adjust the various associated C pools based on the results of the previous step + # checks + if(FALSE) { + + biomass.final <- this.individual$cmass_leaf+this.individual$cmass_root+this.individual$cmass_heart+this.individual$cmass_sap-this.individual$cmass_debt + if(abs((biomass.final/biomass.total) - 1.1) < 0.001) { + print("--- okay ---") + } + else { + print("--- not okay ---") + } + print(this.individual$indiv.pft.id) + lifeform[this.individual$indiv.pft.id+1] + print(biomass.final/biomass.total) + print(unlist(updated.pools)) + print("--- end ---") + } - # STEP 4 - update N compartments using the initial C-N ratios # STEP 5 - adjust the allometry of the individual based on the updated pools # QUESTION: what to do if allometry returns FALSE? diff --git a/models/lpjguess/man/updateState.LPJGUESS.Rd b/models/lpjguess/man/updateState.LPJGUESS.Rd index b624d42e8c8..5c7c0e598a7 100644 --- a/models/lpjguess/man/updateState.LPJGUESS.Rd +++ b/models/lpjguess/man/updateState.LPJGUESS.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/updateIndividual.LPJGUESS.R +% Please edit documentation in R/updateState.LPJGUESS.R \name{updateState.LPJGUESS} \alias{updateState.LPJGUESS} \title{updateState.LPJGUESS} From 50170e2c6c27f7aa6af64878b7e0290234c8b94e Mon Sep 17 00:00:00 2001 From: istfer Date: Thu, 20 Jun 2019 12:37:06 -0400 Subject: [PATCH 35/56] using phenology and leafphysiognomy --- models/lpjguess/R/write.config.LPJGUESS.R | 32 ++++++++++++++++++++--- models/lpjguess/inst/pecan.ins | 4 +-- 2 files changed, 31 insertions(+), 5 deletions(-) diff --git a/models/lpjguess/R/write.config.LPJGUESS.R b/models/lpjguess/R/write.config.LPJGUESS.R index b8a0d11b95a..54fbdda95a6 100644 --- a/models/lpjguess/R/write.config.LPJGUESS.R +++ b/models/lpjguess/R/write.config.LPJGUESS.R @@ -98,7 +98,7 @@ write.insfile.LPJGUESS <- function(settings, trait.values, rundir, outdir, run.i guessins <- readLines(con = system.file("template.ins", package = "PEcAn.LPJGUESS"), n = -1) paramsins <- readLines(con = system.file("pecan.ins", package = "PEcAn.LPJGUESS"), n = -1) - pftindx <- 152:222 # should grab automatically + pftindx <- 152:223 # should grab automatically pftblock <- paramsins[pftindx] # lines with pft params # cp the grid indices file @@ -115,7 +115,7 @@ write.insfile.LPJGUESS <- function(settings, trait.values, rundir, outdir, run.i # these are strings, should they be passed via xml? # e.g. defaults lifeform=tree phenology=evergreen leafphysiognomy=broadleaf landcover=natural pathway=c3 - noprior_params <- c("lifeform", "phenology", "leafphysiognomy", "landcover", "pathway") + noprior_params <- c("lifeform", "landcover", "pathway") write2pftblock <- vector("list", length(settings$pfts)) # write params with values from trait.values @@ -228,6 +228,28 @@ write.insfile.LPJGUESS <- function(settings, trait.values, rundir, outdir, run.i #' @author Istem Fer pecan2lpjguess <- function(trait.values){ + # leafphysiognomy and phenology are special cases + # these are binary flags + ph_params <- c("evergreen", "cold_deciduous", "broad_leaved") + if(any(ph_params %in% unlist(lapply(trait.values, names)))){ + for(i in seq_along(trait.values)){ + if("evergreen" %in% names(trait.values[[i]])){ + # "any" might be unexpected here, grasses can be "any" phenology + trait.values[[i]][names(trait.values[[i]]) == "evergreen"] <- ifelse(trait.values[[i]][names(trait.values[[i]]) == "evergreen"], "evergreen", "any") + names(trait.values[[i]])[names(trait.values[[i]]) == "evergreen"] <- "phenology" + } + if("cold_deciduous" %in% names(trait.values[[i]])){ + trait.values[[i]][names(trait.values[[i]]) == "cold_deciduous"] <- ifelse(trait.values[[i]][names(trait.values[[i]]) == "cold_deciduous"], "summergreen", "raingreen") + names(trait.values[[i]])[names(trait.values[[i]]) == "cold_deciduous"] <- "phenology" + } + if("broad_leaved" %in% names(trait.values[[i]])){ + trait.values[[i]][names(trait.values[[i]]) == "broad_leaved"] <- ifelse(trait.values[[i]][names(trait.values[[i]]) == "broad_leaved"], "broadleaf", "needleleaf") + names(trait.values[[i]])[names(trait.values[[i]]) == "broad_leaved"] <- "leafphysiognomy" + } + } + } + + # TODO :match all lpjguess and pecan names vartable <- tibble::tribble( ~pecanname, ~lpjguessname, ~pecanunits, ~lpjguessunits, @@ -289,7 +311,11 @@ pecan2lpjguess <- function(trait.values){ "eps_iso", "eps_iso", NA, NA, "seas_iso", "seas_iso", NA, NA, "eps_mon", "eps_mon", NA, NA, - "storfrac_mon", "storfrac_mon", NA, NA) + "storfrac_mon", "storfrac_mon", NA, NA, + "minmoist_est", "minmoist_est", NA, NA, + "phenology", "phenology", NA, NA, # these two lines are hacks + "leafphysiognomy", "leafphysiognomy", NA, NA + ) trait.values <- lapply(trait.values, function(x){ names(x) <- vartable$lpjguessname[match(names(x), vartable$pecanname)] diff --git a/models/lpjguess/inst/pecan.ins b/models/lpjguess/inst/pecan.ins index c7931c244fa..86abe21cfe0 100755 --- a/models/lpjguess/inst/pecan.ins +++ b/models/lpjguess/inst/pecan.ins @@ -185,7 +185,7 @@ pft "@pft@" ( res_outtake @res_outtake@ harvest_slow_frac @harvest_slow_frac@ turnover_harv_prod @turnover_harv_prod@ - phenology @phenology@ + phenology '@phenology@' fnstorage @fnstorage@ phengdd5ramp @phengdd5ramp@ est_max @est_max@ @@ -193,7 +193,7 @@ pft "@pft@" ( alphar @alphar@ greff_min @greff_min@ turnover_sap @turnover_sap@ - leafphysiognomy @leafphysiognomy@ + leafphysiognomy '@leafphysiognomy@' k_allom1 @k_allom1@ k_latosa @k_latosa@ gmin @gmin@ From e479b8dedd90dae85ead0439022062fa812b635a Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Thu, 20 Jun 2019 12:45:37 -0400 Subject: [PATCH 36/56] Added allometry() call. Gives the target results for a biomass change doen to about 0.7. Also updated the way of tracking individuals to better facilitate looping. --- models/lpjguess/R/allometry.LPJGUESS.R | 21 +++- models/lpjguess/R/updateState.LPJGUESS.R | 154 +++++++++++++---------- 2 files changed, 107 insertions(+), 68 deletions(-) diff --git a/models/lpjguess/R/allometry.LPJGUESS.R b/models/lpjguess/R/allometry.LPJGUESS.R index d92e69bcc67..982b492b8e1 100644 --- a/models/lpjguess/R/allometry.LPJGUESS.R +++ b/models/lpjguess/R/allometry.LPJGUESS.R @@ -50,7 +50,7 @@ lambertbeer <- function(lai) { # for a vegetation individual change. allometry <- function( # initial allometry/pools - lifeform = "TREE", + lifeform, cmass_leaf, cmass_sap, cmass_heart, @@ -125,8 +125,9 @@ allometry <- function( # MF - added for providing the error code error.string <- "OK" + vol = 0 - if (lifeform == "TREE") { + if (lifeform == 1) { # TREES @@ -144,6 +145,20 @@ allometry <- function( # Stem volume vol = height * pi * diam * diam * 0.25 + + # print("-----------------------------------------------------") + # print(paste0("height = ", height)) + # print(paste0("vol = ", vol)) + # print(paste0("wooddens = ", wooddens)) + # print(paste0("densindiv = ", densindiv)) + # print(paste0("age = ", age)) + # print(paste0("cmass_heart = ", cmass_heart)) + # print(paste0("cmass_sap = ", cmass_sap)) + # print("-----------------------------------------------------") + + + + if (age > 0 & (cmass_heart + cmass_sap) / densindiv / vol < wooddens * 0.9) { error.string <- "LowWoodDensity" } @@ -193,7 +208,7 @@ allometry <- function( } # - else if (lifeform == "GRASS") { + else if (lifeform == 2) { # GRASSES diff --git a/models/lpjguess/R/updateState.LPJGUESS.R b/models/lpjguess/R/updateState.LPJGUESS.R index 091cc6ab0ab..b1f6aa6c0ba 100644 --- a/models/lpjguess/R/updateState.LPJGUESS.R +++ b/models/lpjguess/R/updateState.LPJGUESS.R @@ -46,14 +46,15 @@ updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, biomass # hard coded veg parameters for testing wooddens <- rep(200, 11) + crownarea_max <- rep(50, 11) lifeform <- c(1,1,1,1,1,1,1,1,1,2,2) - k_latosa <- c(5000, 5000, 5000, 6000, 6000, 6000, 6000,6000, 6000, 6000, 6000) + k_latosa <- c(5000, 5000, 5000, 6000, 6000, 6000, 6000,6000, 6000, 6000, 6000) + k_rp <- rep(1.6, 11) + k_allom1 <- c(150, 150, 150, 250, 250, 250, 250, 250, 250, 250, 250) k_allom2 <- rep(60, 11) k_allom3 <- rep(0.67, 11) - leaflong <- c() - leafphysiognomy <- c() - - # get proper SLA + + # calculate SLA using leaf longevity and leaf physiognomy leaflong <- c(3, 3, 0.5, 0.5, 0.5, 3, 2, 2, 0.5, 0.5, 0.5) leafphysiognomy <- c("NEEDLELEAF", "NEEDLELEAF", "NEEDLELEAF", "BROADLEAF", "BROADLEAF", "BROADLEAF", "BROADLEAF","BROADLEAF", "BROADLEAF", "BROADLEAF", "BROADLEAF") sla <- c() @@ -102,41 +103,42 @@ updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, biomass # for each individual for(individual.counter in 1:this.patch$Vegetation$number_of_individuals) { - # IMPORTANT: note that this is for convenience to *read* variables from an individual but not write to - # it also needs to be updated after the main state (model.state) is updated - this.individual <- this.patch$Vegetation$Individuals[[individual.counter]] + # IMPORTANT: note that this is for convenience to *read* variables from the original individual + # but it should not be written to. Instead the 'updated.individual' (defined in the loop below) + # should be updated and then used to update the main state (model.state) + original.individual <- this.patch$Vegetation$Individuals[[individual.counter]] - if(this.individual$alive) { + if(original.individual$alive) { - this.pft.id <- this.individual$indiv.pft.id + this.pft.id <- original.individual$indiv.pft.id #print(paste("PFT id = ", this.pft.id)) if(!this.pft.id %in% active.PFTs) stop(paste0("Found individual of PFT id = ",this.pft.id, " but this doesn't seem to be active in the LPJ-GUESS run")) - # STEP 1 - nudge density of stems by adjusting the "indiv.densindiv" and also scaling the biomass pools appropriately - model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$densindiv <- this.individual$densindiv * dens.rel.change[this.pft.id+1] - model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$cmass_leaf <- this.individual$cmass_leaf * dens.rel.change[this.pft.id+1] - model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$nmass_leaf <- this.individual$nmass_leaf * dens.rel.change[this.pft.id+1] - model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$cmass_root <- this.individual$cmass_root * dens.rel.change[this.pft.id+1] - model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$nmass_root <- this.individual$nmass_root * dens.rel.change[this.pft.id+1] - model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$cmass_sap <- this.individual$cmass_sap * dens.rel.change[this.pft.id+1] - model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$nmass_sap <- this.individual$nmass_sap * dens.rel.change[this.pft.id+1] - model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$cmass_heart <- this.individual$cmass_heart * dens.rel.change[this.pft.id+1] - model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$nmass_heart <- this.individual$nmass_heart * dens.rel.change[this.pft.id+1] - model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$cmass_debt <- this.individual$cmass_debt * dens.rel.change[this.pft.id+1] - - # IMPORTANT: update the this.individual to include the density adjustments above - this.individual <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]] - + updated.individual <- original.individual + # STEP 1 - nudge density of stems by adjusting the "densindiv" and also scaling the biomass pools appropriately + updated.individual$densindiv <- original.individual$densindiv * dens.rel.change[this.pft.id+1] + updated.individual$cmass_leaf <- original.individual$cmass_leaf * dens.rel.change[this.pft.id+1] + updated.individual$nmass_leaf <- original.individual$nmass_leaf * dens.rel.change[this.pft.id+1] + updated.individual$cmass_root <- original.individual$cmass_root * dens.rel.change[this.pft.id+1] + updated.individual$nmass_root <- original.individual$nmass_root * dens.rel.change[this.pft.id+1] + updated.individual$cmass_sap <- original.individual$cmass_sap * dens.rel.change[this.pft.id+1] + updated.individual$nmass_sap <- original.individual$nmass_sap * dens.rel.change[this.pft.id+1] + updated.individual$cmass_heart <- original.individual$cmass_heart * dens.rel.change[this.pft.id+1] + updated.individual$nmass_heart <- original.individual$nmass_heart * dens.rel.change[this.pft.id+1] + updated.individual$cmass_debt <- original.individual$cmass_debt * dens.rel.change[this.pft.id+1] + # STEP 2 - nudge biomass by performing the LPJ-GUESS allocation routine - # calculate the total biomass and the absolute change based on this - biomass.total <- this.individual$cmass_leaf+this.individual$cmass_root+this.individual$cmass_heart+this.individual$cmass_sap-this.individual$cmass_debt + # calculate the total biomass (after the densindiv nudging above) and the absolute change based on this + biomass.total <- updated.individual$cmass_leaf+updated.individual$cmass_root+updated.individual$cmass_heart+updated.individual$cmass_sap-updated.individual$cmass_debt biomass.inc <- (biomass.total * biomass.rel.change[this.pft.id+1]) - biomass.total + # dummy input values to the allocation function below + # note that they are not actually updated by the function, the updated values are in the returned list cmass_leaf_inc <- 0 cmass_root_inc <- 0 cmass_sap_inc <- 0 @@ -146,23 +148,20 @@ updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, biomass litter_root_inc <- 0 exceeds_cmass <- 0 - - #print(this.individual$cmass_leaf/) - updated.pools <- allocation( # vegetation state - bminc = as.numeric(biomass.inc/this.individual$densindiv), - cmass_leaf = as.numeric(this.individual$cmass_leaf/this.individual$densindiv), - cmass_root = as.numeric(this.individual$cmass_root/this.individual$densindiv), - cmass_sap = as.numeric(this.individual$cmass_sap/this.individual$densindiv), - cmass_debt = as.numeric(this.individual$cmass_debt/this.individual$densindiv), - cmass_heart = as.numeric(this.individual$cmass_heart/this.individual$densindiv), - ltor = as.numeric(this.individual$ltor), - height = as.numeric(this.individual$height), + bminc = as.numeric(biomass.inc/updated.individual$densindiv), + cmass_leaf = as.numeric(updated.individual$cmass_leaf/updated.individual$densindiv), + cmass_root = as.numeric(updated.individual$cmass_root/updated.individual$densindiv), + cmass_sap = as.numeric(updated.individual$cmass_sap/updated.individual$densindiv), + cmass_debt = as.numeric(updated.individual$cmass_debt/updated.individual$densindiv), + cmass_heart = as.numeric(updated.individual$cmass_heart/updated.individual$densindiv), + ltor = as.numeric(updated.individual$ltor), + height = as.numeric(updated.individual$height), # PFT parameters sla = as.numeric(sla[this.pft.id+1]), wooddens = as.numeric(wooddens[this.pft.id+1]), - lifeform = as.integer(lifeform[this.pft.id+1]), # BLARP + lifeform = as.integer(lifeform[this.pft.id+1]), k_latosa = as.numeric(k_latosa[this.pft.id+1]), k_allom2 = as.numeric(k_allom2[this.pft.id+1]), k_allom3 = as.numeric(k_allom3[this.pft.id+1]), @@ -180,54 +179,51 @@ updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, biomass # STEP 3 - adjust the various associated C (and N) pools based on the results of the previous step # leaf - original.cmass_leaf <- this.individual$cmass_leaf - new.cmass_leaf <- this.individual$cmass_leaf + (updated.pools[["cmass_leaf_inc"]] * this.individual$densindiv) + original.cmass_leaf <- updated.individual$cmass_leaf + new.cmass_leaf <- updated.individual$cmass_leaf + (updated.pools[["cmass_leaf_inc"]] * updated.individual$densindiv) leaf.scaling <- new.cmass_leaf / original.cmass_leaf - model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$cmass_leaf <- new.cmass_leaf - model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$nmass_leaf <- this.individual$nmass_leaf * leaf.scaling + updated.individual$cmass_leaf <- new.cmass_leaf + updated.individual$nmass_leaf <- updated.individual$nmass_leaf * leaf.scaling # root - original.cmass_root <- this.individual$cmass_root - new.cmass_root <- this.individual$cmass_root + (updated.pools[["cmass_root_inc"]] * this.individual$densindiv) + original.cmass_root <- updated.individual$cmass_root + new.cmass_root <- updated.individual$cmass_root + (updated.pools[["cmass_root_inc"]] * updated.individual$densindiv) root.scaling <- new.cmass_root / original.cmass_root - model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$cmass_root <- new.cmass_root - model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$nmass_root <- this.individual$nmass_root * root.scaling + updated.individual$cmass_root <- new.cmass_root + updated.individual$nmass_root <- updated.individual$nmass_root * root.scaling # sap - original.cmass_sap <- this.individual$cmass_sap - new.cmass_sap <- this.individual$cmass_sap + (updated.pools[["cmass_sap_inc"]] * this.individual$densindiv) + original.cmass_sap <- updated.individual$cmass_sap + new.cmass_sap <- updated.individual$cmass_sap + (updated.pools[["cmass_sap_inc"]] * updated.individual$densindiv) sap.scaling <- new.cmass_sap / original.cmass_sap - model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$cmass_sap <- new.cmass_sap - model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$nmass_sap <- this.individual$nmass_sap * sap.scaling - + updated.individual$cmass_sap <- new.cmass_sap + updated.individual$nmass_sap <- updated.individual$nmass_sap * sap.scaling # heart - original.cmass_heart <- this.individual$cmass_heart - new.cmass_heart <- this.individual$cmass_heart + (updated.pools[["cmass_heart_inc"]] * this.individual$densindiv) + original.cmass_heart <- updated.individual$cmass_heart + new.cmass_heart <- updated.individual$cmass_heart + (updated.pools[["cmass_heart_inc"]] * updated.individual$densindiv) heart.scaling <- new.cmass_heart / original.cmass_heart - model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$cmass_heart <- new.cmass_heart - model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$nmass_heart <- this.individual$nmass_heart * heart.scaling + updated.individual$cmass_heart <- new.cmass_heart + updated.individual$nmass_heart <- updated.individual$nmass_heart * heart.scaling # debt - no equivalant n debt - original.cmass_debt <- this.individual$cmass_debt - new.cmass_debt <- this.individual$cmass_debt + (updated.pools[["cmass_debt_inc"]] * this.individual$densindiv) - model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]]$cmass_debt <- new.cmass_debt - - # IMPORTANT: update the this.individual to after biomass changes above before the checks - this.individual <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]] + original.cmass_debt <- updated.individual$cmass_debt + new.cmass_debt <- updated.individual$cmass_debt + (updated.pools[["cmass_debt_inc"]] * updated.individual$densindiv) + updated.individual$cmass_debt <- new.cmass_debt + # checks if(FALSE) { - biomass.final <- this.individual$cmass_leaf+this.individual$cmass_root+this.individual$cmass_heart+this.individual$cmass_sap-this.individual$cmass_debt + biomass.final <- updated.individual$cmass_leaf+updated.individual$cmass_root+updated.individual$cmass_heart+updated.individual$cmass_sap-updated.individual$cmass_debt if(abs((biomass.final/biomass.total) - 1.1) < 0.001) { print("--- okay ---") } else { print("--- not okay ---") } - print(this.individual$indiv.pft.id) - lifeform[this.individual$indiv.pft.id+1] + print(updated.individual$indiv.pft.id) + print(lifeform[updated.individual$indiv.pft.id+1]) print(biomass.final/biomass.total) print(unlist(updated.pools)) print("--- end ---") @@ -237,6 +233,34 @@ updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, biomass # STEP 5 - adjust the allometry of the individual based on the updated pools # QUESTION: what to do if allometry returns FALSE? + allometry.results <- allometry( + # initial allometry/pools + cmass_leaf = updated.individual$cmass_leaf, + cmass_sap = updated.individual$cmass_sap, + cmass_heart = updated.individual$cmass_heart, + densindiv = updated.individual$densindiv, + age = updated.individual$age, + fpc = updated.individual$fpc, + deltafpc = updated.individual$deltafpc, + # parameter values + lifeform = lifeform[this.pft.id+1], + sla = sla[this.pft.id+1], + k_latosa = k_latosa[this.pft.id+1], + k_rp = k_rp[this.pft.id+1], + k_allom1 = k_allom1[this.pft.id+1], + k_allom2 = k_allom2[this.pft.id+1], + k_allom3 = k_allom3[this.pft.id+1], + wooddens = wooddens[this.pft.id+1], + crownarea_max = crownarea_max[this.pft.id+1]) + + # if not okay print a warning, and should actually start another iteration with new multipliers + if(allometry.results$error.string != "OK") { + print(allometry.results$error.string) + } + # else update the individual, the litter pools and break + else { + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]] <- updated.individual + } } From 05dcadb25c8b700f0b27b2eb35dcd4252e30f395 Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Thu, 20 Jun 2019 16:31:25 -0400 Subject: [PATCH 37/56] Factorised the adjustDensity and adjustBiomass code. --- models/lpjguess/R/adjustBiomass.LPJGUESS.R | 100 +++++++++++++++ models/lpjguess/R/adjustDensity.LPJGUESS.R | 18 +++ models/lpjguess/R/updateState.LPJGUESS.R | 136 ++++----------------- models/lpjguess/man/allometry.Rd | 6 +- 4 files changed, 144 insertions(+), 116 deletions(-) create mode 100644 models/lpjguess/R/adjustBiomass.LPJGUESS.R create mode 100644 models/lpjguess/R/adjustDensity.LPJGUESS.R diff --git a/models/lpjguess/R/adjustBiomass.LPJGUESS.R b/models/lpjguess/R/adjustBiomass.LPJGUESS.R new file mode 100644 index 00000000000..93339dda97d --- /dev/null +++ b/models/lpjguess/R/adjustBiomass.LPJGUESS.R @@ -0,0 +1,100 @@ + + +adjustBiomass <- function(individual, biomass.increment, sla, wooddens, lifeform, k_latosa, k_allom2, k_allom3){ + + # dummy input values to the allocation function below + # note that they are not actually updated by the function, the updated values are in the returned list + cmass_leaf_inc <- 0 + cmass_root_inc <- 0 + cmass_sap_inc <- 0 + cmass_debt_inc <- 0 + cmass_heart_inc <- 0 + litter_leaf_inc <- 0 + litter_root_inc <- 0 + exceeds_cmass <- 0 + + updated.pools <- allocation( + # vegetation state + bminc = as.numeric(biomass.increment/individual$densindiv), + cmass_leaf = as.numeric(individual$cmass_leaf/individual$densindiv), + cmass_root = as.numeric(individual$cmass_root/individual$densindiv), + cmass_sap = as.numeric(individual$cmass_sap/individual$densindiv), + cmass_debt = as.numeric(individual$cmass_debt/individual$densindiv), + cmass_heart = as.numeric(individual$cmass_heart/individual$densindiv), + ltor = as.numeric(individual$ltor), + height = as.numeric(individual$height), + # PFT parameters + sla = as.numeric(sla), + wooddens = as.numeric(wooddens), + lifeform = as.integer(lifeform), + k_latosa = as.numeric(k_latosa), + k_allom2 = as.numeric(k_allom2), + k_allom3 = as.numeric(k_allom3), + # calculated increments (not actually used, the updated values returned in the updated.pools list) + cmass_leaf_inc = as.numeric(cmass_leaf_inc), + cmass_root_inc = as.numeric(cmass_root_inc), + cmass_sap_inc = as.numeric(cmass_sap_inc), + cmass_debt_inc = as.numeric(cmass_debt_inc), + cmass_heart_inc = as.numeric(cmass_heart_inc), + litter_leaf_inc = as.numeric(litter_leaf_inc), + litter_root_inc = as.numeric(litter_root_inc), + exceeds_cmass = as.numeric(exceeds_cmass)) + + + # adjust the various associated C (and N) pools based on the results of the allocation call + + # leaf + original.cmass_leaf <- individual$cmass_leaf + new.cmass_leaf <- individual$cmass_leaf + (updated.pools[["cmass_leaf_inc"]] * individual$densindiv) + leaf.scaling <- new.cmass_leaf / original.cmass_leaf + individual$cmass_leaf <- new.cmass_leaf + individual$nmass_leaf <- individual$nmass_leaf * leaf.scaling + + # root + original.cmass_root <- individual$cmass_root + new.cmass_root <- individual$cmass_root + (updated.pools[["cmass_root_inc"]] * individual$densindiv) + root.scaling <- new.cmass_root / original.cmass_root + individual$cmass_root <- new.cmass_root + individual$nmass_root <- individual$nmass_root * root.scaling + + # sap + original.cmass_sap <- individual$cmass_sap + new.cmass_sap <- individual$cmass_sap + (updated.pools[["cmass_sap_inc"]] * individual$densindiv) + sap.scaling <- new.cmass_sap / original.cmass_sap + individual$cmass_sap <- new.cmass_sap + individual$nmass_sap <- individual$nmass_sap * sap.scaling + + # heart + original.cmass_heart <- individual$cmass_heart + new.cmass_heart <- individual$cmass_heart + (updated.pools[["cmass_heart_inc"]] * individual$densindiv) + heart.scaling <- new.cmass_heart / original.cmass_heart + individual$cmass_heart <- new.cmass_heart + individual$nmass_heart <- individual$nmass_heart * heart.scaling + + # debt - note no equivalant N debt + original.cmass_debt <- individual$cmass_debt + new.cmass_debt <- individual$cmass_debt + (updated.pools[["cmass_debt_inc"]] * individual$densindiv) + individual$cmass_debt <- new.cmass_debt + + + # checks + if(FALSE) { + + biomass.final <- individual$cmass_leaf+individual$cmass_root+individual$cmass_heart+individual$cmass_sap-individual$cmass_debt + if(abs((biomass.final/biomass.total) - 1.1) < 0.001) { + print("--- okay ---") + } + else { + print("--- not okay ---") + } + print(individual$indiv.pft.id) + print(lifeform[individual$indiv.pft.id+1]) + print(biomass.final/biomass.total) + print(unlist(updated.pools)) + print("--- end ---") + } + + return(individual) + +} + \ No newline at end of file diff --git a/models/lpjguess/R/adjustDensity.LPJGUESS.R b/models/lpjguess/R/adjustDensity.LPJGUESS.R new file mode 100644 index 00000000000..0b1218c8f30 --- /dev/null +++ b/models/lpjguess/R/adjustDensity.LPJGUESS.R @@ -0,0 +1,18 @@ + +#' @keywords internal +adjustDensity.LPJGUESS <- function(individual, rel.change) { + + individual$densindiv <- individual$densindiv * rel.change + individual$cmass_leaf <- individual$cmass_leaf * rel.change + individual$nmass_leaf <- individual$nmass_leaf * rel.change + individual$cmass_root <- individual$cmass_root * rel.change + individual$nmass_root <- individual$nmass_root * rel.change + individual$cmass_sap <- individual$cmass_sap * rel.change + individual$nmass_sap <- individual$nmass_sap * rel.change + individual$cmass_heart <- individual$cmass_heart * rel.change + individual$nmass_heart <- individual$nmass_heart * rel.change + individual$cmass_debt <- individual$cmass_debt * rel.change + + return(individual) + +} \ No newline at end of file diff --git a/models/lpjguess/R/updateState.LPJGUESS.R b/models/lpjguess/R/updateState.LPJGUESS.R index b1f6aa6c0ba..17e24d7b083 100644 --- a/models/lpjguess/R/updateState.LPJGUESS.R +++ b/models/lpjguess/R/updateState.LPJGUESS.R @@ -53,7 +53,7 @@ updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, biomass k_allom1 <- c(150, 150, 150, 250, 250, 250, 250, 250, 250, 250, 250) k_allom2 <- rep(60, 11) k_allom3 <- rep(0.67, 11) - + # calculate SLA using leaf longevity and leaf physiognomy leaflong <- c(3, 3, 0.5, 0.5, 0.5, 3, 2, 2, 0.5, 0.5, 0.5) leafphysiognomy <- c("NEEDLELEAF", "NEEDLELEAF", "NEEDLELEAF", "BROADLEAF", "BROADLEAF", "BROADLEAF", "BROADLEAF","BROADLEAF", "BROADLEAF", "BROADLEAF", "BROADLEAF") @@ -108,6 +108,7 @@ updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, biomass # should be updated and then used to update the main state (model.state) original.individual <- this.patch$Vegetation$Individuals[[individual.counter]] + # don't adjust non-alive individuals as they will soon be removed if(original.individual$alive) { this.pft.id <- original.individual$indiv.pft.id @@ -117,120 +118,29 @@ updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, biomass " but this doesn't seem to be active in the LPJ-GUESS run")) - updated.individual <- original.individual - # STEP 1 - nudge density of stems by adjusting the "densindiv" and also scaling the biomass pools appropriately - updated.individual$densindiv <- original.individual$densindiv * dens.rel.change[this.pft.id+1] - updated.individual$cmass_leaf <- original.individual$cmass_leaf * dens.rel.change[this.pft.id+1] - updated.individual$nmass_leaf <- original.individual$nmass_leaf * dens.rel.change[this.pft.id+1] - updated.individual$cmass_root <- original.individual$cmass_root * dens.rel.change[this.pft.id+1] - updated.individual$nmass_root <- original.individual$nmass_root * dens.rel.change[this.pft.id+1] - updated.individual$cmass_sap <- original.individual$cmass_sap * dens.rel.change[this.pft.id+1] - updated.individual$nmass_sap <- original.individual$nmass_sap * dens.rel.change[this.pft.id+1] - updated.individual$cmass_heart <- original.individual$cmass_heart * dens.rel.change[this.pft.id+1] - updated.individual$nmass_heart <- original.individual$nmass_heart * dens.rel.change[this.pft.id+1] - updated.individual$cmass_debt <- original.individual$cmass_debt * dens.rel.change[this.pft.id+1] - + updated.individual <- adjustDensity.LPJGUESS(original.individual, dens.rel.change[this.pft.id+1]) + + # STEP 2 - nudge biomass by performing the LPJ-GUESS allocation routine # calculate the total biomass (after the densindiv nudging above) and the absolute change based on this biomass.total <- updated.individual$cmass_leaf+updated.individual$cmass_root+updated.individual$cmass_heart+updated.individual$cmass_sap-updated.individual$cmass_debt biomass.inc <- (biomass.total * biomass.rel.change[this.pft.id+1]) - biomass.total - # dummy input values to the allocation function below - # note that they are not actually updated by the function, the updated values are in the returned list - cmass_leaf_inc <- 0 - cmass_root_inc <- 0 - cmass_sap_inc <- 0 - cmass_debt_inc <- 0 - cmass_heart_inc <- 0 - litter_leaf_inc <- 0 - litter_root_inc <- 0 - exceeds_cmass <- 0 - - updated.pools <- allocation( - # vegetation state - bminc = as.numeric(biomass.inc/updated.individual$densindiv), - cmass_leaf = as.numeric(updated.individual$cmass_leaf/updated.individual$densindiv), - cmass_root = as.numeric(updated.individual$cmass_root/updated.individual$densindiv), - cmass_sap = as.numeric(updated.individual$cmass_sap/updated.individual$densindiv), - cmass_debt = as.numeric(updated.individual$cmass_debt/updated.individual$densindiv), - cmass_heart = as.numeric(updated.individual$cmass_heart/updated.individual$densindiv), - ltor = as.numeric(updated.individual$ltor), - height = as.numeric(updated.individual$height), - # PFT parameters - sla = as.numeric(sla[this.pft.id+1]), - wooddens = as.numeric(wooddens[this.pft.id+1]), - lifeform = as.integer(lifeform[this.pft.id+1]), - k_latosa = as.numeric(k_latosa[this.pft.id+1]), - k_allom2 = as.numeric(k_allom2[this.pft.id+1]), - k_allom3 = as.numeric(k_allom3[this.pft.id+1]), - # calculated increments (not actually used, see values returned in the updated.pools list) - cmass_leaf_inc = as.numeric(cmass_leaf_inc), - cmass_root_inc = as.numeric(cmass_root_inc), - cmass_sap_inc = as.numeric(cmass_sap_inc), - cmass_debt_inc = as.numeric(cmass_debt_inc), - cmass_heart_inc = as.numeric(cmass_heart_inc), - litter_leaf_inc = as.numeric(litter_leaf_inc), - litter_root_inc = as.numeric(litter_root_inc), - exceeds_cmass = as.numeric(exceeds_cmass)) - - - # STEP 3 - adjust the various associated C (and N) pools based on the results of the previous step + # this function call runs the LPJ-GUESS allocation routine and ajusts the pools accordingly + updated.individual <- adjustBiomass(individual = updated.individual, + biomass.increment = biomass.inc, + sla = sla[this.pft.id+1], + wooddens = wooddens[this.pft.id+1], + lifeform = lifeform[this.pft.id+1], + k_latosa = k_latosa[this.pft.id+1], + k_allom2 = k_allom2[this.pft.id+1], + k_allom3 = k_allom3[this.pft.id+1]) - # leaf - original.cmass_leaf <- updated.individual$cmass_leaf - new.cmass_leaf <- updated.individual$cmass_leaf + (updated.pools[["cmass_leaf_inc"]] * updated.individual$densindiv) - leaf.scaling <- new.cmass_leaf / original.cmass_leaf - updated.individual$cmass_leaf <- new.cmass_leaf - updated.individual$nmass_leaf <- updated.individual$nmass_leaf * leaf.scaling - # root - original.cmass_root <- updated.individual$cmass_root - new.cmass_root <- updated.individual$cmass_root + (updated.pools[["cmass_root_inc"]] * updated.individual$densindiv) - root.scaling <- new.cmass_root / original.cmass_root - updated.individual$cmass_root <- new.cmass_root - updated.individual$nmass_root <- updated.individual$nmass_root * root.scaling - # sap - original.cmass_sap <- updated.individual$cmass_sap - new.cmass_sap <- updated.individual$cmass_sap + (updated.pools[["cmass_sap_inc"]] * updated.individual$densindiv) - sap.scaling <- new.cmass_sap / original.cmass_sap - updated.individual$cmass_sap <- new.cmass_sap - updated.individual$nmass_sap <- updated.individual$nmass_sap * sap.scaling - - # heart - original.cmass_heart <- updated.individual$cmass_heart - new.cmass_heart <- updated.individual$cmass_heart + (updated.pools[["cmass_heart_inc"]] * updated.individual$densindiv) - heart.scaling <- new.cmass_heart / original.cmass_heart - updated.individual$cmass_heart <- new.cmass_heart - updated.individual$nmass_heart <- updated.individual$nmass_heart * heart.scaling - - # debt - no equivalant n debt - original.cmass_debt <- updated.individual$cmass_debt - new.cmass_debt <- updated.individual$cmass_debt + (updated.pools[["cmass_debt_inc"]] * updated.individual$densindiv) - updated.individual$cmass_debt <- new.cmass_debt - - - # checks - if(FALSE) { - - biomass.final <- updated.individual$cmass_leaf+updated.individual$cmass_root+updated.individual$cmass_heart+updated.individual$cmass_sap-updated.individual$cmass_debt - if(abs((biomass.final/biomass.total) - 1.1) < 0.001) { - print("--- okay ---") - } - else { - print("--- not okay ---") - } - print(updated.individual$indiv.pft.id) - print(lifeform[updated.individual$indiv.pft.id+1]) - print(biomass.final/biomass.total) - print(unlist(updated.pools)) - print("--- end ---") - } - - - # STEP 5 - adjust the allometry of the individual based on the updated pools + # STEP 3 - adjust the allometry of the individual based on the updated pools # QUESTION: what to do if allometry returns FALSE? allometry.results <- allometry( @@ -253,14 +163,14 @@ updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, biomass wooddens = wooddens[this.pft.id+1], crownarea_max = crownarea_max[this.pft.id+1]) - # if not okay print a warning, and should actually start another iteration with new multipliers - if(allometry.results$error.string != "OK") { - print(allometry.results$error.string) - } - # else update the individual, the litter pools and break - else { - model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]] <- updated.individual - } + # if not okay print a warning, and should actually start another iteration with new multipliers + if(allometry.results$error.string != "OK") { + print(allometry.results$error.string) + } + # else update the individual, the litter pools and break + else { + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]] <- updated.individual + } } diff --git a/models/lpjguess/man/allometry.Rd b/models/lpjguess/man/allometry.Rd index 3d95f2cad1d..cb561f2647a 100644 --- a/models/lpjguess/man/allometry.Rd +++ b/models/lpjguess/man/allometry.Rd @@ -4,9 +4,9 @@ \alias{allometry} \title{LPJ-GUESS allometry} \usage{ -allometry(lifeform = "TREE", cmass_leaf, cmass_sap, cmass_heart, - densindiv, age, fpc, deltafpc, sla, k_latosa, k_rp, k_allom1, k_allom2, - k_allom3, wooddens, crownarea_max) +allometry(lifeform, cmass_leaf, cmass_sap, cmass_heart, densindiv, age, + fpc, deltafpc, sla, k_latosa, k_rp, k_allom1, k_allom2, k_allom3, + wooddens, crownarea_max) } \description{ LPJ-GUESS allometry From a601256354f6466143cfbea5ba8dbe94805386d7 Mon Sep 17 00:00:00 2001 From: istfer Date: Fri, 21 Jun 2019 09:54:58 -0400 Subject: [PATCH 38/56] few modifications for PalEON model version --- models/lpjguess/R/read_state.R | 1 - models/lpjguess/R/write.config.LPJGUESS.R | 28 +++++++++++++++++++-- models/lpjguess/inst/lpjguess_params.Rdata | Bin 2316 -> 2316 bytes models/lpjguess/inst/pecan.ins | 18 +++++++------ models/lpjguess/inst/template.ins | 2 +- 5 files changed, 37 insertions(+), 12 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index e567164f9b2..d41d92fa6a7 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -121,7 +121,6 @@ find_closing <- function(find = "}", line_no, file_in, if_else_check = FALSE){ } # find_closing -#' @export # helper function that determines the stream size to read find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS){ diff --git a/models/lpjguess/R/write.config.LPJGUESS.R b/models/lpjguess/R/write.config.LPJGUESS.R index 54fbdda95a6..2f0907b4bb7 100644 --- a/models/lpjguess/R/write.config.LPJGUESS.R +++ b/models/lpjguess/R/write.config.LPJGUESS.R @@ -22,7 +22,7 @@ ##' @return configuration file for LPJ-GUESS for given run ##' @export ##' @author Istem Fer, Tony Gardella -write.config.LPJGUESS <- function(defaults, trait.values, settings, run.id) { +write.config.LPJGUESS <- function(defaults, trait.values, settings, run.id, restart = NULL) { # find out where to write run/ouput rundir <- file.path(settings$host$rundir, run.id) @@ -98,9 +98,25 @@ write.insfile.LPJGUESS <- function(settings, trait.values, rundir, outdir, run.i guessins <- readLines(con = system.file("template.ins", package = "PEcAn.LPJGUESS"), n = -1) paramsins <- readLines(con = system.file("pecan.ins", package = "PEcAn.LPJGUESS"), n = -1) - pftindx <- 152:223 # should grab automatically + pftindx <- 154:224 # should grab automatically pftblock <- paramsins[pftindx] # lines with pft params + # fill save state flags + if(!is.null(settings$model$save_state)){ + save_state <- as.logical(settings$model$save_state) + if(save_state){ + paramsins <- gsub("@SAVE_STATE_OPTION@", 1, paramsins) + paramsins <- gsub("@STATE_PATH@", paste0("state_path '", outdir, "'"), paramsins) + }else{ + paramsins <- gsub("@RESTART_OPTION@", 0, paramsins) + paramsins <- gsub("@STATE_PATH@", "!state_path", paramsins) + } + }else{ + # wouldn't hurt to save state by default? + paramsins <- gsub("@SAVE_STATE_OPTION@", 1, paramsins) + paramsins <- gsub("@STATE_PATH@", paste0("state_path '", outdir, "'"), paramsins) + } + # cp the grid indices file grid.file <- file.path(settings$host$rundir, "gridind.txt") gridind <- system.file("gridind.txt", package = "PEcAn.LPJGUESS") @@ -213,6 +229,14 @@ write.insfile.LPJGUESS <- function(settings, trait.values, rundir, outdir, run.i settings$model$insfile <- file.path(settings$rundir, run.id, "guess.ins") + # version check + if(!is.null(settings$model$revision)){ + if(settings$model$revision == "PalEON"){ + rm_inds <- which(grepl("@@@@@ Remove in PalEON version @@@@@", paramsins)) + paramsins <- paramsins[-(rm_inds[1]:rm_inds[2])] + } + } + writeLines(paramsins, con = file.path(settings$rundir, run.id, "params.ins")) writeLines(guessins, con = file.path(settings$rundir, run.id, "guess.ins")) diff --git a/models/lpjguess/inst/lpjguess_params.Rdata b/models/lpjguess/inst/lpjguess_params.Rdata index 28c040edd6d042ad5f224c9e5b9163b03e90a29a..112a2316802430db79dae3ecffce4158425b50e8 100644 GIT binary patch delta 25 gcmeAX>Ji!y&&+sWas#vc;(BIACi@GU8(F$p0Bw5+LjV8( delta 41 ncmeAX>Ji!y&n)bq&j15_Kn5d_zqyE+mvOQ`3)kjOmSz?Jkh=#w diff --git a/models/lpjguess/inst/pecan.ins b/models/lpjguess/inst/pecan.ins index 86abe21cfe0..bb3e2aa0c30 100755 --- a/models/lpjguess/inst/pecan.ins +++ b/models/lpjguess/inst/pecan.ins @@ -18,7 +18,7 @@ outputdirectory "./" ! These files may be outcommented if their output is not required. !file_cmass "cmass.out" !file_anpp "anpp.out" -!file_agpp "agpp.out" +file_agpp "agpp.out" !file_fpc "fpc.out" !file_aaet "aaet.out" !file_lai "lai.out" @@ -73,6 +73,7 @@ title 'LPJ-GUESS cohort mode - global pfts' vegmode "cohort" ! "cohort", "individual" or "population" nyear_spinup 500 ! number of years to spin up the simulation for +spinup_lifeform "nolifeform" ifcalcsla 0 ! whether to calculate SLA from leaf longevity ! (PFT-specific value can be specified in this file instead) ifcalccton 1 ! whether to calculate leaf C:N min from leaf longevity @@ -83,7 +84,7 @@ patcharea 1000 ! patch area (m2) estinterval 5 ! years between establishment events in cohort mode ifdisturb 1 ! whether generic patch-destroying disturbances enabled distinterval 100 ! average return time for generic patch-destroying disturbances -! Hickler et al. (2011) used 200 +disturb_year -1 ifbgestab 1 ! whether background establishment enabled ifsme 1 ! whether spatial mass effect enabled ifstochestab 1 ! whether establishment stochastic @@ -105,17 +106,17 @@ nrelocfrac 0.5 ! fraction of N retranslocated prior to leaf and root shedding !/////////////////////////////////////////////////////////////////////////////// - ! SERIALIZATION SETTINGS +! SERIALIZATION SETTINGS !/////////////////////////////////////////////////////////////////////////////// - !state_year 500 ! year to save/start state file (no setting = after spinup) +!state_year 500 ! year to save/start state file (no setting = after spinup) restart 0 ! wheter to start from a state file -save_state 0 ! wheter to save a state file -!state_path "" ! directory to put state files in +save_state @SAVE_STATE_OPTION@ ! wheter to save a state file +@STATE_PATH@ ! directory to put state files in ifsmoothgreffmort 1 ! whether to vary mort_greff smoothly with growth efficiency (1) ! or to use the standard step-function (0) - ! greff_min values below calibrated for the smooth (1) option +! greff_min values below calibrated for the smooth (1) option ifdroughtlimitedestab 0 ! whether establishment is limited by growing season drought ! guess2008 - species version has 1 ifrainonwetdaysonly 0 ! whether to rain on wet days only (1), or to rain a bit every day (0) @@ -132,6 +133,7 @@ run_pasture 0 ! whether to simulate pasture (1) or not (0) run_natural 1 ! whether to simulate natural vegetation (1) or not (0) run_peatland 1 ! whether to simulate peatland (1) or not (0) +@@@@@ Remove in PalEON version @@@@@ lcfrac_fixed 0 ! use landcover fractions (%) below (1) or read from input file (0) lc_fixed_urban 0 ! URBAN lc_fixed_cropland 50 ! CROPLAND @@ -140,7 +142,7 @@ lc_fixed_forest 0 ! FOREST lc_fixed_natural 25 ! NATURAL lc_fixed_peatland 25 ! PEATLAND equal_landcover_area 0 ! divide gridcell into equal active landcover fractions - +@@@@@ Remove in PalEON version @@@@@ !/////////////////////////////////////////////////////////////////////////////////////// diff --git a/models/lpjguess/inst/template.ins b/models/lpjguess/inst/template.ins index c86f5fb8382..aa5520e66c4 100755 --- a/models/lpjguess/inst/template.ins +++ b/models/lpjguess/inst/template.ins @@ -14,7 +14,7 @@ coordinates_precision 2 ! Forcing Data & gridlists ! -param "file_gridlist" (str "@GRID_FILE@") +param "file_gridlist_cf" (str "@GRID_FILE@") param "file_co2" (str "@CO2_FILE@") param "file_cru" (str "@SOIL_FILE@") From 0c6f6241e85c8c09bc8bfdf18b46b5d9f63667e6 Mon Sep 17 00:00:00 2001 From: istfer Date: Fri, 21 Jun 2019 11:03:54 -0400 Subject: [PATCH 39/56] parsing files some more --- models/lpjguess/R/read_state.R | 105 +- models/lpjguess/inst/guess.PalEON.cpp | 2694 +++++++++++++++ models/lpjguess/inst/guess.PalEON.h | 3976 ++++++++++++++++++++++ models/lpjguess/inst/parameters.PalEON.h | 366 ++ 4 files changed, 7102 insertions(+), 39 deletions(-) create mode 100644 models/lpjguess/inst/guess.PalEON.cpp create mode 100644 models/lpjguess/inst/guess.PalEON.h create mode 100644 models/lpjguess/inst/parameters.PalEON.h diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index d41d92fa6a7..56295b4e257 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -176,22 +176,9 @@ find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LP if(current_stream_type$name != "solvesom"){ PEcAn.logger::logger.debug("Another struct type.") } - #for now hardcoding this will be back - # specs$n <- specs$what <- specs$size <- specs$names <- rep(NA, 2) - # specs$what[1] <- "double" - # specs$size[1] <- 8 - # specs$names[1] <- "clitter" - # specs$n[1] <- 12 #NSOMPOOL - # - # specs$what[2] <- "double" - # specs$size[2] <- 8 - # specs$names[2] <- "nlitter" - # specs$n[2] <- 12 #NSOMPOOL - # - # LOOKS LIKE THIS ONE IS NOT SERIALIZED PROPERLY - # just return 8 - - + + # with these you're supposed to first read the dimensions of the array and then the values stored + # hardcoding this for now specs$n <- 1 specs$what <- "integer" specs$size <- 8 @@ -360,29 +347,34 @@ library(stringr) # Fluxes : The Fluxes class stores accumulated monthly and annual fluxes. One object of type Fluxes is defined for each patch. # Individual : Stores state variables for an average individual plant. In cohort mode, it is the average individual of a cohort of plants approximately the same age and from the same patch. -# maybe put guess.h and guess.cpp for each model version into the model package -guesscpp_loc <- "/fs/data5/pecan.models/LPJ-GUESS/framework/guess.cpp" -guessh_loc <- "/fs/data5/pecan.models/LPJ-GUESS/framework/guess.h" -paramh_loc <- "/fs/data5/pecan.models/LPJ-GUESS/framework/parameters.h" + +# test path +outdir <- "/fs/data2/output/PEcAn_1000010473/out/1002655714" + +# outdir, at least model version, maybe also settings +read_binary_LPJGUESS <- function(outdir, version = "PalEON"){ + +} + +# find rundir too, params.ins is in there and we need to get some values from there +rundir <- file.path(dirname(dirname(outdir)), "run", basename(outdir)) # guess.cpp has the info of what is being written -guesscpp_in <- readLines(guesscpp_loc) +guesscpp_name <- paste0("guess.", version, ".cpp") # these are gonna be in the package guess.VERSION.cpp +guesscpp_in <- readLines(con = system.file(guesscpp_name, package = "PEcAn.LPJGUESS"), n = -1) # guess.h has the types so that we know what streamsize to read -guessh_in <- readLines(guessh_loc) +guessh_name <- paste0("guess.", version, ".h") +guessh_in <- readLines(con = system.file(guessh_name, package = "PEcAn.LPJGUESS"), n = -1) # parameters.h has some more types -paramh_in <- readLines(paramh_loc) - -############ open +paramh_name <- paste0("parameters.", version, ".h") +paramh_in <- readLines(con = system.file(paramh_name, package = "PEcAn.LPJGUESS"), n = -1) -# test path -out.path = "/fs/data2/output/PEcAn_1000002393/out/1000458390" -setwd(out.path) ###################################### ## read meta.bin # not sure if the content will change under guessserializer.cpp meta_data <- list() -meta_bin_con <- file("meta.bin", "rb") +meta_bin_con <- file(file.path(outdir, "meta.bin"), "rb") meta_data$num_processes <- readBin(meta_bin_con, integer(), 1, size = 4) meta_data$vegmode <- readBin(meta_bin_con, integer(), 1, size = 4) meta_data$npft <- readBin(meta_bin_con, integer(), 1, size = 4) @@ -393,14 +385,25 @@ for(i in seq_len(meta_data$npft)){ } close(meta_bin_con) +# how many PFTs are there in this run +n_pft <- meta_data$npft + # open connection to the binary state file -zz <- file("0.state", "rb") +if(meta_data$num_processes == 1){ + zz <- file(file.path(outdir,"0.state"), "rb") +}else{ + # then file names would be different 1.state etc etc + PEcAn.logger::logger.severe("This function is implemented to read state from 1 process only.") +} + ### these are the values read from params.ins, passed to this fcn -n_pft <- meta_data$npft -npatches <- 5 +paramsins <- readLines(file.path(rundir, "params.ins"), n = -1) +npatches <- as.numeric(gsub(".*([0-9]+).*$", "\\1", paramsins[grepl("npatch", paramsins, fixed = TRUE)])) + + +################################ CHECKS AND EXTRACTIONS ################################ -################################ check class compatibility ################################ # between model versions we don't expect major classes or hierarchy to change # but give check and fail if necessary LPJ_GUESS_CLASSES <- c("Gridcell", "Climate", "Gridcellpft", "Stand", "Standpft", "Patch", "Patchpft", @@ -468,13 +471,37 @@ for(i in seq_along(guessh_in)){ dont_need <- c("COLDEST_DAY_NHEMISPHERE", "COLDEST_DAY_SHEMISPHERE", "WARMEST_DAY_NHEMISPHERE", "WARMEST_DAY_SHEMISPHERE", "data[]") lpjguess_consts[match(dont_need, names(lpjguess_consts))] <- NULL # this needs to be extracted from parameters.h:48-49 or somewhere else, but hardcoding for now -lpjguess_consts$NLANDCOVERTYPES <- 6 -# this needs to be extracted from guess.h:94 , but hardcoding for now + +# need to parse out few more constants +for(i in seq_along(paramh_in)){ #do same for parameters.h + res <- str_match(paramh_in[i], "typedef enum \\{(.*?)\\} landcovertype\\;") + if(!is.na(res[,2])){ + lpjguess_consts$NLANDCOVERTYPES <- length(strsplit(res[,2], ",")[[1]]) - 1 # last element is NLANDCOVERTYPES + } +} +for(i in seq_along(guessh_in)){ + if(grepl("enum PerPatchFluxType {", guessh_in[i], fixed = TRUE)){ + cl_i <- find_closing("}", i, guessh_in) + #get rid of commented out lines + sub_string <- guessh_in[i:cl_i][!grepl("///", guessh_in[i:cl_i], fixed = TRUE)] + # split and count + lpjguess_consts$PerPatchFluxType <- length(strsplit(paste(sub_string, collapse = " "), ",")[[1]]) - 1 + } + if(grepl("enum PerPFTFluxType {", guessh_in[i], fixed = TRUE)){ + cl_i <- find_closing("}", i, guessh_in) + #get rid of commented out lines + sub_string <- guessh_in[i:cl_i][!grepl("///", guessh_in[i:cl_i], fixed = TRUE)] + # split and count + lpjguess_consts$PerPFTFluxType <- length(strsplit(paste(sub_string, collapse = " "), ",")[[1]]) - 1 + } + +} + +# this needs to be extracted from guess.h:93-94 , but hardcoding for now +# hopefully CENTURY pool names might not change for a while lpjguess_consts$NSOMPOOL <- 12 -# this needs to be extracted from guess.h:644 , but hardcoding for now NOTE that new versions has 13 flux types -lpjguess_consts$PerPatchFluxType <- 12 -# this needs to be extracted from guess.h:659 , but hardcoding for now -lpjguess_consts$PerPFTFluxType <- 5 + + LPJ_GUESS_CONST_INTS <- data.frame(var = names(lpjguess_consts), val = as.numeric(unlist(lpjguess_consts)), stringsAsFactors = FALSE) diff --git a/models/lpjguess/inst/guess.PalEON.cpp b/models/lpjguess/inst/guess.PalEON.cpp new file mode 100644 index 00000000000..da6de4f0370 --- /dev/null +++ b/models/lpjguess/inst/guess.PalEON.cpp @@ -0,0 +1,2694 @@ +/////////////////////////////////////////////////////////////////////////////////////// +/// \file guess.cpp +/// \brief LPJ-GUESS Combined Modular Framework +/// +/// \author Ben Smith +/// $Date: 2016-12-08 18:24:04 +0100 (Do, 08. Dez 2016) $ +/// +/////////////////////////////////////////////////////////////////////////////////////// + +#include +#include "config.h" +#include "guess.h" + +/////////////////////////////////////////////////////////////////////////////////////// +// GLOBAL VARIABLES WITH EXTERNAL LINKAGE +// These variables are declared in the framework header file, and defined here. +// They are accessible throughout the model code. + +Date date; // object describing timing stage of simulation +int npft; // number of possible PFTs +int nst; // number of possible stand types +int nst_lc[NLANDCOVERTYPES]; // number of possible stand types in each land cover type +int nmt; // number of possible management types + +ManagementTypelist mtlist; +StandTypelist stlist; +Pftlist pftlist; + +// emission ratios from fire (NH3, NOx, N2O, N2) Delmas et al. 1995 + +const double Fluxes::NH3_FIRERATIO = 0.005; +const double Fluxes::NOx_FIRERATIO = 0.237; +const double Fluxes::N2O_FIRERATIO = 0.036; +const double Fluxes::N2_FIRERATIO = 0.722; + + +//////////////////////////////////////////////////////////////////////////////// +// Implementation of PhotosynthesisResult member functions +//////////////////////////////////////////////////////////////////////////////// + + +void PhotosynthesisResult::serialize(ArchiveStream& arch) { + arch & agd_g + & adtmm + & rd_g + & vm + & je + & nactive_opt + & vmaxnlim; +} + +//////////////////////////////////////////////////////////////////////////////// +// Implementation of Climate member functions +//////////////////////////////////////////////////////////////////////////////// + + +void Climate::serialize(ArchiveStream& arch) { + arch & temp + & rad + & par + & prec + & daylength + & co2 + & lat + & insol + & instype + & eet + & mtemp + & mtemp_min20 + & mtemp_max20 + & mtemp_max + & gdd5 + & agdd5 + & chilldays + & ifsensechill + & gtemp + & dtemp_31 + & dprec_31 + & deet_31 + & mtemp_min_20 + & mtemp_max_20 + & mtemp_min + & atemp_mean + & sinelat + & cosinelat + & qo & u & v & hh & sinehh + & daylength_save + & doneday + & andep + & dndep + & dprec_10 + & sprec_2 + & maxtemp + & mtemp_20 + & mprec_20 + & mpet_20 + & mprec_pet_20 + & mprec_petmin_20 + & mprec_petmax_20 + & mtemp20 + & mprec20 + & mpet20 + & mprec_pet20 + & mprec_petmin20 + & mprec_petmax20 + & hmtemp_20 + & hmprec_20 + & hmeet_20 + & seasonality + & seasonality_lastyear + & prec_seasonality + & prec_seasonality_lastyear + & prec_range + & prec_range_lastyear + & temp_seasonality + & temp_seasonality_lastyear + & var_prec + & var_temp + & aprec; +} + +//////////////////////////////////////////////////////////////////////////////// +// Implementation of Fluxes member functions +//////////////////////////////////////////////////////////////////////////////// + +Fluxes::Fluxes(Patch& p) + : patch(p), + annual_fluxes_per_pft(npft, std::vector(NPERPFTFLUXTYPES)) { + + reset(); +} + +void Fluxes::reset() { + for (size_t i = 0; i < annual_fluxes_per_pft.size(); ++i) { + std::fill_n(annual_fluxes_per_pft[i].begin(), int(NPERPFTFLUXTYPES), 0); + } + + for (int m = 0; m < 12; ++m) { + std::fill_n(monthly_fluxes_pft[m], int(NPERPFTFLUXTYPES), 0); + std::fill_n(monthly_fluxes_patch[m], int(NPERPATCHFLUXTYPES), 0); + } + + for (int d = 0; d < date.year_length(); ++d) { + std::fill_n(daily_fluxes_pft[d], int(NPERPFTFLUXTYPES), 0); + std::fill_n(daily_fluxes_patch[d], int(NPERPATCHFLUXTYPES), 0); + } +} + +void Fluxes::serialize(ArchiveStream& arch) { + arch & annual_fluxes_per_pft + & monthly_fluxes_patch + & monthly_fluxes_pft; +} + +void Fluxes::report_flux(PerPFTFluxType flux_type, int pft_id, double value) { + annual_fluxes_per_pft[pft_id][flux_type] += value; + monthly_fluxes_pft[date.month][flux_type] += value; + daily_fluxes_pft[date.day][flux_type] += value; //Var = value ??? +} + +void Fluxes::report_flux(PerPatchFluxType flux_type, double value) { + monthly_fluxes_patch[date.month][flux_type] += value; + daily_fluxes_patch[date.day][flux_type] += value; +} + +double Fluxes::get_monthly_flux(PerPFTFluxType flux_type, int month) const { + return monthly_fluxes_pft[month][flux_type]; +} + +double Fluxes::get_monthly_flux(PerPatchFluxType flux_type, int month) const { + return monthly_fluxes_patch[month][flux_type]; +} + +double Fluxes::get_annual_flux(PerPFTFluxType flux_type, int pft_id) const { + return annual_fluxes_per_pft[pft_id][flux_type]; +} + +double Fluxes::get_annual_flux(PerPFTFluxType flux_type) const { + double sum = 0; + for (size_t i = 0; i < annual_fluxes_per_pft.size(); ++i) { + sum += annual_fluxes_per_pft[i][flux_type]; + } + return sum; +} + +double Fluxes::get_annual_flux(PerPatchFluxType flux_type) const { + double sum = 0; + for (int m = 0; m < 12; ++m) { + sum += monthly_fluxes_patch[m][flux_type]; + } + return sum; +} + +//////////////////////////////////////////////////////////////////////////////// +// Implementation of Vegetation member functions +//////////////////////////////////////////////////////////////////////////////// + + +void Vegetation::serialize(ArchiveStream& arch) { + if (arch.save()) { + arch & nobj; + + for (unsigned int i = 0; i < nobj; i++) { + Individual& indiv = (*this)[i]; + arch & indiv.pft.id + & indiv; + } + } + else { + killall(); + unsigned int number_of_individuals; + arch & number_of_individuals; + + for (unsigned int i = 0; i < number_of_individuals; i++) { + int pft_id; + arch & pft_id; + Individual& indiv = createobj(pftlist[pft_id], *this); + arch & indiv; + } + } +} + +//////////////////////////////////////////////////////////////////////////////// +// Implementation of LitterSolveSOM member functions +//////////////////////////////////////////////////////////////////////////////// + + +void LitterSolveSOM::serialize(ArchiveStream& arch) { + arch & clitter + & nlitter; +} + +//////////////////////////////////////////////////////////////////////////////// +// Implementation of Soil member functions +//////////////////////////////////////////////////////////////////////////////// + + +void Soil::serialize(ArchiveStream& arch) { + arch & wcont + & awcont + & wcont_evap + & dwcontupper + & mwcontupper + & snowpack + & runoff + & temp + & dtemp + & mtemp + & gtemp + & cpool_slow + & cpool_fast + & decomp_litter_mean + & k_soilfast_mean + & k_soilslow_mean + & alag + & exp_alag + & mwcont + & dwcontlower + & mwcontlower + // probably shouldn't need to serialize these + & rain_melt + & max_rain_melt + & percolate; + + for (int i = 0; igrowingseason; + else + return true; +} + +//////////////////////////////////////////////////////////////////////////////// +// Implementation of Patch member functions +//////////////////////////////////////////////////////////////////////////////// + + +Patch::Patch(int i,Stand& s,Soiltype& st): + id(i),stand(s),vegetation(*this),soil(*this,st),fluxes(*this) { + + for (unsigned int p = 0; p < pftlist.nobj; p++) { + pft.createobj(pftlist[p]); + } + + age = 0; + disturbed = false; + managed = false; + man_strength = 0.0; + managed_this_year = false; + plant_this_year = false; + wdemand = 0.0; + wdemand_leafon = 0.0; + + growingseasondays = 0; + + fireprob = 0.0; + ndemand = 0.0; + dnfert = 0.0; + anfert = 0.0; + nharv = 0; + for (int i = 0; i < NYEARAAET; i++) + aaet_5.add(0.0); +} + +void Patch::serialize(ArchiveStream& arch) { + if (arch.save()) { + for (unsigned int i = 0; i < pft.nobj; i++) { + arch & pft[i]; + } + } + else { + pft.killall(); + + for (unsigned int i = 0; i < pftlist.nobj; i++) { + pft.createobj(pftlist[i]); + arch & pft[i]; + } + } + + arch & vegetation + & soil + & fluxes + & fpar_grass + & fpar_ff + & par_grass_mean + & nday_growingseason + & fpc_total + & disturbed + & managed + & age + & fireprob + & growingseasondays + & intercep + & aaet + & aaet_5 + & aevap + & aintercep + & arunoff + & apet + & eet_net_veg + & wdemand + & wdemand_day + & wdemand_leafon + & fpc_rescale + & maet + & mevap + & mintercep + & mrunoff + & mpet + & ndemand + & irrigation_y; +} + +const Climate& Patch::get_climate() const { + // All patches within a stand share the same climate + return stand.get_climate(); +} + +bool Patch::has_fires() const { + return iffire && stand.landcover != CROPLAND && !managed && + (stand.landcover != PASTURE || disturb_pasture); +} + +bool Patch::has_disturbances() const { + return ifdisturb && stand.landcover != CROPLAND && !managed && + (stand.landcover != PASTURE || disturb_pasture); +} + +/// C content of patch +/** + * INPUT PARAMETERS + * + * \param scale_indiv scaling factor for living C + * \param luc down-scales living C (used in C balance tests) + */ +double Patch::ccont(double scale_indiv, bool luc) { + + double ccont = 0.0; + + ccont += soil.cpool_fast; + ccont += soil.cpool_slow; + + for (int i=0; i= NLANDCOVERTYPES) { + fail("Unrecognized landcover type\n"); + } + + for (unsigned int p=0;p 0) { + num_patches = npatch; // use patch number provided by calling funciton + } + + for (unsigned int p=0;p= st.firstmanageyear) { + for(unsigned int i=0;i= 0) + pft[pftid].irrigated = true; + } + + if (st.intercrop==NATURALGRASS && ifintercropgrass) { + hasgrassintercrop = true; + + for (unsigned int i=0; i -1) { + if (!readNfert) + gridcell->pft[pftid].Nfert_read = mt0.nfert; + if (!readsowingdates) + pft[pftid].sdate_force = mt0.sdate; + if (!readharvestdates) + pft[pftid].hdate_force = mt0.hdate; + } + + if(!readNfert_st) + gridcell->st[st.id].nfert = mt0.nfert; + + if(!st.restrictpfts) + return; + + // Set standpft- and patchpft-variables for active crops + for (int rot=0; rot=0) { + + if(lc == CROPLAND) { + + pft[id].active = true; + + if (rot == 0) { + // Set crop cycle dates to default values only for first crop in a rotation. + for (unsigned int p = 0; p < nobj; p++) { + + Gridcellpft& gcpft = get_gridcell().pft[id]; + Patchpft& ppft = (*this)[p].pft[id]; + + ppft.set_cropphen()->sdate = gcpft.sdate_default; + ppft.set_cropphen()->hlimitdate = gcpft.hlimitdate_default; + + if (pftlist[id].phenology == ANY) + ppft.set_cropphen()->growingseason = true; + else if (pftlist[id].phenology == CROPGREEN) { + ppft.set_cropphen()->eicdate = Date::stepfromdate(ppft.get_cropphen()->sdate, -15); + } + } + } + else if(rot == 0) { + + // Only first tree rotation implemented; pft[id].active etc. has to be set anew in stand.crop_rotation() + pft[id].active = true; + pft[id].plant = true; + if(st.reestab == "RESTRICTED") { + pft[id].reestab = true; + } + else if(st.reestab == "ALL") { + pftlist.firstobj(); + while (pftlist.isobj) { + Pft& pftx = pftlist.getobj(); + // Options here are only relevant when planted trees (FOREST) and regenerated growth (FOREST and/or NATURAL) needs to be distinguished in the output + // 1. reestablishment by both forest and natural pfts + // if(pftx.landcover == lc || st.naturalveg == "ALL" && pftx.landcover == NATURAL) { + // 2. reestablishment by natural pfts (when active) and planted forest pfts + // if(pftx.landcover == lc && (st.naturalveg != "ALL" || pft[pftx.id].plant) || st.naturalveg == "ALL" && pftx.landcover == NATURAL) { + // 3. reestablishment only by natural pfts (when active) + if(pftx.landcover == lc && st.naturalveg != "ALL" || st.naturalveg == "ALL" && pftx.landcover == NATURAL) { + pft[pftx.id].active = true; + pft[pftx.id].reestab = true; + } + pftlist.nextobj(); + } + } + } + } + } + else if(!mt.fallow) { + dprintf("Warning: stand type %d pft %s not in pftlist !\n", stid, (char*)mt.pftname);; + break; + } + } + else if(mt.planting_system == "SELECTION") { + + if(mt.selection != "") { + pftlist.firstobj(); + while (pftlist.isobj) { + Pft& pftx = pftlist.getobj(); + + if(mt.pftinselection((const char*)pftx.name)) { + + pft[pftx.id].active = true; + pft[pftx.id].reestab = true; + if(pftx.lifeform == TREE) + pft[pftx.id].plant = true; + } + else if(pftx.lifeform == TREE) { // Whether grass is allowed is specified in the generic code above + pft[pftx.id].active = false; + } + pftlist.nextobj(); + } + } + else { + dprintf("Warning: stand type %d planting selection not defined !\n", stid);; + break; + } + } + else if(mt.planting_system != "") { + + // planting systems (pft selections) defined here + + + } + } +} + +void Stand::rotate() { + + if (pftid >= 0 && stid >= 0) { + + ndays_inrotation = 0; + + int pftid_old = pftid; + + current_rot = (current_rot + 1) % stlist[stid].rotation.ncrops; + ManagementType& mt = stlist[stid].get_management(current_rot); + pftid = pftlist.getpftid(mt.pftname); + + // If fallow, use old pftid ! + if(mt.fallow) + pftid = pftid_old; + + Standpft& standpft = pft[pftid]; + + if (mt.hydrology == IRRIGATED) { + isirrigated = true; + standpft.irrigated = true; + } + else { + isirrigated = false; + standpft.irrigated = false; + } + + if (!readNfert) + gridcell->pft[pftid].Nfert_read = mt.nfert; + if (!readsowingdates) + standpft.sdate_force = mt.sdate; + if (!readharvestdates) + standpft.hdate_force = mt.hdate; + if(!readNfert_st) + gridcell->st[stid].nfert = mt.nfert; + } +} + +double Stand::transfer_area_lc(landcovertype to) { + + double area = 0.0; + + if (transfer_area_st) { + + for (int j=0; jcreate_stand(st.landcover, nobj); + int new_seed = new_stand.seed; + + // ...and deserialize to that stand + ArchiveInStream ais(ss); + new_stand.serialize(ais); + + new_stand.clone_year = date.year; +// new_stand.seed = new_seed; // ? + + // Set land use settings for new stand + new_stand.init_stand_lu(st, fraction); + + for (unsigned int p = 0; p < nobj; p++) { +// new_stand[p].age = 0; // probably not what we want + new_stand[p].managed = false; // or use value of mother stand ? + } + + return new_stand; +} + +double Stand::get_landcover_fraction() const { + if (get_gridcell().landcover.frac[landcover]) + return frac / get_gridcell().landcover.frac[landcover]; + else + return 0.0; +} + +void Stand::set_gridcell_fraction(double fraction) { + frac = fraction; +} + +void Stand::serialize(ArchiveStream& arch) { + if (arch.save()) { + for (unsigned int i = 0; i < pft.nobj; i++) { + arch & pft[i]; + } + + arch & nobj; + for (unsigned int k = 0; k < nobj; k++) { + arch & (*this)[k]; + } + } + else { + pft.killall(); + for (unsigned int i = 0; i < pftlist.nobj; i++) { + Standpft& standpft = pft.createobj(pftlist[i]); + arch & standpft; + } + + killall(); + unsigned int npatch; + arch & npatch; + for (unsigned int k = 0; k < npatch; k++) { + Patch& patch = createobj(*this, soiltype); + arch & patch; + } + } + + arch & first_year + & clone_year + & frac + & stid + & pftid + & current_rot + & ndays_inrotation + & infallow + & isirrigated + & hasgrassintercrop + & gdd0_intercrop + & cloned + & origin + & landcover + & seed; +} + +const Climate& Stand::get_climate() const { + + // In this implementation all stands within a grid cell + // share the same climate. Note that this might not be + // true in all versions of LPJ-GUESS, some may have + // different climate per landcover type for instance. + + return get_gridcell().climate; +} + +Gridcell& Stand::get_gridcell() const { + assert(gridcell); + return *gridcell; +} + +//////////////////////////////////////////////////////////////////////////////// +// Implementation of cropindiv_struct member functions +//////////////////////////////////////////////////////////////////////////////// + +void cropindiv_struct::serialize(ArchiveStream& arch) { + arch & grs_cmass_plant + & grs_cmass_leaf + & grs_cmass_root + & grs_cmass_ho + & grs_cmass_agpool + & grs_cmass_dead_leaf + & grs_cmass_stem + & cmass_leaf_sen + & nmass_ho + & nmass_agpool + & nmass_dead_leaf + & isintercropgrass; +} + +//////////////////////////////////////////////////////////////////////////////// +// Implementation of Individual member functions +//////////////////////////////////////////////////////////////////////////////// + +Individual::Individual(int i,Pft& p,Vegetation& v):pft(p),vegetation(v),id(i) { + + anpp = 0.0; + fpc = 0.0; + fpc_daily = 0.0; + densindiv = 0.0; + cmass_leaf = 0.0; + cmass_root = 0.0; + cmass_sap = 0.0; + cmass_heart = 0.0; + cmass_debt = 0.0; + cmass_leaf_post_turnover = 0.0; + cmass_root_post_turnover = 0.0; + cmass_tot_luc = 0.0; + phen = 0.0; + aphen = 0.0; + deltafpc = 0.0; + + nmass_leaf = 0.0; + nmass_root = 0.0; + nmass_sap = 0.0; + nmass_heart = 0.0; + cton_leaf_aopt = 0.0; + cton_leaf_aavr = 0.0; + cton_status = 0.0; + cmass_veg = 0.0; + nmass_veg = 0.0; + nmass_tot_luc = 0.0; + + nactive = 0.0; + nextin = 1.0; + nstore_longterm = 0.0; + nstore_labile = 0.0; + ndemand = 0.0; + fnuptake = 1.0; + anuptake = 0.0; + max_n_storage = 0.0; + scale_n_storage = 0.0; + + leafndemand = 0.0; + rootndemand = 0.0; + sapndemand = 0.0; + storendemand = 0.0; + leaffndemand = 0.0; + rootfndemand = 0.0; + sapfndemand = 0.0; + storefndemand = 0.0; + leafndemand_store = 0.0; + rootndemand_store = 0.0; + + nstress = false; + + // additional initialisation + age = 0.0; + fpar = 0.0; + aphen_raingreen = 0; + intercep = 0.0; + phen_mean = 0.0; + wstress = false; + lai = 0.0; + lai_layer = 0.0; + lai_indiv = 0.0; + lai_daily = 0.0; + lai_indiv_daily = 0.0; + alive = false; + + int m; + for (m=0; m<12; m++) { + mlai[m] = 0.0; + mlai_max[m] = 0.0; + } + + // bvoc + monstor = 0.; + iso = 0.; + mon = 0.; + fvocseas = 1.; + + dnpp = 0.0; + cropindiv = NULL; + last_turnover_day = -1; + + Stand& stand = vegetation.patch.stand; + + if (pft.landcover==CROPLAND) { + cropindiv=new cropindiv_struct; + + if (stand.pftid == pft.id) { + cropindiv->isprimarycrop = true; + } + else if (stand.hasgrassintercrop && pft.isintercropgrass) { // grass cover crop growth + cropindiv->isintercropgrass = true; + } + } +// dprintf("Year %d: Individual in stand %d created:id=%d, pft=%s\n", ::date.year-nyear_spinup+1901,vegetation.patch.stand.id,id,(char*)pft.name); +} + +void Individual::serialize(ArchiveStream& arch) { + arch & cmass_leaf + & cmass_root + & cmass_sap + & cmass_heart + & cmass_debt + & cmass_leaf_post_turnover + & cmass_root_post_turnover + & last_turnover_day + & fpc + & fpc_daily + & fpar + & densindiv + & phen + & aphen + & aphen_raingreen + & anpp + & aet + & aaet + & ltor + & height + & crownarea + & deltafpc + & boleht + & lai + & lai_layer + & lai_indiv + & lai_daily + & lai_indiv_daily + & greff_5 + & age + & mlai + & fpar_leafon + & lai_leafon_layer + & intercep + & phen_mean + & wstress + & alive + & iso + & mon + & monstor + & fvocseas + & nmass_leaf + & nmass_root + & nmass_sap + & nmass_heart + & nactive + & nextin + & nstore_longterm + & nstore_labile + & ndemand + & fnuptake + & anuptake + & max_n_storage + & scale_n_storage + & avmaxnlim + & cton_leaf_aopt + & cton_leaf_aavr + & cton_status + & cmass_veg + & nmass_veg + + & photosynthesis + & nstress + & leafndemand + & rootndemand + & sapndemand + & storendemand + & leaffndemand + & rootfndemand + & sapfndemand + & storefndemand + & leafndemand_store + & rootndemand_store + & nday_leafon; + + if (pft.landcover==CROPLAND) + arch & *cropindiv; +} + +Individual::~Individual() { + if (cropindiv) + delete cropindiv; +} + +/// Access functions for cropindiv +cropindiv_struct* Individual::get_cropindiv() const { + if (pft.landcover != CROPLAND) { + fail("Only crop individuals have cropindiv struct. Re-write code !\n"); + } + return cropindiv; +} + +cropindiv_struct* Individual::set_cropindiv() { + if (pft.landcover != CROPLAND) { + fail("Only crop individuals have cropindiv struct. Re-write code !\n"); + } + return cropindiv; +} + +void Individual::report_flux(Fluxes::PerPFTFluxType flux_type, double value) { + if (alive || istruecrop_or_intercropgrass()) { + vegetation.patch.fluxes.report_flux(flux_type, pft.id, value); + } +} + +void Individual::report_flux(Fluxes::PerPatchFluxType flux_type, double value) { + if (alive || istruecrop_or_intercropgrass()) { + vegetation.patch.fluxes.report_flux(flux_type, value); + } +} + + +/// Help function for reduce_biomass(), partitions nstore into leafs and roots +/** + * As leaf and roots can have a very low N concentration after growth and allocation, + * N in nstore() is split between them to saticfy relationship between their average C:N ratios + */ +void nstore_adjust(double& cmass_leaf,double& cmass_root, double& nmass_leaf, double& nmass_root, + double nstore, double cton_leaf, double cton_root) { + + // (1) cmass_leaf / ((nmass_leaf + leaf_ndemand) * cton_leaf) = cmass_root / ((nmass_root + root_ndemand) * cton_root) + // (2) leaf_ndemand + root_ndemand = nstore + + // (1) + (2) leaf_ndemand = (cmass_leaf * ratio (nmass_root + nstore) - cmass_root * nmass_leaf) / (cmass_root + cmass_leaf * ratio) + // + // where ratio = cton_root / cton_leaf + + double ratio = cton_root / cton_leaf; + + double leaf_ndemand = (cmass_leaf * ratio * (nmass_root + nstore) - cmass_root * nmass_leaf) / (cmass_root + cmass_leaf * ratio); + double root_ndemand = nstore - leaf_ndemand; + + nmass_leaf += leaf_ndemand; + nmass_root += root_ndemand; +} + +void Individual::reduce_biomass(double mortality, double mortality_fire) { + + // This function needs to be modified if a new lifeform is added, + // specifically to deal with nstore(). + assert(pft.lifeform == TREE || pft.lifeform == GRASS); + + if (!negligible(mortality)) { + + const double mortality_non_fire = mortality - mortality_fire; + + // Transfer killed biomass to litter + // (above-ground biomass killed by fire enters atmosphere, not litter) + + Patchpft& ppft = patchpft(); + + double cmass_leaf_litter = mortality * cmass_leaf; + double cmass_root_litter = mortality * cmass_root; + + if (pft.landcover==CROPLAND) { + if (pft.aboveground_ho) + cmass_leaf_litter += mortality * cropindiv->cmass_ho; + else + cmass_root_litter += mortality * cropindiv->cmass_ho; + + cmass_leaf_litter += mortality * cropindiv->cmass_agpool; + } + + ppft.litter_leaf += cmass_leaf_litter * mortality_non_fire / mortality; + ppft.litter_root += cmass_root_litter; + + if (cmass_debt <= cmass_heart + cmass_sap) { + if (cmass_debt <= cmass_heart) { + ppft.litter_sap += mortality_non_fire * cmass_sap; + ppft.litter_heart += mortality_non_fire * (cmass_heart - cmass_debt); + } + else { + ppft.litter_sap += mortality_non_fire * (cmass_sap + cmass_heart - cmass_debt); + } + } + else { + double debt_excess = mortality_non_fire * (cmass_debt - (cmass_sap + cmass_heart)); + report_flux(Fluxes::NPP, debt_excess); + report_flux(Fluxes::RA, -debt_excess); + } + + double nmass_leaf_litter = mortality * nmass_leaf; + double nmass_root_litter = mortality * nmass_root; + + if (pft.landcover==CROPLAND) { + if (pft.aboveground_ho) + nmass_leaf_litter += mortality * cropindiv->nmass_ho; + else + nmass_root_litter += mortality * cropindiv->nmass_ho; + + nmass_leaf_litter += mortality * cropindiv->nmass_agpool; + } + + // stored N is partioned out to leaf and root biomass as new tissue after growth might have extremely low + // N content (to get closer to relationship between compartment averages (cton_leaf, cton_root, cton_sap)) + nstore_adjust(cmass_leaf_litter, cmass_root_litter, nmass_leaf_litter, nmass_root_litter, + mortality * nstore(), pft.cton_leaf_avr,pft.cton_root_avr); + + ppft.nmass_litter_leaf += nmass_leaf_litter * mortality_non_fire / mortality; + ppft.nmass_litter_root += nmass_root_litter; + ppft.nmass_litter_sap += mortality_non_fire * nmass_sap; + ppft.nmass_litter_heart += mortality_non_fire * nmass_heart; + + // Flux to atmosphere from burnt above-ground biomass + + double cflux_fire = mortality_fire * (cmass_leaf_litter / mortality + cmass_wood()); + double nflux_fire = mortality_fire * (nmass_leaf_litter / mortality + nmass_wood()); + + report_flux(Fluxes::FIREC, cflux_fire); + + report_flux(Fluxes::NH3_FIRE, Fluxes::NH3_FIRERATIO * nflux_fire); + report_flux(Fluxes::NOx_FIRE, Fluxes::NOx_FIRERATIO * nflux_fire); + report_flux(Fluxes::N2O_FIRE, Fluxes::N2O_FIRERATIO * nflux_fire); + report_flux(Fluxes::N2_FIRE, Fluxes::N2_FIRERATIO * nflux_fire); + + // Reduce this Individual's biomass values + + const double remaining = 1.0 - mortality; + + if (pft.lifeform != GRASS) { + densindiv *= remaining; + } + + cmass_leaf *= remaining; + cmass_root *= remaining; + cmass_sap *= remaining; + cmass_heart *= remaining; + cmass_debt *= remaining; + if (pft.landcover==CROPLAND) { + cropindiv->cmass_ho *= remaining; + cropindiv->cmass_agpool *= remaining; + } + nmass_leaf *= remaining; + nmass_root *= remaining; + nmass_sap *= remaining; + nmass_heart *= remaining; + nstore_longterm *= remaining; + nstore_labile *= remaining; + if (pft.landcover==CROPLAND) { + cropindiv->nmass_ho *= remaining; + cropindiv->nmass_agpool *= remaining; + } + } +} + +double Individual::cton_leaf(bool use_phen /* = true*/) const { + + Stand& stand = vegetation.patch.stand; + + if (ifnlim) { + + if (stand.is_true_crop_stand() && !negligible(cmass_leaf_today()) && !negligible(nmass_leaf)) { + return cmass_leaf_today() / nmass_leaf; + } + else if (!stand.is_true_crop_stand() && !negligible(cmass_leaf) && !negligible(nmass_leaf)) { + if (use_phen) { + if (!negligible(phen)) { + return cmass_leaf_today() / nmass_leaf; + } + else { + return pft.cton_leaf_avr; + } + } + else { + return cmass_leaf / nmass_leaf; + } + } + else { + return pft.cton_leaf_max; + } + } + else { + return pft.cton_leaf_avr; + } +} + +double Individual::cton_root(bool use_phen /* = true*/) const { + + if (ifnlim) { + if (!negligible(cmass_root) && !negligible(nmass_root)) { + if (use_phen) { + if (!negligible(cmass_root_today())) { + return cmass_root_today() / nmass_root; + } + else { + return pft.cton_root_avr; + } + } + else { + return cmass_root / nmass_root; + } + } + else { + return pft.cton_root_max; + } + } + else { + return pft.cton_root_avr; + } +} + +double Individual::cton_sap() const { + + if (pft.lifeform == TREE) { + if (ifnlim) { + if (!negligible(cmass_sap) && !negligible(nmass_sap)) + return cmass_sap / nmass_sap; + else + return pft.cton_sap_max; + } + else { + return pft.cton_sap_avr; + } + } + else { + return 1.0; + } +} + +/// C content of individual +/** + * INPUT PARAMETERS + * + * \param scale_indiv scaling factor for living C + * \param luc down-scales living C (used in C balance tests) + */ +double Individual::ccont(double scale_indiv, bool luc) const { + + double ccont = 0.0; + + if (alive || istruecrop_or_intercropgrass()) { + + if (has_daily_turnover()) { // Not taking into account future daily wood allocation/turnover + + if (cropindiv) { + + if (luc) { + ccont += cropindiv->grs_cmass_leaf - cropindiv->grs_cmass_leaf_luc * (1.0 - scale_indiv); + ccont += cropindiv->grs_cmass_root - cropindiv->grs_cmass_root_luc * (1.0 - scale_indiv); + } + else { + ccont += cropindiv->grs_cmass_leaf * scale_indiv; + ccont += cropindiv->grs_cmass_root * scale_indiv; + } + + if (pft.phenology == CROPGREEN) { + + if (luc) { + ccont += cropindiv->grs_cmass_ho - cropindiv->grs_cmass_ho_luc * (1.0 - scale_indiv); + ccont += cropindiv->grs_cmass_agpool - cropindiv->grs_cmass_agpool_luc * (1.0 - scale_indiv); + ccont += cropindiv->grs_cmass_dead_leaf - cropindiv->grs_cmass_dead_leaf_luc * (1.0 - scale_indiv); + ccont += cropindiv->grs_cmass_stem - cropindiv->grs_cmass_stem_luc * (1.0 - scale_indiv); + } + else { + ccont += cropindiv->grs_cmass_ho * scale_indiv; + ccont += cropindiv->grs_cmass_agpool * scale_indiv; + ccont += cropindiv->grs_cmass_dead_leaf * scale_indiv; + ccont += cropindiv->grs_cmass_stem * scale_indiv; + } + } + } + } + else { + + ccont = cmass_leaf + cmass_root + cmass_sap + cmass_heart - cmass_debt; + + if (pft.landcover == CROPLAND) { + ccont += cropindiv->cmass_ho + cropindiv->cmass_agpool; + // Yearly allocation not defined for crops with nlim + } + ccont *= scale_indiv; + } + } + + return ccont; +} + +/// N content of individual +/** + * INPUT PARAMETERS + * + * \param scale_indiv scaling factor for living N + * \param luc down-scales living N (used in C balance tests) + */ +double Individual::ncont(double scale_indiv, bool luc) const { + + double ncont = 0.0; + + if (luc) { + + ncont += nmass_leaf - nmass_leaf_luc * (1.0 - scale_indiv); + ncont += nmass_root - nmass_root_luc * (1.0 - scale_indiv); + ncont += nmass_sap - nmass_sap_luc * (1.0 - scale_indiv); + ncont += nmass_heart - nmass_heart_luc * (1.0 - scale_indiv); + ncont += nstore_longterm - nstore_longterm_luc * (1.0 - scale_indiv); + ncont += nstore_labile - nstore_labile_luc * (1.0 - scale_indiv); + } + else { + ncont += nmass_leaf * scale_indiv; + ncont += nmass_root * scale_indiv; + ncont += nmass_sap * scale_indiv; + ncont += nmass_heart * scale_indiv; + ncont += nstore_longterm * scale_indiv; + ncont += nstore_labile * scale_indiv; + } + + if (pft.landcover == CROPLAND) { + + if (luc) { + ncont += cropindiv->nmass_ho - cropindiv->nmass_ho_luc * (1.0 - scale_indiv); + ncont += cropindiv->nmass_agpool - cropindiv->nmass_agpool_luc * (1.0 - scale_indiv); + ncont += cropindiv->nmass_dead_leaf - cropindiv->nmass_dead_leaf_luc * (1.0 - scale_indiv); + } + else { + ncont += cropindiv->nmass_ho * scale_indiv; + ncont += cropindiv->nmass_agpool * scale_indiv; + ncont += cropindiv->nmass_dead_leaf * scale_indiv; + } + } + + return ncont; +} + +/// Whether grass growth is uninterrupted by crop growth. +bool Individual::continous_grass() const { + + if (pft.landcover != CROPLAND) { + return false; + } + + Stand& stand = vegetation.patch.stand; + StandType& st = stlist[stand.stid]; + bool sowing_restriction = true; + + for (int i=0; i -1 && !stand.get_gridcell().pft[pftid].sowing_restriction) { + sowing_restriction = false; + } + } + + return cropindiv->isintercropgrass && sowing_restriction; +} + +double Individual::ndemand_storage(double cton_leaf_opt) { + + if (vegetation.patch.stand.is_true_crop_stand() && ifnlim) // only CROPGREEN, only ifnlim ? + // analogous with root demand + storendemand = max(0.0, cropindiv->grs_cmass_stem / (cton_leaf_opt * pft.cton_stem_avr / pft.cton_leaf_avr) - cropindiv->nmass_agpool); + else + storendemand = max(0.0, min(anpp * scale_n_storage / cton_leaf(), max_n_storage) - nstore()); + + return storendemand; +} + +/// Checks C mass and zeroes any negative value, balancing by adding to npp and reducing respiration +double Individual::check_C_mass() { + + if (pft.landcover != CROPLAND) + return 0; + + double negative_cmass = 0.0; + + if (cropindiv->grs_cmass_leaf < 0.0) { + negative_cmass -= cropindiv->grs_cmass_leaf; + cropindiv->ycmass_leaf -= cropindiv->grs_cmass_leaf; + cropindiv->grs_cmass_plant -= cropindiv->grs_cmass_leaf; + cropindiv->grs_cmass_leaf = 0.0; + } + if (cropindiv->grs_cmass_root < 0.0) { + negative_cmass -= cropindiv->grs_cmass_root; + cropindiv->ycmass_root -= cropindiv->grs_cmass_root; + cropindiv->grs_cmass_plant -= cropindiv->grs_cmass_root; + cropindiv->grs_cmass_root = 0.0; + } + if (cropindiv->grs_cmass_ho < 0.0) { + negative_cmass -= cropindiv->grs_cmass_ho; + cropindiv->ycmass_ho -= cropindiv->grs_cmass_ho; + cropindiv->grs_cmass_plant -= cropindiv->grs_cmass_ho; + cropindiv->grs_cmass_ho = 0.0; + } + if (cropindiv->grs_cmass_agpool < 0.0) { + negative_cmass -= cropindiv->grs_cmass_agpool; + cropindiv->ycmass_agpool -= cropindiv->grs_cmass_agpool; + cropindiv->grs_cmass_plant -= cropindiv->grs_cmass_agpool; + cropindiv->grs_cmass_agpool = 0.0; + } + if (cropindiv->grs_cmass_dead_leaf < 0.0) { + negative_cmass -= cropindiv->grs_cmass_dead_leaf; + cropindiv->ycmass_dead_leaf -= cropindiv->grs_cmass_dead_leaf; + cropindiv->grs_cmass_plant -= cropindiv->grs_cmass_dead_leaf; + cropindiv->grs_cmass_dead_leaf = 0.0; + } + if (cropindiv->grs_cmass_stem < 0.0) { + negative_cmass -= cropindiv->grs_cmass_stem; + cropindiv->ycmass_stem -= cropindiv->grs_cmass_stem; + cropindiv->grs_cmass_plant -= cropindiv->grs_cmass_stem; + cropindiv->grs_cmass_stem = 0.0; + } + + if (largerthanzero(negative_cmass, -14)) { + anpp += negative_cmass; + report_flux(Fluxes::NPP, negative_cmass); + report_flux(Fluxes::RA, -negative_cmass); + } + + return negative_cmass; +} + +/// Checks N mass and zeroes any negative value, balancing by reducing N mass of other organs and (if needed) reducing anflux_landuse_change +double Individual::check_N_mass() { + + if (pft.landcover != CROPLAND && pft.landcover != PASTURE) + return 0; + + double negative_nmass = 0.0; + + if (nmass_leaf < 0.0) { + negative_nmass -= nmass_leaf; + if (cropindiv) + cropindiv->ynmass_leaf -= nmass_leaf; + nmass_leaf = 0.0; + } + if (nmass_root < 0.0) { + negative_nmass -= nmass_root; + if (cropindiv) + cropindiv->ynmass_root -= nmass_root; + nmass_root = 0.0; + } + if (cropindiv) { + if (cropindiv->nmass_ho < 0.0) { + negative_nmass -= cropindiv->nmass_ho; + cropindiv->ynmass_ho -= cropindiv->nmass_ho; + cropindiv->nmass_ho = 0.0; + } + if (cropindiv->nmass_agpool < 0.0) { + negative_nmass -= cropindiv->nmass_agpool; + cropindiv->ynmass_agpool -= cropindiv->nmass_agpool; + cropindiv->nmass_agpool = 0.0; + } + if (cropindiv->nmass_dead_leaf < 0.0) { + negative_nmass -= cropindiv->nmass_dead_leaf; + cropindiv->ynmass_dead_leaf -= cropindiv->nmass_dead_leaf; + cropindiv->nmass_dead_leaf = 0.0; + } + } + if (nstore_labile < 0.0) { + negative_nmass -= nstore_labile; + nstore_labile = 0.0; + } + if (nstore_longterm < 0.0) { + negative_nmass -= nstore_longterm; + nstore_longterm = 0.0; + } + + if (largerthanzero(negative_nmass, -14)) { + double pos_nmass = ncont(); + if (pos_nmass > negative_nmass) { + nmass_leaf -= negative_nmass * nmass_leaf / pos_nmass; + nmass_root -= negative_nmass * nmass_root / pos_nmass; + if (cropindiv) { + cropindiv->nmass_ho -= negative_nmass * cropindiv->nmass_ho / pos_nmass; + cropindiv->nmass_agpool -= negative_nmass * cropindiv->nmass_agpool / pos_nmass; + cropindiv->nmass_dead_leaf -= negative_nmass * cropindiv->nmass_dead_leaf / pos_nmass; + } + } + else { + vegetation.patch.stand.get_gridcell().landcover.anflux_landuse_change -= (negative_nmass - pos_nmass) * vegetation.patch.stand.get_gridcell_fraction(); + nmass_leaf = 0.0; + nmass_leaf = 0.0; + if (cropindiv) { + cropindiv->nmass_ho = 0.0; + cropindiv->nmass_agpool = 0.0; + cropindiv->nmass_dead_leaf = 0.0; + } + } + } + + return negative_nmass; +} + +/// Whether resetting of grs_cmass and turnover (if has_daily_turnover() returns true) of continuous grass is to be done this day. +bool Individual::is_turnover_day() const { + + if (patchpft().cropphen && patchpft().cropphen->growingseason) { + + const Climate& climate = vegetation.patch.get_climate(); + + return date.day == climate.testday_prec; + } + else { + return false; + } +} + +Patchpft& Individual::patchpft() const { + return vegetation.patch.pft[pft.id]; +} + +/// Save cmass-values on first day of the year of land cover change in expanding stands +void Individual::save_cmass_luc() { + cmass_tot_luc = 0.0; + + if (cropindiv) { + cropindiv->grs_cmass_leaf_luc = cropindiv->grs_cmass_leaf; + cropindiv->grs_cmass_root_luc = cropindiv->grs_cmass_root; + cropindiv->grs_cmass_ho_luc = cropindiv->grs_cmass_ho; + cropindiv->grs_cmass_agpool_luc = cropindiv->grs_cmass_agpool; + cropindiv->grs_cmass_dead_leaf_luc = cropindiv->grs_cmass_dead_leaf; + cropindiv->grs_cmass_stem_luc = cropindiv->grs_cmass_stem; + } + cmass_tot_luc = ccont(); +} + +/// Save nmass-values on first day of the year of land cover change in expanding stands +void Individual::save_nmass_luc() { + nmass_leaf_luc = nmass_leaf; + nmass_root_luc = nmass_root; + nmass_sap_luc = nmass_sap; + nmass_heart_luc = nmass_heart; + nstore_longterm_luc = nstore_longterm; + nstore_labile_luc = nstore_labile; + + if (cropindiv) { + cropindiv->nmass_ho_luc = cropindiv->nmass_ho; + cropindiv->nmass_agpool_luc = cropindiv->nmass_agpool; + cropindiv->nmass_dead_leaf_luc = cropindiv->nmass_dead_leaf; + } + nmass_tot_luc = ncont(); +} + +/// Gets the individual's daily cmass_leaf value +double Individual::cmass_leaf_today() const { + + if (istruecrop_or_intercropgrass()) + return patchpft().cropphen->growingseason ? cropindiv->grs_cmass_leaf : 0; + else + return cmass_leaf * phen; +} + +/// Gets the individual's daily cmass_root value +double Individual::cmass_root_today() const { + + if (istruecrop_or_intercropgrass()) + return patchpft().cropphen->growingseason ? cropindiv->grs_cmass_root : 0; + else + return cmass_root * phen; +} + +/// Gets the individual's daily fpc value +double Individual::fpc_today() const { + + if (pft.phenology == CROPGREEN) + return patchpft().cropphen->growingseason ? fpc_daily : 0; + else + return fpc * phen; +} + +/// Gets the individual's daily lai value +double Individual::lai_today() const { + + if (pft.phenology == CROPGREEN) + return patchpft().cropphen->growingseason ? lai_daily : 0; + else + return lai * phen; +} + +/// Gets the individual's daily lai_indiv value +double Individual::lai_indiv_today() const { + + if (pft.phenology == CROPGREEN) + return patchpft().cropphen->growingseason ? lai_indiv_daily : 0; + else + return lai_indiv * phen; +} + +/// Gets the Nitrigen limited LAI +double Individual::lai_nitrogen_today() const{ + if (pft.phenology==CROPGREEN) { + + double Ln = 0.0; + if (patchpft().cropphen->growingseason && cmass_leaf_today() > 0.0) { + const double k = 0.5; + const double ktn = 0.52*k + 0.01; // Yin et al 2003 + double nb = 1/(pft.cton_leaf_max*pft.sla); + Ln = (1/ktn) * log(1+ktn*nmass_leaf/nb); + } + return Ln; + } + else { + return 1.0; + } +} + +/// Gets the growingseason status for crop individual. Non-crop individuals always return true. +bool Individual::growingseason() const { + return patchpft().cropphen ? patchpft().cropphen->growingseason : true; +} + +/// Whether harvest and turnover is done on actual C and N on harvest or turnover day, which can occur any day of the year. +bool Individual::has_daily_turnover() const { + return istruecrop_or_intercropgrass(); +} + +/// Help function for kill(), partitions wood biomass into litter and harvest +/** + * Wood biomass (either C or N) is partitioned into litter pools and + * harvest, according to PFT specific harvest fractions. + * + * Biomass is sent in as sap and heart, any debt should already have been + * subtracted from these before calling this function. + * + * \param mass_sap Sapwood + * \param mass_heart Heartwood + * \param harv_eff Harvest efficiency (fraction of biomass harvested) + * \param harvest_slow_frac Fraction of harvested products that goes into slow depository + * \param res_outtake Fraction of residue outtake at harvest + * \param litter_sap Biomass going to sapwood litter pool + * \param litter_heart Biomass going to heartwood litter pool + * \param fast_harvest Biomass going to harvest flux + * \param slow_harvest Biomass going to slow depository + */ +void partition_wood_biomass(double mass_sap, double mass_heart, + double harv_eff, double harvest_slow_frac, double res_outtake, + double& litter_sap, double& litter_heart, + double& fast_harvest, double& slow_harvest) { + + double sap_left = mass_sap; + double heart_left = mass_heart; + + // Remove harvest + double total_wood_harvest = harv_eff * (sap_left + heart_left); + + sap_left *= 1 - harv_eff; + heart_left *= 1 - harv_eff; + + // Partition wood harvest into slow and fast + slow_harvest = total_wood_harvest * harvest_slow_frac; + fast_harvest = total_wood_harvest * (1 - harvest_slow_frac); + + // Remove residue outtake + fast_harvest += res_outtake * (sap_left + heart_left); + + sap_left *= 1 - res_outtake; + heart_left *= 1 - res_outtake; + + // The rest goes to litter + litter_sap = sap_left; + litter_heart = heart_left; +} + + +void Individual::kill(bool harvest /* = false */) { + Patchpft& ppft = patchpft(); + + double charvest_flux = 0.0; + double charvested_products_slow = 0.0; + + double nharvest_flux = 0.0; + double nharvested_products_slow = 0.0; + + double harv_eff = 0.0; + double harvest_slow_frac = 0.0; + double res_outtake = 0.0; + + // The function always deals with harvest, but the harvest + // fractions are zero when there is no harvest. + if (harvest) { + harv_eff = pft.harv_eff; + + if (ifslowharvestpool) { + harvest_slow_frac = pft.harvest_slow_frac; + } + + res_outtake = pft.res_outtake; + } + + // C doesn't return to litter/harvest if the Individual isn't alive + if (alive || istruecrop_or_intercropgrass()) { + + // For leaf and root, catches small, negative values too + + // Leaf: remove residue outtake and send the rest to litter + if (has_daily_turnover() && cropindiv) { + + if (pft.lifeform == GRASS && pft.phenology != CROPGREEN) { + charvest_flux += cropindiv->grs_cmass_leaf * harv_eff; + cropindiv->grs_cmass_leaf *= (1 - harv_eff); + } + + ppft.litter_leaf += cropindiv->grs_cmass_leaf * (1 - res_outtake); + charvest_flux += cropindiv->grs_cmass_leaf * res_outtake; + } + else { + + if (pft.lifeform == GRASS && pft.phenology != CROPGREEN) { + charvest_flux += cmass_leaf * harv_eff; + cmass_leaf *= (1 - harv_eff); + } + ppft.litter_leaf += cmass_leaf * (1 - res_outtake); + charvest_flux += cmass_leaf * res_outtake; + } + // Root: all goes to litter + if (has_daily_turnover() && cropindiv) + ppft.litter_root += cropindiv->grs_cmass_root; + else + ppft.litter_root += cmass_root; + + if (pft.landcover == CROPLAND) { + + if (has_daily_turnover()) { + + charvest_flux += cropindiv->grs_cmass_ho * harv_eff; + cropindiv->grs_cmass_ho *= (1 - harv_eff); + + if (pft.aboveground_ho) { + ppft.litter_leaf+=cropindiv->grs_cmass_ho * (1 - res_outtake); + charvest_flux += cropindiv->grs_cmass_ho * res_outtake; + } + else { + ppft.litter_root+=cropindiv->grs_cmass_ho; + } + ppft.litter_leaf+=cropindiv->grs_cmass_agpool * (1 - res_outtake); + charvest_flux += cropindiv->grs_cmass_agpool * res_outtake; + + ppft.litter_leaf+=cropindiv->grs_cmass_dead_leaf * (1 - res_outtake); + charvest_flux += cropindiv->grs_cmass_dead_leaf * res_outtake; + + ppft.litter_leaf+=cropindiv->grs_cmass_stem * (1 - res_outtake); + charvest_flux += cropindiv->grs_cmass_stem * res_outtake; + } + else { + + charvest_flux += cropindiv->cmass_ho * harv_eff; + cropindiv->cmass_ho *= (1 - harv_eff); + + if (pft.aboveground_ho) { + ppft.litter_leaf+=cropindiv->cmass_ho * (1 - res_outtake); + charvest_flux += cropindiv->cmass_ho * res_outtake; + } + else { + ppft.litter_root+=cropindiv->cmass_ho; + } + ppft.litter_leaf+=cropindiv->cmass_agpool * (1 - res_outtake); + charvest_flux += cropindiv->cmass_agpool * res_outtake; + } + } + + // Deal with the wood biomass and carbon debt for trees + if (pft.lifeform == TREE) { + + // debt smaller than existing wood biomass + if (cmass_debt <= cmass_sap + cmass_heart) { + + // before partitioning the biomass into litter and harvest, + // first get rid of the debt so we're left with only + // sap and heart + double to_partition_sap = 0.0; + double to_partition_heart = 0.0; + + if (cmass_heart >= cmass_debt) { + to_partition_sap = cmass_sap; + to_partition_heart = cmass_heart - cmass_debt; + } + else { + to_partition_sap = cmass_sap + cmass_heart - cmass_debt; + } + + double clitter_sap, clitter_heart, cwood_harvest; + + partition_wood_biomass(to_partition_sap, to_partition_heart, + harv_eff, harvest_slow_frac, res_outtake, + clitter_sap, clitter_heart, + cwood_harvest, charvested_products_slow); + + ppft.litter_sap += clitter_sap; + ppft.litter_heart += clitter_heart; + + charvest_flux += cwood_harvest; + } + // debt larger than existing wood biomass + else { + double debt_excess = cmass_debt - (cmass_sap + cmass_heart); + report_flux(Fluxes::NPP, debt_excess); + report_flux(Fluxes::RA, -debt_excess); + } + } + } + + // Nitrogen always return to soil litter + if (pft.lifeform == TREE) { + + double nlitter_sap, nlitter_heart, nwood_harvest; + + // Transfer nitrogen storage to sapwood nitrogen litter/harvest + partition_wood_biomass(nmass_sap + nstore(), nmass_heart, + harv_eff, harvest_slow_frac, res_outtake, + nlitter_sap, nlitter_heart, + nwood_harvest, nharvested_products_slow); + + ppft.nmass_litter_sap += nlitter_sap; + ppft.nmass_litter_heart += nlitter_heart; + + nharvest_flux += nwood_harvest; + } + else { + // Transfer nitrogen storage to root nitrogen litter + ppft.nmass_litter_root += nstore(); + } + + // Leaf: remove residue outtake and send the rest to litter + ppft.nmass_litter_leaf += nmass_leaf * (1 - res_outtake); + nharvest_flux += nmass_leaf * res_outtake; + + // Root: all goes to litter + ppft.nmass_litter_root += nmass_root; + + if (pft.landcover == CROPLAND) { + if (pft.aboveground_ho) { + ppft.nmass_litter_leaf+=cropindiv->nmass_ho * (1 - res_outtake); + nharvest_flux += cropindiv->nmass_ho * res_outtake; + } + else + ppft.litter_root+=cropindiv->nmass_ho; + + ppft.nmass_litter_leaf+=cropindiv->nmass_agpool * (1 - res_outtake); + nharvest_flux += cropindiv->nmass_agpool * res_outtake; + ppft.nmass_litter_leaf += cropindiv->nmass_dead_leaf * (1 - res_outtake); + nharvest_flux += cropindiv->nmass_dead_leaf * res_outtake; + } + + // Report harvest fluxes + report_flux(Fluxes::HARVESTC, charvest_flux); + report_flux(Fluxes::HARVESTN, nharvest_flux); + + // Add to biomass depositories for long-lived products + ppft.harvested_products_slow += charvested_products_slow; + ppft.harvested_products_slow_nmass += nharvested_products_slow; +} + +double Individual::wscal_mean() const { + return patchpft().wscal_mean; +} + +//////////////////////////////////////////////////////////////////////////////// +// Implementation of Gridcellpft member functions +//////////////////////////////////////////////////////////////////////////////// + + +void Gridcellpft::serialize(ArchiveStream& arch) { + arch & addtw + & Km + & autumnoccurred + & springoccurred + & vernstartoccurred + & vernendoccurred + & first_autumndate + & first_autumndate20 + & first_autumndate_20 + & last_springdate + & last_springdate20 + & last_springdate_20 + & last_verndate + & last_verndate20 + & last_verndate_20 + & sdate_default + & sdatecalc_temp + & sdatecalc_prec + & sdate_force + & hdate_force + & Nfert_read + & hlimitdate_default + & wintertype + & swindow + & swindow_irr + & sowing_restriction; +} + +//////////////////////////////////////////////////////////////////////////////// +// Implementation of Gridcellst member functions +//////////////////////////////////////////////////////////////////////////////// + +void Gridcellst::serialize(ArchiveStream& arch) { + arch & frac + & nstands + & nfert; +} + +//////////////////////////////////////////////////////////////////////////////// +// Implementation of Landcover member functions +//////////////////////////////////////////////////////////////////////////////// + +Landcover::Landcover() { + + updated = false; + + acflux_harvest_slow = 0.0; + acflux_landuse_change = 0.0; + anflux_harvest_slow = 0.0; + anflux_landuse_change = 0.0; + + for (int i=0; i= nyear_spinup && !negligible(ccont - ccont_zero + cflux - cflux_zero, -10)) { + dprintf("\nStand %d Patch %d Indiv %d C balance year %d day %d: %.10f\n", patch.stand.id, patch.id, indiv.id, date.year, date.day, ccont - ccont_zero + cflux - cflux_zero); + dprintf("C pool change: %.10f\n", ccont - ccont_zero); + dprintf("C flux: %.10f\n\n", cflux - cflux_zero); + balance = false; + } + + return balance; +} + +bool MassBalance::check_indiv_N(Individual& indiv, bool check_harvest) { + + bool balance = true; + + if (ifnlim) { + + Patch& patch = indiv.vegetation.patch; + Stand& stand = patch.stand; + if(!stand.is_true_crop_stand()) + return balance; + Gridcell& gridcell = stand.get_gridcell(); + double ncont = indiv.ncont(); + ncont += patch.ncont(0.0); + double nflux = patch.nflux(); + + if(check_harvest && patch.isharvestday) + ncont_zero = ncont_zero_scaled; + + if(date.year >= nyear_spinup && !negligible(ncont - ncont_zero + nflux - nflux_zero, -14)) { + dprintf("\nStand %d Patch %d Indiv %d N balance year %d day %d: %.10f\n", patch.stand.id, patch.id, indiv.id, date.year, date.day, ncont - ncont_zero + nflux - nflux_zero); + dprintf("N pool change: %.14f\n", ncont - ncont_zero); + dprintf("N flux: %.14f\n\n", nflux - nflux_zero); + balance = false; + } + + } + + return balance; +} + +/// Should be preceded by init_indiv() +/** check_harvest must be true if growth_daily() is tested + * canopy_exchange() and growth_daily() and functions in between cannot be tested separately + */ +bool MassBalance::check_indiv(Individual& indiv, bool check_harvest) { + + return check_indiv_C(indiv, check_harvest) && check_indiv_N(indiv, check_harvest); +} + +/// Should be used together with check_patch() e.g. in framework() +void MassBalance::init_patch(Patch& patch) { + + Stand& stand = patch.stand; + if (!stand.is_true_crop_stand()) + return; + Gridcell& gridcell = stand.get_gridcell(); + + double scale = 1.0; + if (patch.stand.get_gridcell().landcover.updated && (patch.nharv == 0 || date.day == 0)) + scale = stand.scale_LC_change; + + ccont_zero = patch.ccont(); + ccont_zero_scaled = patch.ccont(scale, true); + cflux_zero = patch.cflux(); + + if (stand.get_gridcell_fraction()) + cflux_zero += gridcell.landcover.acflux_harvest_slow / stand.get_gridcell_fraction(); + + ncont_zero = patch.ncont(); + ncont_zero_scaled = patch.ncont(scale, true); + nflux_zero = patch.nflux(); + + if (stand.get_gridcell_fraction()) + nflux_zero += gridcell.landcover.anflux_harvest_slow / stand.get_gridcell_fraction(); +} + +bool MassBalance::check_patch_C(Patch& patch, bool check_harvest) { + + bool balance = true; + Stand& stand = patch.stand; + if (!stand.is_true_crop_stand()) + return balance; + Gridcell& gridcell = stand.get_gridcell(); + double ccont = patch.ccont(); + double cflux = patch.cflux(); + + if (stand.get_gridcell_fraction()) + cflux += gridcell.landcover.acflux_harvest_slow / stand.get_gridcell_fraction(); + + if (check_harvest && patch.isharvestday) + ccont_zero = ccont_zero_scaled; + + if (date.year >= nyear_spinup && !negligible(ccont - ccont_zero + cflux - cflux_zero, -10)) { + dprintf("\nStand %d Patch %d C balance year %d day %d: %.10f\n", patch.stand.id, patch.id, date.year, date.day, ccont - ccont_zero + cflux - cflux_zero); + dprintf("C pool change: %.10f\n", ccont - ccont_zero); + dprintf("C flux: %.10f\n\n", cflux - cflux_zero); + balance = false; + } + + return balance; +} + +bool MassBalance::check_patch_N(Patch& patch, bool check_harvest) { + + bool balance = true; + + if (ifnlim) { + + Stand& stand = patch.stand; + if (!stand.is_true_crop_stand()) + return balance; + Gridcell& gridcell = stand.get_gridcell(); + double ncont = patch.ncont(); + double nflux = patch.nflux(); + + if (stand.get_gridcell_fraction()) + nflux += gridcell.landcover.anflux_harvest_slow / stand.get_gridcell_fraction(); + + if (check_harvest && patch.isharvestday) + ncont_zero = ncont_zero_scaled; + + if (date.year >= nyear_spinup && !negligible(ncont - ncont_zero + nflux - nflux_zero, -14)) { + dprintf("\nStand %d Patch %d N balance year %d day %d: %.14f\n", patch.stand.id, patch.id, date.year, date.day, ncont - ncont_zero + nflux - nflux_zero); + dprintf("N pool change: %.14f\n", ncont - ncont_zero); + dprintf("N flux: %.14f\n\n", nflux - nflux_zero); + balance = false; + } + + } + + return balance; +} + +/// Should be preceded by init_patch() e.g. i framework() +/** check_harvest must be true if growth_daily() is tested + * canopy_exchange() and growth_daily() and functions in between cannot be tested separately + * (init_patch() must be before canopy_exchange() and check_patch() after growth_daily() + */ +bool MassBalance::check_patch(Patch& patch, bool check_harvest) { + + return check_patch_C(patch, check_harvest) && check_patch_N(patch, check_harvest); +} + +void MassBalance::check_year(Gridcell& gridcell) { + + if (date.year < start_year) { + return; + } + + double ccont_year = gridcell.ccont(); + double cflux_year = gridcell.cflux(); + + double ncont_year = gridcell.ncont(); + double nflux_year = gridcell.nflux(); + + if (date.year == start_year) { + ccont_zero = ccont_year; + ncont_zero = ncont_year; + } + else { + + cflux += cflux_year; + nflux += nflux_year; + + // C balance check: + if (!negligible(ccont_year - ccont + cflux_year, -9)) { + dprintf("\n(%.2f, %.2f): C balance year %d: %.10f\n", gridcell.get_lon(), gridcell.get_lat(), date.year, ccont_year - ccont + cflux_year); + dprintf("C pool change: %.5f\n", ccont_year - ccont); + dprintf("C flux: %.5f\n", cflux_year); + } + // Cropland without N-limitation is not balanced in N, fertilisation gives poorer N-balance + // For natural vegetation or unfertilised N-limited cropland, the check can be much stricter + if (ifnlim) { + // N balance check: + if (!negligible(ncont_year - ncont + nflux_year, -9)) { + dprintf("\n(%.2f, %.2f): N balance year %d: %.9f\n", gridcell.get_lon(), gridcell.get_lat(), date.year, ncont_year - ncont + nflux_year); + dprintf("N pool change: %.9f\n", ncont_year - ncont); + dprintf("N flux: %.9f\n", nflux_year); + } + } + } + ccont = ccont_year; + ncont = ncont_year; +} + +void MassBalance::check_period(Gridcell& gridcell) { + + // C balance check: + if (!negligible(ccont - ccont_zero + cflux, -9)) { + dprintf("\nWARNING: (%.2f, %.2f): Period C balance: %.10f\n", gridcell.get_lon(), gridcell.get_lat(), ccont - ccont_zero + cflux); + dprintf("C pool change: %.10f\n", ccont - ccont_zero); + dprintf("C fluxes: %.10f\n", cflux); + } + // Cropland without N-limitation is not balanced in N, fertilisation gives poorer N-balance + // For natural vegetation or unfertilised N-limited cropland, the check can be much stricter + if (ifnlim) { + // N balance check: + if (!negligible(ncont - ncont_zero + nflux, -9)) { + dprintf("\nWARNING: (%.2f, %.2f): Period N balance: %.10f\n", gridcell.get_lon(), gridcell.get_lat(), ncont - ncont_zero + nflux); + dprintf("N pool change: %.10f\n", ncont - ncont_zero); + dprintf("N fluxes: %.10f\n", nflux); + } + } +} + +void MassBalance::init(Gridcell& gridcell) { + +// start_year = date.year; + ccont_zero = gridcell.ccont(); + cflux_zero = gridcell.cflux(); +} + +void MassBalance::check(Gridcell& gridcell) { + + double ccont = gridcell.ccont(); + double cflux = gridcell.cflux(); + + if (!negligible(ccont - ccont_zero + cflux, -5)) { + dprintf("\n(%.2f, %.2f): C balance year %d: %.5f\n", gridcell.get_lon(), gridcell.get_lat(), date.year, ccont - ccont_zero + cflux); + dprintf("C pool change: %.5f\n", ccont - ccont_zero); + dprintf("C flux: %.5f\n\n", cflux); + } +} + +/////////////////////////////////////////////////////////////////////////////////////// +// REFERENCES +// +// LPJF refers to the original FORTRAN implementation of LPJ as described by Sitch +// et al 2000 +// Delmas, R., Lacaux, J.P., Menaut, J.C., Abbadie, L., Le Roux, X., Helaa, G., Lobert, J., 1995. +// Nitrogen compound emission from biomass burning in tropical African Savanna FOS/DECAFE 1991 +// experiment. Journal of Atmospheric Chemistry 22, 175-193. diff --git a/models/lpjguess/inst/guess.PalEON.h b/models/lpjguess/inst/guess.PalEON.h new file mode 100644 index 00000000000..4f5d0d10732 --- /dev/null +++ b/models/lpjguess/inst/guess.PalEON.h @@ -0,0 +1,3976 @@ +/////////////////////////////////////////////////////////////////////////////////////// +/// \file guess.h +/// \brief Framework header file, LPJ-GUESS Combined Modular Framework +/// +/// This header file contains: +/// (1) definitions of all main classes used by the framework and modules. Modules may +/// require classes to contain certain member variables and functions (see module +/// source files for details). +/// (2) other type, constant and function definitions to be accessible throughout the +/// model code. +/// (3) a forward declaration of the framework function if this is not the main +/// function. +/// +/// \author Ben Smith +/// $Date: 2016-12-08 18:24:04 +0100 (Do, 08. Dez 2016) $ +/// +/////////////////////////////////////////////////////////////////////////////////////// + +#ifndef LPJ_GUESS_GUESS_H +#define LPJ_GUESS_GUESS_H + +/////////////////////////////////////////////////////////////////////////////////////// +// #INCLUDES FOR LIBRARY HEADER FILES +// C/C++ libraries required for member functions of classes defined in this file. +// These libraries will also be available globally (so omit these #includes from source +// files). In addition to various standard C/C++ runtime libraries, the framework +// requires the following libraries (individual modules may use additional libraries) +// +// GUTIL +// Includes class xtring, providing functionality for pointer-free dynamic handling +// of character strings; wherever possible in LPJ-GUESS, strings are represented as +// objects of type xtring rather than simple arrays of type char. GUTIL also provides +// templates for dynamic collection classes (list arrays of various types), argument +// processing for printf-style functions, timing functions and other utilities. + +#include +#include +#include +#include +#include "gutil.h" +#include +#include +#include "shell.h" +#include "guessmath.h" +#include "archive.h" +#include "parameters.h" +#include "guesscontainer.h" + +/////////////////////////////////////////////////////////////////////////////////////// +// GLOBAL ENUMERATED TYPE DEFINITIONS + +/// Life form class for PFTs (trees, grasses) +//typedef enum {NOLIFEFORM, TREE, GRASS} lifeformtype; + +/// Phenology class for PFTs +typedef enum {NOPHENOLOGY, EVERGREEN, RAINGREEN, SUMMERGREEN, CROPGREEN, ANY} phenologytype; + +/// Biochemical pathway for photosynthesis (C3 or C4) +typedef enum {NOPATHWAY, C3, C4} pathwaytype; + +/// Leaf physiognomy types for PFTs +typedef enum {NOLEAFTYPE, NEEDLELEAF, BROADLEAF} leafphysiognomytype; + +/// Units for insolation driving data +/** Insolation can be expressed as: + * + * - Percentage sunshine + * - Net instantaneous downward shortwave radiation flux (W/m2) + * - Total (i.e. with no correction for surface albedo) instantaneous downward + * shortwave radiation flux (W/m2) + * + * Radiation flux can be interpreted as W/m2 during daylight hours, or averaged + * over the whole time step which it represents (24 hours in daily mode). For + * this reason there are two enumerators for these insolation types (e.g. SWRAD + * and SWRAD_TS). + */ +typedef enum { + /// No insolation type chosen + NOINSOL, + /// Percentage sunshine + SUNSHINE, + /// Net shortwave radiation flux during daylight hours (W/m2) + NETSWRAD, + /// Total shortwave radiation flux during daylight hours (W/m2) + SWRAD, + /// Net shortwave radiation flux during whole time step (W/m2) + NETSWRAD_TS, + /// Total shortwave radiation flux during whole time step (W/m2) + SWRAD_TS +} insoltype; + +/// CENTURY pool names, NSOMPOOL number of SOM pools +typedef enum {SURFSTRUCT, SOILSTRUCT, SOILMICRO, SURFHUMUS, SURFMICRO, SURFMETA, SURFFWD, SURFCWD, + SOILMETA, SLOWSOM, PASSIVESOM, LEACHED, NSOMPOOL} pooltype; + +/// Irrigation type for PFTs +typedef enum {RAINFED, IRRIGATED} hydrologytype; +/// Intercrop type for PFTs +typedef enum {NOINTERCROP, NATURALGRASS} intercroptype; + +/// Seasonality type of gridcell +/** 0:SEASONALITY_NO No seasonality + * 1:SEASONALITY_PREC Precipitation seasonality only + * 2:SEASONALITY_PRECTEMP Both temperature and precipitation seasonality, but "weak" temperature seasonality (coldest month > 10degC) + * 3:SEASONALITY_TEMP Temperature seasonality only + * 4:SEASONALITY_TEMPPREC Both temperature and precipitation seasonality, but temperature most important (coldest month < 10degC) + * 5:SEASONALITY_TEMPWARM Temperature seasonality, always above 10 degrees (currently not used) + */ +typedef enum {SEASONALITY_NO, SEASONALITY_PREC, SEASONALITY_PRECTEMP, SEASONALITY_TEMP, SEASONALITY_TEMPPREC} seasonality_type; + +/// Precipitation seasonality type of gridcell +/** 0:DRY (minprec_pet20<=0.5 && maxprec_pet20<=0.5) + * 1:DRY_INTERMEDIATE (minprec_pet20<=0.5 && maxprec_pet20>0.5 && maxprec_pet20<=1.0) + * 2:DRY_WET (minprec_pet20<=0.5 && maxprec_pet20>1.0) + * 3:INTERMEDIATE (minprec_pet20>0.5 && minprec_pet20<=1.0 && maxprec_pet20>0.5 && maxprec_pet20<=1.0) + * 4:INTERMEDIATE_WET (minprec_pet20>0.5 && minprec_pet20<=1.0 && maxprec_pet20>1.0) + * 5:WET (minprec_pet20>1.0 && maxprec_pet20>1.0) + */ +typedef enum {DRY, DRY_INTERMEDIATE, DRY_WET, INTERMEDIATE, INTERMEDIATE_WET, WET} prec_seasonality_type; + + +/// Temperature seasonality type of gridcell +/** 0:COLD (mtemp_max20<=10) + * 1:COLD_WARM (mtemp_min20<=10 && mtemp_max20>10 && mtemp_max20<=30) + * 2:COLD_HOT (mtemp_min20<=10 && mtemp_max20>30) + * 3:WARM (mtemp_min20>10 && mtemp_max20<=30) + * 4:WARM_HOT (mtemp_min20>10 && mtemp_max20>30) + * 5:HOT (mtemp_min20>30) + */ +typedef enum {COLD, COLD_WARM, COLD_HOT, WARM, WARM_HOT, HOT} temp_seasonality_type; + +/////////////////////////////////////////////////////////////////////////////////////// +// GLOBAL CONSTANTS + +/// number of soil layers modelled +const int NSOILLAYER = 2; + +// SOIL DEPTH VALUES + +/// soil upper layer depth (mm) +const double SOILDEPTH_UPPER = 500.0; +/// soil lower layer depth (mm) +const double SOILDEPTH_LOWER = 1000.0; + +/// Year at which to calculate equilibrium soil carbon +const int SOLVESOM_END=400; + +/// Year at which to begin documenting means for calculation of equilibrium soil carbon +const int SOLVESOM_BEGIN = 350; + +/// Number of years to average growth efficiency over in function mortality +const int NYEARGREFF = 5; + +/// Coldest day in N hemisphere (January 15) +/** Used to decide when to start counting GDD's and leaf-on days + * for summergreen phenology. + */ +const int COLDEST_DAY_NHEMISPHERE = 14; + +/// Coldest day in S hemisphere (July 15) +/** Used to decide when to start counting GDD's and leaf-on days + * for summergreen phenology. + */ +const int COLDEST_DAY_SHEMISPHERE = 195; + +/// Warmest day in N hemisphere (same as COLDEST_DAY_SHEMISPHERE) +const int WARMEST_DAY_NHEMISPHERE = COLDEST_DAY_SHEMISPHERE; + +/// Warmest day in S hemisphere (same as COLDEST_DAY_NHEMISPHERE) +const int WARMEST_DAY_SHEMISPHERE = COLDEST_DAY_NHEMISPHERE; + +/// number of years to average aaet over in function soilnadd +const int NYEARAAET = 5; + +/// Priestley-Taylor coefficient (conversion factor from equilibrium evapotranspiration to PET) +const double PRIESTLEY_TAYLOR = 1.32; + +// Solving Century SOM pools + +/// fraction of nyear_spinup minus freenyears at which to begin documenting for calculation of Century equilibrium +const double SOLVESOMCENT_SPINBEGIN = 0.1; +/// fraction of nyear_spinup minus freenyears at which to end documentation and start calculation of Century equilibrium +const double SOLVESOMCENT_SPINEND = 0.3; + +/// Kelvin to deg c conversion +const double K2degC = 273.15; + +/// Maximum number of crop rotation items +const int NROTATIONPERIODS_MAX = 3; + +/// Conversion factor for CO2 from ppmv to mole fraction +const double CO2_CONV = 1.0e-6; + +/// Initial carbon allocated to crop organs at sowing, kg m-2 +const double CMASS_SEED = 0.01; + +/////////////////////////////////////////////////////////////////////////////////////// +// FORWARD DECLARATIONS OF CLASSES DEFINED IN THIS FILE +// Forward declarations of classes used as types (e.g. for reference variables in some +// classes) before they are actually defined + +class Date; +class Stand; +class Patch; +class Vegetation; +class Individual; +class Gridcell; +class Patchpft; + +/////////////////////////////////////////////////////////////////////////////////////// +// GLOBAL VARIABLES WITH EXTERNAL LINKAGE +// These variables are defined in the framework source code file, and are accessible +// throughout the code + +/// Object describing timing stage of simulation +extern Date date; + +/// Number of possible PFTs +extern int npft; +/// Number of stand types in stlist +extern int nst; +/// Number of stand types per land cover +extern int nst_lc[NLANDCOVERTYPES]; +/// Number of management types in stlist +extern int nmt; + +/// General purpose object for handling simulation timing. +/** In general, frameworks should use a single Date object for all simulation + * timing. + * + * Member variables of the class (see below) provide various kinds of calender + * and timing information, assuming init has been called to initialise the + * object, and next() has been called at the end of each simulation day. + */ +class Date { + + // MEMBER VARIABLES + +public: + + /// Maximum number of days in an LPJ-GUESS simulation year + /** The standard version doesn't yet support leap years. */ + static const int MAX_YEAR_LENGTH = 365; + + /// number of days in each month (0=January - 11=December) + int ndaymonth[12]; + + /// julian day of year (0-364; 0=Jan 1) + int day; + + /// day of current month (0=first day) + int dayofmonth; + + /// month number (0=January - 11=December) + int month; + + /// year since start of simulation (0=first simulation year) + int year; + + /// number of subdaily periods in a day (to be set in IO module) + int subdaily; + + /// julian day for middle day of each month + int middaymonth[12]; + + /// true if last year of simulation, false otherwise + bool islastyear; + + /// true if last month of year, false otherwise + bool islastmonth; + + /// true if last day of month, false otherwise + bool islastday; + + /// true if middle day of month, false otherwise + bool ismidday; + + /// The calendar year corresponding to simulation year 0 + int first_calendar_year; + +private: + + int nyear; + + // MEMBER FUNCTIONS + +public: + + /// Constructor function called automatically when Date object is created + /** Do not call explicitly. Initialises some member variables. */ + Date() { + const int data[] = {31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31}; + int month; + int dayct = 0; + for (month=0; month<12; month++) { + ndaymonth[month] = data[month]; + middaymonth[month] = dayct + data[month] / 2; + dayct += data[month]; + } + subdaily = 1; + first_calendar_year = 0; + } + + /// Initialises date to day 0 of year 0 and sets intended number of simulation years + /** Intended number of simulation years is only used to set islastyear flag, + * actual simulation may be longer or shorter. + * + * \param nyearsim Intended number of simulation years + */ + void init(int nyearsim) { + nyear = nyearsim; + day = month=year = dayofmonth = 0; + islastmonth = islastday = ismidday = false; + if (nyear == 1) islastyear = true; + else islastyear = false; + } + + /// Call at end of every simulation day to update member variables. + void next() { + if (islastday) { + if (islastmonth) { + dayofmonth = 0; + day = 0; + month = 0; + year++; + if (year == nyear - 1) islastyear = true; + islastmonth = false; + } + else { + day++; + dayofmonth = 0; + month++; + if (month == 11) islastmonth = true; + } + islastday = false; + } + else { + day++; + dayofmonth++; + if (dayofmonth == ndaymonth[month] / 2) ismidday = true; + else { + ismidday = false; + if (dayofmonth == ndaymonth[month] - 1) islastday = true; + } + } + } + + // \returns index (0-11) of previous month (11 if currently month 0). + int prevmonth() { + if (month > 0) return month - 1; + return 11; + } + + /// \returns index of next month (0 if currently month 11) + int nextmonth() { + if (month < 11) return month+1; + return 0; + } + + /// Check if the year is leap + /** \param year Calendar year + * The algorith is as follows: only year that are divisible by 4 could + * potentially be leap (e.g., 1904), however, not if they're divisble by + * 100 (e.g., 1900 is not leap), unless they're divisble by 400 (e.g., 2000 + * is still leap). + */ + static bool is_leap(int year) { + return (!(year % 4) && (year % 100 | !(year % 400))); + } + + /// Whether the current mode is diurnal + bool diurnal() const { return subdaily > 1; } + + /// Sets calendar year for simulation year 0 + /** Astronomical year numbering is used, so year 1 BC is represented by 0, + * 2 BC = -1 etc. See ISO 8601. + */ + void set_first_calendar_year(int calendar_year) { + first_calendar_year = calendar_year; + } + + /// Returns the calendar year corresponding to the current simulation year + /** Astronomical year numbering is used, so year 1 BC is represented by 0, + * 2 BC = -1 etc. See ISO 8601. + */ + int get_calendar_year() const { + return year + first_calendar_year; + } + + /// \returns the number of days in the current simulation year + /** For this function to work properly in simulations with varying number + * of days per year, the set_first_calendar_year must have been called first. + * + * Currently there is no support for leap years, so this function + * always returns 365. */ + int year_length() const { + return MAX_YEAR_LENGTH; + } + + /// Step n days from a date. + /** Current implementation does not consider leap days, and the same + * apply for the current use of the function through-out the model. + */ + static int stepfromdate(int day, int step) { + + if(day < 0) // a negative value should not be a valid day + return -1; + else if(day + step > 0) + return (day + step) % MAX_YEAR_LENGTH; + else if(day + step < 0) + return day + step + MAX_YEAR_LENGTH; + else + return 0; + } +}; + +/// Object describing sub-daily periods +class Day { +public: + /// Whether sub-daily period first/last within day (both true in daily mode) + bool isstart, isend; + + /// Ordinal number of the sub-daily period [0, date.subdaily) + int period; + + /// Constructs beginning of the day period (the only one in daily mode) + Day() { + isstart = true; + isend = !date.diurnal(); + period = 0; + } + + /// Advances to the next sub-daily period + void next() { + period++; + isstart = false; + isend = period == date.subdaily - 1; + } +}; + +/// Object updating gridcell mass balance; currently used in framework() +class MassBalance : public Serializable { + + int start_year; + double ccont; + double ccont_zero; + double ccont_zero_scaled; + double cflux; + double cflux_zero; + + double ncont; + double ncont_zero; + double ncont_zero_scaled; + double nflux; + double nflux_zero; + +public: + MassBalance() { + + start_year = nyear_spinup; + ccont = 0.0; + ccont_zero = 0.0; + ccont_zero_scaled = 0.0; + cflux = 0.0; + cflux_zero = 0.0; + ncont = 0.0; + ncont_zero = 0.0; + ncont_zero_scaled = 0.0; + nflux = 0.0; + nflux_zero = 0.0; + } + + MassBalance(int start_yearX) { + + start_year = start_yearX; + ccont = 0.0; + ccont_zero = 0.0; + ccont_zero_scaled = 0.0; + cflux = 0.0; + cflux_zero = 0.0; + ncont = 0.0; + ncont_zero = 0.0; + ncont_zero_scaled = 0.0; + nflux = 0.0; + nflux_zero = 0.0; + } + + void init(Gridcell& gridcell); + void check(Gridcell& gridcell); + // indiv and patch-level functions are for use with true crop stands only + void init_indiv(Individual& indiv); + bool check_indiv(Individual& indiv, bool check_harvest = false); + bool check_indiv_C(Individual& indiv, bool check_harvest = false); + bool check_indiv_N(Individual& indiv, bool check_harvest = false); + void init_patch(Patch& patch); + bool check_patch(Patch& patch, bool check_harvest = false); + bool check_patch_C(Patch& patch, bool check_harvest = false); + bool check_patch_N(Patch& patch, bool check_harvest = false); + + void check_year(Gridcell& gridcell); + void check_period(Gridcell& gridcell); + + void serialize(ArchiveStream& arch); +}; + +/// This struct contains the result of a photosynthesis calculation. +/** \see photosynthesis */ +struct PhotosynthesisResult : public Serializable { + /// Constructs an empty result + PhotosynthesisResult() { + clear(); + } + + /// Clears all members + /** This is returned by the photosynthesis function when no photosynthesis + * takes place. + */ + void clear() { + agd_g = 0; + adtmm = 0; + rd_g = 0; + vm = 0; + je = 0; + nactive_opt = 0.0; + vmaxnlim = 1.0; + } + + /// RuBisCO capacity (gC/m2/day) + double vm; + + /// gross daily photosynthesis (gC/m2/day) + double agd_g; + + /// leaf-level net daytime photosynthesis + /** expressed in CO2 diffusion units (mm/m2/day) */ + double adtmm; + + /// leaf respiration (gC/m2/day) + double rd_g; + + /// PAR-limited photosynthesis rate (gC/m2/h) + double je; + + /// optimal leaf nitrogen associated with photosynthesis (kgN/m2) + double nactive_opt; + + /// nitrogen limitation on vm + double vmaxnlim; + + /// net C-assimilation (gross photosynthesis minus leaf respiration) (kgC/m2/day) + double net_assimilation() const { + return (agd_g - rd_g) * 1e-3; + } + + void serialize(ArchiveStream& arch); +}; + + +/// The Climate for a grid cell +/** Stores all static and variable data relating to climate parameters, as well as + * latitude, atmospheric CO2 concentration and daylength for a grid cell. Includes + * a reference to the parent Gridcell object (defined below). Initialised by a + * call to initdrivers. + */ +class Climate : public Serializable { + + // MEMBER VARIABLES + +public: + /// reference to parent Gridcell object + Gridcell& gridcell; + + /// mean air temperature today (deg C) + double temp; + + /// total daily net downward shortwave solar radiation today (J/m2/day) + double rad; + + /// total daily photosynthetically-active radiation today (J/m2/day) + double par; + + /// precipitation today (mm) + double prec; + + /// day length today (h) + double daylength; + + /// atmospheric ambient CO2 concentration today (ppmv) + double co2; + + /// latitude (degrees; +=north, -=south) + double lat; + + /// Insolation today, see also instype + double insol; + + /// Type of insolation + /** This decides how to interpret the variable insol, + * see also documentation for the insoltype enum. + */ + insoltype instype; + + /// equilibrium evapotranspiration today (mm/day) + double eet; + + /// mean temperature for the last 31 days (deg C) + double mtemp; + + /// mean of lowest mean monthly temperature for the last 20 years (deg C) + double mtemp_min20; + + /// mean of highest mean monthly temperature for the last 20 years (deg C) + double mtemp_max20; + + /// highest mean monthly temperature for the last 12 months (deg C) + double mtemp_max; + + /// accumulated growing degree day sum on 5 degree base + /** reset when temperatures fall below 5 deg C */ + double gdd5; + + /// total gdd5 (accumulated) for this year (reset 1 January) + double agdd5; + + /// number of days with temperatures <5 deg C + /** reset when temperatures fall below 5 deg C; + * maximum value is number of days in the year */ + int chilldays; + + /// true if chill day count may be reset by temperature fall below 5 deg C + bool ifsensechill; + + /** Respiration response to today's air temperature incorporating damping of Q10 + * due to temperature acclimation (Lloyd & Taylor 1994) + */ + double gtemp; + + /// daily temperatures for the last 31 days (deg C) + Historic dtemp_31; + + /// daily precipitation for the last 31 days (deg C) + Historic dprec_31; + + /// daily eet for the last 31 days (deg C) + Historic deet_31; + + /// minimum monthly temperatures for the last 20 years (deg C) + double mtemp_min_20[20]; + + /// maximum monthly temperatures for the last 20 years (deg C) + double mtemp_max_20[20]; + + /// minimum monthly temperature for the last 12 months (deg C) + double mtemp_min; + + /// mean of monthly temperatures for the last 12 months (deg C) + double atemp_mean; + + /// annual nitrogen deposition (kgN/m2/year) + double andep; + /// daily nitrogen deposition (kgN/m2) + double dndep; + + // f_js_20170118 monthly climate data + double montemp[12]; + double monprec[12]; + double mongdd5[12]; + + // Saved parameters used by function daylengthinsoleet + + double sinelat; + double cosinelat; + double qo[Date::MAX_YEAR_LENGTH]; + double u[Date::MAX_YEAR_LENGTH]; + double v[Date::MAX_YEAR_LENGTH]; + double hh[Date::MAX_YEAR_LENGTH]; + double sinehh[Date::MAX_YEAR_LENGTH]; + double daylength_save[Date::MAX_YEAR_LENGTH]; + /// indicates whether saved values exist for this day + bool doneday[Date::MAX_YEAR_LENGTH]; + + /// diurnal temperature range, used in daily/monthly BVOC (deg C) + double dtr; + + // containers for sub-daily values of temperature, short-wave downward + // radiation, par, rad and gtemp (equivalent to temp, insol, par, rad and gtemp) + // NB: units of these variable are the same as their daily counterparts, + // i.e. representing daily averages (e.g. pars [J/m2/day]) + + /// Sub-daily temperature (deg C) (\see temp) + std::vector temps; + + /// Sub-daily insolation (\see insol) + std::vector insols; + + /// Sub-daily PAR (\see par) + std::vector pars; + + /// Sub-daily net downward shortwave solar radiation (\see rad) + std::vector rads; + + /// Sub-daily respiration response (\see gtemp) + std::vector gtemps; + + /// Variables used for crop sowing date or seasonality calculation + + /// daily precipitations for the last 10 days (mm) + double dprec_10[10]; + /// daily 10 day-sums of precipitations for today and yesterday (mm) + double sprec_2[2]; + /// max temperature during the last test period + double maxtemp; + /// summer day when we test last year's crossing of sowing temperature limits; NH:June 30(day 180), SH:Dec.31(day 364), set in getgridcell() + int testday_temp; + /// last day of dry month when we test last year's crossing of sowing precipitation limits; NH:Dec.31(day 364), SH:June 30(day 180), set in getgridcell() + int testday_prec; + /// date used for sowing if no frost or spring occured during the year between the testmonths; NH:14, SH:195, set in getgridcell() + int coldestday; + /// used to adapt equations to hemisphere, set in getgridcell() + int adjustlat; + /// accumulated monthly pet values for this year + double mpet_year[12]; + /// past 20 years monthly temperature values + double mtemp_20[20][12]; + /// past 20 years monthly precipitation values + double mprec_20[20][12]; + /// past 20 years monthly PET values + double mpet_20[20][12]; + /// past 20 years monthly precipitation to PET ratios + double mprec_pet_20[20][12]; + /// past 20 years minimum of monthly precipitation to PET ratios + double mprec_petmin_20[20]; + /// past 20 years maximum of monthly precipitation to PET ratios + double mprec_petmax_20[20]; + /// 20-year running average monthly temperature values + double mtemp20[12]; + /// 20-year running average monthly precipitation values + double mprec20[12]; + /// 20-year running average monthly PET values + double mpet20[12]; + /// 20-year running average monthly precipitation to PET ratios + double mprec_pet20[12]; + /// 20-year running average of minimum monthly precipitation to PET ratios + double mprec_petmin20; + /// 20-year running average of maximum monthly precipitation to PET ratios + double mprec_petmax20; + + Historic hmtemp_20[12]; + Historic hmprec_20[12]; + Historic hmeet_20[12]; + + /// seasonality type (SEASONALITY_NO, SEASONALITY_PREC, SEASONALITY_PRECTEMP, SEASONALITY_TEMP, SEASONALITY_TEMPPREC) + seasonality_type seasonality; + seasonality_type seasonality_lastyear; + + /// precipitation seasonality type (DRY, DRY_INTERMEDIATE, DRY_WET, INTERMEDIATE, INTERMEDIATE_WET, WET) + /** based on the extremes of the 20-year monthly means + */ + prec_seasonality_type prec_seasonality; + prec_seasonality_type prec_seasonality_lastyear; + + /// precipitation range (DRY, DRY_INTERMEDIATE, DRY_WET, INTERMEDIATE, INTERMEDIATE_WET, WET) + /** based on the average of the 20-year monthly extremes + */ + prec_seasonality_type prec_range; + prec_seasonality_type prec_range_lastyear; + + /// temperature seasonality (COLD, COLD_WARM, COLD_HOT, WARM, WARM_HOT, HOT) + temp_seasonality_type temp_seasonality; + temp_seasonality_type temp_seasonality_lastyear; + + /// whether several months with precipitation maxima exists (remains to be implemented) + bool biseasonal; + + /// variation coefficient of 20-year mean monthly temperatures + double var_prec; + /// variation coefficient of 20-year mean monthly precipitation to PET ratios + double var_temp; + + /// annual precipitation sum + double aprec; + +public: + /// constructor function: initialises gridcell member + Climate(Gridcell& gc):gridcell(gc) { + + for(int m=0;m<12;m++) { + + mtemp20[m] = 0.0; + mprec20[m] = 0.0; + mpet20[m] = 0.0; + mpet_year[m] = 0.0; + mprec_pet20[m] = 0.0; + + for(int y=0;y<20;y++) { + mtemp_20[y][m] = 0.0; + mprec_20[y][m] = 0.0; + mpet_20[y][m] = 0.0; + mprec_pet_20[y][m] = 0.0; + } + } + + for(int y=0;y<20;y++) { + + mprec_petmin_20[y] = 0.0; + mprec_petmax_20[y] = 0.0; + } + + mprec_petmin20=0.0; + mprec_petmax20=0.0; + + seasonality=SEASONALITY_NO; + seasonality_lastyear=SEASONALITY_NO; + prec_seasonality=DRY; + prec_seasonality_lastyear=DRY; + prec_range=DRY; + prec_range_lastyear=DRY; + temp_seasonality=COLD; + temp_seasonality_lastyear=COLD; + biseasonal=false; + + eet=0.0; + }; + + /// Initialises certain member variables + /** Should be called before Climate object is applied to a new grid cell */ + void initdrivers(double latitude) { + + std::fill_n(mtemp_min_20, 20, 0.0); + std::fill_n(mtemp_max_20, 20, 0.0); + + mtemp_min20 = 0.0; + mtemp_max20 = 0.0; + mtemp = 0.0; + maxtemp = 0.0; + gdd5 = 0.0; + chilldays = 0; + ifsensechill = true; + atemp_mean = 0.0; + + lat = latitude; + std::fill_n(doneday, Date::MAX_YEAR_LENGTH, false); + sinelat = sin(lat * DEGTORAD); + cosinelat = cos(lat * DEGTORAD); + + // Set crop-specific members + if (latitude >= 0) { + testday_temp = 180; //June 30(day 180) + testday_prec = 364; //Dec.31(day 364) + coldestday = COLDEST_DAY_NHEMISPHERE; + adjustlat = 0; + } + else { + testday_temp = 364; //Dec.31(day 364) + testday_prec = 180; //June 30(day 180) + coldestday = COLDEST_DAY_SHEMISPHERE; + adjustlat = 181; + } + } + + void serialize(ArchiveStream& arch); +}; + + +/// Stores accumulated monthly and annual fluxes. +/** This class handles the storage and accounting of fluxes for a single patch. + * Different fluxes can be stored in different ways, depending on what kind of + * flux it is and what kind of output we want. The details of whether fluxes + * are stored per PFT or just as a patch total, or per day, month or only a + * yearly sum, is hidden from the 'scientific' code, which merely reports the + * fluxes generated. + */ +class Fluxes : public Serializable { + +public: + + /// Fluxes stored as totals for the whole patch + enum PerPatchFluxType { + /// Carbon flux to atmosphere from burnt vegetation and litter (kgC/m2) + FIREC, + /// Carbon flux to atmosphere from soil respiration (kgC/m2) + SOILC, + /// Flux from atmosphere to vegetation associated with establishment (kgC/m2) + ESTC, + /// Flux to atmosphere from consumed harvested products (kgC/m2) + HARVESTC, + /// Flux from atmosphere to vegetation associated with sowing (kgC/m2) + SEEDC, + /// Nitrogen flux to atmosphere from consumed harvested products (kgN/m2) + HARVESTN, + /// Nitrogen flux from atmosphere to vegetation associated with sowing (kgC/m2) + SEEDN, + /// NH3 flux to atmosphere from fire + NH3_FIRE, + /// NOx flux to atmosphere from fire + NOx_FIRE, + /// N2O flux to atmosphere from fire + N2O_FIRE, + /// N2 flux to atmosphere from fire + N2_FIRE, + /// N flux from soil + N_SOIL, + /// Reproduction costs + REPRC, + /// Number of types, must be last + NPERPATCHFLUXTYPES + }; + + /// Fluxes stored per pft + enum PerPFTFluxType { + /// NPP (kgC/m2) + NPP, + /// GPP (kgC/m2) + GPP, + /// Autotrophic respiration (kgC/m2) + RA, + /// Isoprene (mgC/m2) + ISO, + /// Monoterpene (mgC/m2) + MON, + /// Number of types, must be last + NPERPFTFLUXTYPES + }; + + // emission ratios from fire (NH3, NOx, N2O, N2) Delmas et al. 1995 + // values in .cpp file + + static const double NH3_FIRERATIO; + static const double NOx_FIRERATIO; + static const double N2O_FIRERATIO; + static const double N2_FIRERATIO; + + /// Reference to patch to which this Fluxes object belongs + Patch& patch; + + // MEMBER FUNCTIONS + +public: + /// constructor: initialises members + Fluxes(Patch& p); + + /// Sets all fluxes to zero (call at the beginning of each year) + void reset(); + + void serialize(ArchiveStream& arch); + + /// Report flux for a certain flux type + void report_flux(PerPFTFluxType flux_type, int pft_id, double value); + + /// Report flux for a certain flux type + void report_flux(PerPatchFluxType flux_type, double value); + + /// \returns flux for a given month and flux type (for all PFTs) + double get_monthly_flux(PerPFTFluxType flux_type, int month) const; + + /// \returns flux for a given month and flux type + double get_monthly_flux(PerPatchFluxType flux_type, int month) const; + + /// \returns annual flux for a given PFT and flux type + double get_annual_flux(PerPFTFluxType flux_type, int pft_id) const; + + /// \returns annual flux for a given flux type (for all PFTs) + double get_annual_flux(PerPFTFluxType flux_type) const; + + /// \returns annual flux for a given flux type + double get_annual_flux(PerPatchFluxType flux_type) const; + +private: + + /// Stores one flux value per PFT and flux type + std::vector > annual_fluxes_per_pft; + + /// Stores one flux value per month and flux type + /** For the fluxes only stored as totals for the whole patch */ + double monthly_fluxes_patch[12][NPERPATCHFLUXTYPES]; + + /// Stores one flux value per month and flux type + /** For the fluxes stored per pft for annual values */ + double monthly_fluxes_pft[12][NPERPFTFLUXTYPES]; + + /// Stores one flux value per day and flux type + double daily_fluxes_patch[365][NPERPATCHFLUXTYPES]; + + /// Stores one flux value per day and flux type + double daily_fluxes_pft[365][NPERPFTFLUXTYPES]; +}; + +/// Storage class of crop management information for one rotation period for a stand type, read from the instruction file. +class ManagementType { + +public: + /// id code (should be zero based and sequential, 0...nst-1) + int id; + /// name of management type + xtring name; + + /// type of planting system ("", "MONOCULTURE", "SELECTION", etc.) + xtring planting_system; + /// type of harvest system ("", "CLEARCUT", "CONTINUOUS") + xtring harvest_system; + /// name of crop pft + xtring pftname; + /// identifier of pft selection + xtring selection; + /// Rotation period in years + double nyears; + /// hydrology (RAINFED,IRRIGATED) + hydrologytype hydrology; + /// irrigation efficiency +// double firr; + /// forced sowing date, unless sdate_force read from file + int sdate; + /// forced harvest date, unless hdate_force read from file + int hdate; + /// Nitrogen fertilisation amount, unless Nfert_read read from file + double nfert; + /// Whether grass is grown in fallow + bool fallow; + /// Double cropping of one crop (e.g. rice) + bool multicrop; + + ManagementType() { + + planting_system = ""; + harvest_system = ""; + pftname = ""; + selection = ""; + nyears = 1.0; + hydrology = RAINFED; +// firr = 0.0; + sdate = -1; + hdate = -1; + nfert = -1.0; + fallow = false; + multicrop = false; + } + + // Copy constructor + ManagementType(const ManagementType& from) { + + name = from.name; + pftname = from.pftname; + hydrology = from.hydrology; + sdate = from.sdate; + hdate = from.hdate; + nfert = from.nfert; + fallow = from.fallow; + } + + bool is_managed() { + + // Add new management parameters here + if(pftname != "" || planting_system != "" || selection != ""|| harvest_system != "" || hydrology == IRRIGATED || fallow || nfert > -1.0) + return true; + else + return false; + } + + /// Returns true if pft is in pftselection. + int pftinselection(const char* name) { + + bool found = false; + char *p = NULL, string_copy[200] = {0}; + + strcpy(string_copy, selection); + p = strtok(string_copy, "\t\n "); + if(p) { + if(!strcmp(name, p)) { + found = true; + } + } + + do { + p = strtok(NULL, "\t\n "); + if(p) { + if(!strcmp(name, p)) { + found = true; + } + } + } + while(p && !found); + + return found; + } +}; + +/// A list of management types +/** Functionality for building, maintaining, referencing and destroying a list array of + * management types objects. + * + * Functionality is inherited from the ListArray_id template type in the GUTIL + * Library. Sequential management type objects can be referenced as array elements by id: + * + * ManagementTypelist mtlist; + * ... + * for (i=0; i { + +public: + int getmtid(xtring mtname) { + + int id = -1; + + for(unsigned int i=0; i< this->nobj; i++) { + + ManagementType& mt = (*this)[i]; + if(mt.name == mtname) { + id = mt.id; + break; + } + } + + return id; + } +}; + +/// The one and only linked list of ManagementType objects +extern ManagementTypelist mtlist; + +/// Storage class of crop rotation information for a stand type, read from the instruction file. +struct CropRotation { + + /// Number of crops in rotation + int ncrops; + /// First rotation year + int firstrotyear; + + CropRotation() { + ncrops = 0; + firstrotyear = 0; + } +}; + +/// Stand type class for storing both static parameters, read from the instruction file, +/* and dynamic variables, updated in landcover_change() + * Active stand types are stored in the stlist analogous to the pftlist. + */ +class StandType { + +public: + /// id code (should be zero based and sequential, 0...nst-1) + int id; + /// name of stand type + xtring name; + + /// specifies type of landcover + /** \see landcovertype */ + landcovertype landcover; // specifies type of landcover (0 = URBAN, 1 = CROP, 2 = PASTURE, 3 = FOREST, 4 = NATURAL, 5 = PEATLAND) + /// Rotation information, read from the instruction file + CropRotation rotation; + /// Management struct (static) + ManagementType management; + /// Management types in a rotation cycle + xtring mtnames[NROTATIONPERIODS_MAX]; + /// First management year: sets time when common features for managed stands begin, e.g. relaxed establishment rules and absence of disturbance before harvest begins + /** \this currently only applies for stands with wood havest */ + int firstmanageyear; + + /// intercrop (NOINTERCROP,NATURALGRASS) + intercroptype intercrop; + /// whether natural pft:s are allowed to grow in stand type + xtring naturalveg; // "", "GRASSONLY", "ALL" + // whether only pft:s defined in management are allowed (plus intercrop or naturalveg/grass) + bool restrictpfts; + /// whether planted pft:s or all active pft:s are allowed to established after planting in a forest stand ("", "RESTRICTED", "ALL") + xtring reestab; + + StandType() { + + intercrop = NOINTERCROP; + naturalveg = ""; + restrictpfts = false; + reestab = "ALL"; + firstmanageyear = 100000; + } + + ManagementType& get_management(int rot = 0) { + + if(rotation.ncrops > 1) { + return mtlist[mtlist.getmtid(mtnames[rot])]; + } + else { + return management; + } + } + + /// Returns position of management in rotation list if present. Returns -1 if not. + int mtinrotation(xtring name) { + + int mtno = -1; + for(int i=0; i { + +}; + +/// The one and only linked list of StandType objects +extern StandTypelist stlist; + + +/// Holds static functional parameters for a plant functional type (PFT). +/** There should be one Pft object for each potentially occurring PFT. The same Pft object + * may be referenced (via the pft member of the Individual object; see below) by different + * average individuals. Member functions are included for initialising SLA given leaf + * longevity, and for initialising sapling/regen characteristics (required for + * population mode). + */ +class Pft { + + // MEMBER VARIABLES + +public: + /// id code (should be zero based and sequential, 0...npft-1) + int id; + /// name of PFT + xtring name; + /// life form (tree or grass) + lifeformtype lifeform; + /// leaf phenology (raingreen, summergreen, evergreen, rain+summergreen, cropgreen) + phenologytype phenology; + /// leaf physiognomy (needleleaf, broadleaf) + leafphysiognomytype leafphysiognomy; + /// growing degree sum on 5 degree base required for full leaf cover + double phengdd5ramp; + /// water stress threshold for leaf abscission (range 0-1; raingreen PFTs) + double wscal_min; + /// biochemical pathway for photosynthesis (C3 or C4) + pathwaytype pathway; + /// approximate low temperature limit for photosynthesis (deg C) + double pstemp_min; + /// approximate lower range of temperature optimum for photosynthesis (deg C) + double pstemp_low; + /// approximate upper range of temperature optimum for photosynthesis (deg C) + double pstemp_high; + /// maximum temperature limit for photosynthesis (deg C) + double pstemp_max; + /// non-water-stressed ratio of intercellular to ambient CO2 partial pressure + double lambda_max; + /// vegetation root profile + /** array containing fraction of roots in each soil layer, [0=upper layer] */ + double rootdist[NSOILLAYER]; + /// canopy conductance component not associated with photosynthesis (mm/s) + double gmin; + /// maximum evapotranspiration rate (mm/day) + double emax; + /// maintenance respiration coefficient (0-1) + double respcoeff; + + /// minimum leaf C:N mass ratio allowed when nitrogen demand is determined + double cton_leaf_min; + /// maximum leaf C:N mass ratio allowed when nitrogen demand is determined + double cton_leaf_max; + /// average leaf C:N mass ratio (between min and max) + double cton_leaf_avr; + /// average fine root C:N mass ratio (connected cton_leaf_avr) + double cton_root_avr; + /// maximum fine root C:N mass ratio (used when mass is negligible) + double cton_root_max; + /// average sapwood C:N mass ratio (connected cton_leaf_avr) + double cton_sap_avr; + /// maximum sapwood C:N mass ratio (used when mass is negligible) + double cton_sap_max; + /// reference fine root C:N mass ratio + double cton_root; + /// reference sapwood C:N mass ratio + double cton_sap; + /// Maximum nitrogen (NH4+ and NO3- seperatly) uptake per fine root [kgN kgC-1 day-1] + double nuptoroot; + /// coefficient to compensate for vertical distribution of fine root on nitrogen uptake + double nupscoeff; + /// fraction of sapwood (root for herbaceous pfts) that can be used as a nitrogen longterm storage scalar + double fnstorage; + + /// Michaelis-Menten kinetic parameters + /** Half saturation concentration for N uptake [kgN l-1] (Rothstein 2000) */ + double km_volume; + + /// fraction of NPP allocated to reproduction + double reprfrac; + /// annual leaf turnover as a proportion of leaf C biomass + double turnover_leaf; + /// annual fine root turnover as a proportion of fine root C biomass + double turnover_root; + /// annual sapwood turnover as a proportion of sapwood C biomass + double turnover_sap; + /// sapwood and heartwood density (kgC/m3) + double wooddens; + /// maximum tree crown area (m2) + double crownarea_max; + /// constant in allometry equations + double k_allom1; + /// constant in allometry equations + double k_allom2; + /// constant in allometry equations + double k_allom3; + /// constant in allometry equations + double k_rp; + /// tree leaf to sapwood area ratio + double k_latosa; + /// specific leaf area (m2/kgC) + double sla; + /// leaf longevity (years) + double leaflong; + /// leaf to root mass ratio under non-water-stressed conditions + double ltor_max; + /// litter moisture flammability threshold (fraction of AWC) + double litterme; + /// fire resistance (0-1) + double fireresist; + /// minimum forest-floor PAR level for growth (grasses) or establishment (trees) + /** J/m2/day, individual and cohort modes */ + double parff_min; + /** parameter capturing non-linearity in recruitment rate relative to + * understorey growing conditions for trees (Fulton 1991) (individual and + * cohort modes) + */ + double alphar; + /// maximum sapling establishment rate (saplings/m2/year) (individual and cohort modes) + double est_max; + /** constant used in calculation of sapling establishment rate when spatial + * mass effect enabled (individual and cohort modes) + */ + double kest_repr; + /// constant affecting amount of background establishment + /** \see ifbgestab */ + double kest_bg; + /** constant used in calculation of sapling establishment rate when spatial + * mass effect disabled (individual and cohort modes) + */ + double kest_pres; + /// expected longevity under non-stressed conditions (individual and cohort modes) + double longevity; + /// threshold growth efficiency for imposition of growth suppression mortality + /** kgC/m2 leaf/year, individual and cohort modes */ + double greff_min; + + // Bioclimatic limits (all temperatures deg C) + + /// minimum 20-year coldest month mean temperature for survival + double tcmin_surv; + /// maximum 20-year coldest month mean temperature for establishment + double tcmax_est; + /// minimum degree day sum on 5 deg C base for establishment + double gdd5min_est; + /// minimum 20-year coldest month mean temperature for establishment + double tcmin_est; + /// minimum warmest month mean temperature for establishment + double twmin_est; + /// continentality parameter for boreal summergreen trees + double twminusc; + /// constant in equation for budburst chilling time requirement (Sykes et al 1996) + double k_chilla; + /// coefficient in equation for budburst chilling time requirement + double k_chillb; + /// exponent in equation for budburst chilling time requirement + double k_chillk; + /// array containing values for GDD0(c) given c=number of chill days + /** Sykes et al 1996, Eqn 1 + * gdd0 has one element for each possible value for number of chill days + */ + double gdd0[Date::MAX_YEAR_LENGTH + 1]; + /// interception coefficient (unitless) + double intc; + + /// the amount of N that is applied (kg N m-2) + double N_appfert; + /// 0 - 1 how much of the fertiliser is applied the first date, default 1. + double fertrate[2]; + /// dates relative to sowing date + int fertdates[2]; + double fert_stages[2]; + bool fertilised[2]; + + double T_vn_min; + double T_vn_opt; + double T_vn_max; + + double T_veg_min; + double T_veg_opt; + double T_veg_max; + + double T_rep_min; + double T_rep_opt; + double T_rep_max; + + double photo[3]; + + double dev_rate_veg; + double dev_rate_rep; + + double a1, b1, c1, d1, a2, b2, c2, d2, a3, b3, c3, d3; + double cton_stem_avr; + double cton_stem_max; + + /// Drought tolerance level (0 = very -> 1 = not at all) (unitless) + /** Used to implement drought-limited establishment */ + double drought_tolerance; + + // f_js_20170118 PalEON_Species + double minmoist_est; + + // bvoc + + /// aerodynamic conductance (m s-1) + double ga; + /// isoprene emission capacity (ug C g-1 h-1) + double eps_iso; + /// whether (1) or not (1) isoprene emissions show a seasonality + bool seas_iso; + /// monoterpene emission capacity (ug C g-1 h-1) + double eps_mon; + /// fraction of monoterpene production that goes into storage pool (-) + double storfrac_mon; + + + /// Sapling/regeneration characteristics (used only in population mode) + /** For trees, on sapling individual basis (kgC); for grasses, on stand area basis, + * kgC/m2 */ + struct { + /// leaf C biomass + double cmass_leaf; + /// fine root C biomass + double cmass_root; + /// sapwood C biomass + double cmass_sap; + /// heartwood C biomass + double cmass_heart; + } regen; + + /// specifies type of landcover pft is allowed to grow in (0 = URBAN, 1 = CROP, 2 = PASTURE, 3 = FOREST, 4 = NATURAL, 5 = PEATLAND) + landcovertype landcover; + /// pft selection + xtring selection; + /// fraction of residue outtake at harvest + double res_outtake; + /// harvest efficiency + double harv_eff; + /// harvest efficiency of intercrop grass + double harv_eff_ic; + /// fraction of harvested products that goes into patchpft.harvested_products_slow + double harvest_slow_frac; + /// yearly turnover fraction of patchpft.harvested_products_slow (goes to gridcell.acflux_harvest_slow) + double turnover_harv_prod; + /// whether pft may grow as cover crop + bool isintercropgrass; + /// whether autumn temperature dependent sowing date is calculated + bool ifsdautumn; + /// upper temperature limit for autumn sowing + double tempautumn; + /// lower temperature limit for spring sowing + double tempspring; + /// default length of growing period + int lgp_def; + /// upper minimum temperature limit for crop sowing + double maxtemp_sowing; + /// default sowing date in the northern hemisphere (julian day) + int sdatenh; + /// default sowing date in the southern hemisphere + int sdatesh; + /// whether sowing date adjusting equation is used + bool sd_adjust; + /// parameter 1 in sowing date adjusting equation + double sd_adjust_par1; + /// parameter 2 in sowing date adjusting equation + double sd_adjust_par2; + /// parameter 3 in sowing date adjusting equation + double sd_adjust_par3; + /// latest date for harvesting in the northern hemisphere + int hlimitdatenh; + /// latest date for harvesting in the southern hemisphere + int hlimitdatesh; + /// default base temperature (°C) for heat unit (hu) calculation + double tb; + /// temperature under which vernalisation is possible (°C) + double trg; + /// default number of vernalising days required + int pvd; + /// sensitivity to the photoperiod effect [0-1] + double psens; + /// basal photoperiod (h) (pb { + +public: + int getpftid(xtring pftname) { + + int id = -1; + + for(unsigned int i=0; i< this->nobj; i++) { + + Pft& pft = (*this)[i]; + if(pft.name == pftname) { + id = pft.id; + break; + } + } + + return id; + } +}; + +/// The one and only linked list of Pft objects +extern Pftlist pftlist; + +/// Container for crop-specific data at the individual level +struct cropindiv_struct : public Serializable { + + //Plant carbon biomass variables are all on patch area basis (kgC/m2) + + /// year's harvestable organ C biomass (= ycmass_plant) + double cmass_ho; + /// above-ground pool C biomass (when calculating daily cmass_leaf from lai_crop) (= ycmass_agpool) + double cmass_agpool; + double cmass_stem; + + /// year's maximum value of leaf C biomass + double cmass_leaf_max; + /// grs_cmass_leaf value saved at day before senescence (for LAI-calculation in allometry) + double cmass_leaf_sen; + + /// today's increase of whole plant C biomass + double dcmass_plant; + /// today's increase of leaf C biomass + double dcmass_leaf; + /// today's increase of root C biomass + double dcmass_root; + /// today's increase of harvestable organ C biomass + double dcmass_ho; + /// today's increase of above-ground pool C biomass + double dcmass_agpool; + double dcmass_stem; + + /// today's increase of leaf N biomass + double dnmass_leaf; + /// today's increase of root N biomass + double dnmass_root; + /// today's increase of harvestable organ N biomass + double dnmass_ho; + /// today's increase of above-ground pool N biomass + double dnmass_agpool; + + ///CARBON + /// daily updated whole plant C biomass, reset at harvest day + double grs_cmass_plant; + /// daily updated leaf C biomass, reset at harvest day + double grs_cmass_leaf; + /// daily updated root C biomass, reset at harvest day + double grs_cmass_root; + /// daily updated harvestable organ C biomass, reset at harvest day + double grs_cmass_ho; + /// daily updated above-ground pool C biomass, reset at harvest day + double grs_cmass_agpool; + /// daily updated dead leaf C biomass, reset at harvest day + double grs_cmass_dead_leaf; + /// daily updated stem pool C biomass, reset at harvest day + double grs_cmass_stem; + + /// carbon content of harvestable organs saved on first day of land use change year + double grs_cmass_leaf_luc; + /// carbon content of harvestable organs saved on first day of land use change year + double grs_cmass_root_luc; + /// carbon content of harvestable organs saved on first day of land use change year + double grs_cmass_ho_luc; + /// carbon content of above-ground pool saved on first day of land use change year + double grs_cmass_agpool_luc; + /// carbon content of dead leaves saved on first day of land use change year + double grs_cmass_dead_leaf_luc; + /// carbon content of stem saved on first day of land use change year + double grs_cmass_stem_luc; + + /// daily updated whole plant C biomass, reset at day 0 + double ycmass_plant; + /// daily updated leaf C biomass, reset at day 0 + double ycmass_leaf; + /// daily updated root C biomass, reset at day 0 + double ycmass_root; + /// daily updated harvestable organ C biomass, reset at day 0 + double ycmass_ho; + /// daily updated above-ground pool C biomass, reset at day 0 + double ycmass_agpool; + /// daily updated dead leaf C biomass, reset at day 0 + double ycmass_dead_leaf; + /// daily updated stem C biomass, reset at day 0 + double ycmass_stem; + + /// year's whole plant C biomass at time of harvest (cumulative if several harvest events) + double harv_cmass_plant; + /// year's leaf C biomass at time of harvest (cumulative if several harvest events) + double harv_cmass_leaf; + /// year's root C biomass at time of harvest (cumulative if several harvest events) + double harv_cmass_root; + /// year's harvestable organ C biomass at time of harvest (cumulative if several harvest events) + double harv_cmass_ho; + /// year's above-ground pool C biomass at time of harvest (cumulative if several harvest events) + double harv_cmass_agpool; + /// year's stem C biomass at time of harvest (cumulative if several harvest events) + double harv_cmass_stem; + + ///NITROGEN + /// nitrogen content of harvestable organs + double nmass_ho; + /// nitrogen content of above-ground pool + double nmass_agpool; + /// nitrogen content of dead leaves + double nmass_dead_leaf; + + /// nitrogen content of harvestable organs saved on first day of land use change year + double nmass_ho_luc; + /// nitrogen content of above-ground pool saved on first day of land use change year + double nmass_agpool_luc; + /// nitrogen content of dead leaves saved on first day of land use change year + double nmass_dead_leaf_luc; + + /// daily updated leaf N biomass, reset at day 0 + double ynmass_leaf; + /// daily updated root N biomass, reset at day 0 + double ynmass_root; + /// daily updated harvestable organ N biomass, reset at day 0 + double ynmass_ho; + /// daily updated above-ground pool N biomass, reset at day 0 + double ynmass_agpool; + /// daily updated dead leaf N biomass, reset at day 0 + double ynmass_dead_leaf; + + /// year's leaf N biomass at time of harvest (cumulative if several harvest events) + double harv_nmass_leaf; + /// year's root N biomass at time of harvest (cumulative if several harvest events) + double harv_nmass_root; + /// year's harvestable organ N biomass at time of harvest (cumulative if several harvest events) + double harv_nmass_ho; + /// year's above-ground pool N biomass at time of harvest (cumulative if several harvest events) + double harv_nmass_agpool; + + /// dry weight crop yield harvested this year (cumulative if several harvest events), based on harv_cmass_xx + double harv_yield; + + /// harvestable organ C biomass at the last two harvest events this year + double cmass_ho_harvest[2]; + /// harvestable organ N biomass at the last two harvest events this year + double nmass_ho_harvest[2]; + /// dry weight crop yield at the last two harvest events this year + double yield_harvest[2]; + + /// dry weight crop yield grown this year (cumulative if several harvest events), based on ycmass_xx + double yield; + + /// whether this pft is the main crop in the stand (pft.id==stand.pftid) + bool isprimarycrop; + /// whether this pft is allowed to compete with the main crop during the same growing period (for future use) + bool isprimarycovegetation; + /// whether this pft is grown during a second growing period, different from the primary (main) crop (for future use) +// bool issecondarycrop; + + /// set to true if pft.isintercropgrass is true and the stand's main crop pft.intercrop is "naturalgrass" + bool isintercropgrass; + + cropindiv_struct() { + cmass_ho=0.0; + cmass_agpool=0.0; + cmass_stem = 0.0; + cmass_leaf_max=0.0; + cmass_leaf_sen=0.0; + yield=0.0; + yield_harvest[0]=0.0; + yield_harvest[1]=0.0; + dcmass_leaf=0.0; + dcmass_root=0.0; + dcmass_plant=0.0; + dcmass_ho=0.0; + dcmass_agpool=0.0; + grs_cmass_leaf=0.0; + grs_cmass_root=0.0; + grs_cmass_plant=0.0; + grs_cmass_ho=0.0; + grs_cmass_agpool=0.0; + grs_cmass_stem = 0.0; + grs_cmass_dead_leaf = 0.0; + grs_cmass_leaf_luc=0.0; + grs_cmass_root_luc=0.0; + grs_cmass_ho_luc=0.0; + grs_cmass_agpool_luc=0.0; + grs_cmass_dead_leaf_luc = 0.0; + grs_cmass_stem_luc = 0.0; + nmass_ho=0.0; + nmass_agpool=0.0; + nmass_dead_leaf = 0.0; + ycmass_leaf=0.0; + ycmass_root=0.0; + ycmass_plant=0.0; + ycmass_ho=0.0; + ycmass_agpool=0.0; + ycmass_stem = 0.0; + ycmass_dead_leaf = 0.0; + harv_cmass_leaf=0.0; + harv_cmass_root=0.0; + harv_cmass_root=0.0; + harv_cmass_ho=0.0; + harv_yield=0.0; + harv_cmass_agpool=0.0; + harv_cmass_stem = 0.0; + cmass_ho_harvest[0]=0.0; + cmass_ho_harvest[1]=0.0; + + //Nitrogen + dnmass_leaf=0.0; + dnmass_root=0.0; + dnmass_ho=0.0; + dnmass_agpool=0.0; + ynmass_leaf=0.0; + ynmass_root=0.0; + ynmass_ho=0.0; + ynmass_agpool=0.0; + ynmass_dead_leaf = 0.0; + harv_nmass_leaf=0.0; + harv_nmass_root=0.0; + harv_nmass_root=0.0; + harv_nmass_ho=0.0; + harv_nmass_agpool=0.0; + nmass_dead_leaf_luc = 0.0; + nmass_ho_harvest[0]=0.0; + nmass_ho_harvest[1]=0.0; + + isprimarycrop=false; + isprimarycovegetation=false; +// issecondarycrop=false; + isintercropgrass=false; + } + + void serialize(ArchiveStream& arch); +}; + + +/// A vegetation individual. +/** In population mode this is the average individual of a PFT population; + * in cohort mode: the average individual of a cohort; + * in individual mode: an individual plant. Each grass PFT is represented as a single + * individual in all modes. Individual objects are collected within list arrays of + * class Vegetation (defined below), of which there is one for each patch, and include + * a reference to their 'parent' Vegetation object. Use the createobj member function + * of class Vegetation to add new individuals. + */ +class Individual : public Serializable { + +public: + /// reference to Pft object containing static parameters for this individual + Pft& pft; + /// reference to Vegetation object to which this Individual belongs + Vegetation& vegetation; + /// id code (0-based, sequential) + int id; + /// leaf C biomass on modelled area basis (kgC/m2) + double cmass_leaf; + /// fine root C biomass on modelled area basis (kgC/m2) + double cmass_root; + /// sapwood C biomass on modelled area basis (kgC/m2) + double cmass_sap; + /// heartwood C biomass on modelled area basis (kgC/m2) + double cmass_heart; + /// C "debt" (retrospective storage) (kgC/m2) + double cmass_debt; + /// Total C mass at land use change (kgC/m2) + double cmass_tot_luc; + /// leaf C mass after tunrnover + double cmass_leaf_post_turnover; + /// root C mass after turnover + double cmass_root_post_turnover; + /// Latest tunover day for this individual + int last_turnover_day; + + /// leaf N biomass on modelled area basis (kgN/m2) + double nmass_leaf; + /// root N biomass on modelled area basis (kgN/m2) + double nmass_root; + /// sap N biomass on modelled area basis (kgN/m2) + double nmass_sap; + /// heart N biomass on modelled area basis (kgN/m2) + double nmass_heart; + + /// leaf N biomass on modelled area basis saved on first day of land use change year + double nmass_leaf_luc; + /// root N biomass on modelled area basis on first day of land use change year + double nmass_root_luc; + /// sap N biomass on modelled area basis on first day of land use change year + double nmass_sap_luc; + /// heart N biomass on modelled area basis on first day of land use change year + double nmass_heart_luc; + /// total N biomass on modelled area basis on first day of land use change year + double nmass_tot_luc; + + /// foliar projective cover (FPC) under full leaf cover as fraction of modelled area + double fpc; + /// foliar projective cover (FPC) this day as fraction of modelled area + double fpc_daily; + /// fraction of PAR absorbed by foliage over projective area today, taking account of leaf phenological state + double fpar; + /// average density of individuals over patch (indiv/m2) + double densindiv; + /// vegetation phenological state (fraction of potential leaf cover) + double phen; + /// annual sum of daily fractional leaf cover + /** Equivalent number of days with full leaf cover + * (population mode only; reset on expected coldest day of year) + */ + double aphen; + /// annual number of days with full leaf cover) (raingreen PFTs only; reset on 1 January) + int aphen_raingreen; + + /// Photosynthesis values for this individual under non-water-stress conditions + PhotosynthesisResult photosynthesis; + + /// sub-daily version of the above variable (NB: daily units) + std::vector phots; + + /// accumulated NPP over modelled area (kgC/m2/year); + /** annual NPP following call to growth module on last day of simulation year */ + double anpp; + /// actual evapotranspiration over projected area (mm/day) + double aet; + /// annual actual evapotranspiration over projected area (mm/year) + double aaet; + /// leaf to root mass ratio + double ltor; + /// plant height (m) + double height; + /// plant crown area (m2) + double crownarea; + /// increment in fpc since last simulation year + double deltafpc; + /// bole height, i.e. height above ground of bottom of crown cylinder (m) + /** (individual and cohort modes only) */ + double boleht; + /// patch-level lai for this individual or cohort (function fpar) + double lai; + /// patch-level lai for cohort in current vertical layer (function fpar) + double lai_layer; + /// individual leaf area index (individual and cohort modes only) + double lai_indiv; + /// patch-level individual leaf area index (individual and cohort modes only) + double lai_daily; + /// daily individual leaf area index (individual and cohort modes only) + double lai_indiv_daily; + /// growth efficiency (NPP/leaf area) for each of the last five simulation years (kgC/m2/yr) + Historic greff_5; + /// increment of wood C for each of the last five simulation years (kgC/m2/yr) + Historic cmass_wood_inc_5; + /// individual/cohort age (years) + double age; + /// monthly LAI (including phenology component) + double mlai[12]; + /// monthly maximum LAI (including phenology component) + double mlai_max[12]; + /// FPAR assuming full leaf cover for all vegetation + double fpar_leafon; + /// LAI for current layer in canopy (cohort/individual mode; see function fpar) + double lai_leafon_layer; + /// non-water-stressed canopy conductance on FPC basis (mm/s) + double gpterm; + /// sub-daily version of the above variable (mm/s) + std::vector gpterms; + /// interception associated with this individual today (patch basis) + double intercep; + + /// accumulated mean fraction of potential leaf cover + double phen_mean; + + /// whether individual subject to water stress + bool wstress; + + /// leaf nitrogen that is photosyntetic active + double nactive; + /// Nitrogen extinction scalar + /** Scalar to account for leaf nitrogen not following the optimal light + * extinction, but is shallower. + */ + double nextin; + /// long-term storage of labile nitrogen + double nstore_longterm; + /// storage of labile nitrogen + double nstore_labile; + /// long-term storage of labile nitrogen saved on first day of land use change year + double nstore_longterm_luc; + /// storage of labile nitrogen saved on first day of land use change year + double nstore_labile_luc; + /// daily total nitrogen demand + double ndemand; + /// fraction of individual nitrogen demand available for uptake + double fnuptake; + /// annual nitrogen uptake + double anuptake; + /// maximum size of nitrogen storage + double max_n_storage; + /// scales annual npp to maximum nitrogen storage + double scale_n_storage; + /// annual nitrogen limitation on vmax + double avmaxnlim; + /// annual optimal leaf C:N ratio + double cton_leaf_aopt; + /// annual average leaf C:N ratio + double cton_leaf_aavr; + /// plant mobile nitrogen status + double cton_status; + /// total carbon in compartments before growth + double cmass_veg; + /// total nitrogen in compartments before growth + double nmass_veg; + /// whether individual subject to nitrogen stress + bool nstress; + /// daily leaf nitrogen demand calculated from Vmax (kgN/m2) + double leafndemand; + /// daily root nitrogen demand based on leafndemand + double rootndemand; + /// daily sap wood nitrogen demand based on leafndemand + double sapndemand; + /// daily labile nitrogen demand based on npp + double storendemand; + /// daily harvestable organ nitrogen demand + double hondemand; + /// leaf fraction of total nitrogen demand + double leaffndemand; + /// root fraction of total nitrogen demand + double rootfndemand; + /// sap fraction of total nitrogen demand + double sapfndemand; + /// store fraction of total nitrogen demand + double storefndemand; + /// daily leaf nitrogen demand over possible uptake (storage demand) + double leafndemand_store; + /// daily root nitrogen demand over possible uptake (storage demand) + double rootndemand_store; + + /// The daily C lossed from leaves due to senescense, only crops. + double daily_cmass_leafloss; + /// The daily N lossed from leaves due to senescense, only crops. + double daily_nmass_leafloss; + /// The daily C lossed from roots due to senescense, only crops. + double daily_cmass_rootloss; + /// The daily N lossed from roots due to senescense, only crops. + double daily_nmass_rootloss; + + /// Number of days with non-negligible phenology this month + int nday_leafon; + // Whether this individual is truly alive. + /** Set to false for first year after the Individual object is created, then true. */ + bool alive; + /// NPP this day + double dnpp; + + // bvoc + + /// isoprene production (mg C m-2 d-1) + double iso; + /// monoterpene production (mg C m-2 d-1) + double mon; + /// monoterpene storage pool (mg C m-2) + double monstor; + /// isoprene seasonality factor (-) + double fvocseas; + + /// Pointer to struct with crop-specific data + cropindiv_struct *cropindiv; + + // MEMBER FUNCTIONS + +public: + + // Constructor function for objects of class Individual + // Initialisation of certain member variables + + Individual(int i,Pft& p,Vegetation& v); + ~Individual(); + + /// Access functions for cropindiv: + cropindiv_struct* get_cropindiv() const; + cropindiv_struct* set_cropindiv(); + + void serialize(ArchiveStream& arch); + + /// Report a flux associated with this Individual + /** Fluxes from 'new' Individuals (alive == false) will not be reported */ + void report_flux(Fluxes::PerPFTFluxType flux_type, double value); + + /// Report a flux associated with this Individual + /** Fluxes from 'new' Individuals (alive == false) will not be reported */ + void report_flux(Fluxes::PerPatchFluxType flux_type, double value); + + /// Whether an individual is either a true crop or a cover crop grass + inline bool istruecrop_or_intercropgrass() const { + return (pft.landcover==CROPLAND && (pft.phenology==CROPGREEN || cropindiv->isintercropgrass)); + } + + /// Whether harvest and turnover is done on actual C and N on harvest or turnover day, which can occur any day of the year. + bool has_daily_turnover() const; + + /// Whether resetting of grs_cmass and turnover (if has_daily_turnover() returns true) of continuous grass is to be done this day. + /** This should occur at the very end of the growing period */ + bool is_turnover_day() const; + + /// Reduce current biomass due to mortality and/or fire + /** The removed biomass is put into litter pools and/or goes to fire fluxes. + * + * \param mortality fraction of Individual's biomass killed due to + * mortality (including fire) + * \param mortality_fire fraction of Individual's biomass killed due to + * fire only + */ + void reduce_biomass(double mortality, double mortality_fire); + + /// Total storage of nitrogen + double nstore() const { + return nstore_longterm + nstore_labile; + } + + /// Total carbon wood biomass + double cmass_wood() const { + return cmass_sap + cmass_heart - cmass_debt; + } + + /// Total nitrogen wood biomass + double nmass_wood() const { + return nmass_sap + nmass_heart; + } + + /// Total carbon biomass + double ccont(double scale_indiv = 1.0, bool luc = false) const; + /// Total nitrogen biomass + double ncont(double scale_indiv = 1.0, bool luc = false) const; + + /// Whether grass growth is uninterrupted by crop growth. + bool continous_grass() const; + + /// Checks whether any grs_cmass is negative, in which case it is zeroed and fluxes are corrected (only cropland). + double check_C_mass(); + /// Checks whether any nmass is negative, in which case it is zeroed and fluxes are corrected (only cropland). + double check_N_mass(); + + /// Save cmass-values on first day of the year of land cover change in expanding stands + void save_cmass_luc(); + /// Save nmass-values on first day of the year of land cover change in expanding stands + void save_nmass_luc(); + + /// Current leaf C:N ratio + /** + * \param use_phen Set to false if indiv.phen shouldn't be considered + * when calculating C:N ratio + */ + double cton_leaf(bool use_phen = true) const; + + /// Current fine root C:N ratio + /** + * \param use_phen Set to false if indiv.phen shouldn't be considered + * when calculating C:N ratio + */ + double cton_root(bool use_phen = true) const; + + /// Current sap C:N ratio + double cton_sap() const; + + /// Gets the individual's Patchpft + Patchpft& patchpft() const; + + /// Transfers the individual's biomass (C and N) to litter and harvest pools/fluxes + /** + * \param harvest Set to true if some of the biomass should be harvested, + * harvest will be done according to the PFT's harvest efficiency + * and residue outtake. + */ + void kill(bool harvest = false); + + /// Annual mean wscal - water stress parameter (0-1 range; 1 = minimum stress) + /** Value only valid at end of year, after call to canopy_exchange(). + * + * Currently, all Individuals belonging to a Patchpft share the same water stress. + */ + double wscal_mean() const; + + /// Gets the individual's daily cmass_leaf value + double cmass_leaf_today() const; + /// Gets the individual's daily cmass_root value + double cmass_root_today() const; + + /// Gets the individual's daily LAI value (patch-level) + /** Based on total leaf area for whatever the individual represents + * (individual, cohort, population), over the whole patch. + */ + double lai_today() const; + + /// Gets the individual's daily LAI value (individual-level) + /** Based on the leaf area for the average individual and + * the average individual's crown area. + */ + double lai_indiv_today() const; + + /// Gets the Nitrogen limited LAI, Eq. 8 Olin 2015 + double lai_nitrogen_today() const; + + /// Gets the individual's daily fpc value + double fpc_today() const; + + /// Gets the growingseason status for crop individual. Non-crop individuals always return true. + bool growingseason() const; + + /// The N demand of the storage, only used for PNV. + double ndemand_storage(double cton_leaf_opt); +}; + + +/// The vegetation in a patch - a list of individuals +/** Functionality for building, maintaining, referencing and destroying a list array of + * Individual objects. A single Vegetation object is defined for each patch. A + * reference to the parent Patch object (defined below) is included as a member + * variable. + * + * Functionality is inherited from the ListArray_idin1 template type in the GUTIL + * Library. Sequential Individual objects can be referenced as array elements by id, + * or by iteration through the linked list: + * + * Vegetation vegetation + * ... + * vegetation.firstobj(); + * while (vegetation.isobj) { + * Individual& thisindiv=vegetation.getobj(); + * // query or modify object thisindiv here + * vegetation.nextobj(); + * } + */ +class Vegetation : public ListArray_idin2, public Serializable { + +public: + // MEMBER VARIABLES + + /// reference to parent Patch object + Patch& patch; + + // MEMBER FUNCTIONS + + /// constructor (initialises member variable patch) + Vegetation(Patch& p):patch(p) {}; + + void serialize(ArchiveStream& arch); +}; + + +/// Soiltype stores static parameters for soils and the snow pack. +/** One Soiltype object is defined for each Gridcell. State variables for soils + * are held by objects of class Soil, of which there is one for each patch + * (see below). + */ +class Soiltype { + + // MEMBER VARIABLES + +public: + + /// available water holding capacity as fraction of soil volume + double awc_frac; + /// available water holding capacity of soil layers [0=upper layer] (mm) + double awc[NSOILLAYER]; + + /// coefficient in percolation calculation (K in Eqn 31, Haxeltine & Prentice 1996) + double perc_base; + /// exponent in percolation calculation (=4 in Eqn 31, Haxeltine & Prentice 1996) + double perc_exp; + + /// thermal diffusivity at 0% WHC (mm2/s) + double thermdiff_0; + /// thermal diffusivity at 15% WHC (mm2/s) + double thermdiff_15; + /// thermal diffusivity at 100% WHC (mm2/s) + double thermdiff_100; + + /// wilting point of soil layers [0=upper layer] (mm) Cosby et al 1984 + double wp[NSOILLAYER]; + /// saturation point. Cosby et al 1984 + double wsats[NSOILLAYER]; + + /// year at which to calculate equilibrium soil carbon + int solvesom_end; + /// year at which to begin documenting means for calculation of equilibrium soil carbon + int solvesom_begin; + + /// water holding capacity plus wilting point for whole soil volume + double wtot; + + // For CENTURY ... + /// fraction of soil that is sand + double sand_frac; + /// fraction of soil that is clay + double clay_frac; + /// fraction of soil that is silt + double silt_frac; + + // MEMBER FUNCTIONS + +public: + + /// Constructor: initialises certain member variables + Soiltype() { + + solvesom_end = SOLVESOM_END; + solvesom_begin = SOLVESOM_BEGIN; + } + + /// Override the default SOM years with 70-80% of the spin-up period length + void updateSolveSOMvalues(const int& nyrspinup) { + + solvesom_end = static_cast(0.8 * nyrspinup); + solvesom_begin = static_cast(0.7 * nyrspinup); + + } +}; + +/// CENTURY SOIL POOL +class Sompool : public Serializable { + +public: + + /// Constructor + Sompool() { + + // Initialise pool + + cmass = 0.0; + nmass = 0.0; + ligcfrac = 0.0; + delta_cmass = 0.0; + delta_nmass = 0.0; + fracremain = 0.0; + litterme = 0.0; + fireresist = 0.0; + + for (int m = 0; m < 12; m++) { + mfracremain_mean[m] = 0.0; + } + } + + /// C mass in pool kgC/m2 + double cmass; + /// Nitrogen mass in pool kgN/m2 + double nmass; + /// (potential) decrease in C following decomposition today (kgC/m2) + double cdec; + /// (potential) decrease in nitrogen following decomposition today (kgN/m2) + double ndec; + /// daily change in carbon and nitrogen + double delta_cmass,delta_nmass; + /// lignin fractions + double ligcfrac; + /// fraction of pool remaining after decomposition + double fracremain; + /// nitrogen to carbon ratio + double ntoc; + + // Fire + /// soil litter moisture flammability threshold (fraction of AWC) + double litterme; + /// soil litter fire resistance (0-1) + double fireresist; + + // Fast SOM spinup variables + + /// monthly mean fraction of carbon pool remaining after decomposition + double mfracremain_mean[12]; + + void serialize(ArchiveStream& arch); +}; + +/// This struct contains litter for solving Century SOM pools. +/** \see equilsom() */ +struct LitterSolveSOM : public Serializable { + /// Constructs an empty result + LitterSolveSOM() { + clear(); + } + + /// Clears all members + void clear() { + for (int p = 0; p < NSOMPOOL; p++) { + clitter[p] = 0.0; + nlitter[p] = 0.0; + } + } + + /// Add litter + void add_litter(double cvalue, double nvalue, int pool) { + clitter[pool] += cvalue; + nlitter[pool] += nvalue; + } + + double get_clitter(int pool) { + return clitter[pool]; + } + double get_nlitter(int pool) { + return nlitter[pool]; + } + + void serialize(ArchiveStream& arch); + +private: + /// Carbon litter + double clitter[NSOMPOOL]; + + /// Nitrogen litter + double nlitter[NSOMPOOL]; +}; + +/// Soil stores state variables for soils and the snow pack. +/** Initialised by a call to initdrivers. One Soil object is defined for each patch. + * A reference to the parent Patch object (defined below) is included as a member + * variable. Soil static parameters are stored as objects of class Soiltype, of which + * there is one for each grid cell. A reference to the Soiltype object holding the + * static parameters for this soil is included as a member variable. + */ +class Soil : public Serializable { + + // MEMBER VARIABLES + +public: + /// reference to parent Patch object + Patch& patch; + /// reference to Soiltype object holding static parameters for this soil + Soiltype& soiltype; + /// water content of soil layers [0=upper layer] as fraction of available water holding capacity; + double wcont[NSOILLAYER]; + /// DLE - the average wcont over the growing season, for each soil layer + double awcont[NSOILLAYER]; + /// water content of sublayer of upper soil layer for which evaporation from the bare soil surface is possible + /** fraction of available water holding capacity */ + double wcont_evap; + /// daily water content in upper soil layer for each day of year + double dwcontupper[Date::MAX_YEAR_LENGTH]; + /// mean water content in upper soil layer for last month + /** (valid only on last day of month following call to daily_accounting_patch) */ + double mwcontupper; + /// stored snow as average over modelled area (mm rainfall equivalents) + double snowpack; + /// total runoff today (mm/day) + double runoff; + /// soil temperature today at 0.25 m depth (deg C) + double temp; + /// daily temperatures for the last month (deg C) + /** (valid only on last day of month following call to daily_accounting_patch) */ + double dtemp[31]; + /// mean soil temperature for the last month (deg C) + /** (valid only on last day of month following call to daily_accounting_patch) */ + double mtemp; + /** respiration response to today's soil temperature at 0.25 m depth + * incorporating damping of Q10 due to temperature acclimation (Lloyd & Taylor 1994) + */ + double gtemp; + /// soil organic matter (SOM) pool with c. 1000 yr turnover (kgC/m2) + double cpool_slow; + /// soil organic matter (SOM) pool with c. 33 yr turnover (kgC/m2) + double cpool_fast; + + // Running sums (converted to long term means) maintained by SOM dynamics module + + /// mean annual litter decomposition (kgC/m2/yr) + double decomp_litter_mean; + /// mean value of decay constant for fast SOM fraction + double k_soilfast_mean; + /// mean value of decay constant for slow SOM fraction + double k_soilslow_mean; + + + // Parameters used by function soiltemp and updated monthly + + double alag, exp_alag; + + + /// water content of soil layers [0=upper layer] as fraction of available water holding capacity + double mwcont[12][NSOILLAYER]; + /// daily water content in lower soil layer for each day of year + double dwcontlower[Date::MAX_YEAR_LENGTH]; + /// mean water content in lower soil layer for last month + /** (valid only on last day of month following call to daily_accounting_patch) */ + double mwcontlower; + + /// rainfall and snowmelt today (mm) + double rain_melt; + /// upper limit for percolation (mm) + double max_rain_melt; + /// whether to percolate today + bool percolate; + +////////////////////////////////////////////////////////////////////////////////// +// CENTURY SOM pools and other variables + + Sompool sompool[NSOMPOOL]; + + /// daily percolation (mm) + double dperc; + /// fraction of decayed organic nitrogen leached each day; + double orgleachfrac; + /// soil mineral nitrogen pool (kgN/m2) + double nmass_avail; + /// soil nitrogen input (kgN/m2) + double ninput; + /// annual sum of nitrogen mineralisation + double anmin; + /// annual sum of nitrogen immobilisation + double animmob; + /// annual leaching from available nitrogen pool + double aminleach; + /// annual leaching of organics from active nitrogen pool + double aorgNleach; + /// total annual nitrogen fixation + double anfix; + /// calculated annual mean nitrogen fixation + double anfix_calc; + /// annual leaching of organics nitrogen from carbon pool + double aorgCleach; + + // Variables for fast spinup of SOM pools + + /// monthly fraction of available mineral nitrogen taken up + double fnuptake_mean[12]; + /// monthly fraction of organic carbon/nitrogen leached + double morgleach_mean[12]; + /// monthly fraction of available mineral nitrogen leached + double mminleach_mean[12]; + /// annual nitrogen fixation + double anfix_mean; + + // Solving Century SOM pools + + /// years at which to begin documenting for calculation of Century equilibrium + int solvesomcent_beginyr; + /// years at which to end documentation and start calculation of Century equilibrium + int solvesomcent_endyr; + + /// Cumulative litter pools for one year. + LitterSolveSOM litterSolveSOM; + + std::vector solvesom; + + /// stored nitrogen deposition in snowpack + double snowpack_nmass; + + // MEMBER FUNCTIONS + +public: + /// constructor (initialises member variable patch) + Soil(Patch& p,Soiltype& s):patch(p),soiltype(s) { + initdrivers(); + } + + void initdrivers() { + + // Initialises certain member variables + + alag = 0.0; + exp_alag = 1.0; + cpool_slow = 0.0; + cpool_fast = 0.0; + decomp_litter_mean = 0.0; + k_soilfast_mean = 0.0; + k_soilslow_mean = 0.0; + wcont[0] = 0.0; + wcont[1] = 0.0; + wcont_evap = 0.0; + snowpack = 0.0; + orgleachfrac = 0.0; + + + mwcontupper = 0.0; + mwcontlower = 0.0; + for (int mth=0; mth<12; mth++) { + mwcont[mth][0] = 0.0; + mwcont[mth][1] = 0.0; + fnuptake_mean[mth] = 0.0; + morgleach_mean[mth] = 0.0; + mminleach_mean[mth] = 0.0; + } + + std::fill_n(dwcontupper, Date::MAX_YEAR_LENGTH, 0.0); + std::fill_n(dwcontlower, Date::MAX_YEAR_LENGTH, 0.0); + + ///////////////////////////////////////////////////// + // Initialise CENTURY pools + + // Set initial CENTURY pool N:C ratios + // Parton et al 1993, Fig 4 + + sompool[SOILMICRO].ntoc = 1.0 / 15.0; + sompool[SURFHUMUS].ntoc = 1.0 / 15.0; + sompool[SLOWSOM].ntoc = 1.0 / 20.0; + sompool[SURFMICRO].ntoc = 1.0 / 20.0; + + // passive has a fixed value + sompool[PASSIVESOM].ntoc = 1.0 / 9.0; + + nmass_avail = 0.0; + ninput = 0.0; + anmin = 0.0; + animmob = 0.0; + aminleach = 0.0; + aorgNleach = 0.0; + aorgCleach = 0.0; + anfix = 0.0; + anfix_calc = 0.0; + anfix_mean = 0.0; + snowpack_nmass = 0.0; + dperc = 0.0; + + solvesomcent_beginyr = (int)(SOLVESOMCENT_SPINBEGIN * (nyear_spinup - freenyears) + freenyears); + solvesomcent_endyr = (int)(SOLVESOMCENT_SPINEND * (nyear_spinup - freenyears) + freenyears); + } + + void serialize(ArchiveStream& arch); +}; + +/// Container for crop-specific data at patchpft level +struct cropphen_struct : public Serializable { + + /// latest sowing date + int sdate; + /// sowing date of growing period ending in latest harvest this year + int sdate_harv; + /// sowing dates of growing periods ending in the two latest harvests this year + int sdate_harvest[2]; + /// sowing dates of growing periods starting this year + int sdate_thisyear[2]; + /// number of sowings this year + int nsow; + /// latest harvest date + int hdate; + /// two latest harvest dates this year + int hdate_harvest[2]; + /// last date for harvest + int hlimitdate; + /// last day of heat unit sampling period, set in Crop_sowing_date_new() + int hucountend; + /// number of harvests this year + int nharv; + /// whether sdate_harvest[0] happened last year + bool sownlastyear; + /// latest senescence start date this year + int sendate; + /// latest beginning of intercropseason (2 weeks after the harvest date) + int bicdate; + /// latest end of intercropseason (2 weeks before the sowing date) + int eicdate; + /// number of growing days this growing period + int growingdays; + /// number of growing days this year (used for wscal_mean calculation) + int growingdays_y; + /// length of growingseason ending in last harvest + int lgp; + /// base temp for heat unit calculation (°C) + double tb; + /// number of vernalising days required + int pvd; + /// number of accumulated vernalizing days + int vdsum; + /// heat unit reduction factor due to vernalization [0-1] + double vrf; + /// heat unit reduction factor due to photoperiodism [0-1] + double prf; + /// potential heat units required for crop maturity (°Cd) + double phu; + /// potential heat units that would have been used without dynamic phu calculation + double phu_old; + /// heat unit sum aquired during last growing period (°Cd) + double husum; + /// heat unit sum aquired durin sampling period, starting with sdate + double husum_sampled; + /// this year's heat unit sum aquired from sdate to hucountend + double husum_max; + /// running mean of recent past's husum_max + double husum_max_10; + /// number of heat units sampling years + int nyears_hu_sample; + /// fraction of growing season [0-1] (husum/phu) + double fphu; + /// fraction of growing season at latest harvest + double fphu_harv; + /// whether in period of heat unit sampling + bool hu_samplingperiod; + /// number of heat unit sampling days + int hu_samplingdays; + /// harvest index today [0-1, >1 if below-ground ho], harvestable organ/above-ground C for above-ground harvestable organs, dependent on fphu, reduced by water stress + double hi; + /// fraction of harvest index today + double fhi; + /// phenology (fphu) contribution of fraction of harvest index today + double fhi_phen; //Phenology (fPHU) compoment of fhi + /// water stress contribution of fraction of harvest index today + double fhi_water; + /// fraction of harvest index at latest harvest + double fhi_harv; + /// sum of crop patch demand (patch.wdemand) during crop growing period, reset on harvest day + double demandsum_crop; + /// sum of crop supply (patchpft.wsupply) during crop growing period, reset on harvest day + double supplysum_crop; + + /// whether inside crop/intercrop grass growing period + bool growingseason; + /// whether yesterday was inside crop/intercrop grass growing period + bool growingseason_ystd; + /// whether inside crop senescence + bool senescence; + /// whether yesterday was inside crop senescence + bool senescence_ystd; + /// whether inside intercrop crass growing period (main crop pft variable) + bool intercropseason; + + double vdsum_alloc; + double vd; + + /// The fraction of the daily assimilates allocated to roots. + double f_alloc_root; + /// The fraction of the daily assimilates allocated to leaves. + double f_alloc_leaf; + /// The fraction of the daily assimilates allocated to harvestable organs, seeds. + double f_alloc_horg; + /// The fraction of the daily assimilates allocated to stem. + double f_alloc_stem; + /// Development stage from Wang & Engel 1998 + double dev_stage; + // A variable holding the memory of whether this field was fertilised or not. + bool fertilised[3]; + + cropphen_struct() { + sdate=-1; + sdate_harv=-1; + nsow=0; + sownlastyear=false; + sendate=-1; + hdate=-1; + hlimitdate=-1; + hucountend=-1; + nharv=0; + tb=0.0; + pvd=0; + vdsum=0; + vrf=1.0; + phu=0.0; + phu_old=0.0; + husum_max=0.0; + husum_sampled=0.0; + husum_max_10=0.0; + nyears_hu_sample = 0; + prf=1.0; + husum=0.0; + fphu=0.0; + fphu_harv=0.0; + hu_samplingdays=0; + hu_samplingperiod=false; + + hi=0.0; + fhi=0.0; + fhi_phen=0.0; + fhi_water=1.0; + fhi_harv=0.0; + demandsum_crop=0.0; + supplysum_crop=0.0; + + growingseason=false; //Initialized to true for normal grass growth (CC3G & CC4G) in establishment + growingseason_ystd=false; + senescence=false; + senescence_ystd=false; + intercropseason=false; + bicdate=-1; + eicdate=-1; + growingdays=0; + growingdays_y=0; + lgp=0; + + for(int j=0;j<2;j++) { + sdate_harvest[j]=-1; + hdate_harvest[j]=-1; + sdate_thisyear[j]=-1; + } + + vdsum_alloc=0.0; + vd = 0.0; + f_alloc_root=0.0; + f_alloc_leaf=0.0; + f_alloc_horg=0.0; + f_alloc_stem=0.0; + dev_stage = 0.0; + + fertilised[0] = false; + fertilised[1] = false; + fertilised[2] = false; + } + + void serialize(ArchiveStream& arch); +}; + + +/// State variables common to all individuals of a particular PFT in a particular patch +/** Used in individual and cohort modes only. */ +class Patchpft : public Serializable { + + // MEMBER VARIABLES: + +public: + + /// id code (equal to value of member variable id in corresponding Pft object) + int id; + /// reference to corresponding Pft object in PFT list + Pft& pft; + /// potential annual net assimilation (leaf-level net photosynthesis) at forest floor (kgC/m2/year) + double anetps_ff; + /// water stress parameter (0-1 range; 1=minimum stress) + double wscal; + /// running sum (converted to annual mean) for wscal + double wscal_mean; + /// potential annual net assimilation at forest floor averaged over establishment interval (kgC/m2/year) + double anetps_ff_est; + /// first-year value of anetps_ff_est + double anetps_ff_est_initial; + /// annual mean wscal averaged over establishment interval + double wscal_mean_est; + /// vegetation phenological state (fraction of potential leaf cover), updated daily + double phen; + /// annual sum of daily fractional leaf cover + /** equivalent number of days with full leaf cover + * (reset on expected coldest day of year) + */ + double aphen; + /// whether PFT can establish in this patch under current conditions + bool establish; + /// running total for number of saplings of this PFT to establish (cohort mode) + double nsapling; + /// leaf-derived litter for PFT on modelled area basis (kgC/m2) + double litter_leaf; + /// fine root-derived litter for PFT on modelled area basis (kgC/m2) + double litter_root; + /// remaining sapwood-derived litter for PFT on modelled area basis (kgC/m2) + double litter_sap; + /// year's sapwood-derived litter for PFT on modelled area basis (kgC/m2) + double litter_sap_year; + /// remaining heartwood-derived litter for PFT on modelled area basis (kgC/m2) + double litter_heart; + /// year's heartwood-derived litter for PFT on modelled area basis (kgC/m2) + double litter_heart_year; + /// litter derived from allocation to reproduction for PFT on modelled area basis (kgC/m2) + double litter_repr; + + /// leaf-derived nitrogen litter for PFT on modelled area basis (kgN/m2) + double nmass_litter_leaf; + /// root-derived nitrogen litter for PFT on modelled area basis (kgN/m2) + double nmass_litter_root; + /// remaining sapwood-derived nitrogen litter for PFT on modelled area basis (kgN/m2) + double nmass_litter_sap; + /// year's sapwood-derived nitrogen litter for PFT on modelled area basis (kgN/m2) + double nmass_litter_sap_year; + /// remaining heartwood-derived nitrogen litter for PFT on modelled area basis (kgN/m2) + double nmass_litter_heart; + /// year's heartwood-derived nitrogen litter for PFT on modelled area basis (kgN/m2) + double nmass_litter_heart_year; + + /// non-FPC-weighted canopy conductance value for PFT under water-stress conditions (mm/s) + double gcbase; + /// daily value of the above variable (mm/s) + double gcbase_day; + + /// evapotranspirational "supply" function for this PFT today (mm/day) + double wsupply; + double wsupply_leafon; + /// fractional uptake of water from each soil layer today + double fwuptake[NSOILLAYER]; + + /// whether water-stress conditions for this PFT + bool wstress; + /// daily version of the above variable + bool wstress_day; + + /// carbon depository for long-lived products like wood + double harvested_products_slow; + /// nitrogen depository for long-lived products like wood + double harvested_products_slow_nmass; + /// first and last day of crop sowing window, calculated in crop_sowing_patch() or Crop_sowing_date_new() + int swindow[2]; + /// daily value of water deficit, calculated in irrigated_water_uptake() + double water_deficit_d; + /// yearly sum of water deficit + double water_deficit_y; + + /// Struct for crop-specific variables + cropphen_struct *cropphen; + + // MEMBER FUNCTIONS: + + /// Constructor: initialises id, pft and data members + Patchpft(int i,Pft& p):id(i),pft(p) { + + litter_leaf = 0.0; + litter_root = 0.0; + litter_sap = 0.0; + litter_sap_year = 0.0; + litter_heart = 0.0; + litter_heart_year = 0.0; + litter_repr = 0.0; + + nmass_litter_leaf = 0.0; + nmass_litter_root = 0.0; + nmass_litter_sap = 0.0; + nmass_litter_sap_year = 0.0; + nmass_litter_heart = 0.0; + nmass_litter_heart_year = 0.0; + + wscal = 1.0; + wscal_mean = 1.0; + anetps_ff = 0.0; + aphen = 0.0; + phen = 0.0; + wsupply = 0.0; + wsupply_leafon = 0.0; + anetps_ff_est = 0.0; + anetps_ff_est_initial = 0.0; + wscal_mean_est = 0.0; + nsapling = 0; + + for(int i=0;i pft; + /// vegetation for this patch + Vegetation vegetation; + /// soil for this patch + Soil soil; + /// fluxes for this patch + Fluxes fluxes; + /// FPAR at top of grass canopy today + double fpar_grass; + /// FPAR at soil surface today + double fpar_ff; + /// mean growing season PAR at top of grass canopy (J/m2/day) + double par_grass_mean; + /// number of days in growing season, estimated from mean vegetation leaf-on fraction + /** \see function fpar in canopy exchange module */ + int nday_growingseason; + /// total patch FPC + double fpc_total; + /// whether patch was disturbed last year + bool disturbed; + /// patch age (years since last disturbance) + int age; + /// probability of fire this year + double fireprob; + + /// whether management has started on this patch + bool managed; + /// cutting intensity (initial percent of trees cut, further selection at individual level has to be done in a separate function) + double man_strength; + + bool managed_this_year; + bool plant_this_year; + + /// DLE - the number of days over which wcont is averaged for this patch + /** i.e. those days for which daily temp > 5.0 degC */ + int growingseasondays; + + + // Variables used by new hydrology (Dieter Gerten 2002-07) + + /// interception by vegetation today on patch basis (mm) + double intercep; + /// annual sum of AET (mm/year) + double aaet; + /// annual sum of AET (mm/year) for each of the last five simulation years + Historic aaet_5; + /// annual sum of soil evaporation (mm/year) + double aevap; + /// annual sum of interception (mm/year) + double aintercep; + /// annual sum of runoff (mm/year) + double asurfrunoff; + /// annual sum of runoff (mm/year) + double adrainrunoff; + /// annual sum of runoff (mm/year) + double abaserunoff; + /// annual sum of runoff (mm/year) + double arunoff; + /// annual sum of potential evapotranspiration (mm/year) + double apet; + + /// equilibrium evapotranspiration today, deducting interception (mm) + double eet_net_veg; + + /// transpirative demand for patch, patch vegetative area basis (mm/day) + double wdemand; + /// daily average of the above variable (mm/day) + double wdemand_day; + /// transpirative demand for patch assuming full leaf cover today + /** mm/day, patch vegetative area basis */ + double wdemand_leafon; + /// rescaling factor to account for spatial overlap between individuals/cohorts populations + double fpc_rescale; + + /// monthly AET (mm/month) + double maet[12]; + /// monthly soil evaporation (mm/month) + double mevap[12]; + /// monthly interception (mm/month) + double mintercep[12]; + /// monthly runoff (mm/month) + double mrunoff[12]; + /// monthly PET (mm/month) + double mpet[12]; + + /// daily nitrogen demand + double ndemand; + + /// annual nitrogen fertilization (kgN/m2/year) + double anfert; + /// daily nitrogen fertilization (kgN/m2/day) + double dnfert; + + /// daily value of irrigation water (mm), set in irrigation(), derived from water_deficit_d + double irrigation_d; + /// yearly sum of irrigation water (mm) + double irrigation_y; + + /// whether litter is to be sent to the soil today + bool is_litter_day; + /// number of harvests and/or cover-crop killing or turnover events + int nharv; + /// whether today is a harvest day and/or cover-crop killing or turnover day + bool isharvestday; + + // MEMBER FUNCTIONS + + /// Constructor: initialises various members and builds list array of Patchpft objects. + Patch(int i,Stand& s,Soiltype& st); + + void serialize(ArchiveStream& arch); + + /// Returns the Climate for this Patch + /** This function returns a const reference to prevent code which operates + * on a patch basis to modify the climate and thereby affect other + * patches/stands. + */ + const Climate& get_climate() const; + + /// Returns whether we should model fire in this patch + bool has_fires() const; + + /// Returns whether we should model disturbances in this patch + bool has_disturbances() const; + /// Total patch carbon biomass and litter + double ccont(double scale_indiv = 1.0, bool luc = false); + /// Total patch nitrogen biomass and litter + double ncont(double scale_indiv = 1.0, bool luc = false); + /// Total patch carbon fluxes so far this year + double cflux(); + /// Total patch nitrogen fluxes so far this year + double nflux(); + + /// Get 5-year mean of wood C mass increase (periodic annual increment) + double get_cmass_wood_inc_5() { + double cmass_wood_inc_5_mean = 0.0; + for (unsigned int i=0; i 10) { + if(indiv.cmass_wood_inc_5.size()) + cmass_wood_inc_5_mean += indiv.cmass_wood_inc_5.mean(); + } + } + return cmass_wood_inc_5_mean; + } + + /// Get cmass_wood of all individuals in patch + double cmass_wood() { + double cmass_wood = 0.0; + for (unsigned int i=0; i, public Serializable { + +public: + + // MEMBER VARIABLES + + /// list array [0...npft-1] of Standpft (initialised in constructor) + ListArray_idin1 pft; + + /// A number identifying this Stand within the grid cell + int id; + + /// stand type id + int stid; + + /// pft id of main crop, updated during rotation + int pftid; + + /// current crop rotation item + int current_rot; + /// number of days passed in current rotation item + int ndays_inrotation; + /// Returns true if stand is in fallow (with cover crop grass) + bool infallow; + /// Returns true if crop rotation item is to be updated today + bool isrotationday; + /// Returns true if current crop management hydrology == irrigated, updated during rotation + bool isirrigated; + /// Returns true if the stand's main crop pft intercrop==naturalgrass and a pft with isintercrop==true is in the pftlist. + bool hasgrassintercrop; + /// gdd5-value at first intercrop grass growth + double gdd0_intercrop; + + /// old fraction of this stand relative to the gridcell before update + double frac_old; + + /// used during land cover change involving several calls to reveiving_stand_change() + /** Set to frac_old in reduce_stands(), then modified in donor_stand_change() and receiving_stand_change(). + */ + double frac_temp; + /// fraction unavailable for transfer to other stand types + double protected_frac; + /// net stand fraction change + double frac_change; + /// gross fraction increase + double gross_frac_increase; + /// gross fraction decrease + double gross_frac_decrease; + /// fraction that has been cloned from another stand + double cloned_fraction; + /// Returns true if this stand is cloned from another stand + bool cloned; + /// pointer to array of fractions transferred from this stand to other stand types + double *transfer_area_st; + /// land cover origin of this stand + landcovertype origin; + /// used for output from separate stands + double anpp; + /// used for output from separate stands + double cmass; + + /// Seed for generating random numbers within this Stand + /** The reason why Stand has its own seed, rather than using for instance + * a single global seed is to make it easier to compare results when using + * different land cover types. + * + * Randomness not associated with a specific stand, but rather a whole + * grid cell should instead use the seed in the Gridcell class. + * + * \see randfrac() + */ + long seed; + + /// type of landcover + /** \see landcovertype + * initialised in constructor + */ + landcovertype landcover; + + /// The year when this stand was created. + /** Will typically be year zero unless running with dynamic + * land cover. + * + * Needed to set patchpft.anetps_ff_est_initial + */ + int first_year; + // The year this stand was cloned from another stand + int clone_year; + /// scaling factor for stands that have grown in area this year (old fraction/new fraction) + double scale_LC_change; + + // MEMBER FUNCTIONS + + /// Constructs a Stand + /** \param i The id for the stand within the grid cell + * \param gc The parent grid cell + * \param st The soil type to be used within this Stand + * \param landcover The type of landcover to use for this stand + */ + Stand(int i, Gridcell* gc, Soiltype& st, landcovertype landcover, int no_patch = 0); + + ~Stand(); + + /// Gives the fraction of this Stand relative to the whole grid cell + double get_gridcell_fraction() const; + + /// Gives the fraction of this Stand relative to its land cover type; NB: unsafe to use within landcover_dynamics() ! + double get_landcover_fraction() const; + + /// Set the fraction of this Stand relative to the gridcell + void set_gridcell_fraction(double fraction); + + /// Returns the number of patches in this Stand + unsigned int npatch() const { return nobj; } + + /// Returns true if stand is true crop stand, as opposed to pasture grass grown on cropland or other land cover + inline bool is_true_crop_stand() { + return landcover==CROPLAND && pft[pftid].pft.phenology==CROPGREEN; // OK also for fallow (pftid always cropgreen) + } + /// Moves crop rotation forward + void rotate(); + /// Returns area transferred to other land cover during land cover change + double transfer_area_lc(landcovertype to); + /// Initiates new stand land cover settings + void init_stand_lu(StandType& st, double fraction); + /// Total stand carbon biomass and litter + double ccont(double scale_indiv = 1.0); + /// Total stand nitrogen biomass and litter + double ncont(double scale_indiv = 1.0); + /// Total stand carbon fluxes so far this year + double cflux(); + /// Total stand nitrogen fluxes so far this year + double nflux(); + + /// Creates a duplicate stand with a new landcovertype + /** The new stand is added to this stand's gridcell. + * + * \returns reference to the new stand + */ + Stand& clone(StandType& st, double fraction); + + void serialize(ArchiveStream& arch); + + /// Returns the Climate for this Stand + /** This function returns a const reference to prevent code which operates + * on a stand basis to modify the climate and thereby affect other + * stands. + */ + const Climate& get_climate() const; + + /// Returns the Gridcell containing this Stand + Gridcell& get_gridcell() const; + +private: + + /// Pointer to parent object, could be a null pointer + /** Prefer to access the gridcell through get_gridcell(), even internally + * within the Stand class. + */ + Gridcell* gridcell; + + /// Soil type to be used in this Stand + Soiltype& soiltype; + + /// Fraction of this stand relative to the gridcell + /** used by crop stands; initialized in constructor to 1, + * set in landcover_init() + */ + double frac; +}; + + + +/// State variables common to all individuals of a particular PFT in a GRIDCELL. +class Gridcellpft : public Serializable { + +public: + + // MEMBER VARIABLES + + /// A number identifying this object within its list array + int id; + + /// A reference to the Pft object for this Gridcellpft + Pft& pft; + + /// annual degree day sum above threshold damaging temperature + /** used in calculation of heat stess mortality; Sitch et al 2000, Eqn 55 + */ + double addtw; + + /// Michaelis-Menten kinetic parameters + /** Half saturation concentration for N uptake (Rothstein 2000, Macduff 2002) + */ + double Km; + + ///Crop-specific variables: + /// whether the daily temperature has fallen below the autumn temperature limit (tempautumn) this year + bool autumnoccurred; + /// whether the daily temperature has risen above the spring temperature limit (tempspring) this year + bool springoccurred; + /// whether the daily temperature has fallen below the vernalization limit (trg) this year + bool vernstartoccurred; + /// whether the daily temperature rises over the vernalization limit (trg) this year + bool vernendoccurred; + /// first day when temperature fell below the autumn temperature limit (tempautumn) this year + int first_autumndate; + /// 20-year mean + int first_autumndate20; + /// memory of the last 20 years' values + int first_autumndate_20[20]; + /// last day when temperature rose above the spring temperature limit (tempspring) this year + int last_springdate; + /// 20-year mean + int last_springdate20; + /// memory of the last 20 years' values + int last_springdate_20[20]; + /// last day when temperature has fallen below the vernilisation temperature limit (trg) this year (if vernstartoccurred==true) + int last_verndate; + /// 20-year mean + int last_verndate20; + /// memory of the last 20 years' values + int last_verndate_20[20]; + /// default sowing date (pft.sdatenh/sdatesh) + int sdate_default; + /// calculated sowing date from temperature limits + int sdatecalc_temp; + /// calculated sowing date from precipitation limits + int sdatecalc_prec; + /// sowing date from input file + int sdate_force; + /// harvest date from input file + int hdate_force; + /// N fertilization from input file + double Nfert_read; + /// default harvest date (pft.hlimitdatenh/hlimitdatesh) + int hlimitdate_default; + /// whether autumn sowing is either calculated or prescribed + bool wintertype; + /// first and last day of crop sowing window, calculated in calc_sowing_windows() + int swindow[2]; + /// first and last day of crop sowing window for irrigated crops, calculated in calc_sowing_windows() + int swindow_irr[2]; + /// temperature limits precludes crop sowing + bool sowing_restriction; + + // MEMBER FUNCTIONS + + /// Constructs a Gridcellpft object + /** \param i The id for this object + * \param p A reference to the Pft for this Gridcellpft + */ + Gridcellpft(int i,Pft& p):id(i),pft(p) { + addtw = 0.0; + Km = 0.0; + + autumnoccurred=false; + springoccurred=false; + vernstartoccurred=false; + vernendoccurred=false; + first_autumndate=-1; + first_autumndate20=-1; + last_springdate=-1; + last_springdate20=-1; + last_verndate=-1; + last_verndate20=-1; + for (int year=0;year<20;year++) { + first_autumndate_20[year]=-1; + last_springdate_20[year]=-1; + last_verndate_20[year]=-1; + } + sdate_default=-1; + sdate_force=-1; + hdate_force=-1; + Nfert_read=-1; + sdatecalc_temp=-1; + sdatecalc_prec=-1; + hlimitdate_default=-1; + wintertype=false; + swindow[0]=-1; + swindow[1]=-1; + sowing_restriction = false; + } + + void serialize(ArchiveStream& arch); +}; + +/// State variables common to all individuals of a particular STANDTYPE in a GRIDCELL. +class Gridcellst : public Serializable { + +public: + + // MEMBER VARIABLES + + /// A number identifying this object within its list array + int id; + + /// A reference to the StandType object for this Gridcellst + StandType& st; + + /// fraction of this stand type relative to the gridcell + double frac; + /// old fraction of this stand type relative to the gridcell before update + double frac_old; + /// fraction unavailable for transfer to other stand types + double protected_frac; + + /// net fraction change + double frac_change; + /// gross fraction increase + double gross_frac_increase; + /// gross fraction decrease + double gross_frac_decrease; + + // current number of stands of this stand type + int nstands; + + double nfert; + + // MEMBER FUNCTIONS + + /// Constructs a Gridcellst object + /** \param i The id for this object + * \param s A reference to the StandType for this Gridcellst + */ + Gridcellst(int i,StandType& s):id(i),st(s) { + frac = 1.0; + frac_old = 0.0; + protected_frac = 0.0; + frac_change = 0.0; + gross_frac_increase = 0.0; + gross_frac_decrease = 0.0; + nstands = 0; + nfert = -1.0; + } + + void serialize(ArchiveStream& arch); +}; + +/// Storage of land cover fraction data and some land cover change-related pools and fluxes +struct Landcover : public Serializable { + + Landcover(); + + /// The fractions of the different land cover types. + /** landcoverfrac is read in from land cover input file or from + * instruction file in getlandcover(). + */ + double frac[NLANDCOVERTYPES]; + + /// The land cover fractions from the previous year + /** Used to keep track of the changes when running with dynamic + * land cover. + */ + double frac_old[NLANDCOVERTYPES]; + + double frac_change[NLANDCOVERTYPES]; + + /// Transfer matrices + double frac_transfer[NLANDCOVERTYPES][NLANDCOVERTYPES]; + double primary_frac_transfer[NLANDCOVERTYPES][NLANDCOVERTYPES]; + + /// Whether the land cover fractions changed for this grid cell this year + /** \see landcover_dynamics + */ + bool updated; + + /// Gridcell-level C flux from slow harvested products + double acflux_harvest_slow; + + /// Gridcell-level C flux from harvest associated with landcover change + double acflux_landuse_change; + + /// Gridcell-level N flux from slow harvested products + double anflux_harvest_slow; + + /// Gridcell-level N flux from harvest associated with landcover change + double anflux_landuse_change; + + /// Landcover-level C flux from slow harvested products (donating landcover) + double acflux_harvest_slow_lc[NLANDCOVERTYPES]; + + /// Landcover-level C flux from harvest associated with landcover change (donating landcover) + double acflux_landuse_change_lc[NLANDCOVERTYPES]; + + /// Landcover-level N flux from slow harvested products (donating landcover) + double anflux_harvest_slow_lc[NLANDCOVERTYPES]; + + /// Landcover-level N flux from harvest associated with landcover change (donating landcover) + double anflux_landuse_change_lc[NLANDCOVERTYPES]; + + /// Which landcover types create new stands when area increases. + bool expand_to_new_stand[NLANDCOVERTYPES]; + + /// Whether to pool all transferred land from a donor landcover (overrides different landcover targets of different stand types and stands in a landcover) + bool pool_to_all_landcovers[NLANDCOVERTYPES]; + + /// Whether to pool transferred land to a receptor landcover (crop and pasture stands to new natural stand: pool!) + bool pool_from_all_landcovers[NLANDCOVERTYPES]; + + void serialize(ArchiveStream& arch); +}; + +/// The Gridcell class corresponds to a modelled locality or grid cell. +/** Member variables include an object of type Climate (holding climate, insolation and + * CO2 data), a object of type Soiltype (holding soil static parameters) and a list + * array of Stand objects. Soil objects (holding soil state variables) are associated + * with patches, not gridcells. A separate Gridcell object must be declared for each modelled + * locality or grid cell. + */ +class Gridcell : public GuessContainer, public Serializable { + +public: + + // MEMBER VARIABLES + + /// climate, insolation and CO2 for this grid cell + Climate climate; + + /// soil static parameters for this grid cell + Soiltype soiltype; + + /// landcover fractions and landcover-specific variables + Landcover landcover; + + /// list array [0...npft-1] of Gridcellpft (initialised in constructor) + ListArray_idin1 pft; + + /// list array [0...nst-1] of Gridcellst (initialised in constructor) + ListArray_idin1 st; + + /// object for keeping track of carbon and nitrogen balance + MassBalance balance; + + /// Seed for generating random numbers within this Gridcell + /** The reason why Gridcell has its own seed, rather than using for instance + * a single global seed is to make it easier to compare results when for + * instance changing the order in which the simulation proceeds. It also + * gets serialized together with the rest of the Gridcell state to make it + * possible to get exactly identical results after a restart. + * + * \see randfrac() + */ + long seed; + + // MEMBER FUNCTIONS + + /// Constructs a Gridcell object + Gridcell(); + + /// Longitude for this grid cell + double get_lon() const; + + /// Latitude for this grid cell + double get_lat() const; + + /// Set longitude and latitude for this grid cell + void set_coordinates(double longitude, double latitude); + + void serialize(ArchiveStream& arch); + + /// Creates a new Stand in this grid cell + Stand& create_stand(landcovertype lc, int no_patch = 0); + + /// Creates new stand and initiates land cover settings when run_landcover==true + Stand& create_stand_lu(StandType& st, double fraction, int no_patch = 0); + + /// Total gridcell carbon biomass and litter + double ccont(); + /// Total gridcell nitrogen biomass and litter + double ncont(); + /// Total gridcell carbon fluxes so far this year + double cflux(); + /// Total gridcell nitrogen fluxes so far this year + double nflux(); + + /// Deletes the stand which the iterator is pointing at + /** Returns an iterator pointing to the object following the erased object. + */ + iterator delete_stand(iterator itr); + + /// Returns number of stands + unsigned int nbr_stands() const; + +private: + + /// Longitude for this grid cell + double lon; + + /// Latitude for this grid cell + double lat; + +}; + + +#endif // LPJ_GUESS_GUESS_H + +/////////////////////////////////////////////////////////////////////////////////////// +// REFERENCES +// +// LPJF refers to the original FORTRAN implementation of LPJ as described by Sitch +// et al 2000 +// Delmas, R., Lacaux, J.P., Menaut, J.C., Abbadie, L., Le Roux, X., Helaa, G., Lobert, J., 1995. +// Nitrogen compound emission from biomass burning in tropical African Savanna FOS/DECAFE 1991 +// experiment. Journal of Atmospheric Chemistry 22, 175-193. +// Cosby, B. J., Hornberger, C. M., Clapp, R. B., & Ginn, T. R. 1984 A statistical +// exploration of the relationships of soil moisture characteristic to the +// physical properties of soil. +// Water Resources Research, 20: 682-690. +// Franzlubbers, AJ & Stuedemann, JA 2009 Soil-profile organic carbon and total +// nitrogen during 12 years of pasture management in the Southern Piedmont USA. +// Agriculture Ecosystems & Environment, 129, 28-36. +// Friend, A. D., Stevens, A. K., Knox, R. G. & Cannell, M. G. R. 1997. A +// process-based, terrestrial biosphere model of ecosystem dynamics +// (Hybrid v3.0). Ecological Modelling, 95, 249-287. +// Fulton, MR 1991 Adult recruitment rate as a function of juvenile growth in size- +// structured plant populations. Oikos 61: 102-105. +// Haxeltine A & Prentice IC 1996 BIOME3: an equilibrium terrestrial biosphere +// model based on ecophysiological constraints, resource availability, and +// competition among plant functional types. Global Biogeochemical Cycles 10: +// 693-709 +// Lloyd, J & Taylor JA 1994 On the temperature dependence of soil respiration +// Functional Ecology 8: 315-323 +// Macduff, JH, Humphreys, MO & Thomas, H 2002. Effects of a stay-green mutation on +// plant nitrogen relations in Lolium perenne during N starvation and after +// defoliation. Annals of Botany, 89, 11-21. +// Monsi M & Saeki T 1953 Ueber den Lichtfaktor in den Pflanzengesellschaften und +// seine Bedeutung fuer die Stoffproduktion. Japanese Journal of Botany 14: 22-52 +// Olin S., G. Schurgers, M. Lindeskog, D. Wårlind, B. Smith, P. Bodin, J. +// Holmér, and A. Arneth. 2015 Biogeosciences Discuss., 12, 1047-1111. The +// impact of atmospheric CO2 and N management on yields and tissue C:N in +// the main wheat regions of Western Europe +// Parton, W. J., Hanson, P. J., Swanston, C., Torn, M., Trumbore, S. E., Riley, W. +// & Kelly, R. 2010. ForCent model development and testing using the Enriched +// Background Isotope Study experiment. Journal of Geophysical +// Research-Biogeosciences, 115. +// Prentice, IC, Sykes, MT & Cramer W 1993 A simulation model for the transient +// effects of climate change on forest landscapes. Ecological Modelling 65: 51-70. +// Reich, PB, Walters MB & Ellsworth DS 1992 Leaf Life-Span in Relation to Leaf, +// Plant, and Stand Characteristics among Diverse Ecosystems. +// Ecological Monographs 62: 365-392. +// Sitch, S, Prentice IC, Smith, B & Other LPJ Consortium Members (2000) LPJ - a +// coupled model of vegetation dynamics and the terrestrial carbon cycle. In: +// Sitch, S. The Role of Vegetation Dynamics in the Control of Atmospheric CO2 +// Content, PhD Thesis, Lund University, Lund, Sweden. +// Sykes, MT, Prentice IC & Cramer W 1996 A bioclimatic model for the potential +// distributions of north European tree species under present and future climates. +// Journal of Biogeography 23: 209-233. +// Wang, E, Engel, T, 1998 Simulation of phenological development of wheat crops +// Agricultural Systems 58:1-24 +// White, M A, Thornton, P E, Running, S. & Nemani, R 2000 Parameterization and +// Sensitivity Analysis of the BIOME-BGC Terrestrial Ecosystem Model: Net Primary +// Production Controls. Earth Interactions, 4, 1-55. diff --git a/models/lpjguess/inst/parameters.PalEON.h b/models/lpjguess/inst/parameters.PalEON.h new file mode 100644 index 00000000000..39597db3a46 --- /dev/null +++ b/models/lpjguess/inst/parameters.PalEON.h @@ -0,0 +1,366 @@ +/////////////////////////////////////////////////////////////////////////////////////// +/// \file parameters.h +/// \brief The parameters module is responsible for reading in the instruction file +/// +/// This module defines and makes available a lot of the instruction file parameters +/// used by the model, but also lets other modules define their own parameters or +/// access "custom" parameters without defining them. +/// +/// A new parameter can be added by creating a new global variable here (or a new +/// Pft member variable if it's a PFT parameter), and then declaring it in +/// plib_declarations in parameters.cpp. See the many existing examples, and +/// documentation in the PLIB library for further documentation about this. +/// +/// Sometimes, adding a new parameter shouldn't (or can't) be done here however. +/// A parameter specific for a certain input module, should only be declared if +/// that input module is used. In this case the input module should declare its +/// own parameters when it is created. This can also be a good idea simply to +/// make modules more independent. For parameters like this, we can either use +/// the "custom" parameters (\see Paramlist) which don't need to be declared at +/// all, or the parameters can be declared with the declare_parameter family of +/// functions. +/// +/// \author Joe Siltberg +/// $Date: 2016-12-08 18:24:04 +0100 (Do, 08. Dez 2016) $ +/// +/////////////////////////////////////////////////////////////////////////////////////// + +#ifndef LPJ_GUESS_PARAMETERS_H +#define LPJ_GUESS_PARAMETERS_H + +#include "gutil.h" +#include + + +/////////////////////////////////////////////////////////////////////////////////////// +// Enums needed by some of the global instruction file parameters defined below + + +/// Vegetation 'mode', i.e. what each Individual object represents +/** Can be one of: + * 1. The average characteristics of all individuals comprising a PFT + * population over the modelled area (standard LPJ mode) + * 2. A cohort of individuals of a PFT that are roughly the same age + * 3. An individual plant + */ +typedef enum {NOVEGMODE, INDIVIDUAL, COHORT, POPULATION} vegmodetype; + +/// Land cover type of a stand. NLANDCOVERTYPES keeps count of number of items. +/* NB. set_lc_change_array() must be modified when adding new land cover types + */ +typedef enum {URBAN, CROPLAND, PASTURE, FOREST, NATURAL, PEATLAND, BARREN, NLANDCOVERTYPES} landcovertype; + +/// Water uptake parameterisations +/** \see water_uptake in canexch.cpp + */ +typedef enum {WR_WCONT, WR_ROOTDIST, WR_SMART, WR_SPECIESSPECIFIC} wateruptaketype; + +// f_js_20170517 moved that declaration here from guess.h for SPINUP_LIFEFORM +typedef enum {NOLIFEFORM, TREE, GRASS} lifeformtype; + +/////////////////////////////////////////////////////////////////////////////////////// +// Global instruction file parameters + +/// Title for this run +extern xtring title; + +/// Vegetation mode (population, cohort or individual) +extern vegmodetype vegmode; + +/// Default number of patches in each stand +/** Should always be 1 in population mode, + * cropland stands always have 1 patch. + * Actual patch number for stand objects may differ and + * should always be queried by stand.npatch() + */ +extern int npatch; + +/// Number of patches in each stand for secondary stands +extern int npatch_secondarystand; + +/// Whether to reduce equal percentage of all stands of a stand type at land cover change +extern bool reduce_all_stands; + +/// Minimum age of stands to reduce at land cover change +extern int age_limit_reduce; + +/// Patch area (m2) (individual and cohort mode only) +extern double patcharea; + +/// Whether background establishment enabled (individual, cohort mode) +extern bool ifbgestab; + +/// Whether spatial mass effect enabled for establishment (individual, cohort mode) +extern bool ifsme; + +/// Whether establishment stochastic (individual, cohort mode) +extern bool ifstochestab; + +/// Whether mortality stochastic (individual, cohort mode) +extern bool ifstochmort; + +/// Whether fire enabled +extern bool iffire; + +/// Whether "generic" patch-destroying disturbance enabled (individual, cohort mode) +extern bool ifdisturb; + +/// Generic patch-destroying disturbance interval (individual, cohort mode) +extern double distinterval; + +/// Whether SLA calculated from leaf longevity (alt: prescribed) +extern bool ifcalcsla; + +/// Whether leaf C:N ratio minimum calculated from leaf longevity (alt: prescribed) +extern bool ifcalccton; + +/// Establishment interval in cohort mode (years) +extern int estinterval; + +/// Whether C debt (storage between years) permitted +extern bool ifcdebt; + +/// Water uptake parameterisation +extern wateruptaketype wateruptake; + +/// whether CENTURY SOM dynamics (otherwise uses standard LPJ formalism) +extern bool ifcentury; +/// whether plant growth limited by available N +extern bool ifnlim; + +/// number of years to allow spinup without nitrogen limitation +extern int freenyears; +/// fraction of nitrogen relocated by plants from roots and leaves +extern double nrelocfrac; +/// first term in nitrogen fixation eqn (Cleveland et al 1999) +extern double nfix_a; +/// second term in nitrogen fixation eqn (Cleveland et al 1999) +extern double nfix_b; + +// f_js_20170517 +extern int disturb_year; +extern lifeformtype spinup_lifeform; + +/// Whether other landcovers than natural vegetation are simulated. +extern bool run_landcover; + +/// Whether a specific landcover type is simulated (URBAN, CROPLAND, PASTURE, FOREST, NATURAL, PEATLAND, BARREN). +extern bool run[NLANDCOVERTYPES]; + +/// Whether landcover fractions are not read from input file. +extern bool lcfrac_fixed; + +/// Whether fractions of stand types of a specific land cover are not read from input file. +extern bool frac_fixed[NLANDCOVERTYPES]; + +/// Set to false by initio( ) if fraction input files have yearly data. +extern bool all_fracs_const; + +/// If a slow harvested product pool is included in patchpft. +extern bool ifslowharvestpool; + +// If grass is allowed to grow between crop growingseasons +extern bool ifintercropgrass; + +// Whether to calculate dynamic potential heat units +extern bool ifcalcdynamic_phu; + +// Whether to use gross land transfer: simulate gross lcc (1); read landcover transfer matrix input file (2); read stand type transfer matrix input file (3), or not (0) +extern int gross_land_transfer; + +// Whether to use primary/secondary land transition info in landcover transfer input file (1). or not (0) +extern bool ifprimary_lc_transfer; + +// Whether to use primary-to-secondary land transition info (within land cover type) in landcover transfer input file (1). or not (0) +extern bool ifprimary_to_secondary_transfer; + +// Pooling level of land cover transitions; 0: one big pool; 1: land cover-level; 2: stand type-level +extern int transfer_level; + +// Whether to create new stands in transfer_to_new_stand() according to the rules in copy_stand_type() +extern bool iftransfer_to_new_stand; + +// Whether to limit dynamic phu calculation to a period specified by nyear_dyn_phu +extern bool ifdyn_phu_limit; + +// Number of years to calculate dynamic phu if dynamic_phu_limit is true +extern int nyear_dyn_phu; + +/// number of spinup years +extern int nyear_spinup; + +/// Whether to use sowingdates from input file +extern bool readsowingdates; + +/// Whether to use harvestdates from input file +extern bool readharvestdates; + +/// Whether to read N fertilization from input file +extern bool readNfert; + +/// Whether to read N fertilization (stand tyoe level) from input file +extern bool readNfert_st; + +/// Whether to print multiple stands within a land cover type (except cropland) separately +extern bool printseparatestands; + +/// Whether to simulate tillage by increasing soil respiration +extern bool iftillage; + +/// Use silt/sand fractions per soiltype +extern bool textured_soil; + +/// Whether pastures are affected by disturbance and fire (affects pastures' npatch) +extern bool disturb_pasture; + +/// Whether to simulate cropland as pasture +extern bool grassforcrop; + +/////////////////////////////////////////////////////////////////////////////////////// +// Settings controlling the saving and loading from state files + +/// Location of state files +extern xtring state_path; + +/// Whether to restart from state files +extern bool restart; + +/// Whether to save state files +extern bool save_state; + +/// Save/restart year +extern int state_year; + +/// whether to vary mort_greff smoothly with growth efficiency (1) or to use the standard step-function (0) +extern bool ifsmoothgreffmort; + +/// whether establishment is limited by growing season drought +extern bool ifdroughtlimitedestab; + +/// rain on wet days only (1, true), or a little every day (0, false); +extern bool ifrainonwetdaysonly; + +/// whether BVOC calculations are included +extern bool ifbvoc; + + +/////////////////////////////////////////////////////////////////////////////////////// +// The Paramlist class (and Paramtype) +// + +/// Represents one custom "param" item +/** \see Paramlist */ +struct Paramtype { + xtring name; + xtring str; + double num; +}; + +/// List for the "custom" parameters +/** Functionality for storing and retrieving custom "param" items from the instruction + * script. "Custom" parameters can be accessed by other modules without the need to + * define them beforehand. This of course also means there is no help text associated + * with these parameters, so the user can't get any documentation about them from + * the command line. + * + * Custom keywords may be included in the instruction script using syntax similar to + * the following examples: + * + * \code + * param "co2" (num 340) + * param "file_gridlist" (str "gridlist.txt") + * \endcode + * + * To retrieve the values associated with the "param" strings in the above examples, + * use the following function calls (may appear anywhere in this file; instruction + * script must have been read in first): + * + * \code + * param["co2"].num + * param["file_gridlist"].str + * \endcode + * + * Each "param" item can store EITHER a number (int or double) OR a string, but not + * both types of data. Function fail is called to terminate output if a "param" item + * with the specified identifier was not read in. + */ +class Paramlist : public ListArray { + +public: + /// Adds a parameter with a numeric value, overwriting if it already existed + void addparam(xtring name,xtring value); + + /// Adds a parameter with a string value, overwriting if it already existed + void addparam(xtring name,double value); + + /// Fetches a parameter from the list, aborts the program if it didn't exist + Paramtype& operator[](xtring name); + + /// Tests if param exists + bool isparam(xtring name); + +private: + /// Tries to find the parameter in the list + /** \returns 0 if it wasn't there. */ + Paramtype* find(xtring name); +}; + +/// The global Paramlist object +/** Contains all the custom parameters after reading in the instruction file */ +extern Paramlist param; + +/// Reads in the instruction file +/** Uses PLIB library functions to read instructions from file specified by + * 'insfilename'. + */ +void read_instruction_file(const char* insfilename); + +/// Displays documentation about the instruction file parameters to the user +void printhelp(); + + +/////////////////////////////////////////////////////////////////////////////////////// +// Interface for declaring parameters from other modules + +/// Declares an xtring parameter +/** \param name The name of the parameter + * \param param Pointer to variable where the value of the parameter is to be placed + * \param maxlen Maximum allowed length of the parameter in the ins file + * \param help Documentation describing the parameter to the user + */ +void declare_parameter(const char* name, xtring* param, int maxlen, const char* help = ""); + +/// Declares a std:string parameter +/** \param name The name of the parameter + * \param param Pointer to variable where the value of the parameter is to be placed + * \param maxlen Maximum allowed length of the parameter in the ins file + * \param help Documentation describing the parameter to the user + */ +void declare_parameter(const char* name, std::string* param, int maxlen, const char* help = ""); + +/// Declares an int parameter +/** \param name The name of the parameter + * \param param Pointer to variable where the value of the parameter is to be placed + * \param min Minimum allowed value of the parameter in the ins file + * \param max Maximum allowed value of the parameter in the ins file + * \param help Documentation describing the parameter to the user + */ +void declare_parameter(const char* name, int* param, int min, int max, const char* help = ""); + +/// Declares a double parameter +/** \param name The name of the parameter + * \param param Pointer to variable where the value of the parameter is to be placed + * \param min Minimum allowed value of the parameter in the ins file + * \param max Maximum allowed value of the parameter in the ins file + * \param help Documentation describing the parameter to the user + */ +void declare_parameter(const char* name, double* param, double min, double max, const char* help = ""); + +/// Declares a bool parameter +/** \param name The name of the parameter + * \param param Pointer to variable where the value of the parameter is to be placed + * \param help Documentation describing the parameter to the user + */ +void declare_parameter(const char* name, bool* param, const char* help = ""); + +#endif // LPJ_GUESS_PARAMETERS_H From 3293a0dc3b7baa0bbbb50378b48c5f934d9fd2cc Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Fri, 21 Jun 2019 15:19:21 -0400 Subject: [PATCH 40/56] Also scale and adjust N pools. --- models/lpjguess/R/adjustBiomass.LPJGUESS.R | 74 ++++++++++++++----- models/lpjguess/R/adjustDensity.LPJGUESS.R | 6 ++ ...calculateGridcellVariablePerPFT.LPJGUESS.R | 22 +++++- models/lpjguess/R/updateState.LPJGUESS.R | 61 ++++++++++----- models/lpjguess/src/allocation.LPJGUESS.cpp | 1 + 5 files changed, 123 insertions(+), 41 deletions(-) diff --git a/models/lpjguess/R/adjustBiomass.LPJGUESS.R b/models/lpjguess/R/adjustBiomass.LPJGUESS.R index 93339dda97d..126a547bb5e 100644 --- a/models/lpjguess/R/adjustBiomass.LPJGUESS.R +++ b/models/lpjguess/R/adjustBiomass.LPJGUESS.R @@ -1,6 +1,6 @@ -adjustBiomass <- function(individual, biomass.increment, sla, wooddens, lifeform, k_latosa, k_allom2, k_allom3){ +adjustBiomass <- function(individual, rel.change, sla, wooddens, lifeform, k_latosa, k_allom2, k_allom3){ # dummy input values to the allocation function below # note that they are not actually updated by the function, the updated values are in the returned list @@ -13,9 +13,14 @@ adjustBiomass <- function(individual, biomass.increment, sla, wooddens, lifefor litter_root_inc <- 0 exceeds_cmass <- 0 + # calculate the total biomass and the absolute change based on this + biomass.total <- individual$cmass_leaf+individual$cmass_root+individual$cmass_heart+individual$cmass_sap-individual$cmass_debt + biomass.inc <- (biomass.total * rel.change) - biomass.total + + updated.pools <- allocation( # vegetation state - bminc = as.numeric(biomass.increment/individual$densindiv), + bminc = as.numeric(biomass.inc/individual$densindiv), cmass_leaf = as.numeric(individual$cmass_leaf/individual$densindiv), cmass_root = as.numeric(individual$cmass_root/individual$densindiv), cmass_sap = as.numeric(individual$cmass_sap/individual$densindiv), @@ -57,24 +62,49 @@ adjustBiomass <- function(individual, biomass.increment, sla, wooddens, lifefor individual$cmass_root <- new.cmass_root individual$nmass_root <- individual$nmass_root * root.scaling - # sap - original.cmass_sap <- individual$cmass_sap - new.cmass_sap <- individual$cmass_sap + (updated.pools[["cmass_sap_inc"]] * individual$densindiv) - sap.scaling <- new.cmass_sap / original.cmass_sap - individual$cmass_sap <- new.cmass_sap - individual$nmass_sap <- individual$nmass_sap * sap.scaling - # heart - original.cmass_heart <- individual$cmass_heart - new.cmass_heart <- individual$cmass_heart + (updated.pools[["cmass_heart_inc"]] * individual$densindiv) - heart.scaling <- new.cmass_heart / original.cmass_heart - individual$cmass_heart <- new.cmass_heart - individual$nmass_heart <- individual$nmass_heart * heart.scaling + # sap, heart and debt only for trees + if(lifeform == 1) { + + # sap + original.cmass_sap <- individual$cmass_sap + new.cmass_sap <- individual$cmass_sap + (updated.pools[["cmass_sap_inc"]] * individual$densindiv) + sap.scaling <- new.cmass_sap / original.cmass_sap + individual$cmass_sap <- new.cmass_sap + individual$nmass_sap <- individual$nmass_sap * sap.scaling + + + # heart + original.cmass_heart <- individual$cmass_heart + new.cmass_heart <- individual$cmass_heart + (updated.pools[["cmass_heart_inc"]] * individual$densindiv) + heart.scaling <- new.cmass_heart / original.cmass_heart + individual$cmass_heart <- new.cmass_heart + individual$nmass_heart <- individual$nmass_heart * heart.scaling + + # debt - note no equivalant N debt + original.cmass_debt <- individual$cmass_debt + new.cmass_debt <- individual$cmass_debt + (updated.pools[["cmass_debt_inc"]] * individual$densindiv) + individual$cmass_debt <- new.cmass_debt + + } + else { + # define these for later + original.cmass_sap <- 0 + original.cmass_heart <- 0 + original.cmass_debt <- 0 + } + + # N labile and long term storage - note no equivalant C pools and they are not determined by allocation upgrade, + # so simply scale by the overall biomass change + individual$nstore_labile <- individual$nstore_labile * rel.change + individual$nstore_longterm <- individual$nstore_longterm * rel.change + - # debt - note no equivalant N debt - original.cmass_debt <- individual$cmass_debt - new.cmass_debt <- individual$cmass_debt + (updated.pools[["cmass_debt_inc"]] * individual$densindiv) - individual$cmass_debt <- new.cmass_debt + # TODO (potentially): MF - for simulations involving managed forestry and harvest the variable 'cmass_wood_inc_5' + # should also be updated. This is a vector, and I am not sure if the increment should go at the start or the end of it. + # But also, how to deal simultaneously with harvesting and nudging will probably require some thought, and maybe + # it is not necessary or appropriate to update this variable + #print(individual$cmass_wood_inc_5) # checks @@ -94,7 +124,11 @@ adjustBiomass <- function(individual, biomass.increment, sla, wooddens, lifefor print("--- end ---") } - return(individual) + + return(list(individual = individual, + litter_leaf_inc = updated.pools[["litter_leaf_inc"]], + litter_root_inc = updated.pools[["litter_root_inc"]], + exceeds_cmass = updated.pools[["exceeds_cmass"]] + )) } - \ No newline at end of file diff --git a/models/lpjguess/R/adjustDensity.LPJGUESS.R b/models/lpjguess/R/adjustDensity.LPJGUESS.R index 0b1218c8f30..88ed654600c 100644 --- a/models/lpjguess/R/adjustDensity.LPJGUESS.R +++ b/models/lpjguess/R/adjustDensity.LPJGUESS.R @@ -2,7 +2,9 @@ #' @keywords internal adjustDensity.LPJGUESS <- function(individual, rel.change) { + # the density individual$densindiv <- individual$densindiv * rel.change + #the coupled C and N pools individual$cmass_leaf <- individual$cmass_leaf * rel.change individual$nmass_leaf <- individual$nmass_leaf * rel.change individual$cmass_root <- individual$cmass_root * rel.change @@ -11,7 +13,11 @@ adjustDensity.LPJGUESS <- function(individual, rel.change) { individual$nmass_sap <- individual$nmass_sap * rel.change individual$cmass_heart <- individual$cmass_heart * rel.change individual$nmass_heart <- individual$nmass_heart * rel.change + # the carbon debt ('retrocative storage' with no N couterpart) individual$cmass_debt <- individual$cmass_debt * rel.change + # labile and long term N storage with no C counterparts + individual$nstore_longterm <- individual$nstore_longterm * rel.change + individual$nstore_labile <- individual$nstore_labile * rel.change return(individual) diff --git a/models/lpjguess/R/calculateGridcellVariablePerPFT.LPJGUESS.R b/models/lpjguess/R/calculateGridcellVariablePerPFT.LPJGUESS.R index 4cb63b9ad6a..6da7278b35d 100644 --- a/models/lpjguess/R/calculateGridcellVariablePerPFT.LPJGUESS.R +++ b/models/lpjguess/R/calculateGridcellVariablePerPFT.LPJGUESS.R @@ -66,9 +66,29 @@ calculateGridcellVariablePerPFT <- function(model.state, variable) { if(!this.pft.id %in% active.PFTs) stop(paste0("Found individual of PFT id = ",this.pft.id, " but this doesn't seem to be active in the LPJ-GUESS run")) # calculate the total cmass and density of individuals per PFT - if(variable == "biomass") { + if(variable == "cmass") { gc.sum[this.pft.id+1] <- gc.sum[this.pft.id+1] + ((this.individual$cmass_leaf+this.individual$cmass_root+ this.individual$cmass_heart+this.individual$cmass_sap-this.individual$cmass_debt)/npatches) + + #print(paste("leaf =" , this.individual$cmass_leaf)) + #print(paste("root =" , this.individual$cmass_root)) + #print(paste("sap =" , this.individual$cmass_sap)) + #print(paste("heart =" , this.individual$cmass_heart)) + #print(paste("id = ", this.individual$indiv.pft.id, "debt =" , this.individual$cmass_debt)) + + } + else if(variable == "nmass") { + gc.sum[this.pft.id+1] <- gc.sum[this.pft.id+1] + ((this.individual$nmass_leaf+this.individual$nmass_root+this.individual$nmass_heart+ + this.individual$nmass_sap+this.individual$nstore_labile+this.individual$nstore_longterm)/npatches) + #gc.sum[this.pft.id+1] <- gc.sum[this.pft.id+1] + ((this.individual$nmass_leaf+this.individual$nmass_root+this.individual$nmass_heart+ + # this.individual$nmass_sap)/npatches) + + + #print(paste("leaf =" , this.individual$nmass_leaf)) + #print(paste("root =" , this.individual$nmass_root)) + #print(paste("sap =" , this.individual$nmass_sap)) + #print(paste("heart =" , this.individual$nmass_heart)) + } else gc.sum[this.pft.id+1] <- gc.sum[this.pft.id+1] + (this.individual[[variable]]/npatches) diff --git a/models/lpjguess/R/updateState.LPJGUESS.R b/models/lpjguess/R/updateState.LPJGUESS.R index 17e24d7b083..44b6dbf40c9 100644 --- a/models/lpjguess/R/updateState.LPJGUESS.R +++ b/models/lpjguess/R/updateState.LPJGUESS.R @@ -22,10 +22,10 @@ #' @param dens.target A numeric vector of the target stand-level stem densities (indiv/m^2) as named numeric vector #' with one entry per PFT/species, with the names being the PFT/species codes. These values should be produced #' using state data assimilation from function XXXXXX -#' @param biomass.target A numeric vector of the target stand-level biomasses (kgC/m^2) as named numeric vector +#' @param cmass.target A numeric vector of the target stand-level biomasses (kgC/m^2) as named numeric vector #' with one entry per PFT/species, with the names being the PFT/species codes. These values should be produced #' using state data assimilation from function XXXXXX -#' @param biomass.target A numeric vector of the target stand-level biomasses (kgC/m^2) as named numeric vector +#' @param cmass.target A numeric vector of the target stand-level biomasses (kgC/m^2) as named numeric vector #' with one entry per PFT/species, with the names being the PFT/species codes. These values should be produced #' using state data assimilation from function XXXXXX #' @return And updated model state (as a big old list o' lists) @@ -34,12 +34,12 @@ -updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, biomass.initial, biomass.target) { +updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, cmass.initial, cmass.target) { # calculate relative increases to be applied later on (per PFT) dens.rel.change <- dens.target/dens.initial - biomass.rel.change <- biomass.target/biomass.initial + biomass.rel.change <- cmass.target/cmass.initial #print(dens.rel.change) #print(biomass.rel.change) @@ -124,21 +124,23 @@ updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, biomass # STEP 2 - nudge biomass by performing the LPJ-GUESS allocation routine - # calculate the total biomass (after the densindiv nudging above) and the absolute change based on this - biomass.total <- updated.individual$cmass_leaf+updated.individual$cmass_root+updated.individual$cmass_heart+updated.individual$cmass_sap-updated.individual$cmass_debt - biomass.inc <- (biomass.total * biomass.rel.change[this.pft.id+1]) - biomass.total - - # this function call runs the LPJ-GUESS allocation routine and ajusts the pools accordingly - updated.individual <- adjustBiomass(individual = updated.individual, - biomass.increment = biomass.inc, - sla = sla[this.pft.id+1], - wooddens = wooddens[this.pft.id+1], - lifeform = lifeform[this.pft.id+1], - k_latosa = k_latosa[this.pft.id+1], - k_allom2 = k_allom2[this.pft.id+1], - k_allom3 = k_allom3[this.pft.id+1]) - - + # this function call runs the LPJ-GUESS allocation routine and adjusts the pools vegetation pools accordingly + # however, it doesn't adjust the litter pools or do anything with 'exceeds_cmass', these are returned + # as elements of the list, because they should only be applied to the state *if* this was a valid allocation + updated.list <- adjustBiomass(individual = updated.individual, + rel.change = biomass.rel.change[this.pft.id+1], + sla = sla[this.pft.id+1], + wooddens = wooddens[this.pft.id+1], + lifeform = lifeform[this.pft.id+1], + k_latosa = k_latosa[this.pft.id+1], + k_allom2 = k_allom2[this.pft.id+1], + k_allom3 = k_allom3[this.pft.id+1]) + # extract the elements from the return list + updated.individual <- updated.list[["individual"]] + litter_root_inc <- updated.list[["litter_root_inc"]] + litter_leaf_inc <- updated.list[["litter_leaf_inc"]] + exceeds_cmass <- updated.list[["exceeds_cmass"]] + rm(updated.list) # STEP 3 - adjust the allometry of the individual based on the updated pools # QUESTION: what to do if allometry returns FALSE? @@ -167,9 +169,28 @@ updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, biomass if(allometry.results$error.string != "OK") { print(allometry.results$error.string) } - # else update the individual, the litter pools and break + # else update the individual, the litter pools, exceeds_cmass and break else { + # first the individual model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]] <- updated.individual + + # now the litter pools (determine N based on intial C:N ratio) + # C:N ratios + leaf_litter_cton <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_leaf[[this.pft.id+1]] / model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$nmass_litter_leaf[[this.pft.id+1]] + root_litter_cton <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_root[[this.pft.id+1]] / model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$nmass_litter_root[[this.pft.id+1]] + # update the C pools based on the calculated increments + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_leaf[[this.pft.id+1]] <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_leaf[[this.pft.id+1]] + (litter_leaf_inc * updated.individual$densindiv) + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_root[[this.pft.id+1]] <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_root[[this.pft.id+1]] + (litter_root_inc * updated.individual$densindiv) + # update the N pools simple by dividing the new C pool by the C:N ratio + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$nmass_litter_leaf[[this.pft.id+1]] <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_leaf[[this.pft.id+1]] / leaf_litter_cton + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$nmass_litter_root[[this.pft.id+1]] <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_root[[this.pft.id+1]] / root_litter_cton + + # and finally exceeds_cmass + # - not currently dealing with this because it is only used to maintin mass balance which + # we *probably* don't need to do here, but print a warning if it is non-zero + if(!exceeds_cmass == 0) warning(paste("Non-zero exceeds_cmass following allocation, exceeds_cmass =", exceeds_cmass)) + + } diff --git a/models/lpjguess/src/allocation.LPJGUESS.cpp b/models/lpjguess/src/allocation.LPJGUESS.cpp index 1ec01200aa7..7e44efa79dc 100644 --- a/models/lpjguess/src/allocation.LPJGUESS.cpp +++ b/models/lpjguess/src/allocation.LPJGUESS.cpp @@ -623,6 +623,7 @@ double EPS = 1.0e-12; assert(fabs(bminc + exceeds_cmass - (cmass_leaf_inc + cmass_root_inc + cmass_sap_inc + cmass_heart_inc + litter_leaf_inc + litter_root_inc)) < EPS); + List ret; ret["cmass_leaf_inc"] = cmass_leaf_inc; ret["cmass_root_inc"] = cmass_root_inc; From aae14e639b6c5d7eb526f532c93bacfe7c7c2f9a Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Fri, 21 Jun 2019 16:03:29 -0400 Subject: [PATCH 41/56] Mostly code tidying/documentation ahead of merging. --- models/lpjguess/R/adjustDensity.LPJGUESS.R | 19 ++++++ models/lpjguess/R/allometry.LPJGUESS.R | 68 ++++++++++++------- models/lpjguess/R/updateState.LPJGUESS.R | 43 ++++++++---- models/lpjguess/man/adjustDensity.LPJGUESS.Rd | 24 +++++++ models/lpjguess/man/allometry.Rd | 55 ++++++++++++++- models/lpjguess/man/updateState.LPJGUESS.Rd | 8 +-- 6 files changed, 175 insertions(+), 42 deletions(-) create mode 100644 models/lpjguess/man/adjustDensity.LPJGUESS.Rd diff --git a/models/lpjguess/R/adjustDensity.LPJGUESS.R b/models/lpjguess/R/adjustDensity.LPJGUESS.R index 88ed654600c..22ad8cbcf4b 100644 --- a/models/lpjguess/R/adjustDensity.LPJGUESS.R +++ b/models/lpjguess/R/adjustDensity.LPJGUESS.R @@ -1,5 +1,24 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2012 University of Illinois, NCSA. +# All rights reserved. This program and the accompanying materials +# are made available under the terms of the +# University of Illinois/NCSA Open Source License +# which accompanies this distribution, and is available at +# http://opensource.ncsa.illinois.edu/license.html +#------------------------------------------------------------------------------- +#' Adjust LPJ-GUESS individual's density +#' +#' Very simple function that just scales the density of individuals and the associated C and N pools +#' by a relative amount +#' +#' @param individual A nested list which encapsulates an LPJ-GUESS 'Individual' as read from a binary state file +#' @param rel.change A numeric by which to scale the density and C and N pools +#' +#' #' @keywords internal +#' @return the scaled 'individual' (the initial nested list with update values) +#' @author Matthew Forrest adjustDensity.LPJGUESS <- function(individual, rel.change) { # the density diff --git a/models/lpjguess/R/allometry.LPJGUESS.R b/models/lpjguess/R/allometry.LPJGUESS.R index 982b492b8e1..7db0bcfe05d 100644 --- a/models/lpjguess/R/allometry.LPJGUESS.R +++ b/models/lpjguess/R/allometry.LPJGUESS.R @@ -16,38 +16,60 @@ lambertbeer <- function(lai) { -## Matthew Forrest 2019-06-19 This function was transcribed from LPJ-GUESS (v4.0) C++ to R for the purpose of nudging the LPJ-GUESS state offline. -## The idea id of course to use the output from the analysis step from an SDA routine to provide the nudged values, although that isn't -## relevant to the following code. -## -## Since the original C++ code took as its only argument an LPJ-GUESS C++ class of type 'Individual' there was no way (to my knowledge) -## of directly compiling using Rcpp (unlike for allocation.cpp/allocation.R. which was easy to compile from the native C++ using -## Rcpp with very few changes). -## -## As noted in the original function header taken from the the C++ code below, this function should be run after its biomass values -## have been updated. In this case that means after the allocation() function has been applied to an individual. -## -## This function can return FALSE for following reasons: -## 1. The individual has negligible leaf biomass. -## 2. The -## + ## -## In LPJ-GUESS this individual would be killed as a result of any of these happening. -## What to do in such a case with SDA in PEcAn is not immediately clear. +## In LPJ-GUESS this individual would be killed as a result of any of these happening. So instead PEcAn should +## modify the ratio of nudged biomass and density and try again. + +########################################### +# // ALLOMETRY +# // Should be called to update allometry, FPC and FPC increment whenever biomass values +# // for a vegetation individual (cohort) change. + #' LPJ-GUESS allometry +#' +#' The LPJ-GUESS allometry function transcribed into R. #' +#' @param lifeform An integer code for the lifeform of this individual (cohort): 1 = Tree, 2 = Grass +#' @param cmass_leaf The leaf C pool size (kgC/m^2) +#' @param cmass_sap The sapwood C pool size (kgC/m^2) +#' @param cmass_heart The heartwood C pool size (kgC/m^2) +#' @param densindiv The density of individuals in the cohort (indiv/m^2) +#' @param age The age of the coort +#' @param fpc The folar projective cover +#' @param deltafpc The change in foliar projective cover +#' @param sla The SLA (specific leaf area) (per PFT parameter) +#' @param k_latosa The leaf area to sapwood area ratio (per PFT parameter) +#' @param k_rp,k_allom1,k_allom2,k_allom3, Allometry coefficients (per PFT parameters) +#' @param wooddens Wood density (kgC/m^2) (per PFT parameter) +#' @param crownarea_max Maximum allowed crown area (m^2) (per PFT parameter) +#' +#' This function was transcribed from LPJ-GUESS (v4.0) C++ to R for the purpose of nudging the LPJ-GUESS state offline. +#' The idea is of course to use the output from the analysis step from an SDA routine to provide the nudged values, although that isn't +#' relevant to the following code. #' +#' Since the original C++ code took as its only argument an LPJ-GUESS C++ class of type 'Individual' there was no way (to my knowledge) +#' of directly compiling using Rcpp (unlike for allocation.cpp/allocation.R. which was easy to compile from the native C++ using +#' Rcpp with very few changes). #' +#' As noted in the original function header taken from the the C++ code (copied above), this function should be run after its biomass values +#' have been updated. In this case that means after the allocation() function has been applied to an individual. +#' +#' This function can return following error codes: +#' 1. "NegligibleLeafMass" - The individual has negligible leaf biomass. +#' 2. "MaxHeightExceeded" - The indidual exceeds the maximum allowed height +#' 3. "LowWoodDensity" - The individual's *actual* wood density drops below 90% of prescribed value. This (slighty weird +#' and unphysical) requirement is necessary because sometimes LPJ-GUESS can take carbon from the heartwood to +#' ensure C-balance. I think. Or some other hockery-pockery. +#' +#' If all is well the code is simply "OK". #' #' @keywords internal +#' @return A named list of updated state variables for the individual/cohort. The first value in the list is the error code. +#' @author Matthew Forrest #' - -###########################################/ -# ALLOMETRY -# Should be called to update allometry, FPC and FPC increment whenever biomass values -# for a vegetation individual change. allometry <- function( # initial allometry/pools lifeform, @@ -254,9 +276,7 @@ allometry <- function( return( list( error.string = error.string, - vol = vol, height = height, - diam =diam, crownarea = crownarea, lai_indiv = lai_indiv, lai = lai, diff --git a/models/lpjguess/R/updateState.LPJGUESS.R b/models/lpjguess/R/updateState.LPJGUESS.R index 44b6dbf40c9..f64801c611c 100644 --- a/models/lpjguess/R/updateState.LPJGUESS.R +++ b/models/lpjguess/R/updateState.LPJGUESS.R @@ -142,9 +142,9 @@ updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, cmass.i exceeds_cmass <- updated.list[["exceeds_cmass"]] rm(updated.list) - # STEP 3 - adjust the allometry of the individual based on the updated pools - # QUESTION: what to do if allometry returns FALSE? + # STEP 3 - calculate the new allometry of the individual based on the updated pools + allometry.results <- allometry( # initial allometry/pools cmass_leaf = updated.individual$cmass_leaf, @@ -165,40 +165,57 @@ updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, cmass.i wooddens = wooddens[this.pft.id+1], crownarea_max = crownarea_max[this.pft.id+1]) + + # STEP 4 - check if new allometry is valid. If yes, update state and move on, + # if not adjust the nudging and start again + # if not okay print a warning, and should actually start another iteration with new multipliers if(allometry.results$error.string != "OK") { print(allometry.results$error.string) + + # HERE + + } - # else update the individual, the litter pools, exceeds_cmass and break + # else update the allometry, save the individual back to the state, update the litter pools, + # deal with exceeds_cmass and finally break else { - # first the individual + + # first update the allometry + updated.individual$height <- allometry.results$height + updated.individual$crownarea <- allometry.results$crownarea + updated.individual$lai_indiv <- allometry.results$lai_indiv + updated.individual$lai <- allometry.results$lai + updated.individual$deltafpc <- allometry.results$deltafpc + updated.individual$fpc <- allometry.results$fpc + updated.individual$boleht <- allometry.results$boleht + + # save the individual back to the state model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]] <- updated.individual # now the litter pools (determine N based on intial C:N ratio) # C:N ratios leaf_litter_cton <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_leaf[[this.pft.id+1]] / model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$nmass_litter_leaf[[this.pft.id+1]] root_litter_cton <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_root[[this.pft.id+1]] / model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$nmass_litter_root[[this.pft.id+1]] - # update the C pools based on the calculated increments + # update the C pools based on the calculated increments from the allocation call (these will only be non-zero in 'abnormal cases) model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_leaf[[this.pft.id+1]] <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_leaf[[this.pft.id+1]] + (litter_leaf_inc * updated.individual$densindiv) model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_root[[this.pft.id+1]] <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_root[[this.pft.id+1]] + (litter_root_inc * updated.individual$densindiv) # update the N pools simple by dividing the new C pool by the C:N ratio model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$nmass_litter_leaf[[this.pft.id+1]] <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_leaf[[this.pft.id+1]] / leaf_litter_cton model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$nmass_litter_root[[this.pft.id+1]] <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_root[[this.pft.id+1]] / root_litter_cton - - # and finally exceeds_cmass - # - not currently dealing with this because it is only used to maintin mass balance which + + # and finally exceeds_cmass - not currently dealing with this because it is only used to maintin mass balance which # we *probably* don't need to do here, but print a warning if it is non-zero if(!exceeds_cmass == 0) warning(paste("Non-zero exceeds_cmass following allocation, exceeds_cmass =", exceeds_cmass)) - } - + } # if allometry valid - } + } # if individual is alive - } + } # for each individual - } + } # for each patch } # for each stand diff --git a/models/lpjguess/man/adjustDensity.LPJGUESS.Rd b/models/lpjguess/man/adjustDensity.LPJGUESS.Rd new file mode 100644 index 00000000000..5df6681e612 --- /dev/null +++ b/models/lpjguess/man/adjustDensity.LPJGUESS.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/adjustDensity.LPJGUESS.R +\name{adjustDensity.LPJGUESS} +\alias{adjustDensity.LPJGUESS} +\title{Adjust LPJ-GUESS individual's density} +\usage{ +adjustDensity.LPJGUESS(individual, rel.change) +} +\arguments{ +\item{individual}{A nested list which encapsulates an LPJ-GUESS 'Individual' as read from a binary state file} + +\item{rel.change}{A numeric by which to scale the density and C and N pools} +} +\value{ +the scaled 'individual' (the initial nested list with update values) +} +\description{ +Very simple function that just scales the density of individuals and the associated C and N pools +by a relative amount +} +\author{ +Matthew Forrest +} +\keyword{internal} diff --git a/models/lpjguess/man/allometry.Rd b/models/lpjguess/man/allometry.Rd index cb561f2647a..4a572e4e611 100644 --- a/models/lpjguess/man/allometry.Rd +++ b/models/lpjguess/man/allometry.Rd @@ -8,7 +8,60 @@ allometry(lifeform, cmass_leaf, cmass_sap, cmass_heart, densindiv, age, fpc, deltafpc, sla, k_latosa, k_rp, k_allom1, k_allom2, k_allom3, wooddens, crownarea_max) } +\arguments{ +\item{lifeform}{An integer code for the lifeform of this individual (cohort): 1 = Tree, 2 = Grass} + +\item{cmass_leaf}{The leaf C pool size (kgC/m^2)} + +\item{cmass_sap}{The sapwood C pool size (kgC/m^2)} + +\item{cmass_heart}{The heartwood C pool size (kgC/m^2)} + +\item{densindiv}{The density of individuals in the cohort (indiv/m^2)} + +\item{age}{The age of the coort} + +\item{fpc}{The folar projective cover} + +\item{deltafpc}{The change in foliar projective cover} + +\item{sla}{The SLA (specific leaf area) (per PFT parameter)} + +\item{k_latosa}{The leaf area to sapwood area ratio (per PFT parameter)} + +\item{k_rp, k_allom1, k_allom2, k_allom3, }{Allometry coefficients (per PFT parameters)} + +\item{wooddens}{Wood density (kgC/m^2) (per PFT parameter)} + +\item{crownarea_max}{Maximum allowed crown area (m^2) (per PFT parameter) + +This function was transcribed from LPJ-GUESS (v4.0) C++ to R for the purpose of nudging the LPJ-GUESS state offline. +The idea is of course to use the output from the analysis step from an SDA routine to provide the nudged values, although that isn't +relevant to the following code. + +Since the original C++ code took as its only argument an LPJ-GUESS C++ class of type 'Individual' there was no way (to my knowledge) +of directly compiling using Rcpp (unlike for allocation.cpp/allocation.R. which was easy to compile from the native C++ using +Rcpp with very few changes). + +As noted in the original function header taken from the the C++ code (copied above), this function should be run after its biomass values +have been updated. In this case that means after the allocation() function has been applied to an individual. + +This function can return following error codes: + 1. "NegligibleLeafMass" - The individual has negligible leaf biomass. + 2. "MaxHeightExceeded" - The indidual exceeds the maximum allowed height + 3. "LowWoodDensity" - The individual's *actual* wood density drops below 90% of prescribed value. This (slighty weird + and unphysical) requirement is necessary because sometimes LPJ-GUESS can take carbon from the heartwood to + ensure C-balance. I think. Or some other hockery-pockery. + + If all is well the code is simply "OK".} +} +\value{ +A named list of updated state variables for the individual/cohort. The first value in the list is the error code. +} \description{ -LPJ-GUESS allometry +The LPJ-GUESS allometry function transcribed into R. +} +\author{ +Matthew Forrest } \keyword{internal} diff --git a/models/lpjguess/man/updateState.LPJGUESS.Rd b/models/lpjguess/man/updateState.LPJGUESS.Rd index 5c7c0e598a7..ec6a8ed5186 100644 --- a/models/lpjguess/man/updateState.LPJGUESS.Rd +++ b/models/lpjguess/man/updateState.LPJGUESS.Rd @@ -4,8 +4,8 @@ \alias{updateState.LPJGUESS} \title{updateState.LPJGUESS} \usage{ -updateState.LPJGUESS(model.state, dens.initial, dens.target, - biomass.initial, biomass.target) +updateState.LPJGUESS(model.state, dens.initial, dens.target, cmass.initial, + cmass.target) } \arguments{ \item{model.state}{A large multiply-nested list containing the entire LPJ-GUESS state as read by @@ -19,11 +19,11 @@ using state data assimilation from function XXXXXX.} with one entry per PFT/species, with the names being the PFT/species codes. These values should be produced using state data assimilation from function XXXXXX} -\item{biomass.target}{A numeric vector of the target stand-level biomasses (kgC/m^2) as named numeric vector +\item{cmass.target}{A numeric vector of the target stand-level biomasses (kgC/m^2) as named numeric vector with one entry per PFT/species, with the names being the PFT/species codes. These values should be produced using state data assimilation from function XXXXXX} -\item{biomass.target}{A numeric vector of the target stand-level biomasses (kgC/m^2) as named numeric vector +\item{cmass.target}{A numeric vector of the target stand-level biomasses (kgC/m^2) as named numeric vector with one entry per PFT/species, with the names being the PFT/species codes. These values should be produced using state data assimilation from function XXXXXX} } From 6fdb02b9f09e04f8e12f0dcbe0dc27737eb681a9 Mon Sep 17 00:00:00 2001 From: istfer Date: Fri, 21 Jun 2019 17:45:32 -0400 Subject: [PATCH 42/56] modifying function for PalEON version --- models/lpjguess/R/read_state.R | 168 ++++++++++++++++++++++----------- 1 file changed, 113 insertions(+), 55 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index 56295b4e257..ee3e0f26c3b 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -77,7 +77,12 @@ serialize_starts_ends <- function(file_in, pattern = "void Gridcell::serialize") # find the starting line from the given pattern starting_line <- which(!is.na(str_match(file_in, pattern))) if(length(starting_line) != 1){ # check what's going on - PEcAn.logger::logger.severe("Couldn't find the starting line with this pattern ***",pattern, "***.") + # new versions serialize structs too + pattern <- gsub("class", "struct", pattern) + starting_line <- which(!is.na(str_match(file_in, pattern))) + if(length(starting_line) != 1){ + PEcAn.logger::logger.severe("Couldn't find the starting line with this pattern ***", pattern, "***.") + } } # screen for the closing curly bracket after function started @@ -139,7 +144,9 @@ find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LP # this is only length 1 specs$n <- 1 specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + specs$what <- unique(specs$what) specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + specs$size <- unique(specs$size) specs$single <- TRUE }else if(current_stream_type$type == "Historic"){ @@ -148,29 +155,66 @@ find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LP # Historic types are special to LPJ-GUESS # They have stored values, current index, and a boolean in that order - specs$n <- specs$what <- specs$size <- specs$names <- rep(NA, 3) - # always three, this is a type defined in guessmath.h - specs$what[1] <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$size[1] <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$names[1] <- current_stream_type$name - # n is tricky, it can be hardcoded it can be one of the const ints - to_read <- str_match(sub_string, paste0("Historic<", specs$what[1], ", (.*?)>.*"))[,2] - if(to_read %in% LPJ_GUESS_CONST_INTS$var){ - specs$n <- LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var == to_read] - }else{ - specs$n[1] <- as.numeric(to_read) + + #is there a following bracket? + if(grepl("\\[*\\]", sub_string)){ # e.g. "Historic hmtemp_20[12];" + to_read <- str_match(sub_string, paste0("Historic.*"))[,2] + if(to_read %in% LPJ_GUESS_CONST_INTS$var){ + nvar <- LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var == to_read] + }else{ + nvar <- as.numeric(to_read) + } + + ntimes <- as.numeric(str_match(sub_string, paste0("Historic<.*>.*\\[(.*?)\\]"))[,2]) + + specs <- vector("list", ntimes) + for(specs.i in seq_len(ntimes)){ + specs[[specs.i]] <- list() + if(specs.i %% 3 == 1){ + specs[[specs.i]]$what <- "double" + specs[[specs.i]]$n <- 20 + specs[[specs.i]]$size <- 8 + }else if(specs.i %% 3 == 2){ + specs[[specs.i]]$what <- "integer" + specs[[specs.i]]$n <- 1 + specs[[specs.i]]$size <- 8 + }else if(specs.i %% 3 == 0){ + specs[[specs.i]]$what <- "logical" + specs[[specs.i]]$n <- 1 + specs[[specs.i]]$size <- 8 + } + + } + specs$name <- current_stream_type$name + specs$single <- FALSE + }else{ # e.g. "Historic deet_31;" + + specs$n <- specs$what <- specs$size <- specs$names <- rep(NA, 3) + # always three, this is a type defined in guessmath.h + specs$what[1] <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + specs$size[1] <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + specs$names[1] <- current_stream_type$name + # n is tricky, it can be hardcoded it can be one of the const ints + to_read <- str_match(sub_string, paste0("Historic<", specs$what[1], ", (.*?)>.*"))[,2] + if(to_read %in% LPJ_GUESS_CONST_INTS$var){ + specs$n <- LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var == to_read] + }else{ + specs$n[1] <- as.numeric(to_read) + } + specs$what[2] <- "integer" #need to check what size_t is + specs$size[2] <- 8 + specs$n[2] <- 1 + specs$names[2] <- "current_index" + + specs$what[3] <- "logical" + specs$size[3] <- 1 + specs$n[3] <- 1 + specs$names[3] <- "full" + + specs$single <- FALSE } - specs$what[2] <- "integer" #need to check what size_t is - specs$size[2] <- 8 - specs$n[2] <- 1 - specs$names[2] <- "current_index" - - specs$what[3] <- "logical" - specs$size[3] <- 1 - specs$n[3] <- 1 - specs$names[3] <- "full" - - specs$single <- FALSE + + }else if(current_stream_type$type == "struct"){ if(current_stream_type$name != "solvesom"){ @@ -238,15 +282,16 @@ find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES return(list(type = "int", name = "nstands", substring = "int nstands;")) #there is not substring like that in guess.h } - if(current_stream_var == "landcover"){ # a bit of a special case - return(list(type = "landcovertype", name = "landcover", substring = "landcovertype landcover;")) - } + # This is an older version thing!!! + # if(current_stream_var == "landcover"){ # a bit of a special case + # return(list(type = "landcovertype", name = "landcover", substring = "landcovertype landcover;")) + # } # it might be difficult to extract the "type" before the varname # there are not that many to check possible_types <- c("class ", "double ", "bool ", "int ") - possible_types <- c(possible_types, LPJ_GUESS_TYPES) + possible_types <- c(possible_types, paste0(LPJ_GUESS_TYPES, " ")) beg_end <- NULL # not going to need it always @@ -316,6 +361,14 @@ find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES stream_name <- current_stream_var }else{ stream_type <- possible_types[sapply(possible_types, grepl, sub_string, fixed = TRUE)] + if(length(stream_type) == 2){ # one string nested in the other? + # try the longer + if(grepl(stream_type[which.max(nchar(stream_type))], sub_string, fixed = TRUE)){ + stream_type <- stream_type[which.max(nchar(stream_type))] + } + }else if(length(stream_type) > 2){ # haven't seen anything like that yet + PEcAn.logger::logger.severe("Check this out.") + } stream_name <- current_stream_var } @@ -349,7 +402,7 @@ library(stringr) # test path -outdir <- "/fs/data2/output/PEcAn_1000010473/out/1002655714" +outdir <- "/fs/data2/output/PEcAn_1000010473/out/1002656304" # outdir, at least model version, maybe also settings read_binary_LPJGUESS <- function(outdir, version = "PalEON"){ @@ -369,6 +422,10 @@ guessh_in <- readLines(con = system.file(guessh_name, package = "PEcAn.LPJGUES paramh_name <- paste0("parameters.", version, ".h") paramh_in <- readLines(con = system.file(paramh_name, package = "PEcAn.LPJGUESS"), n = -1) +### these are the values read from params.ins, passed to this fcn +paramsins <- readLines(file.path(rundir, "params.ins"), n = -1) +npatches <- as.numeric(gsub(".*([0-9]+).*$", "\\1", paramsins[grepl("npatch", paramsins, fixed = TRUE)])) + ###################################### ## read meta.bin @@ -397,9 +454,6 @@ if(meta_data$num_processes == 1){ } -### these are the values read from params.ins, passed to this fcn -paramsins <- readLines(file.path(rundir, "params.ins"), n = -1) -npatches <- as.numeric(gsub(".*([0-9]+).*$", "\\1", paramsins[grepl("npatch", paramsins, fixed = TRUE)])) ################################ CHECKS AND EXTRACTIONS ################################ @@ -412,13 +466,9 @@ LPJ_GUESS_CLASSES <- c("Gridcell", "Climate", "Gridcellpft", "Stand", "Standpft" lpjguess_classes <- list() ctr <- 1 # NOTE THAT THESE PATTERNS ASSUME SOME CODING STYLE, thanks to LPJ-GUESS developers this might not be an issue in the future -for(i in seq_along(guessh_in)){ +for(i in seq_along(guesscpp_in)){ # search for "class XXX : public Serializable {" - res <- str_match(guessh_in[i], "class (.*?) : public Serializable") - if(is.na(res[,2])){ - # try "class XXX : public ..., public Serializable {" pattern - res <- str_match(guessh_in[i], "class (.*?) : public .* Serializable") - } + res <- str_match(guesscpp_in[i], "void (.*?)::serialize\\(ArchiveStream\\& arch\\)") if(!is.na(res[,2])){ lpjguess_classes[[ctr]] <- res[,2] ctr <- ctr + 1 @@ -519,8 +569,12 @@ streamed_vars_gridcell <- find_stream_var(file_in = guesscpp_in, line_nos = beg_ # there will be nested loops, the hierarchy will follow LPJ-GUESS architecture Gridcell <- list() level <- "Gridcell" -for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts +for(g_i in 1:4){#seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts + ## SOMETHING IS OFFF AT Gridcellpft current_stream <- streamed_vars_gridcell[g_i] + # hackkkk, only one stand + if(current_stream == "st[i]") current_stream <- "Gridcellst" + if(current_stream == "balance") current_stream <- "MassBalance" #not sure how to make this name matching otherwise if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard if(grepl(glob2rx("(*this)[*].landcover"), current_stream)){ # s counter might change, using wildcard # not sure how to handle this better. If we see this, it means we are now looping over Stands @@ -927,32 +981,36 @@ for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts for(pft_i in seq_len(num_pft)){ for(sv_i in seq_along(streamed_vars)){ - #for(sv_i in 21:37){ current_stream <- streamed_vars[sv_i] #it's OK to overwrite current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - if(current_stream_type$type == "class"){ - - # CLASS, NOT EVER GOING HERE? - class_name <- current_stream_type$name - + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) + # and read! + if(current_stream_specs$single){ + Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + }else if(current_stream_specs$name %in% c("hmtemp_20", "hmprec_20", "hmeet_20")){ + # these three are just too different, maybe extract their names in the beginning + # be careful while writing back to the binary + Gridcell[[length(Gridcell)]][[current_stream_type$name]] <- readBin(con = zz, double(), 264, 8) + # Gridcell[[length(Gridcell)]][[current_stream_type$name]] <- vector("list", length(current_stream_specs) - 2) + # for(css.i in seq_len(length(current_stream_specs) - 2)){ + # Gridcell[[length(Gridcell)]][[current_stream_type$name]][[css.i]] <- readBin(con = zz, + # what = current_stream_specs[[css.i]]$what, + # n = current_stream_specs[[css.i]]$n, + # size = current_stream_specs[[css.i]]$size) + #} }else{ - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - # and read! - if(current_stream_specs$single){ - Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ - for(css.i in seq_along(current_stream_specs$what)){ - Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, + for(css.i in seq_along(current_stream_specs$what)){ + Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, what = current_stream_specs$what[css.i], n = current_stream_specs$n[css.i], size = current_stream_specs$size[css.i]) - } } } + } # streamed_vars-loop ends } # pft-loop ends From c86b1a3b8a533c17bbc2aa21dcec7b2d25d5159b Mon Sep 17 00:00:00 2001 From: istfer Date: Sat, 22 Jun 2019 15:03:16 -0400 Subject: [PATCH 43/56] read new PhotosynthesisResults --- models/lpjguess/R/read_state.R | 97 +++++++++++++++++++++++++--------- 1 file changed, 71 insertions(+), 26 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index c83dfa4fb63..6e4730641f3 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -568,11 +568,10 @@ streamed_vars_gridcell <- find_stream_var(file_in = guesscpp_in, line_nos = beg_ # there will be nested loops, the hierarchy will follow LPJ-GUESS architecture Gridcell <- list() level <- "Gridcell" -for(g_i in 1:4){#seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts - ## SOMETHING IS OFFF AT Gridcellpft +for(g_i in 1:8){#seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts current_stream <- streamed_vars_gridcell[g_i] - # hackkkk, only one stand - if(current_stream == "st[i]") current_stream <- "Gridcellst" + # weird, it doesn't go into Gridcell st + if(current_stream == "st[i]") next #current_stream <- "Gridcellst" if(current_stream == "balance") current_stream <- "MassBalance" #not sure how to make this name matching otherwise if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard if(grepl(glob2rx("(*this)[*].landcover"), current_stream)){ # s counter might change, using wildcard @@ -581,12 +580,12 @@ for(g_i in 1:4){#seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts # this is an integer that tells us which landcover type this stand is # so it should be the indice of NATURAL in typedef enum landcovertype (I believe indexing starts from 0) - num_stnd <- as.numeric(Gridcell$nstands) - Gridcell[["Stand"]] <- vector("list", num_stnd) - # note that this is streamed under Gridcell, not Stand in guess.cpp, # but I think this info needs to go together with the Stand sublist - # so prepend landcovertype to the streamed_vars_stand + # so prepend landcovertype to the streamed_vars_stand EDIT: I'll actually just read it here + Gridcell[["Stand"]][["landcovertype"]] <- readBin(zz, what = integer(), n = 1, size = 4) + num_stnd <- as.numeric(Gridcell$nstands) + Gridcell[["Stand"]] <- vector("list", num_stnd) next } @@ -604,11 +603,12 @@ for(g_i in 1:4){#seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts tools::toTitleCase(current_stream_type$name), "::serialize")) streamed_vars_stand <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - streamed_vars_stand <- c("landcover", streamed_vars_stand) # prepending landcovertype to the streamed_vars_stand + # this was previous version + # streamed_vars_stand <- c("landcover", streamed_vars_stand) # prepending landcovertype to the streamed_vars_stand for(stnd_i in seq_len(num_stnd)){ #looping over the stands - for(svs_i in seq_along(streamed_vars_stand)){ # looping over the streamed stand vars + for(svs_i in 1:2){#seq_along(streamed_vars_stand)){ # looping over the streamed stand vars current_stream <- streamed_vars_stand[svs_i] if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard @@ -643,7 +643,7 @@ for(g_i in 1:4){#seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts Gridcell[["Stand"]][[stnd_i]][["Patch"]] <- vector("list", npatches) for(ptch_i in seq_len(npatches)){ #looping over the patches - for(svp_i in seq_along(streamed_vars_patch)){ #looping over the streamed patch vars + for(svp_i in 1){#seq_along(streamed_vars_patch)){ #looping over the streamed patch vars current_stream <- streamed_vars_patch[svp_i] if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard @@ -689,12 +689,16 @@ for(g_i in 1:4){#seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts # if number of individuals is 0 it's a bit suspicious. Not sure if ever will get negative but that'd definitely be wrong PEcAn.logger::logger.warn("Number of individuals under vegetation is", number_of_individuals) } + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]] <- list() Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]] <- vector("list", number_of_individuals) beg_end <- serialize_starts_ends(file_in = guesscpp_in, pattern = paste0("void Individual::serialize")) streamed_vars_indv <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + # NO CROPS + if("*cropindiv" %in% streamed_vars_indv) streamed_vars_indv <- streamed_vars_indv[!(streamed_vars_indv == "*cropindiv")] + # loop over nobj for(indv_i in seq_len(number_of_individuals)){ Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]] <- list() @@ -702,25 +706,64 @@ for(g_i in 1:4){#seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][["indiv.pft.id"]] <- readBin(zz, integer(), 1, size = 4) # read all the individual class for(svi_i in seq_along(streamed_vars_indv)){ # - current_stream <- streamed_vars_indv[svi_i] - - current_stream_type <- find_stream_type("individual", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - if(current_stream_specs$single){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][[current_stream_type$name]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) + current_stream <- streamed_vars_indv[svi_i] + if(current_stream == "photosynthesis") current_stream <- "PhotosynthesisResult" + + if(tools::toTitleCase(current_stream) %in% LPJ_GUESS_CLASSES){ + current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + }else{ + # Only Individual class under Vegetation + current_stream_type <- find_stream_type("Individual", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + } + + if(current_stream_type$type == "class"){ + + if(current_stream_type$name != "PhotosynthesisResult"){ + PEcAn.logger::logger.debug("Classes other than PhotosynthesisResult enter here.") + } + # ONLY PhotosynthesisResult HERE SO FAR ****************************************************************** + beg_end <- serialize_starts_ends(file_in = guesscpp_in, + pattern = paste0("void ", + tools::toTitleCase(current_stream_type$name), + "::serialize")) + streamed_vars_photo <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][["PhotosynthesisResult"]] <- list() + for(photo_i in seq_along(streamed_vars_photo)){ + current_stream <- streamed_vars_photo[photo_i] #it's OK to overwrite + current_stream_type <- find_stream_type("PhotosynthesisResult", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) + # and read! + + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][["PhotosynthesisResult"]][[current_stream_type$name]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + + }# streamed_vars_photo-loop ends + }else{ - for(css.i in seq_along(current_stream_specs$what)){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, - what = current_stream_specs$what[css.i], - n = current_stream_specs$n[css.i], - size = current_stream_specs$size[css.i]) + + + current_stream_type <- find_stream_type("individual", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) + + if(current_stream_specs$single){ + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][[current_stream_type$name]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + }else{ + for(css.i in seq_along(current_stream_specs$what)){ + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, + what = current_stream_specs$what[css.i], + n = current_stream_specs$n[css.i], + size = current_stream_specs$size[css.i]) + } } } - }# end loop over stream vars individual } # end loop over number_of_individuals @@ -771,6 +814,8 @@ for(g_i in 1:4){#seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts }else{ # NOT VEGETATION OR FLUX streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + # NO CROPS, NATURAL VEG + if("*cropphen" %in% streamed_vars) streamed_vars <- streamed_vars[!(streamed_vars == "*cropphen")] num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) for(varname in streamed_vars){ From ecc6faf67ffb343973560f698e6e9355dac0cb6b Mon Sep 17 00:00:00 2001 From: istfer Date: Mon, 24 Jun 2019 13:34:53 -0400 Subject: [PATCH 44/56] updates for the new model version, first pass finished --- models/lpjguess/R/read_state.R | 1234 ++++++++++++++++---------------- 1 file changed, 619 insertions(+), 615 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index 6e4730641f3..69ebc0aeb05 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -166,8 +166,8 @@ find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LP ntimes <- as.numeric(str_match(sub_string, paste0("Historic<.*>.*\\[(.*?)\\]"))[,2]) - specs <- vector("list", ntimes) - for(specs.i in seq_len(ntimes)){ + specs <- vector("list", 3*ntimes) + for(specs.i in seq_along(specs)){ specs[[specs.i]] <- list() if(specs.i %% 3 == 1){ specs[[specs.i]]$what <- "double" @@ -281,10 +281,10 @@ find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES return(list(type = "int", name = "nstands", substring = "int nstands;")) #there is not substring like that in guess.h } - # This is an older version thing!!! - # if(current_stream_var == "landcover"){ # a bit of a special case - # return(list(type = "landcovertype", name = "landcover", substring = "landcovertype landcover;")) - # } + # "landcover" differs from version to version + if(current_stream_var == "landcover" && !is.null(class)){ # a bit of a special case + return(list(type = "landcovertype", name = "landcover", substring = "landcovertype landcover;")) + } # it might be difficult to extract the "type" before the varname # there are not that many to check @@ -406,679 +406,683 @@ outdir <- "/fs/data2/output/PEcAn_1000010473/out/1002656304" # outdir, at least model version, maybe also settings read_binary_LPJGUESS <- function(outdir, version = "PalEON"){ -} - -# find rundir too, params.ins is in there and we need to get some values from there -rundir <- file.path(dirname(dirname(outdir)), "run", basename(outdir)) - -# guess.cpp has the info of what is being written -guesscpp_name <- paste0("guess.", version, ".cpp") # these are gonna be in the package guess.VERSION.cpp -guesscpp_in <- readLines(con = system.file(guesscpp_name, package = "PEcAn.LPJGUESS"), n = -1) -# guess.h has the types so that we know what streamsize to read -guessh_name <- paste0("guess.", version, ".h") -guessh_in <- readLines(con = system.file(guessh_name, package = "PEcAn.LPJGUESS"), n = -1) -# parameters.h has some more types -paramh_name <- paste0("parameters.", version, ".h") -paramh_in <- readLines(con = system.file(paramh_name, package = "PEcAn.LPJGUESS"), n = -1) - -### these are the values read from params.ins, passed to this fcn -paramsins <- readLines(file.path(rundir, "params.ins"), n = -1) -npatches <- as.numeric(gsub(".*([0-9]+).*$", "\\1", paramsins[grepl("npatch", paramsins, fixed = TRUE)])) - - -###################################### -## read meta.bin -# not sure if the content will change under guessserializer.cpp -meta_data <- list() -meta_bin_con <- file(file.path(outdir, "meta.bin"), "rb") -meta_data$num_processes <- readBin(meta_bin_con, integer(), 1, size = 4) -meta_data$vegmode <- readBin(meta_bin_con, integer(), 1, size = 4) -meta_data$npft <- readBin(meta_bin_con, integer(), 1, size = 4) -meta_data$pft <- list() -for(i in seq_len(meta_data$npft)){ - char_len <- readBin(meta_bin_con, integer(), 1, size = 8) - meta_data$pft[[i]] <- readChar(meta_bin_con, char_len) -} -close(meta_bin_con) - -# how many PFTs are there in this run -n_pft <- meta_data$npft - -# open connection to the binary state file -if(meta_data$num_processes == 1){ - zz <- file(file.path(outdir,"0.state"), "rb") -}else{ - # then file names would be different 1.state etc etc - PEcAn.logger::logger.severe("This function is implemented to read state from 1 process only.") -} - - - - -################################ CHECKS AND EXTRACTIONS ################################ - -# between model versions we don't expect major classes or hierarchy to change -# but give check and fail if necessary -LPJ_GUESS_CLASSES <- c("Gridcell", "Climate", "Gridcellpft", "Stand", "Standpft", "Patch", "Patchpft", - "Individual", "Soil", "Sompool", "Fluxes", "Vegetation") - -lpjguess_classes <- list() -ctr <- 1 -# NOTE THAT THESE PATTERNS ASSUME SOME CODING STYLE, thanks to LPJ-GUESS developers this might not be an issue in the future -for(i in seq_along(guesscpp_in)){ - # search for "class XXX : public Serializable {" - res <- str_match(guesscpp_in[i], "void (.*?)::serialize\\(ArchiveStream\\& arch\\)") - if(!is.na(res[,2])){ - lpjguess_classes[[ctr]] <- res[,2] - ctr <- ctr + 1 + # find rundir too, params.ins is in there and we need to get some values from there + rundir <- file.path(dirname(dirname(outdir)), "run", basename(outdir)) + + # guess.cpp has the info of what is being written + guesscpp_name <- paste0("guess.", version, ".cpp") # these are gonna be in the package guess.VERSION.cpp + guesscpp_in <- readLines(con = system.file(guesscpp_name, package = "PEcAn.LPJGUESS"), n = -1) + # guess.h has the types so that we know what streamsize to read + guessh_name <- paste0("guess.", version, ".h") + guessh_in <- readLines(con = system.file(guessh_name, package = "PEcAn.LPJGUESS"), n = -1) + # parameters.h has some more types + paramh_name <- paste0("parameters.", version, ".h") + paramh_in <- readLines(con = system.file(paramh_name, package = "PEcAn.LPJGUESS"), n = -1) + + ### these are the values read from params.ins, passed to this fcn + paramsins <- readLines(file.path(rundir, "params.ins"), n = -1) + npatches <- as.numeric(gsub(".*([0-9]+).*$", "\\1", paramsins[grepl("npatch", paramsins, fixed = TRUE)])) + + + ###################################### + ## read meta.bin + # not sure if the content will change under guessserializer.cpp + meta_data <- list() + meta_bin_con <- file(file.path(outdir, "meta.bin"), "rb") + meta_data$num_processes <- readBin(meta_bin_con, integer(), 1, size = 4) + meta_data$vegmode <- readBin(meta_bin_con, integer(), 1, size = 4) + meta_data$npft <- readBin(meta_bin_con, integer(), 1, size = 4) + meta_data$pft <- list() + for(i in seq_len(meta_data$npft)){ + char_len <- readBin(meta_bin_con, integer(), 1, size = 8) + meta_data$pft[[i]] <- readChar(meta_bin_con, char_len) } -} - -# all match? -if(!setequal(unlist(lpjguess_classes), LPJ_GUESS_CLASSES)){ - PEcAn.logger::logger.severe("This function can only read the following class objects: ", paste(LPJ_GUESS_CLASSES, collapse="--")) -} - -# there are couple of LPJ-GUESS specific types that we'll need below -lpjguess_types <- list() -ctr <- 1 -for(i in seq_along(guessh_in)){ - if(grepl("typedef enum {", guessh_in[i], fixed = TRUE)){ - this_line <- find_closing("}", i, guessh_in) - l_type <- gsub(".*}(.*?);.*", "\\1", guessh_in[this_line]) - l_type <- gsub(" ", "", l_type) - lpjguess_types[[ctr]] <- l_type - ctr <- ctr + 1 + close(meta_bin_con) + + # how many PFTs are there in this run + n_pft <- meta_data$npft + + # open connection to the binary state file + if(meta_data$num_processes == 1){ + zz <- file(file.path(outdir,"0.state"), "rb") + }else{ + # then file names would be different 1.state etc etc + PEcAn.logger::logger.severe("This function is implemented to read state from 1 process only.") } -} -for(i in seq_along(paramh_in)){ #do same for parameters.h - if(grepl("typedef enum {", paramh_in[i], fixed = TRUE)){ - this_line <- find_closing("}", i, paramh_in) - l_type <- gsub(".*}(.*?);.*", "\\1", paramh_in[this_line]) - l_type <- gsub(" ", "", l_type) - lpjguess_types[[ctr]] <- l_type - ctr <- ctr + 1 + + + + + ################################ CHECKS AND EXTRACTIONS ################################ + + # between model versions we don't expect major classes or hierarchy to change + # but give check and fail if necessary + LPJ_GUESS_CLASSES <- c("Gridcell", "Climate", "Gridcellpft", "Gridcellst", "Stand", "Standpft", "Patch", "Patchpft", + "Individual", "Soil", "Sompool", "Fluxes", "Vegetation", "PhotosynthesisResult", "LitterSolveSOM", + "Landcover", "MassBalance") + + lpjguess_classes <- list() + ctr <- 1 + # NOTE THAT THESE PATTERNS ASSUME SOME CODING STYLE, thanks to LPJ-GUESS developers this might not be an issue in the future + for(i in seq_along(guesscpp_in)){ + # search for "class XXX : public Serializable {" + res <- str_match(guesscpp_in[i], "void (.*?)::serialize\\(ArchiveStream\\& arch\\)") + if(!is.na(res[,2]) && !(res[,2] %in% c("cropindiv_struct", "cropphen_struct"))){ # no crops for now + lpjguess_classes[[ctr]] <- res[,2] + ctr <- ctr + 1 + } } -} -LPJ_GUESS_TYPES <- unlist(lpjguess_types) - - -lpjguess_consts <- list() -ctr <- 1 -for(i in seq_along(guessh_in)){ - if(grepl("const int ", guessh_in[i], fixed = TRUE)){ # probably won't need "const double"s - cnst_val <- gsub(".*=(.*?);.*", "\\1", guessh_in[i]) - cnst_val <- gsub(" ", "", cnst_val) # get rid of the space if there is one - cnst_nam <- gsub(".*int(.*?)=.*", "\\1", guessh_in[i]) - cnst_nam <- gsub(" ", "", cnst_nam) - lpjguess_consts[[ctr]] <- cnst_val - names(lpjguess_consts)[ctr] <- cnst_nam - ctr <- ctr + 1 + + # all match? + if(!setequal(unlist(lpjguess_classes), LPJ_GUESS_CLASSES)){ + PEcAn.logger::logger.severe("This function can only read the following class objects: ", paste(LPJ_GUESS_CLASSES, collapse="--")) } -} -# few cleaning -dont_need <- c("COLDEST_DAY_NHEMISPHERE", "COLDEST_DAY_SHEMISPHERE", "WARMEST_DAY_NHEMISPHERE", "WARMEST_DAY_SHEMISPHERE", "data[]") -lpjguess_consts[match(dont_need, names(lpjguess_consts))] <- NULL -# this needs to be extracted from parameters.h:48-49 or somewhere else, but hardcoding for now - -# need to parse out few more constants -for(i in seq_along(paramh_in)){ #do same for parameters.h - res <- str_match(paramh_in[i], "typedef enum \\{(.*?)\\} landcovertype\\;") - if(!is.na(res[,2])){ - lpjguess_consts$NLANDCOVERTYPES <- length(strsplit(res[,2], ",")[[1]]) - 1 # last element is NLANDCOVERTYPES + + # there are couple of LPJ-GUESS specific types that we'll need below + lpjguess_types <- list() + ctr <- 1 + for(i in seq_along(guessh_in)){ + if(grepl("typedef enum {", guessh_in[i], fixed = TRUE)){ + this_line <- find_closing("}", i, guessh_in) + l_type <- gsub(".*}(.*?);.*", "\\1", guessh_in[this_line]) + l_type <- gsub(" ", "", l_type) + lpjguess_types[[ctr]] <- l_type + ctr <- ctr + 1 + } } -} -for(i in seq_along(guessh_in)){ - if(grepl("enum PerPatchFluxType {", guessh_in[i], fixed = TRUE)){ - cl_i <- find_closing("}", i, guessh_in) - #get rid of commented out lines - sub_string <- guessh_in[i:cl_i][!grepl("///", guessh_in[i:cl_i], fixed = TRUE)] - # split and count - lpjguess_consts$PerPatchFluxType <- length(strsplit(paste(sub_string, collapse = " "), ",")[[1]]) - 1 + for(i in seq_along(paramh_in)){ #do same for parameters.h + if(grepl("typedef enum {", paramh_in[i], fixed = TRUE)){ + this_line <- find_closing("}", i, paramh_in) + l_type <- gsub(".*}(.*?);.*", "\\1", paramh_in[this_line]) + l_type <- gsub(" ", "", l_type) + lpjguess_types[[ctr]] <- l_type + ctr <- ctr + 1 + } } - if(grepl("enum PerPFTFluxType {", guessh_in[i], fixed = TRUE)){ - cl_i <- find_closing("}", i, guessh_in) - #get rid of commented out lines - sub_string <- guessh_in[i:cl_i][!grepl("///", guessh_in[i:cl_i], fixed = TRUE)] - # split and count - lpjguess_consts$PerPFTFluxType <- length(strsplit(paste(sub_string, collapse = " "), ",")[[1]]) - 1 + LPJ_GUESS_TYPES <- unlist(lpjguess_types) + + + lpjguess_consts <- list() + ctr <- 1 + for(i in seq_along(guessh_in)){ + if(grepl("const int ", guessh_in[i], fixed = TRUE)){ # probably won't need "const double"s + cnst_val <- gsub(".*=(.*?);.*", "\\1", guessh_in[i]) + cnst_val <- gsub(" ", "", cnst_val) # get rid of the space if there is one + cnst_nam <- gsub(".*int(.*?)=.*", "\\1", guessh_in[i]) + cnst_nam <- gsub(" ", "", cnst_nam) + lpjguess_consts[[ctr]] <- cnst_val + names(lpjguess_consts)[ctr] <- cnst_nam + ctr <- ctr + 1 + } } - -} - -# this needs to be extracted from guess.h:93-94 , but hardcoding for now -# hopefully CENTURY pool names might not change for a while -lpjguess_consts$NSOMPOOL <- 12 - - -LPJ_GUESS_CONST_INTS <- data.frame(var = names(lpjguess_consts), val = as.numeric(unlist(lpjguess_consts)), stringsAsFactors = FALSE) - - -# Gridcell is the top-level container, start parsing from there -beg_end <- serialize_starts_ends(file_in = guesscpp_in, pattern = "void Gridcell::serialize") - -# now we will parse the stuff between these lines -# first find what is being written -streamed_vars_gridcell <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - -################################## CAUTION : THE FOLLOWING IS A MONSTROUS NESTED-LOOP ################################## - -# Now I can use streamed_vars_gridcell to loop over them -# We read everything in this loop, Gridcell list is going to be the top container -# there will be nested loops, the hierarchy will follow LPJ-GUESS architecture -Gridcell <- list() -level <- "Gridcell" -for(g_i in 1:8){#seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts - current_stream <- streamed_vars_gridcell[g_i] - # weird, it doesn't go into Gridcell st - if(current_stream == "st[i]") next #current_stream <- "Gridcellst" - if(current_stream == "balance") current_stream <- "MassBalance" #not sure how to make this name matching otherwise - if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard - if(grepl(glob2rx("(*this)[*].landcover"), current_stream)){ # s counter might change, using wildcard - # not sure how to handle this better. If we see this, it means we are now looping over Stands - # this function considers "NATURAL" vegetation only, so there is only one stand - # this is an integer that tells us which landcover type this stand is - # so it should be the indice of NATURAL in typedef enum landcovertype (I believe indexing starts from 0) - - # note that this is streamed under Gridcell, not Stand in guess.cpp, - # but I think this info needs to go together with the Stand sublist - # so prepend landcovertype to the streamed_vars_stand EDIT: I'll actually just read it here - Gridcell[["Stand"]][["landcovertype"]] <- readBin(zz, what = integer(), n = 1, size = 4) - num_stnd <- as.numeric(Gridcell$nstands) - Gridcell[["Stand"]] <- vector("list", num_stnd) - - next - } + # few cleaning + dont_need <- c("COLDEST_DAY_NHEMISPHERE", "COLDEST_DAY_SHEMISPHERE", "WARMEST_DAY_NHEMISPHERE", "WARMEST_DAY_SHEMISPHERE", "data[]") + lpjguess_consts[match(dont_need, names(lpjguess_consts))] <- NULL - # "(*this)[*]" points to different things under different levels, here it is stand - if(grepl(glob2rx("(*this)[*]"), current_stream)){ # note that first else-part will be evaluated considering the order in guess.cpp - - # STAND - level <- "Stand" - current_stream <- "Stand" - current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void ", - tools::toTitleCase(current_stream_type$name), - "::serialize")) - streamed_vars_stand <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - # this was previous version - # streamed_vars_stand <- c("landcover", streamed_vars_stand) # prepending landcovertype to the streamed_vars_stand + + # need to parse out few more constants + for(i in seq_along(paramh_in)){ #do same for parameters.h + res <- str_match(paramh_in[i], "typedef enum \\{(.*?)\\} landcovertype\\;") + if(!is.na(res[,2])){ + lpjguess_consts$NLANDCOVERTYPES <- length(strsplit(res[,2], ",")[[1]]) - 1 # last element is NLANDCOVERTYPES + } + } + for(i in seq_along(guessh_in)){ + if(grepl("enum PerPatchFluxType {", guessh_in[i], fixed = TRUE)){ + cl_i <- find_closing("}", i, guessh_in) + #get rid of commented out lines + sub_string <- guessh_in[i:cl_i][!grepl("///", guessh_in[i:cl_i], fixed = TRUE)] + # split and count + lpjguess_consts$PerPatchFluxType <- length(strsplit(paste(sub_string, collapse = " "), ",")[[1]]) - 1 + } + if(grepl("enum PerPFTFluxType {", guessh_in[i], fixed = TRUE)){ + cl_i <- find_closing("}", i, guessh_in) + #get rid of commented out lines + sub_string <- guessh_in[i:cl_i][!grepl("///", guessh_in[i:cl_i], fixed = TRUE)] + # split and count + lpjguess_consts$PerPFTFluxType <- length(strsplit(paste(sub_string, collapse = " "), ",")[[1]]) - 1 + } + } + + # this needs to be extracted from guess.h:93-94 , but hardcoding for now + # hopefully CENTURY pool names might not change for a while + lpjguess_consts$NSOMPOOL <- 12 + + + LPJ_GUESS_CONST_INTS <- data.frame(var = names(lpjguess_consts), val = as.numeric(unlist(lpjguess_consts)), stringsAsFactors = FALSE) + + + # Gridcell is the top-level container, start parsing from there + beg_end <- serialize_starts_ends(file_in = guesscpp_in, pattern = "void Gridcell::serialize") + + # now we will parse the stuff between these lines + # first find what is being written + streamed_vars_gridcell <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + + ################################## CAUTION : THE FOLLOWING IS A MONSTROUS NESTED-LOOP ################################## + + # Now I can use streamed_vars_gridcell to loop over them + # We read everything in this loop, Gridcell list is going to be the top container + # there will be nested loops, the hierarchy will follow LPJ-GUESS architecture + Gridcell <- list() + level <- "Gridcell" + for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts + current_stream <- streamed_vars_gridcell[g_i] + # weird, it doesn't go into Gridcell st + if(current_stream == "st[i]") next #current_stream <- "Gridcellst" + if(current_stream == "balance") current_stream <- "MassBalance" #not sure how to make this name matching otherwise + if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard + if(grepl(glob2rx("(*this)[*].landcover"), current_stream)){ # s counter might change, using wildcard + # not sure how to handle this better. If we see this, it means we are now looping over Stands + # this function considers "NATURAL" vegetation only, so there is only one stand + # this is an integer that tells us which landcover type this stand is + # so it should be the indice of NATURAL in typedef enum landcovertype (I believe indexing starts from 0) + + # note that this is streamed under Gridcell, not Stand in guess.cpp, + # but I think this info needs to go together with the Stand sublist + # so prepend landcovertype to the streamed_vars_stand EDIT: I'll actually just read it here + Gridcell[["Stand"]][["landcovertype"]] <- readBin(zz, what = integer(), n = 1, size = 4) + num_stnd <- as.numeric(Gridcell$nstands) + Gridcell[["Stand"]] <- vector("list", num_stnd) + + next + } - for(stnd_i in seq_len(num_stnd)){ #looping over the stands - for(svs_i in 1:2){#seq_along(streamed_vars_stand)){ # looping over the streamed stand vars - - current_stream <- streamed_vars_stand[svs_i] - if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard - - if(current_stream == "nobj" & level == "Stand"){ - # nobj points to different things under different levels, here it is the number of patches - # number of patches is set through insfiles, read by write.configs and passed to this fcn - # but it's also written to the state file, need to move bytes - nofpatch <- readBin(zz, integer(), 1, size = 4) - if(npatches == nofpatch){ # also not a bad place to check if everything is going fine so far - Gridcell[["Stand"]][[stnd_i]]$npatches <- npatches - #Gridcell[["Stand"]] <- vector("list", npatches) - }else{ - PEcAn.logger::logger.severe("The number of patches set through the instruction file does not match the number read from the state files. Probably a bug in the read.state function! Terminating.") - } - next - } - - # "(*this)[*]" points to different things under different levels, here it is patch - if(grepl(glob2rx("(*this)[*]"), current_stream)){ - # PATCH - level <- "Patch" - current_stream <- "Patch" - current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + # "(*this)[*]" points to different things under different levels, here it is stand + if(grepl(glob2rx("(*this)[*]"), current_stream)){ # note that first else-part will be evaluated considering the order in guess.cpp + + # STAND + level <- "Stand" + current_stream <- "Stand" + current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + + beg_end <- serialize_starts_ends(file_in = guesscpp_in, + pattern = paste0("void ", + tools::toTitleCase(current_stream_type$name), + "::serialize")) + streamed_vars_stand <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + # this was previous version + # streamed_vars_stand <- c("landcover", streamed_vars_stand) # prepending landcovertype to the streamed_vars_stand + + + for(stnd_i in seq_len(num_stnd)){ #looping over the stands + for(svs_i in seq_along(streamed_vars_stand)){ # looping over the streamed stand vars - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void ", - tools::toTitleCase(current_stream_type$name), - "::serialize")) - streamed_vars_patch <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + current_stream <- streamed_vars_stand[svs_i] + if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard - Gridcell[["Stand"]][[stnd_i]][["Patch"]] <- vector("list", npatches) + if(current_stream == "nobj" & level == "Stand"){ + # nobj points to different things under different levels, here it is the number of patches + # number of patches is set through insfiles, read by write.configs and passed to this fcn + # but it's also written to the state file, need to move bytes + nofpatch <- readBin(zz, integer(), 1, size = 4) + if(npatches == nofpatch){ # also not a bad place to check if everything is going fine so far + Gridcell[["Stand"]][[stnd_i]]$npatches <- npatches + #Gridcell[["Stand"]] <- vector("list", npatches) + }else{ + PEcAn.logger::logger.severe("The number of patches set through the instruction file does not match the number read from the state files. Probably a bug in the read.state function! Terminating.") + } + next + } - for(ptch_i in seq_len(npatches)){ #looping over the patches - for(svp_i in 1){#seq_along(streamed_vars_patch)){ #looping over the streamed patch vars - current_stream <- streamed_vars_patch[svp_i] - if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard - - if(tools::toTitleCase(current_stream) %in% LPJ_GUESS_CLASSES){ - current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - }else{ - current_stream_type <- find_stream_type("Patch", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - } - - - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[length(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])+1]] <- list() - names(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])[length(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])] <- current_stream_type$name - - if(current_stream_type$type == "class"){ + # "(*this)[*]" points to different things under different levels, here it is patch + if(grepl(glob2rx("(*this)[*]"), current_stream)){ + # PATCH + level <- "Patch" + current_stream <- "Patch" + current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + + beg_end <- serialize_starts_ends(file_in = guesscpp_in, + pattern = paste0("void ", + tools::toTitleCase(current_stream_type$name), + "::serialize")) + streamed_vars_patch <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + + Gridcell[["Stand"]][[stnd_i]][["Patch"]] <- vector("list", npatches) + + for(ptch_i in seq_len(npatches)){ #looping over the patches + for(svp_i in seq_along(streamed_vars_patch)){ #looping over the streamed patch vars + current_stream <- streamed_vars_patch[svp_i] + if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard - # CLASS - class_name <- current_stream_type$name + if(tools::toTitleCase(current_stream) %in% LPJ_GUESS_CLASSES){ + current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + }else{ + current_stream_type <- find_stream_type("Patch", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + } - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void ", - tools::toTitleCase(current_stream_type$name), - "::serialize")) + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[length(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])+1]] <- list() + names(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])[length(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])] <- current_stream_type$name - if(class_name == "Vegetation"){ - # VEGETATION - # Vegetation class has a bit of a different structure, it has one more depth, see model documentation - streamed_vars_veg <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + if(current_stream_type$type == "class"){ - # NOTE : Unlike other parts, this bit is a lot less generalized!!! - # I'm gonna asumme Vegetation class won't change much in the future - # indiv.pft.id and indiv needs to be looped over nobj times - if(!setequal(streamed_vars_veg, c("nobj", "indiv.pft.id", "indiv"))){ - PEcAn.logger::logger.severe("Vegetation class object changed in this model version, you need to fix read.state") - } - - # nobj points to different things under different levels, here it is the number of individuals - number_of_individuals <- readBin(zz, integer(), 1, size = 4) - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["number_of_individuals"]] <- number_of_individuals + # CLASS + class_name <- current_stream_type$name - # few checks for sensible vals - if(number_of_individuals < 1 | number_of_individuals > 10000){ # should there be an upper limit here too? - # if number of individuals is 0 it's a bit suspicious. Not sure if ever will get negative but that'd definitely be wrong - PEcAn.logger::logger.warn("Number of individuals under vegetation is", number_of_individuals) - } - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]] <- list() - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]] <- vector("list", number_of_individuals) - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void Individual::serialize")) - streamed_vars_indv <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + pattern = paste0("void ", + tools::toTitleCase(current_stream_type$name), + "::serialize")) - # NO CROPS - if("*cropindiv" %in% streamed_vars_indv) streamed_vars_indv <- streamed_vars_indv[!(streamed_vars_indv == "*cropindiv")] - # loop over nobj - for(indv_i in seq_len(number_of_individuals)){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]] <- list() - # which PFT is this? - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][["indiv.pft.id"]] <- readBin(zz, integer(), 1, size = 4) - # read all the individual class - for(svi_i in seq_along(streamed_vars_indv)){ # - - current_stream <- streamed_vars_indv[svi_i] - if(current_stream == "photosynthesis") current_stream <- "PhotosynthesisResult" + if(class_name == "Vegetation"){ + # VEGETATION + # Vegetation class has a bit of a different structure, it has one more depth, see model documentation + streamed_vars_veg <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + + # NOTE : Unlike other parts, this bit is a lot less generalized!!! + # I'm gonna asumme Vegetation class won't change much in the future + # indiv.pft.id and indiv needs to be looped over nobj times + if(!setequal(streamed_vars_veg, c("nobj", "indiv.pft.id", "indiv"))){ + PEcAn.logger::logger.severe("Vegetation class object changed in this model version, you need to fix read.state") + } + + # nobj points to different things under different levels, here it is the number of individuals + number_of_individuals <- readBin(zz, integer(), 1, size = 4) + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["number_of_individuals"]] <- number_of_individuals + + # few checks for sensible vals + if(number_of_individuals < 1 | number_of_individuals > 10000){ # should there be an upper limit here too? + # if number of individuals is 0 it's a bit suspicious. Not sure if ever will get negative but that'd definitely be wrong + PEcAn.logger::logger.warn("Number of individuals under vegetation is", number_of_individuals) + } + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]] <- list() + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]] <- vector("list", number_of_individuals) + + beg_end <- serialize_starts_ends(file_in = guesscpp_in, + pattern = paste0("void Individual::serialize")) + streamed_vars_indv <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + + # NO CROPS + if("*cropindiv" %in% streamed_vars_indv) streamed_vars_indv <- streamed_vars_indv[!(streamed_vars_indv == "*cropindiv")] + + # loop over nobj + for(indv_i in seq_len(number_of_individuals)){ + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]] <- list() + # which PFT is this? + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][["indiv.pft.id"]] <- readBin(zz, integer(), 1, size = 4) + # read all the individual class + for(svi_i in seq_along(streamed_vars_indv)){ # - if(tools::toTitleCase(current_stream) %in% LPJ_GUESS_CLASSES){ + current_stream <- streamed_vars_indv[svi_i] + if(current_stream == "photosynthesis") current_stream <- "PhotosynthesisResult" + + if(tools::toTitleCase(current_stream) %in% LPJ_GUESS_CLASSES){ current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - }else{ + }else{ # Only Individual class under Vegetation current_stream_type <- find_stream_type("Individual", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - } - - if(current_stream_type$type == "class"){ - - if(current_stream_type$name != "PhotosynthesisResult"){ - PEcAn.logger::logger.debug("Classes other than PhotosynthesisResult enter here.") } - # ONLY PhotosynthesisResult HERE SO FAR ****************************************************************** - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void ", - tools::toTitleCase(current_stream_type$name), - "::serialize")) - streamed_vars_photo <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][["PhotosynthesisResult"]] <- list() - for(photo_i in seq_along(streamed_vars_photo)){ - current_stream <- streamed_vars_photo[photo_i] #it's OK to overwrite - current_stream_type <- find_stream_type("PhotosynthesisResult", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + if(current_stream_type$type == "class"){ + + if(current_stream_type$name != "PhotosynthesisResult"){ + PEcAn.logger::logger.debug("Classes other than PhotosynthesisResult enter here.") + } + # ONLY PhotosynthesisResult HERE SO FAR ****************************************************************** + beg_end <- serialize_starts_ends(file_in = guesscpp_in, + pattern = paste0("void ", + tools::toTitleCase(current_stream_type$name), + "::serialize")) + streamed_vars_photo <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][["PhotosynthesisResult"]] <- list() + for(photo_i in seq_along(streamed_vars_photo)){ + current_stream <- streamed_vars_photo[photo_i] #it's OK to overwrite + current_stream_type <- find_stream_type("PhotosynthesisResult", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) + # and read! + + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][["PhotosynthesisResult"]][[current_stream_type$name]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + + }# streamed_vars_photo-loop ends - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - # and read! - - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][["PhotosynthesisResult"]][[current_stream_type$name]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - - }# streamed_vars_photo-loop ends - - }else{ - - - current_stream_type <- find_stream_type("individual", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - - if(current_stream_specs$single){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][[current_stream_type$name]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) }else{ - for(css.i in seq_along(current_stream_specs$what)){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, - what = current_stream_specs$what[css.i], - n = current_stream_specs$n[css.i], - size = current_stream_specs$size[css.i]) + + + current_stream_type <- find_stream_type("individual", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) + + if(current_stream_specs$single){ + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][[current_stream_type$name]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + }else{ + for(css.i in seq_along(current_stream_specs$what)){ + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, + what = current_stream_specs$what[css.i], + n = current_stream_specs$n[css.i], + size = current_stream_specs$size[css.i]) + } } } - } - }# end loop over stream vars individual - } # end loop over number_of_individuals + }# end loop over stream vars individual + } # end loop over number_of_individuals - - - }else if(class_name == "Fluxes"){ - # FLUXES - # this is not generalized at all - streamed_vars_flux <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - - if(!setequal(streamed_vars_flux, c("annual_fluxes_per_pft", "monthly_fluxes_patch", "monthly_fluxes_pft"))){ - PEcAn.logger::logger.severe("Fluxes class object changed in this model version, you need to fix read.state") - } - - # annual_fluxes_per_pft loops over - # parse from guess.h - PerPFTFluxType <- c("NPP", "GPP", "RA", "ISO", "MON") - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]] <- list() - key1 <- readBin(zz, "integer", 1, 8) - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]][["n_pft"]] <- key1 - for(fpft_i in seq_len(key1)){ # key1 11 PFTs - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]][[fpft_i]] <- list() - key2 <- readBin(zz, "integer", 1, 8) - if(key2 > 10000){ #make sure you dind't read a weird number, this is supposed to be number of fluxes per pft, can't have too many - PEcAn.logger::logger.severe("Number of fluxes per pft read from the state file is too high. Check read.state function") + + + }else if(class_name == "Fluxes"){ + # FLUXES + # this is not generalized at all + streamed_vars_flux <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + + if(!setequal(streamed_vars_flux, c("annual_fluxes_per_pft", "monthly_fluxes_patch", "monthly_fluxes_pft"))){ + PEcAn.logger::logger.severe("Fluxes class object changed in this model version, you need to fix read.state") } - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]][[fpft_i]][["key2"]] <- key2 - for(flux_i in seq_len(key2)){ - # is this double? - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]][[fpft_i]][[PerPFTFluxType[flux_i]]] <- readBin(zz, "double", 1, 8) + + # annual_fluxes_per_pft loops over + # parse from guess.h + PerPFTFluxType <- c("NPP", "GPP", "RA", "ISO", "MON") + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]] <- list() + key1 <- readBin(zz, "integer", 1, 8) + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]][["n_pft"]] <- key1 + for(fpft_i in seq_len(key1)){ # key1 11 PFTs + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]][[fpft_i]] <- list() + key2 <- readBin(zz, "integer", 1, 8) + if(key2 > 10000){ #make sure you dind't read a weird number, this is supposed to be number of fluxes per pft, can't have too many + PEcAn.logger::logger.severe("Number of fluxes per pft read from the state file is too high. Check read.state function") + } + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]][[fpft_i]][["key2"]] <- key2 + for(flux_i in seq_len(key2)){ + # is this double? + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]][[fpft_i]][[PerPFTFluxType[flux_i]]] <- readBin(zz, "double", 1, 8) + } } - } - - # monthly_fluxes_patch read as a vector at once - # double monthly_fluxes_patch[12][NPERPATCHFLUXTYPES]; - # maybe read this as a matrix? - n_monthly_fluxes_patch <- 12 * LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var =="PerPatchFluxType"] - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["monthly_fluxes_patch"]] <- readBin(zz, "double", n_monthly_fluxes_patch, 8) - - # monthly_fluxes_pft read as a vector at once - # double monthly_fluxes_pft[12][NPERPFTFLUXTYPES]; - # maybe read this as a matrix? - n_monthly_fluxes_pft <- 12 * LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var =="PerPFTFluxType"] - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["monthly_fluxes_pft"]] <- readBin(zz, "double", n_monthly_fluxes_pft, 8) - - }else{ - # NOT VEGETATION OR FLUX - streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - # NO CROPS, NATURAL VEG - if("*cropphen" %in% streamed_vars) streamed_vars <- streamed_vars[!(streamed_vars == "*cropphen")] - num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) - - for(varname in streamed_vars){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[current_stream_type$name]][[varname]] <- vector("list", num_pft) - } - - # maybe try modifying this bit later to make it a function - for(pft_i in seq_len(num_pft)){ - for(sv_i in seq_along(streamed_vars)){ - current_stream <- streamed_vars[sv_i] #it's OK to overwrite - current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - - if(current_stream_type$type == "class"){ - - if(current_stream_type$name != "sompool"){ - PEcAn.logger::logger.debug("Classes other than sompool enter here.") - } - # ONLY SOMPOOL HERE SO FAR ****************************************************************** - # code below is very sompool specific - # class_name <- # don't overwrite class_name - - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void ", - tools::toTitleCase(current_stream_type$name), - "::serialize")) - streamed_vars_sompool <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - - nsompool <- LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var == "NSOMPOOL"] - - for(varname in streamed_vars_sompool){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Soil"]][["sompool[i]"]][[varname]] <- vector("list", nsompool) - } + + # monthly_fluxes_patch read as a vector at once + # double monthly_fluxes_patch[12][NPERPATCHFLUXTYPES]; + # maybe read this as a matrix? + n_monthly_fluxes_patch <- 12 * LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var =="PerPatchFluxType"] + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["monthly_fluxes_patch"]] <- readBin(zz, "double", n_monthly_fluxes_patch, 8) + + # monthly_fluxes_pft read as a vector at once + # double monthly_fluxes_pft[12][NPERPFTFLUXTYPES]; + # maybe read this as a matrix? + n_monthly_fluxes_pft <- 12 * LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var =="PerPFTFluxType"] + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["monthly_fluxes_pft"]] <- readBin(zz, "double", n_monthly_fluxes_pft, 8) + + }else{ + # NOT VEGETATION OR FLUX + streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + # NO CROPS, NATURAL VEG + if("*cropphen" %in% streamed_vars) streamed_vars <- streamed_vars[!(streamed_vars == "*cropphen")] + num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) + + for(varname in streamed_vars){ + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[current_stream_type$name]][[varname]] <- vector("list", num_pft) + } + + # maybe try modifying this bit later to make it a function + for(pft_i in seq_len(num_pft)){ + for(sv_i in seq_along(streamed_vars)){ + current_stream <- streamed_vars[sv_i] #it's OK to overwrite + current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - names( Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Soil"]])[names( Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Soil"]]) == "sompool[i]"] <- "Sompool" - - ###################### LOOP OVER NSOMPOOL - for(som_i in seq_len(nsompool)){ - for(sv_sompool_i in seq_along(streamed_vars_sompool)){ - current_stream <- streamed_vars_sompool[sv_sompool_i] - - current_stream_type <- find_stream_type("Sompool", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - - if(current_stream_specs$single){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Soil"]][["Sompool"]][[current_stream_type$name]][[som_i]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ - PEcAn.logger::logger.severe("Historic under sompool.") # Not expecting any + if(current_stream_type$type == "class"){ + + if(current_stream_type$name != "sompool"){ + PEcAn.logger::logger.debug("Classes other than sompool enter here.") + } + # ONLY SOMPOOL HERE SO FAR ****************************************************************** + # code below is very sompool specific + # class_name <- # don't overwrite class_name + + beg_end <- serialize_starts_ends(file_in = guesscpp_in, + pattern = paste0("void ", + tools::toTitleCase(current_stream_type$name), + "::serialize")) + streamed_vars_sompool <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + + nsompool <- LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var == "NSOMPOOL"] + + for(varname in streamed_vars_sompool){ + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Soil"]][["sompool[i]"]][[varname]] <- vector("list", nsompool) + } + + names( Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Soil"]])[names( Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Soil"]]) == "sompool[i]"] <- "Sompool" + + ###################### LOOP OVER NSOMPOOL + for(som_i in seq_len(nsompool)){ + for(sv_sompool_i in seq_along(streamed_vars_sompool)){ + current_stream <- streamed_vars_sompool[sv_sompool_i] + + current_stream_type <- find_stream_type("Sompool", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) + + if(current_stream_specs$single){ + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Soil"]][["Sompool"]][[current_stream_type$name]][[som_i]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + }else{ + PEcAn.logger::logger.severe("Historic under sompool.") # Not expecting any + } } } - } - - }else{ - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - # and read! - if(current_stream_specs$single){ # maybe use current_stream in sublist names to find correct place - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[length( Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ # only for historic type? - for(css.i in seq_along(current_stream_specs$what)){ # maybe use current_stream in sublist names to find correct place - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[length( Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, - what = current_stream_specs$what[css.i], - n = current_stream_specs$n[css.i], - size = current_stream_specs$size[css.i]) + + }else{ + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) + # and read! + if(current_stream_specs$single){ # maybe use current_stream in sublist names to find correct place + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[length( Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + }else{ # only for historic type? + for(css.i in seq_along(current_stream_specs$what)){ # maybe use current_stream in sublist names to find correct place + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[length( Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, + what = current_stream_specs$what[css.i], + n = current_stream_specs$n[css.i], + size = current_stream_specs$size[css.i]) + } } } - } - } # streamed_vars-loop ends - } # pft-loop ends - } - - - }else{ - # NOT CLASS - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - # and read! - if(current_stream_specs$single){ - - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[current_stream_type$name]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ # probably don't need this but let's keep - for(css_i in seq_along(current_stream_specs$what)){ - # CHANGE ALL THESE HISTORIC TYPES SO THAT cirrent_index and full goes together with the variable - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[current_stream_specs$names[css_i]]] <- readBin(con = zz, - what = current_stream_specs$what[css_i], - n = current_stream_specs$n[css_i], - size = current_stream_specs$size[css_i]) + } # streamed_vars-loop ends + } # pft-loop ends } - } - }# end if-class within Patch - } - } - - }else{ - # NOT PATCH - - if(tools::toTitleCase(current_stream) %in% LPJ_GUESS_CLASSES){ - current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - }else{ - current_stream_type <- find_stream_type("Stand", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - } - - Gridcell[["Stand"]][[stnd_i]][[length(Gridcell[["Stand"]][[stnd_i]])+1]] <- list() - names(Gridcell[["Stand"]][[stnd_i]])[length(Gridcell[["Stand"]][[stnd_i]])] <- current_stream_type$name - - if(current_stream_type$type == "class"){ - - # CLASS - class_name <- current_stream_type$name - - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void ", - tools::toTitleCase(current_stream_type$name), - "::serialize")) - streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) - - for(varname in streamed_vars){ - Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]][[varname]] <- varname - Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]][[varname]] <- vector("list", num_pft) - } - - for(pft_i in seq_len(num_pft)){ - for(sv_i in seq_along(streamed_vars)){ - current_stream <- streamed_vars[sv_i] #it's OK to overwrite - current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - - if(current_stream_type$type == "class"){ - # CLASS, NOT EVER GOING HERE? - class_name <- current_stream_type$name }else{ + # NOT CLASS current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) # and read! if(current_stream_specs$single){ - Gridcell[["Stand"]][[stnd_i]][[length(Gridcell[["Stand"]][[stnd_i]])]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ - for(css.i in seq_along(current_stream_specs$what)){ - Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, - what = current_stream_specs$what[css.i], - n = current_stream_specs$n[css.i], - size = current_stream_specs$size[css.i]) + + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[current_stream_type$name]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + }else{ # probably don't need this but let's keep + for(css_i in seq_along(current_stream_specs$what)){ + # CHANGE ALL THESE HISTORIC TYPES SO THAT cirrent_index and full goes together with the variable + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[current_stream_specs$names[css_i]]] <- readBin(con = zz, + what = current_stream_specs$what[css_i], + n = current_stream_specs$n[css_i], + size = current_stream_specs$size[css_i]) } } - } - } # streamed_vars-loop ends - } # pft-loop ends + }# end if-class within Patch + } + } }else{ - # NOT CLASS - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - # and read! - if(current_stream_specs$single){ - Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ # probably don't need this but let's keep - for(css_i in seq_along(current_stream_specs$what)){ - Gridcell[[length(Gridcell)]][[current_stream_specs$names[css_i]]] <- readBin(con = zz, - what = current_stream_specs$what[css_i], - n = current_stream_specs$n[css_i], - size = current_stream_specs$size[css_i]) - } + # NOT PATCH + + if(tools::toTitleCase(current_stream) %in% LPJ_GUESS_CLASSES && current_stream != "landcover"){ + current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + }else{ + current_stream_type <- find_stream_type("Stand", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) } - }# end if-class within Stand - } # end patch-if - - - }# end for-loop over the streamed stand vars (svs_i, L.165) - }# end for-loop over the stands (stnd_i, L.164) - - }else{ #not reading in Stand variables - - # NOT STAND - - current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - - Gridcell[[length(Gridcell)+1]] <- list() - names(Gridcell)[length(Gridcell)] <- current_stream_type$name - if(current_stream_type$type == "class"){ + + Gridcell[["Stand"]][[stnd_i]][[length(Gridcell[["Stand"]][[stnd_i]])+1]] <- list() + names(Gridcell[["Stand"]][[stnd_i]])[length(Gridcell[["Stand"]][[stnd_i]])] <- current_stream_type$name + + if(current_stream_type$type == "class"){ + + # CLASS + class_name <- current_stream_type$name + + beg_end <- serialize_starts_ends(file_in = guesscpp_in, + pattern = paste0("void ", + tools::toTitleCase(current_stream_type$name), + "::serialize")) + streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) + + for(varname in streamed_vars){ + Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]][[varname]] <- varname + Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]][[varname]] <- vector("list", num_pft) + } + + for(pft_i in seq_len(num_pft)){ + for(sv_i in seq_along(streamed_vars)){ + current_stream <- streamed_vars[sv_i] #it's OK to overwrite + current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + + if(current_stream_type$type == "class"){ + + # CLASS, NOT EVER GOING HERE? + class_name <- current_stream_type$name + + }else{ + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) + # and read! + if(current_stream_specs$single){ + Gridcell[["Stand"]][[stnd_i]][[length(Gridcell[["Stand"]][[stnd_i]])]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + }else{ + for(css.i in seq_along(current_stream_specs$what)){ + Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, + what = current_stream_specs$what[css.i], + n = current_stream_specs$n[css.i], + size = current_stream_specs$size[css.i]) + } + } + } + } # streamed_vars-loop ends + } # pft-loop ends + + }else{ + # NOT CLASS + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) + # and read! + if(current_stream_specs$single){ + Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + }else{ # probably don't need this but let's keep + for(css_i in seq_along(current_stream_specs$what)){ + Gridcell[[length(Gridcell)]][[current_stream_specs$names[css_i]]] <- readBin(con = zz, + what = current_stream_specs$what[css_i], + n = current_stream_specs$n[css_i], + size = current_stream_specs$size[css_i]) + } + } + }# end if-class within Stand + } # end patch-if + + + }# end for-loop over the streamed stand vars (svs_i, L.165) + }# end for-loop over the stands (stnd_i, L.164) - # CLASS - class_name <- current_stream_type$name + }else{ #not reading in Stand variables - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void ", - tools::toTitleCase(current_stream_type$name), - "::serialize")) - streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) + # NOT STAND - for(varname in streamed_vars){ - Gridcell[[length(Gridcell)]][[varname]] <- varname - Gridcell[[length(Gridcell)]][[varname]] <- vector("list", num_pft) - } + current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - for(pft_i in seq_len(num_pft)){ - for(sv_i in seq_along(streamed_vars)){ - current_stream <- streamed_vars[sv_i] #it's OK to overwrite - current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - # and read! - if(current_stream_specs$single){ - Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else if(current_stream_specs$name %in% c("hmtemp_20", "hmprec_20", "hmeet_20")){ - # these three are just too different, maybe extract their names in the beginning - # be careful while writing back to the binary - Gridcell[[length(Gridcell)]][[current_stream_type$name]] <- readBin(con = zz, double(), 264, 8) - # Gridcell[[length(Gridcell)]][[current_stream_type$name]] <- vector("list", length(current_stream_specs) - 2) - # for(css.i in seq_len(length(current_stream_specs) - 2)){ - # Gridcell[[length(Gridcell)]][[current_stream_type$name]][[css.i]] <- readBin(con = zz, - # what = current_stream_specs[[css.i]]$what, - # n = current_stream_specs[[css.i]]$n, - # size = current_stream_specs[[css.i]]$size) - #} - }else{ - for(css.i in seq_along(current_stream_specs$what)){ - Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, + Gridcell[[length(Gridcell)+1]] <- list() + names(Gridcell)[length(Gridcell)] <- current_stream_type$name + if(current_stream_type$type == "class"){ + + # CLASS + class_name <- current_stream_type$name + + beg_end <- serialize_starts_ends(file_in = guesscpp_in, + pattern = paste0("void ", + tools::toTitleCase(current_stream_type$name), + "::serialize")) + streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) + num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) + + for(varname in streamed_vars){ + Gridcell[[length(Gridcell)]][[varname]] <- varname + Gridcell[[length(Gridcell)]][[varname]] <- vector("list", num_pft) + } + + for(pft_i in seq_len(num_pft)){ + for(sv_i in seq_along(streamed_vars)){ + current_stream <- streamed_vars[sv_i] #it's OK to overwrite + current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) + + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) + # and read! + if(current_stream_specs$single){ + Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + }else if(current_stream_specs$name %in% c("hmtemp_20", "hmprec_20", "hmeet_20")){ + # these three are just too different, maybe extract their names in the beginning + # be careful while writing back to the binary + # Gridcell[[length(Gridcell)]][[current_stream_type$name]] <- readBin(con = zz, double(), 264, 8) + Gridcell[[length(Gridcell)]][[current_stream_type$name]] <- vector("list", length(current_stream_specs) - 2) + for(css.i in seq_len(length(current_stream_specs) - 2)){ + Gridcell[[length(Gridcell)]][[current_stream_type$name]][[css.i]] <- readBin(con = zz, + what = current_stream_specs[[css.i]]$what, + n = current_stream_specs[[css.i]]$n, + size = current_stream_specs[[css.i]]$size) + } + }else{ + for(css.i in seq_along(current_stream_specs$what)){ + Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, what = current_stream_specs$what[css.i], n = current_stream_specs$n[css.i], size = current_stream_specs$size[css.i]) + } } + + } # streamed_vars-loop ends + } # pft-loop ends + + }else{ + # NOT CLASS + current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) + # and read! + if(current_stream_specs$single){ + Gridcell[[length(Gridcell)]][[current_stream_type$name]] <- readBin(con = zz, + what = current_stream_specs$what, + n = current_stream_specs$n, + size = current_stream_specs$size) + }else{ # probably don't need this but let's keep + for(css_i in seq_along(current_stream_specs$what)){ + Gridcell[[length(Gridcell)]][[current_stream_specs$names[css_i]]] <- readBin(con = zz, + what = current_stream_specs$what[css_i], + n = current_stream_specs$n[css_i], + size = current_stream_specs$size[css_i]) } - - } # streamed_vars-loop ends - } # pft-loop ends - - }else{ - # NOT CLASS - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - # and read! - if(current_stream_specs$single){ - Gridcell[[length(Gridcell)]][[current_stream_type$name]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ # probably don't need this but let's keep - for(css_i in seq_along(current_stream_specs$what)){ - Gridcell[[length(Gridcell)]][[current_stream_specs$names[css_i]]] <- readBin(con = zz, - what = current_stream_specs$what[css_i], - n = current_stream_specs$n[css_i], - size = current_stream_specs$size[css_i]) } - } - }# end if-class within Gridcell - - } # Stand if-else ends -} # Gridcell-loop ends + }# end if-class within Gridcell + + } # Stand if-else ends + } # Gridcell-loop ends + close(zz) + return(Gridcell) +} # read_binary_LPJGUESS end + + From cb206bffaece2abd8001305df64eb3023294b9a3 Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Mon, 24 Jun 2019 14:55:16 -0400 Subject: [PATCH 45/56] Documented adjustBiomass() and cleaned the fucntion a little. --- models/lpjguess/R/adjustBiomass.LPJGUESS.R | 63 +++++++++++++--------- models/lpjguess/man/adjustBiomass.Rd | 47 ++++++++++++++++ 2 files changed, 84 insertions(+), 26 deletions(-) create mode 100644 models/lpjguess/man/adjustBiomass.Rd diff --git a/models/lpjguess/R/adjustBiomass.LPJGUESS.R b/models/lpjguess/R/adjustBiomass.LPJGUESS.R index 126a547bb5e..6de1a87715f 100644 --- a/models/lpjguess/R/adjustBiomass.LPJGUESS.R +++ b/models/lpjguess/R/adjustBiomass.LPJGUESS.R @@ -1,5 +1,40 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2012 University of Illinois, NCSA. +# All rights reserved. This program and the accompanying materials +# are made available under the terms of the +# University of Illinois/NCSA Open Source License +# which accompanies this distribution, and is available at +# http://opensource.ncsa.illinois.edu/license.html +#------------------------------------------------------------------------------- - +#' Adjust LPJ-GUESS individual's biomass +#' +#' This function adjusts an LPJ-GUESS individual by calling the LPJ-GUESS allocation function (compiled C++) +#' with a given biomass change. It updates the individual biomass pools directly, and also returns, in a list further +#' adjustments to the litter pools. +#' +#' @param individual A nested list which encapsulates an LPJ-GUESS 'Individual' as read from a binary state file +#' @param rel.change A numeric by which to scale the density and C and N pools +#' @param sla The SLA (specific leaf area) (per PFT parameter) +#' @param k_latosa The leaf area to sapwood area ratio (per PFT parameter) +#' @param k_allom2,k_allom3, Allometry coefficients (per PFT parameters) +#' @param wooddens Wood density (kgC/m^2) (per PFT parameter) +#' @param crownarea_max Maximum allowed crown area (m^2) (per PFT parameter) +#' @param lifeform An integer code for the lifeform of this individual (cohort): 1 = Tree, 2 = Grass +#' +#' The changes in C pools are determined by the allocation. The changes in the N pools are designed to +#' maintain the pre-exisiing C:N ratios, so N is just scaled using the updated C with the initial C:N ratio. +#' The N storage pools (nstore_longterm and nstore_labile) don't have pre-existing C:N ratios, so they are +#' just scaled by the overall biomass change (the 'rel.change' argument to the function). +#' +#' Note that after this function is called the function \code{allometry} should be used to update the individual +#' and to check that the newly updated individual has a 'valid' allometry. The litter pools should also be updated. +#' This is implemented in the \code{updateState} function following the call to this \code{adjustBiomass} function. +#' +#' +#' @keywords internal +#' @return the scaled 'individual' (the initial nested list with update values) +#' @author Matthew Forrest adjustBiomass <- function(individual, rel.change, sla, wooddens, lifeform, k_latosa, k_allom2, k_allom3){ # dummy input values to the allocation function below @@ -87,12 +122,7 @@ adjustBiomass <- function(individual, rel.change, sla, wooddens, lifeform, k_la individual$cmass_debt <- new.cmass_debt } - else { - # define these for later - original.cmass_sap <- 0 - original.cmass_heart <- 0 - original.cmass_debt <- 0 - } + # N labile and long term storage - note no equivalant C pools and they are not determined by allocation upgrade, # so simply scale by the overall biomass change @@ -106,25 +136,6 @@ adjustBiomass <- function(individual, rel.change, sla, wooddens, lifeform, k_la # it is not necessary or appropriate to update this variable #print(individual$cmass_wood_inc_5) - - # checks - if(FALSE) { - - biomass.final <- individual$cmass_leaf+individual$cmass_root+individual$cmass_heart+individual$cmass_sap-individual$cmass_debt - if(abs((biomass.final/biomass.total) - 1.1) < 0.001) { - print("--- okay ---") - } - else { - print("--- not okay ---") - } - print(individual$indiv.pft.id) - print(lifeform[individual$indiv.pft.id+1]) - print(biomass.final/biomass.total) - print(unlist(updated.pools)) - print("--- end ---") - } - - return(list(individual = individual, litter_leaf_inc = updated.pools[["litter_leaf_inc"]], litter_root_inc = updated.pools[["litter_root_inc"]], diff --git a/models/lpjguess/man/adjustBiomass.Rd b/models/lpjguess/man/adjustBiomass.Rd new file mode 100644 index 00000000000..6af95e96a69 --- /dev/null +++ b/models/lpjguess/man/adjustBiomass.Rd @@ -0,0 +1,47 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/adjustBiomass.LPJGUESS.R +\name{adjustBiomass} +\alias{adjustBiomass} +\title{Adjust LPJ-GUESS individual's biomass} +\usage{ +adjustBiomass(individual, rel.change, sla, wooddens, lifeform, k_latosa, + k_allom2, k_allom3) +} +\arguments{ +\item{individual}{A nested list which encapsulates an LPJ-GUESS 'Individual' as read from a binary state file} + +\item{rel.change}{A numeric by which to scale the density and C and N pools} + +\item{sla}{The SLA (specific leaf area) (per PFT parameter)} + +\item{wooddens}{Wood density (kgC/m^2) (per PFT parameter)} + +\item{lifeform}{An integer code for the lifeform of this individual (cohort): 1 = Tree, 2 = Grass + +The changes in C pools are determined by the allocation. The changes in the N pools are designed to +maintain the pre-exisiing C:N ratios, so N is just scaled using the updated C with the initial C:N ratio. +The N storage pools (nstore_longterm and nstore_labile) don't have pre-existing C:N ratios, so they are +just scaled by the overall biomass change (the 'rel.change' argument to the function). + +Note that after this function is called the function \code{allometry} should be used to update the individual +and to check that the newly updated individual has a 'valid' allometry. The litter pools should also be updated. +This is implemented in the \code{updateState} function following the call to this \code{adjustBiomass} function.} + +\item{k_latosa}{The leaf area to sapwood area ratio (per PFT parameter)} + +\item{k_allom2, k_allom3, }{Allometry coefficients (per PFT parameters)} + +\item{crownarea_max}{Maximum allowed crown area (m^2) (per PFT parameter)} +} +\value{ +the scaled 'individual' (the initial nested list with update values) +} +\description{ +This function adjusts an LPJ-GUESS individual by calling the LPJ-GUESS allocation function (compiled C++) +with a given biomass change. It updates the individual biomass pools directly, and also returns, in a list further +adjustments to the litter pools. +} +\author{ +Matthew Forrest +} +\keyword{internal} From 3df3ec0a617d8e23bb001fdac77a9340ab1b88f4 Mon Sep 17 00:00:00 2001 From: istfer Date: Mon, 24 Jun 2019 15:09:28 -0400 Subject: [PATCH 46/56] start read_restart.LPJGUESS --- models/lpjguess/R/read_restart.LPJGUESS.R | 27 +++++++++++++++++++++++ 1 file changed, 27 insertions(+) create mode 100644 models/lpjguess/R/read_restart.LPJGUESS.R diff --git a/models/lpjguess/R/read_restart.LPJGUESS.R b/models/lpjguess/R/read_restart.LPJGUESS.R new file mode 100644 index 00000000000..bbac7b3621a --- /dev/null +++ b/models/lpjguess/R/read_restart.LPJGUESS.R @@ -0,0 +1,27 @@ + +# developing +outdir = "/fs/data2/output//PEcAn_1000010473/out" +runid = 1002656610 +stop.time = "1960-12-31 23:59:59 UTC" +load("/fs/data2/output/PEcAn_1000010473/SDAsettings_develop.Rdata") +var.names = c("AGB.pft", "TotSoilCarb") +load("/fs/data2/output/PEcAn_1000010473/SDAparams_develop.Rdata") + + +read_restart.LPJGUESS <- function(outdir, runid, stop.time, settings, var.names, params){ + + # which LPJ-GUESS version, the structure of state file depends a lot on version + lpjguess_ver <- settings$model$revision + + # check if files required by read_binary_LPJGUESS exist + needed_files <- paste0(c("guess.", "guess.", "parameters."), lpjguess_ver, c(".cpp", ".h", ".h")) + + file_check <- file.exists(system.file(needed_files, package = "PEcAn.LPJGUESS")) + if(!all(file_check)){ + PEcAn.logger::logger.severe("read_binary_LPJGUESS need :", paste(needed_files[!file_check], collapse = " ")) + } + + + + +} \ No newline at end of file From a0d938e25b7e03c7b411c36d2e60a56ea974c685 Mon Sep 17 00:00:00 2001 From: istfer Date: Mon, 24 Jun 2019 15:58:56 -0400 Subject: [PATCH 47/56] LPJGUESS uses exact days and will require split inputs function --- models/lpjguess/inst/register.LPJGUESS.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/models/lpjguess/inst/register.LPJGUESS.xml b/models/lpjguess/inst/register.LPJGUESS.xml index 287c4307077..9cd26f93063 100644 --- a/models/lpjguess/inst/register.LPJGUESS.xml +++ b/models/lpjguess/inst/register.LPJGUESS.xml @@ -1,5 +1,5 @@ LPJGUESS - FALSE + TRUE \ No newline at end of file From 9f8e7772f32e3e6042f4bdb18daf6ce67f8575e4 Mon Sep 17 00:00:00 2001 From: istfer Date: Mon, 24 Jun 2019 15:59:38 -0400 Subject: [PATCH 48/56] backbone of read_restart --- models/lpjguess/R/read_restart.LPJGUESS.R | 27 +++++++++++++++++------ models/lpjguess/R/read_state.R | 2 +- 2 files changed, 21 insertions(+), 8 deletions(-) diff --git a/models/lpjguess/R/read_restart.LPJGUESS.R b/models/lpjguess/R/read_restart.LPJGUESS.R index bbac7b3621a..6e19cad8306 100644 --- a/models/lpjguess/R/read_restart.LPJGUESS.R +++ b/models/lpjguess/R/read_restart.LPJGUESS.R @@ -1,11 +1,11 @@ # developing -outdir = "/fs/data2/output//PEcAn_1000010473/out" -runid = 1002656610 -stop.time = "1960-12-31 23:59:59 UTC" -load("/fs/data2/output/PEcAn_1000010473/SDAsettings_develop.Rdata") -var.names = c("AGB.pft", "TotSoilCarb") -load("/fs/data2/output/PEcAn_1000010473/SDAparams_develop.Rdata") +# outdir = "/fs/data2/output//PEcAn_1000010473/out" +# runid = 1002656610 +# stop.time = "1960-12-31 23:59:59 UTC" +# load("/fs/data2/output/PEcAn_1000010473/SDAsettings_develop.Rdata") +# var.names = c("AGB.pft", "TotSoilCarb") +# load("/fs/data2/output/PEcAn_1000010473/SDAparams_develop.Rdata") read_restart.LPJGUESS <- function(outdir, runid, stop.time, settings, var.names, params){ @@ -21,7 +21,20 @@ read_restart.LPJGUESS <- function(outdir, runid, stop.time, settings, var.names, PEcAn.logger::logger.severe("read_binary_LPJGUESS need :", paste(needed_files[!file_check], collapse = " ")) } + # read binary state file, takes a couple of minutes + Gridcell_container <- read_binary_LPJGUESS(outdir = file.path(outdir, runid), + version = lpjguess_ver) + forecast <- list() + # for (var_name in var.names) {} -} \ No newline at end of file + params$LPJGUESS_state <- Gridcell_container + + PEcAn.logger::logger.info("Finished --", runid) + + X_tmp <- list(X = unlist(forecast), params = params) + + return(X_tmp) + +} # read_restart.LPJGUESS \ No newline at end of file diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index 69ebc0aeb05..d569ce7762c 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -401,7 +401,7 @@ library(stringr) # test path -outdir <- "/fs/data2/output/PEcAn_1000010473/out/1002656304" +#outdir <- "/fs/data2/output/PEcAn_1000010473/out/1002656304" # outdir, at least model version, maybe also settings read_binary_LPJGUESS <- function(outdir, version = "PalEON"){ From aa3acf56fde6ca962413fd538eddc5191cdf5c77 Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Mon, 24 Jun 2019 17:11:52 -0400 Subject: [PATCH 49/56] Added HEIGHT_MAX as an argument to over-ride the LPJ-GUESS 150m max height. --- models/lpjguess/R/allometry.LPJGUESS.R | 9 +- models/lpjguess/R/updateState.LPJGUESS.R | 254 ++++++++++++++--------- 2 files changed, 167 insertions(+), 96 deletions(-) diff --git a/models/lpjguess/R/allometry.LPJGUESS.R b/models/lpjguess/R/allometry.LPJGUESS.R index 7db0bcfe05d..130406968f2 100644 --- a/models/lpjguess/R/allometry.LPJGUESS.R +++ b/models/lpjguess/R/allometry.LPJGUESS.R @@ -45,6 +45,9 @@ lambertbeer <- function(lai) { #' @param k_rp,k_allom1,k_allom2,k_allom3, Allometry coefficients (per PFT parameters) #' @param wooddens Wood density (kgC/m^2) (per PFT parameter) #' @param crownarea_max Maximum allowed crown area (m^2) (per PFT parameter) +#' @param HEIGHT_MAX Maximum allowed height of an individual. This is the maximum height that a tree +#' can have. This is hard-coded in LPJ-GUESS to 150 m, but for SDA that might be unrealistically big, +#' so this argument allows adjustment. #' #' This function was transcribed from LPJ-GUESS (v4.0) C++ to R for the purpose of nudging the LPJ-GUESS state offline. #' The idea is of course to use the output from the analysis step from an SDA routine to provide the nudged values, although that isn't @@ -88,7 +91,8 @@ allometry <- function( k_allom2, k_allom3, wooddens, - crownarea_max) { + crownarea_max, + HEIGHT_MAX = 150) { # DESCRIPTION # Calculates tree allometry (height and crown area) and fractional projective @@ -142,7 +146,8 @@ allometry <- function( fpc_new = 0.0 # updated FPC # guess2008 - max tree height allowed (metre). - HEIGHT_MAX = 150.0 + # MF - removed to make this tuneable + # HEIGHT_MAX = 150.0 # MF - added for providing the error code diff --git a/models/lpjguess/R/updateState.LPJGUESS.R b/models/lpjguess/R/updateState.LPJGUESS.R index f64801c611c..0bbebc5f515 100644 --- a/models/lpjguess/R/updateState.LPJGUESS.R +++ b/models/lpjguess/R/updateState.LPJGUESS.R @@ -28,13 +28,16 @@ #' @param cmass.target A numeric vector of the target stand-level biomasses (kgC/m^2) as named numeric vector #' with one entry per PFT/species, with the names being the PFT/species codes. These values should be produced #' using state data assimilation from function XXXXXX +#' @param HEIGHT_MAX Maximum allowed height of an individual. This is the maximum height that a tree +#' can have. This is hard-coded in LPJ-GUESS to 150 m, but for SDA that might be unrealistically big, +#' so this argument allows adjustment. #' @return And updated model state (as a big old list o' lists) #' @export #' @author Matthew Forrest -updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, cmass.initial, cmass.target) { +updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, cmass.initial, cmass.target, HEIGHT_MAX = 150) { # calculate relative increases to be applied later on (per PFT) @@ -103,6 +106,7 @@ updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, cmass.i # for each individual for(individual.counter in 1:this.patch$Vegetation$number_of_individuals) { + # IMPORTANT: note that this is for convenience to *read* variables from the original individual # but it should not be written to. Instead the 'updated.individual' (defined in the loop below) # should be updated and then used to update the main state (model.state) @@ -111,105 +115,167 @@ updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, cmass.i # don't adjust non-alive individuals as they will soon be removed if(original.individual$alive) { + # get the PFT id and check that it is active this.pft.id <- original.individual$indiv.pft.id - #print(paste("PFT id = ", this.pft.id)) - if(!this.pft.id %in% active.PFTs) stop(paste0("Found individual of PFT id = ",this.pft.id, " but this doesn't seem to be active in the LPJ-GUESS run")) - - # STEP 1 - nudge density of stems by adjusting the "densindiv" and also scaling the biomass pools appropriately - updated.individual <- adjustDensity.LPJGUESS(original.individual, dens.rel.change[this.pft.id+1]) - - - # STEP 2 - nudge biomass by performing the LPJ-GUESS allocation routine - - # this function call runs the LPJ-GUESS allocation routine and adjusts the pools vegetation pools accordingly - # however, it doesn't adjust the litter pools or do anything with 'exceeds_cmass', these are returned - # as elements of the list, because they should only be applied to the state *if* this was a valid allocation - updated.list <- adjustBiomass(individual = updated.individual, - rel.change = biomass.rel.change[this.pft.id+1], - sla = sla[this.pft.id+1], - wooddens = wooddens[this.pft.id+1], - lifeform = lifeform[this.pft.id+1], - k_latosa = k_latosa[this.pft.id+1], - k_allom2 = k_allom2[this.pft.id+1], - k_allom3 = k_allom3[this.pft.id+1]) - # extract the elements from the return list - updated.individual <- updated.list[["individual"]] - litter_root_inc <- updated.list[["litter_root_inc"]] - litter_leaf_inc <- updated.list[["litter_leaf_inc"]] - exceeds_cmass <- updated.list[["exceeds_cmass"]] - rm(updated.list) - - - # STEP 3 - calculate the new allometry of the individual based on the updated pools - allometry.results <- allometry( - # initial allometry/pools - cmass_leaf = updated.individual$cmass_leaf, - cmass_sap = updated.individual$cmass_sap, - cmass_heart = updated.individual$cmass_heart, - densindiv = updated.individual$densindiv, - age = updated.individual$age, - fpc = updated.individual$fpc, - deltafpc = updated.individual$deltafpc, - # parameter values - lifeform = lifeform[this.pft.id+1], - sla = sla[this.pft.id+1], - k_latosa = k_latosa[this.pft.id+1], - k_rp = k_rp[this.pft.id+1], - k_allom1 = k_allom1[this.pft.id+1], - k_allom2 = k_allom2[this.pft.id+1], - k_allom3 = k_allom3[this.pft.id+1], - wooddens = wooddens[this.pft.id+1], - crownarea_max = crownarea_max[this.pft.id+1]) - + # initialise the result code to "FIRST" for the first iteration + result.code <- "FIRST" - # STEP 4 - check if new allometry is valid. If yes, update state and move on, - # if not adjust the nudging and start again + # get the target changes in densindiv and cmass + target.biomass.rel.change <- biomass.rel.change[this.pft.id+1] + target.densindiv.rel.change <- dens.rel.change[this.pft.id+1] - # if not okay print a warning, and should actually start another iteration with new multipliers - if(allometry.results$error.string != "OK") { - print(allometry.results$error.string) - - # HERE - - - } - # else update the allometry, save the individual back to the state, update the litter pools, - # deal with exceeds_cmass and finally break - else { - - # first update the allometry - updated.individual$height <- allometry.results$height - updated.individual$crownarea <- allometry.results$crownarea - updated.individual$lai_indiv <- allometry.results$lai_indiv - updated.individual$lai <- allometry.results$lai - updated.individual$deltafpc <- allometry.results$deltafpc - updated.individual$fpc <- allometry.results$fpc - updated.individual$boleht <- allometry.results$boleht - - # save the individual back to the state - model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]] <- updated.individual - - # now the litter pools (determine N based on intial C:N ratio) - # C:N ratios - leaf_litter_cton <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_leaf[[this.pft.id+1]] / model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$nmass_litter_leaf[[this.pft.id+1]] - root_litter_cton <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_root[[this.pft.id+1]] / model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$nmass_litter_root[[this.pft.id+1]] - # update the C pools based on the calculated increments from the allocation call (these will only be non-zero in 'abnormal cases) - model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_leaf[[this.pft.id+1]] <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_leaf[[this.pft.id+1]] + (litter_leaf_inc * updated.individual$densindiv) - model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_root[[this.pft.id+1]] <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_root[[this.pft.id+1]] + (litter_root_inc * updated.individual$densindiv) - # update the N pools simple by dividing the new C pool by the C:N ratio - model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$nmass_litter_leaf[[this.pft.id+1]] <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_leaf[[this.pft.id+1]] / leaf_litter_cton - model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$nmass_litter_root[[this.pft.id+1]] <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_root[[this.pft.id+1]] / root_litter_cton - - # and finally exceeds_cmass - not currently dealing with this because it is only used to maintin mass balance which - # we *probably* don't need to do here, but print a warning if it is non-zero - if(!exceeds_cmass == 0) warning(paste("Non-zero exceeds_cmass following allocation, exceeds_cmass =", exceeds_cmass)) - - - } # if allometry valid + # while loop, break out when code is "OK" + counter <- 0 + while(result.code != "OK") { + + + # 'adjust the adjustment' + + # "FIRST" - the first iteration + if(result.code == "FIRST") { + + # if the biomass nudge is less that 0.75 the allocation will probably fail so increase the biomass + # to 0.75 and increase the stem density accordingly + if(target.biomass.rel.change < 0.75) { + target.overall.rel.change <- target.biomass.rel.change * target.densindiv.rel.change + print(target.overall.rel.change) + current.target.biomass.rel.change <- 0.75 + current.target.densindiv.rel.change <- target.overall.rel.change / current.target.biomass.rel.change + derived.overall.rel.change <- current.target.biomass.rel.change * current.target.densindiv.rel.change + print(derived.overall.rel.change) + + } + else { + current.target.biomass.rel.change <- target.biomass.rel.change + current.target.densindiv.rel.change <- target.densindiv.rel.change + } + + } + # this error normally arises because of a too large negative biomass increment, do here set a softer + # biomass nudge + else if(result.code == "LowWoodDensity"){ + target.overall.rel.change <- target.biomass.rel.change * target.densindiv.rel.change + print(target.overall.rel.change) + current.target.biomass.rel.change <- 0.75 + current.target.densindiv.rel.change <- target.overall.rel.change / current.target.biomass.rel.change + derived.overall.rel.change <- current.target.biomass.rel.change * current.target.densindiv.rel.change + print(derived.overall.rel.change) + } + # in the case individuals (as in each actual tree) get too big, so increase the individual density, + # but this needs to be balanced by the a smaller biomass nudge (do 10% increments) + else if(result.code == "MaxHeightExceeded"){ + + current.target.densindiv.rel.change <- current.target.densindiv.rel.change * 1.1 + current.target.biomass.rel.change <- current.target.biomass.rel.change / 1.1 + print(paste(counter, result.code)) + + } + else if(result.code == "NegligibleLeafMass"){ + target.overall.rel.change <- target.biomass.rel.change * target.densindiv.rel.change + print(target.overall.rel.change) + current.target.biomass.rel.change <- 0.75 + current.target.densindiv.rel.change <- target.overall.rel.change / current.target.biomass.rel.change + derived.overall.rel.change <- current.target.biomass.rel.change * current.target.densindiv.rel.change + print(derived.overall.rel.change) + } + + + + # STEP 1 - nudge density of stems by adjusting the "densindiv" and also scaling the biomass pools appropriately + updated.individual <- adjustDensity.LPJGUESS(original.individual, current.target.densindiv.rel.change) + + + # STEP 2 - nudge biomass by performing the LPJ-GUESS allocation routine + + # this function call runs the LPJ-GUESS allocation routine and adjusts the pools vegetation pools accordingly + # however, it doesn't adjust the litter pools or do anything with 'exceeds_cmass', these are returned + # as elements of the list, because they should only be applied to the state *if* this was a valid allocation + updated.list <- adjustBiomass(individual = updated.individual, + rel.change = current.target.biomass.rel.change, + sla = sla[this.pft.id+1], + wooddens = wooddens[this.pft.id+1], + lifeform = lifeform[this.pft.id+1], + k_latosa = k_latosa[this.pft.id+1], + k_allom2 = k_allom2[this.pft.id+1], + k_allom3 = k_allom3[this.pft.id+1]) + # extract the elements from the return list + updated.individual <- updated.list[["individual"]] + litter_root_inc <- updated.list[["litter_root_inc"]] + litter_leaf_inc <- updated.list[["litter_leaf_inc"]] + exceeds_cmass <- updated.list[["exceeds_cmass"]] + rm(updated.list) + + + # STEP 3 - calculate the new allometry of the individual based on the updated pools + + allometry.results <- allometry( + # initial allometry/pools + cmass_leaf = updated.individual$cmass_leaf, + cmass_sap = updated.individual$cmass_sap, + cmass_heart = updated.individual$cmass_heart, + densindiv = updated.individual$densindiv, + age = updated.individual$age, + fpc = updated.individual$fpc, + deltafpc = updated.individual$deltafpc, + # parameter values + lifeform = lifeform[this.pft.id+1], + sla = sla[this.pft.id+1], + k_latosa = k_latosa[this.pft.id+1], + k_rp = k_rp[this.pft.id+1], + k_allom1 = k_allom1[this.pft.id+1], + k_allom2 = k_allom2[this.pft.id+1], + k_allom3 = k_allom3[this.pft.id+1], + wooddens = wooddens[this.pft.id+1], + crownarea_max = crownarea_max[this.pft.id+1], + HEIGHT_MAX = HEIGHT_MAX) + + + # STEP 4 - check if new allometry is valid. If yes, update state and move on, + # if not adjust the nudging and start again + result.code <- allometry.results$error.string + + # if "OK", update the allometry, save the individual back to the state, update the litter pools, + # deal with exceeds_cmass, the code will break out of the while loop + # if not, there will be a new iteration with new multipliers + if(result.code == "OK") { + + # first update the allometry + updated.individual$height <- allometry.results$height + updated.individual$crownarea <- allometry.results$crownarea + updated.individual$lai_indiv <- allometry.results$lai_indiv + updated.individual$lai <- allometry.results$lai + updated.individual$deltafpc <- allometry.results$deltafpc + updated.individual$fpc <- allometry.results$fpc + updated.individual$boleht <- allometry.results$boleht + + # save the individual back to the state + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Vegetation$Individuals[[individual.counter]] <- updated.individual + + # now the litter pools (determine N based on intial C:N ratio) + # C:N ratios + leaf_litter_cton <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_leaf[[this.pft.id+1]] / model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$nmass_litter_leaf[[this.pft.id+1]] + root_litter_cton <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_root[[this.pft.id+1]] / model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$nmass_litter_root[[this.pft.id+1]] + # update the C pools based on the calculated increments from the allocation call (these will only be non-zero in 'abnormal cases) + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_leaf[[this.pft.id+1]] <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_leaf[[this.pft.id+1]] + (litter_leaf_inc * updated.individual$densindiv) + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_root[[this.pft.id+1]] <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_root[[this.pft.id+1]] + (litter_root_inc * updated.individual$densindiv) + # update the N pools simple by dividing the new C pool by the C:N ratio + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$nmass_litter_leaf[[this.pft.id+1]] <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_leaf[[this.pft.id+1]] / leaf_litter_cton + model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$nmass_litter_root[[this.pft.id+1]] <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]]$Patchpft$litter_root[[this.pft.id+1]] / root_litter_cton + + # and finally exceeds_cmass - not currently dealing with this because it is only used to maintin mass balance which + # we *probably* don't need to do here, but print a warning if it is non-zero + if(!exceeds_cmass == 0) warning(paste("Non-zero exceeds_cmass following allocation, exceeds_cmass =", exceeds_cmass)) + + + } # if allometry valid + + counter <- counter + 1 + + } # while code is not "OK" } # if individual is alive @@ -221,7 +287,7 @@ updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, cmass.i - # STEP 6 - introduce new individuals to represent PFTs present in data but not in the model output + # TODO MISSING - introduce new individuals to represent PFTs present in data but not in the model output return(model.state) From 49085a5ac1fe7ca4edb3893fc2fec148003edd45 Mon Sep 17 00:00:00 2001 From: istfer Date: Tue, 25 Jun 2019 16:58:37 -0400 Subject: [PATCH 50/56] start split inputs for LPJGUESS --- models/lpjguess/R/split_inputs.LPJGUESS.R | 135 ++++++++++++++++++++++ 1 file changed, 135 insertions(+) create mode 100644 models/lpjguess/R/split_inputs.LPJGUESS.R diff --git a/models/lpjguess/R/split_inputs.LPJGUESS.R b/models/lpjguess/R/split_inputs.LPJGUESS.R new file mode 100644 index 00000000000..7f4c1e48bd1 --- /dev/null +++ b/models/lpjguess/R/split_inputs.LPJGUESS.R @@ -0,0 +1,135 @@ + +# developing +# settings = settings +# start.time = "1920-01-01 UTC" +# stop.time = "1960-12-31 UTC" +# inputs = "/fs/data3/istfer/LPJGUESS_ShortRuns/LPJGUESS_bcc-csm1-1_031.03/bcc-csm1-1_031.03.1960.2010.tmp.nc" +# overwrite = F + +split_inputs.LPJGUESS <- function(settings, start.time, stop.time, inputs, overwrite = FALSE, outpath = NULL, version = "PalEON"){ + + #### Lubridate start and end times + start.day <- lubridate::yday(start.time) + start.year <- lubridate::year(start.time) + end.day <- lubridate::yday(stop.time) + end.year <- lubridate::year(stop.time) + + # Whole run period + run.start <- lubridate::year(settings$run$start.date) + run.end <- lubridate::year(settings$run$end.date) + + #### Get met paths + met <- inputs + path <- dirname(met) + prefix <- substr(basename(met), 1, nchar(basename(met))-16) #assuming we'll always have "PREFIX.1920.2010.tmp" + if(is.null(outpath)){ + outpath <- path + } + if(!dir.exists(outpath)) dir.create(outpath) + + var.names <- c("tmp", "pre", "cld") + long.names <- c("air_temperature", + "precipitation_flux", + "surface_downwelling_shortwave_flux_in_air") + + # !!! always full years with LPJ-GUESS !!! + files.in <- file.path(outpath, paste0(prefix, run.start, ".", run.end, ".", var.names, ".nc")) + files.out <- file.path(outpath, paste0(prefix, start.year, ".", end.year, ".", var.names, ".nc")) + + if(file.exists(files.out[1]) & !overwrite){ + return(files.out[1]) + } + + ## open netcdf files + fnc.tmp <- ncdf4::nc_open(files.in[1]) + fnc.pre <- ncdf4::nc_open(files.in[2]) + fnc.cld <- ncdf4::nc_open(files.in[3]) + + ## read climate data + nc.tmp <- ncdf4::ncvar_get(fnc.tmp, var.names[1]) + nc.pre <- ncdf4::ncvar_get(fnc.pre, var.names[2]) + nc.cld <- ncdf4::ncvar_get(fnc.cld, var.names[3]) + + # cut where + if(start.year == run.start){ + years <- start.year:end.year + inds <- 1:sum(days_in_year(years)) + }else{ + ### come back + } + + # split + if(version != "PalEON"){ + nc.tmp <- nc.tmp[1,1,inds] + nc.pre <- nc.pre[1,1,inds] + nc.cld <- nc.cld[1,1,inds] + }else{ + nc.tmp <- nc.tmp[inds] + nc.pre <- nc.pre[inds] + nc.cld <- nc.cld[inds] + } + + + var.list <- list(nc.tmp, nc.pre, nc.cld) + + # not that these will be different than "K", "kg m-2 s-1", "W m-2" + var.units <- c(fnc.tmp$var$tmp$units, + fnc.pre$var$pre$units, + fnc.cld$var$cld$units) + + # get other stuff to be written to ncdf + + ## retrieve lat/lon + lon <- ncdf4::ncvar_get(fnc.tmp, "lon") + lat <- ncdf4::ncvar_get(fnc.tmp, "lat") + + # write back + ## write climate data define dimensions + + latdim <- ncdf4::ncdim_def(name = "lat", "degrees_north", as.double(lat)) + londim <- ncdf4::ncdim_def(name = "lon", "degrees_east", as.double(lon)) + timedim <- ncdf4::ncdim_def("time", paste0("days since ", start.year - 1, "-12-31", sep = ""), as.double(c(1:length(nc.tmp)))) + + fillvalue <- 9.96920996838687e+36 + + for (n in seq_along(var.names)) { + # define variable + var.def <- ncdf4::ncvar_def(name = var.names[n], + units = var.units[n], + dim = (list(londim, latdim, timedim)), + fillvalue, long.names[n], + verbose = FALSE, + prec = "float") + + # create netCD file for LPJ-GUESS + ncfile <- ncdf4::nc_create(files.out[[n]], vars = var.def, force_v4 = TRUE) + + if(version != "PalEON"){ + # put variable, rep(...,each=4) is a hack to write the same data for all grids (which all are the + # same) + ncdf4::ncvar_put(ncfile, var.def, rep(var.list[[n]], each = 4)) + }else{ + ncdf4::ncvar_put(ncfile, var.def, var.list[[n]]) + } + + # additional attributes for LPJ-GUESS + ncdf4::ncatt_put(nc = ncfile, varid = var.names[n], attname = "standard_name", long.names[n]) + + ncdf4::ncatt_put(nc = ncfile, varid = "lon", attname = "axis", "X") + ncdf4::ncatt_put(nc = ncfile, varid = "lon", attname = "standard_name", "longitude") + + ncdf4::ncatt_put(nc = ncfile, varid = "lat", attname = "axis", "Y") + ncdf4::ncatt_put(nc = ncfile, varid = "lat", attname = "standard_name", "latitude") + + ncdf4::ncatt_put(nc = ncfile, varid = "time", attname = "calendar", "gregorian") + + ncdf4::nc_close(ncfile) + } + + # close nc + ncdf4::nc_close(fnc.tmp) + ncdf4::nc_close(fnc.pre) + ncdf4::nc_close(fnc.cld) + + return(files.out[1]) +} # split_inputs.LPJGUESS \ No newline at end of file From 90c4c071fd71d781770fecf515dfaa8604d19a79 Mon Sep 17 00:00:00 2001 From: istfer Date: Wed, 26 Jun 2019 12:55:36 -0400 Subject: [PATCH 51/56] number of individuals are back --- models/lpjguess/R/read_state.R | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index d569ce7762c..0603c6c8bee 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -681,14 +681,15 @@ read_binary_LPJGUESS <- function(outdir, version = "PalEON"){ # nobj points to different things under different levels, here it is the number of individuals number_of_individuals <- readBin(zz, integer(), 1, size = 4) + Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]] <- list() Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["number_of_individuals"]] <- number_of_individuals # few checks for sensible vals - if(number_of_individuals < 1 | number_of_individuals > 10000){ # should there be an upper limit here too? + if(number_of_individuals < 0 | number_of_individuals > 10000){ # should there be an upper limit here too? # if number of individuals is 0 it's a bit suspicious. Not sure if ever will get negative but that'd definitely be wrong PEcAn.logger::logger.warn("Number of individuals under vegetation is", number_of_individuals) } - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]] <- list() + #Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]] <- list() Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]] <- vector("list", number_of_individuals) beg_end <- serialize_starts_ends(file_in = guesscpp_in, @@ -1080,6 +1081,9 @@ read_binary_LPJGUESS <- function(outdir, version = "PalEON"){ } # Gridcell-loop ends close(zz) + + Gridcell$meta_data <- meta_data + return(Gridcell) } # read_binary_LPJGUESS end From a0572c014c40483b3b41be13c6cd4820d762ee38 Mon Sep 17 00:00:00 2001 From: Matthew Forrest Date: Thu, 27 Jun 2019 10:44:53 -0400 Subject: [PATCH 52/56] Just coding style --- models/lpjguess/NAMESPACE | 2 +- ...s.LPJGUESS.R => adjust.biomass.LPJGUESS.R} | 58 +- ...y.LPJGUESS.R => adjust.density.LPJGUESS.R} | 26 +- models/lpjguess/R/allocation.LPJGUESS.R | 4 +- models/lpjguess/R/allometry.LPJGUESS.R | 94 +- ...calculateGridcellVariablePerPFT.LPJGUESS.R | 90 +- models/lpjguess/R/read_state.R | 1910 ++++++++--------- ...ate.LPJGUESS.R => update.state.LPJGUESS.R} | 75 +- ...tBiomass.Rd => adjust.biomass.LPJGUESS.Rd} | 10 +- ...LPJGUESS.Rd => adjust.density.LPJGUESS.Rd} | 8 +- models/lpjguess/man/allometry.Rd | 8 +- ...e.LPJGUESS.Rd => update.state.LPJGUESS.Rd} | 14 +- 12 files changed, 1170 insertions(+), 1129 deletions(-) rename models/lpjguess/R/{adjustBiomass.LPJGUESS.R => adjust.biomass.LPJGUESS.R} (72%) rename models/lpjguess/R/{adjustDensity.LPJGUESS.R => adjust.density.LPJGUESS.R} (71%) rename models/lpjguess/R/{updateState.LPJGUESS.R => update.state.LPJGUESS.R} (83%) rename models/lpjguess/man/{adjustBiomass.Rd => adjust.biomass.LPJGUESS.Rd} (89%) rename models/lpjguess/man/{adjustDensity.LPJGUESS.Rd => adjust.density.LPJGUESS.Rd} (76%) rename models/lpjguess/man/{updateState.LPJGUESS.Rd => update.state.LPJGUESS.Rd} (75%) diff --git a/models/lpjguess/NAMESPACE b/models/lpjguess/NAMESPACE index f3715657a52..1b374965b8a 100644 --- a/models/lpjguess/NAMESPACE +++ b/models/lpjguess/NAMESPACE @@ -5,7 +5,7 @@ export(met2model.LPJGUESS) export(model2netcdf.LPJGUESS) export(pecan2lpjguess) export(readStateBinary) -export(updateState.LPJGUESS) +export(update.state.LPJGUESS) export(write.config.LPJGUESS) export(write.insfile.LPJGUESS) importFrom(Rcpp,sourceCpp) diff --git a/models/lpjguess/R/adjustBiomass.LPJGUESS.R b/models/lpjguess/R/adjust.biomass.LPJGUESS.R similarity index 72% rename from models/lpjguess/R/adjustBiomass.LPJGUESS.R rename to models/lpjguess/R/adjust.biomass.LPJGUESS.R index 6de1a87715f..924adb2510c 100644 --- a/models/lpjguess/R/adjustBiomass.LPJGUESS.R +++ b/models/lpjguess/R/adjust.biomass.LPJGUESS.R @@ -7,35 +7,35 @@ # http://opensource.ncsa.illinois.edu/license.html #------------------------------------------------------------------------------- -#' Adjust LPJ-GUESS individual's biomass -#' -#' This function adjusts an LPJ-GUESS individual by calling the LPJ-GUESS allocation function (compiled C++) -#' with a given biomass change. It updates the individual biomass pools directly, and also returns, in a list further -#' adjustments to the litter pools. -#' -#' @param individual A nested list which encapsulates an LPJ-GUESS 'Individual' as read from a binary state file -#' @param rel.change A numeric by which to scale the density and C and N pools -#' @param sla The SLA (specific leaf area) (per PFT parameter) -#' @param k_latosa The leaf area to sapwood area ratio (per PFT parameter) -#' @param k_allom2,k_allom3, Allometry coefficients (per PFT parameters) -#' @param wooddens Wood density (kgC/m^2) (per PFT parameter) -#' @param crownarea_max Maximum allowed crown area (m^2) (per PFT parameter) -#' @param lifeform An integer code for the lifeform of this individual (cohort): 1 = Tree, 2 = Grass -#' -#' The changes in C pools are determined by the allocation. The changes in the N pools are designed to -#' maintain the pre-exisiing C:N ratios, so N is just scaled using the updated C with the initial C:N ratio. -#' The N storage pools (nstore_longterm and nstore_labile) don't have pre-existing C:N ratios, so they are -#' just scaled by the overall biomass change (the 'rel.change' argument to the function). -#' -#' Note that after this function is called the function \code{allometry} should be used to update the individual -#' and to check that the newly updated individual has a 'valid' allometry. The litter pools should also be updated. -#' This is implemented in the \code{updateState} function following the call to this \code{adjustBiomass} function. -#' -#' -#' @keywords internal -#' @return the scaled 'individual' (the initial nested list with update values) -#' @author Matthew Forrest -adjustBiomass <- function(individual, rel.change, sla, wooddens, lifeform, k_latosa, k_allom2, k_allom3){ +##' Adjust LPJ-GUESS individual's biomass +##' +##' This function adjusts an LPJ-GUESS individual by calling the LPJ-GUESS allocation function (compiled C++) +##' with a given biomass change. It updates the individual biomass pools directly, and also returns, in a list further +##' adjustments to the litter pools. +##' +##' @param individual A nested list which encapsulates an LPJ-GUESS 'Individual' as read from a binary state file +##' @param rel.change A numeric by which to scale the density and C and N pools +##' @param sla The SLA (specific leaf area) (per PFT parameter) +##' @param k_latosa The leaf area to sapwood area ratio (per PFT parameter) +##' @param k_allom2,k_allom3, Allometry coefficients (per PFT parameters) +##' @param wooddens Wood density (kgC/m^2) (per PFT parameter) +##' @param crownarea_max Maximum allowed crown area (m^2) (per PFT parameter) +##' @param lifeform An integer code for the lifeform of this individual (cohort): 1 = Tree, 2 = Grass +##' +##' The changes in C pools are determined by the allocation. The changes in the N pools are designed to +##' maintain the pre-exisiing C:N ratios, so N is just scaled using the updated C with the initial C:N ratio. +##' The N storage pools (nstore_longterm and nstore_labile) don't have pre-existing C:N ratios, so they are +##' just scaled by the overall biomass change (the 'rel.change' argument to the function). +##' +##' Note that after this function is called the function \code{allometry} should be used to update the individual +##' and to check that the newly updated individual has a 'valid' allometry. The litter pools should also be updated. +##' This is implemented in the \code{updateState} function following the call to this \code{adjustBiomass} function. +##' +##' +##' @keywords internal +##' @return the scaled 'individual' (the initial nested list with update values) +##' @author Matthew Forrest +adjust.biomass.LPJGUESS <- function(individual, rel.change, sla, wooddens, lifeform, k_latosa, k_allom2, k_allom3){ # dummy input values to the allocation function below # note that they are not actually updated by the function, the updated values are in the returned list diff --git a/models/lpjguess/R/adjustDensity.LPJGUESS.R b/models/lpjguess/R/adjust.density.LPJGUESS.R similarity index 71% rename from models/lpjguess/R/adjustDensity.LPJGUESS.R rename to models/lpjguess/R/adjust.density.LPJGUESS.R index 22ad8cbcf4b..df8710c405a 100644 --- a/models/lpjguess/R/adjustDensity.LPJGUESS.R +++ b/models/lpjguess/R/adjust.density.LPJGUESS.R @@ -7,19 +7,19 @@ # http://opensource.ncsa.illinois.edu/license.html #------------------------------------------------------------------------------- -#' Adjust LPJ-GUESS individual's density -#' -#' Very simple function that just scales the density of individuals and the associated C and N pools -#' by a relative amount -#' -#' @param individual A nested list which encapsulates an LPJ-GUESS 'Individual' as read from a binary state file -#' @param rel.change A numeric by which to scale the density and C and N pools -#' -#' -#' @keywords internal -#' @return the scaled 'individual' (the initial nested list with update values) -#' @author Matthew Forrest -adjustDensity.LPJGUESS <- function(individual, rel.change) { +##' Adjust LPJ-GUESS individual's density +##' +##' Very simple function that just scales the density of individuals and the associated C and N pools +##' by a relative amount +##' +##' @param individual A nested list which encapsulates an LPJ-GUESS 'Individual' as read from a binary state file +##' @param rel.change A numeric by which to scale the density and C and N pools +##' +##' +##' @keywords internal +##' @return the scaled 'individual' (the initial nested list with update values) +##' @author Matthew Forrest +adjust.density.LPJGUESS <- function(individual, rel.change) { # the density individual$densindiv <- individual$densindiv * rel.change diff --git a/models/lpjguess/R/allocation.LPJGUESS.R b/models/lpjguess/R/allocation.LPJGUESS.R index def276d3de8..95deefe5c44 100644 --- a/models/lpjguess/R/allocation.LPJGUESS.R +++ b/models/lpjguess/R/allocation.LPJGUESS.R @@ -1,5 +1,5 @@ -#' @useDynLib PEcAn.LPJGUESS -#' @importFrom Rcpp sourceCpp +##' @useDynLib PEcAn.LPJGUESS +##' @importFrom Rcpp sourceCpp NULL # compile the LPJ-GUESS allocation function using Rcpp diff --git a/models/lpjguess/R/allometry.LPJGUESS.R b/models/lpjguess/R/allometry.LPJGUESS.R index 130406968f2..499a72307bb 100644 --- a/models/lpjguess/R/allometry.LPJGUESS.R +++ b/models/lpjguess/R/allometry.LPJGUESS.R @@ -2,14 +2,14 @@ # NEGLIGABLE # Returns true if |dval| < exp(limit), otherwise false -#' @keywords internal +##' @keywords internal negligible <- function(dval, limit = -30) { if(abs(dval) < exp(limit)) return(TRUE) else return(FALSE) } # LAMBERT-BEER -#' @keywords internal +##' @keywords internal lambertbeer <- function(lai) { return(exp(-.5 * lai)) } @@ -28,51 +28,51 @@ lambertbeer <- function(lai) { # // Should be called to update allometry, FPC and FPC increment whenever biomass values # // for a vegetation individual (cohort) change. -#' LPJ-GUESS allometry -#' -#' The LPJ-GUESS allometry function transcribed into R. -#' -#' @param lifeform An integer code for the lifeform of this individual (cohort): 1 = Tree, 2 = Grass -#' @param cmass_leaf The leaf C pool size (kgC/m^2) -#' @param cmass_sap The sapwood C pool size (kgC/m^2) -#' @param cmass_heart The heartwood C pool size (kgC/m^2) -#' @param densindiv The density of individuals in the cohort (indiv/m^2) -#' @param age The age of the coort -#' @param fpc The folar projective cover -#' @param deltafpc The change in foliar projective cover -#' @param sla The SLA (specific leaf area) (per PFT parameter) -#' @param k_latosa The leaf area to sapwood area ratio (per PFT parameter) -#' @param k_rp,k_allom1,k_allom2,k_allom3, Allometry coefficients (per PFT parameters) -#' @param wooddens Wood density (kgC/m^2) (per PFT parameter) -#' @param crownarea_max Maximum allowed crown area (m^2) (per PFT parameter) -#' @param HEIGHT_MAX Maximum allowed height of an individual. This is the maximum height that a tree -#' can have. This is hard-coded in LPJ-GUESS to 150 m, but for SDA that might be unrealistically big, -#' so this argument allows adjustment. -#' -#' This function was transcribed from LPJ-GUESS (v4.0) C++ to R for the purpose of nudging the LPJ-GUESS state offline. -#' The idea is of course to use the output from the analysis step from an SDA routine to provide the nudged values, although that isn't -#' relevant to the following code. -#' -#' Since the original C++ code took as its only argument an LPJ-GUESS C++ class of type 'Individual' there was no way (to my knowledge) -#' of directly compiling using Rcpp (unlike for allocation.cpp/allocation.R. which was easy to compile from the native C++ using -#' Rcpp with very few changes). -#' -#' As noted in the original function header taken from the the C++ code (copied above), this function should be run after its biomass values -#' have been updated. In this case that means after the allocation() function has been applied to an individual. -#' -#' This function can return following error codes: -#' 1. "NegligibleLeafMass" - The individual has negligible leaf biomass. -#' 2. "MaxHeightExceeded" - The indidual exceeds the maximum allowed height -#' 3. "LowWoodDensity" - The individual's *actual* wood density drops below 90% of prescribed value. This (slighty weird -#' and unphysical) requirement is necessary because sometimes LPJ-GUESS can take carbon from the heartwood to -#' ensure C-balance. I think. Or some other hockery-pockery. -#' -#' If all is well the code is simply "OK". -#' -#' @keywords internal -#' @return A named list of updated state variables for the individual/cohort. The first value in the list is the error code. -#' @author Matthew Forrest -#' +##' LPJ-GUESS allometry +##' +##' The LPJ-GUESS allometry function transcribed into R. +##' +##' @param lifeform An integer code for the lifeform of this individual (cohort): 1 = Tree, 2 = Grass +##' @param cmass_leaf The leaf C pool size (kgC/m^2) +##' @param cmass_sap The sapwood C pool size (kgC/m^2) +##' @param cmass_heart The heartwood C pool size (kgC/m^2) +##' @param densindiv The density of individuals in the cohort (indiv/m^2) +##' @param age The age of the coort +##' @param fpc The folar projective cover +##' @param deltafpc The change in foliar projective cover +##' @param sla The SLA (specific leaf area) (per PFT parameter) +##' @param k_latosa The leaf area to sapwood area ratio (per PFT parameter) +##' @param k_rp,k_allom1,k_allom2,k_allom3, Allometry coefficients (per PFT parameters) +##' @param wooddens Wood density (kgC/m^2) (per PFT parameter) +##' @param crownarea_max Maximum allowed crown area (m^2) (per PFT parameter) +##' @param HEIGHT_MAX Maximum allowed height of an individual. This is the maximum height that a tree +##' can have. This is hard-coded in LPJ-GUESS to 150 m, but for SDA that might be unrealistically big, +##' so this argument allows adjustment. +##' +##' This function was transcribed from LPJ-GUESS (v4.0) C++ to R for the purpose of nudging the LPJ-GUESS state offline. +##' The idea is of course to use the output from the analysis step from an SDA routine to provide the nudged values, although that isn't +##' relevant to the following code. +##' +##' Since the original C++ code took as its only argument an LPJ-GUESS C++ class of type 'Individual' there was no way (to my knowledge) +##' of directly compiling using Rcpp (unlike for allocation.cpp/allocation.R. which was easy to compile from the native C++ using +##' Rcpp with very few changes). +##' +##' As noted in the original function header taken from the the C++ code (copied above), this function should be run after its biomass values +##' have been updated. In this case that means after the allocation() function has been applied to an individual. +##' +##' This function can return following error codes: +##' 1. "NegligibleLeafMass" - The individual has negligible leaf biomass. +##' 2. "MaxHeightExceeded" - The indidual exceeds the maximum allowed height +##' 3. "LowWoodDensity" - The individual's *actual* wood density drops below 90% of prescribed value. This (slighty weird +##' and unphysical) requirement is necessary because sometimes LPJ-GUESS can take carbon from the heartwood to +##' ensure C-balance. I think. Or some other hockery-pockery. +##' +##' If all is well the code is simply "OK". +##' +##' @keywords internal +##' @return A named list of updated state variables for the individual/cohort. The first value in the list is the error code. +##' @author Matthew Forrest +##' allometry <- function( # initial allometry/pools lifeform, diff --git a/models/lpjguess/R/calculateGridcellVariablePerPFT.LPJGUESS.R b/models/lpjguess/R/calculateGridcellVariablePerPFT.LPJGUESS.R index 6da7278b35d..72fa673a807 100644 --- a/models/lpjguess/R/calculateGridcellVariablePerPFT.LPJGUESS.R +++ b/models/lpjguess/R/calculateGridcellVariablePerPFT.LPJGUESS.R @@ -8,20 +8,20 @@ #------------------------------------------------------------------------------- -#' @title calculateGridcellVariablePerPFT -#' -#' @description Calculates a per-PFT, gridcell-summed quantity from the LPJ-GUESS state, correctly averaging over patches. -#' This should be put into the SDA procedure. -#' -#' -#' @param model.state A large multiply-nested list containing the entire LPJ-GUESS state as read by -#' function \code{readStateBinary.LPJGUESS} -#' @param variable A character string specifying what variable to extract. This can be chosen based on the LPJ-GUESS variable name -#' as recorded in the big list of list (that represents describes the model state in R). Once special case is "biomass" which -#' returns the sum of "cmass_leaf", "cmass_root", "cmass_sap" and "cmass_heart" -#' @return A numeric vector, with one entry per PFT -#' @export -#' @author Matthew Forrest +##' @title calculateGridcellVariablePerPFT +##' +##' @description Calculates a per-PFT, gridcell-summed quantity from the LPJ-GUESS state, correctly averaging over patches. +##' This should be put into the SDA procedure. +##' +##' +##' @param model.state A large multiply-nested list containing the entire LPJ-GUESS state as read by +##' function \code{readStateBinary.LPJGUESS} +##' @param variable A character string specifying what variable to extract. This can be chosen based on the LPJ-GUESS variable name +##' as recorded in the big list of list (that represents describes the model state in R). Once special case is "biomass" which +##' returns the sum of "cmass_leaf", "cmass_root", "cmass_sap" and "cmass_heart" +##' @return A numeric vector, with one entry per PFT +##' @export +##' @author Matthew Forrest calculateGridcellVariablePerPFT <- function(model.state, variable) { # nstands - should always be 1 but lets make sure @@ -44,43 +44,66 @@ calculateGridcellVariablePerPFT <- function(model.state, variable) { # arrays to store the aggregated gridcell level properties gc.sum <- numeric(length(model.state$Stand[[stand.counter]]$Standpft$active)) - - + # loop through each patch + print(length(model.state$Stand[[stand.counter]]$Patch)) for(patch.counter in 1:npatches) { + + print("-------------------------------------------------------------------------------------") + print(paste("-------------------------------- PATCH ", patch.counter, " -------------------------------------")) + print("-------------------------------------------------------------------------------------") + + this.patch <- model.state$Stand[[stand.counter]]$Patch[[patch.counter]] # pull out the number of individuals and a list of them - nindividuals <- this.patch$Vegetation$number_of_individuals + nindividuals <- length(this.patch$Vegetation) all.individuals <- this.patch$Vegetation$Individuals # for each individual for(individual.counter in 1:length(all.individuals)) { this.individual <- all.individuals[[individual.counter]] - + + # print(paste("id = ", this.individual$indiv.pft.id)) + # print(paste("leaf =" , this.individual$cmass_leaf)) + # print(paste("root =" , this.individual$cmass_root)) + # print(paste("sap =" , this.individual$cmass_sap)) + # print(paste("heart =" , this.individual$cmass_heart)) + # print(paste("debt =" , this.individual$cmass_debt)) + print(paste("alive =" , this.individual$alive)) + print(individual.counter) + if(this.individual$alive) { + # get the PFT ID this.pft.id <- this.individual$indiv.pft.id - if(!this.pft.id %in% active.PFTs) stop(paste0("Found individual of PFT id = ",this.pft.id, " but this doesn't seem to be active in the LPJ-GUESS run")) + + # covert the PFT from '0-indexed' C++ style to '1-indexed' R style + pft.index <- this.pft.id+1 + # calculate the total cmass and density of individuals per PFT if(variable == "cmass") { - gc.sum[this.pft.id+1] <- gc.sum[this.pft.id+1] + ((this.individual$cmass_leaf+this.individual$cmass_root+ - this.individual$cmass_heart+this.individual$cmass_sap-this.individual$cmass_debt)/npatches) - - #print(paste("leaf =" , this.individual$cmass_leaf)) - #print(paste("root =" , this.individual$cmass_root)) - #print(paste("sap =" , this.individual$cmass_sap)) - #print(paste("heart =" , this.individual$cmass_heart)) - #print(paste("id = ", this.individual$indiv.pft.id, "debt =" , this.individual$cmass_debt)) + gc.sum[pft.index] <- gc.sum[pft.index] + (this.individual$cmass_leaf+this.individual$cmass_root+this.individual$cmass_heart+this.individual$cmass_sap-this.individual$cmass_debt)/npatches + + + print(paste("id = ", this.individual$indiv.pft.id)) + print(paste("leaf =" , this.individual$cmass_leaf)) + print(paste("root =" , this.individual$cmass_root)) + print(paste("sap =" , this.individual$cmass_sap)) + print(paste("heart =" , this.individual$cmass_heart)) + print(paste("debt =" , this.individual$cmass_debt)) + + print(gc.sum) + } else if(variable == "nmass") { - gc.sum[this.pft.id+1] <- gc.sum[this.pft.id+1] + ((this.individual$nmass_leaf+this.individual$nmass_root+this.individual$nmass_heart+ + gc.sum[pft.index] <- gc.sum[pft.index] + ((this.individual$nmass_leaf+this.individual$nmass_root+this.individual$nmass_heart+ this.individual$nmass_sap+this.individual$nstore_labile+this.individual$nstore_longterm)/npatches) - #gc.sum[this.pft.id+1] <- gc.sum[this.pft.id+1] + ((this.individual$nmass_leaf+this.individual$nmass_root+this.individual$nmass_heart+ + #gc.sum[pft.index] <- gc.sum[pft.index] + ((this.individual$nmass_leaf+this.individual$nmass_root+this.individual$nmass_heart+ # this.individual$nmass_sap)/npatches) @@ -90,7 +113,7 @@ calculateGridcellVariablePerPFT <- function(model.state, variable) { #print(paste("heart =" , this.individual$nmass_heart)) } - else gc.sum[this.pft.id+1] <- gc.sum[this.pft.id+1] + (this.individual[[variable]]/npatches) + else gc.sum[pft.index] <- gc.sum[pft.index] + (this.individual[[variable]]/npatches) } @@ -101,9 +124,12 @@ calculateGridcellVariablePerPFT <- function(model.state, variable) { } - return(gc.sum) + - } + } + + return(gc.sum) + } diff --git a/models/lpjguess/R/read_state.R b/models/lpjguess/R/read_state.R index 515510ba217..8f1df550fc8 100644 --- a/models/lpjguess/R/read_state.R +++ b/models/lpjguess/R/read_state.R @@ -1,955 +1,955 @@ -######################## Helper functions ######################## - - -# helper function that lists streamed variables, it just returns the names, types are checked by other fucntion -find_stream_var <- function(file_in, line_nos){ - - streaming_list <- list() - str.i <- 1 - when_here <- NULL - not_skipping <- TRUE - - i <- line_nos[1] - repeat{ - i <- i + 1 - if(!is.null(when_here)){ - if(i == when_here){ - i <- skip_to - when_here <- NULL - } - } - - # some functions (Vegetation, Patch, Stand, Gridcell) have two modes: saving / reading - # we only need the stream that is saved - if(grepl("arch.save()", file_in[i])){ - when_here <- find_closing("}", i, file_in) - skip_to <- find_closing("}", i, file_in, if_else_check = TRUE) - } - - # all streams start with arch & - if(grepl("arch & ", file_in[i])){ - # get variable name - streaming_list[[str.i]] <- sub(".*arch & ", "", file_in[i]) # always one var after arch? - str.i <- str.i + 1 - # check for ampersand for the subsequent variable names - repeat{ - i <- i + 1 - if(!is.null(when_here)){ - if(i == when_here){ - i <- skip_to - when_here <- NULL - } - } - check1 <- !grepl(".*& ", file_in[i]) # when there are no subsequent stream - check2 <- !grepl(".*& ", file_in[i+1]) # sometimes following line is empty or commented, check the next one too - if(check1 & !check2) i <- i+1 - if(check1 & check2) break # looks like there are no subsequent stream - this_line <- gsub("[[:space:]]", "", strsplit(file_in[i], "& ")[[1]]) - for(var in this_line){ - if(var != ""){ - if(var != "arch"){ - streaming_list[[str.i]] <- var - str.i <- str.i + 1 - } - } - } - if(!is.null(when_here)){ # now that increased i check this just in case - if(i == when_here){ - i <- skip_to - when_here <- NULL - } - } - } - } - if(i == line_nos[2]) break - } - - #unlist and nix the ; - returnin_stream <- gsub(";", "", unlist(streaming_list), fixed = TRUE) - return(returnin_stream) -} # find_stream_var - - - -# helper function that scans LPJ-GUESS that returns the beginning and the ending lines of serialized object -serialize_starts_ends <- function(file_in, pattern = "void Gridcell::serialize"){ - # find the starting line from the given pattern - starting_line <- which(!is.na(str_match(file_in, pattern))) - if(length(starting_line) != 1){ # check what's going on - PEcAn.logger::logger.severe("Couldn't find the starting line with this pattern ***",pattern, "***.") - } - - # screen for the closing curly bracket after function started - # keep track of opening-closing brackets - ending_line <- find_closing(find = "}", starting_line, file_in) - - return(c(starting_line, ending_line)) -} # serialize_starts_ends - - -# helper function that finds the closing bracket, can work over if-else -find_closing <- function(find = "}", line_no, file_in, if_else_check = FALSE){ - opened <- 1 - closed <- 0 - if(find == "}"){ - start_char <- "{" - end_char <- "}" - }else{ - #there can be else-ifs, find closing paranthesis / square breacket etc - } - - # check the immediate line and return if closed there already - if(grepl(end_char, file_in[line_no], fixed = TRUE)) return(line_no) - - repeat{ - line_no <- line_no + 1 - if(grepl(start_char, file_in[line_no], fixed = TRUE)) opened <- opened + 1 - if(grepl(end_char, file_in[line_no], fixed = TRUE)) closed <- closed + 1 - if(if_else_check){ - else_found <- FALSE - same_line_check <- grepl("else", file_in[line_no], fixed = TRUE) #same line - next_line_check <- grepl("else", file_in[line_no + 1], fixed = TRUE) #next line - if(same_line_check | next_line_check){ - closed <- closed - 1 - if(next_line_check) line_no <- line_no + 1 - } - } - if(opened == closed) break - } - return(line_no) -} # find_closing - - -#' @export -# helper function that determines the stream size to read -find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS){ - - possible_types <- c("double ", "bool ", "int " , "long ") # space because these can be part of other words - possible_types <- c(possible_types, LPJ_GUESS_TYPES) - n_sizes <- c(8, 1, 4, 8, rep(4, length(LPJ_GUESS_TYPES) )) - rbin_tbl <- c("double", "logical", "integer", "integer", rep("integer", length(LPJ_GUESS_TYPES))) - - specs <- list() - - sub_string <- current_stream_type$substring - - #is there a ; immediately after? - if(grepl(paste0(current_stream_type$type, " ", current_stream_type$name, ";"), sub_string, fixed = TRUE) | - grepl(paste0(current_stream_type$type, " ", current_stream_type$name, ","), sub_string, fixed = TRUE)){ # e.g. "double alag, exp_alag;" - # this is only length 1 - specs$n <- 1 - specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$single <- TRUE - - }else if(current_stream_type$type == "Historic"){ - possible_types <- c("double", "bool", "int" , "long") # # I haven't seen any Historic that doesn't store double but... historic has a comma after type: double, - possible_types <- c(possible_types, LPJ_GUESS_TYPES) - - # Historic types are special to LPJ-GUESS - # They have stored values, current index, and a boolean in that order - specs$n <- specs$what <- specs$size <- specs$names <- rep(NA, 3) - # always three, this is a type defined in guessmath.h - specs$what[1] <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$size[1] <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$names[1] <- current_stream_type$name - # n is tricky, it can be hardcoded it can be one of the const ints - to_read <- str_match(sub_string, paste0("Historic<", specs$what[1], ", (.*?)>.*"))[,2] - if(to_read %in% LPJ_GUESS_CONST_INTS$var){ - specs$n <- LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var == to_read] - }else{ - specs$n[1] <- as.numeric(to_read) - } - specs$what[2] <- "integer" #need to check what size_t is - specs$size[2] <- 8 - specs$n[2] <- 1 - specs$names[2] <- "current_index" - - specs$what[3] <- "logical" - specs$size[3] <- 1 - specs$n[3] <- 1 - specs$names[3] <- "full" - - specs$single <- FALSE - - }else if(current_stream_type$type == "struct"){ - if(current_stream_type$name != "solvesom"){ - PEcAn.logger::logger.debug("Another struct type.") - } - #for now hardcoding this will be back - # specs$n <- specs$what <- specs$size <- specs$names <- rep(NA, 2) - # specs$what[1] <- "double" - # specs$size[1] <- 8 - # specs$names[1] <- "clitter" - # specs$n[1] <- 12 #NSOMPOOL - # - # specs$what[2] <- "double" - # specs$size[2] <- 8 - # specs$names[2] <- "nlitter" - # specs$n[2] <- 12 #NSOMPOOL - # - # LOOKS LIKE THIS ONE IS NOT SERIALIZED PROPERLY - # just return 8 - - - specs$n <- 1 - specs$what <- "integer" - specs$size <- 8 - specs$single <- TRUE - - }else if(grepl(glob2rx(paste0(current_stream_type$type, "*", current_stream_type$name, ";")), sub_string)){ - - # this is only length 1 - specs$n <- 1 - specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$single <- TRUE - - }else if(length(regmatches(sub_string, gregexpr("\\[.+?\\]", sub_string))[[1]]) > 1){ - #looks like we have a matrix - spec_dims <- regmatches(sub_string, gregexpr("\\[.+?\\]", sub_string))[[1]] - spec_dims <- gsub("\\].*", "", gsub(".*\\[", "", spec_dims)) - for(spec_dims_i in seq_along(spec_dims)){ - if(any(sapply(LPJ_GUESS_CONST_INTS$var, grepl, spec_dims[spec_dims_i], fixed = TRUE))){ # uses one of the constant ints - spec_dims[spec_dims_i] <- LPJ_GUESS_CONST_INTS$val[sapply(LPJ_GUESS_CONST_INTS$var, grepl, spec_dims[spec_dims_i], fixed = TRUE)] - }else{ - spec_dims[spec_dims_i] <- as.numeric(sub(".*\\[(.*)\\].*", "\\1", spec_dims[spec_dims_i], perl=TRUE)) - } - } - spec_dims <- as.numeric(spec_dims) - - specs$n <- prod(spec_dims) - specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$single <- TRUE - }else{ - # reading a vector - specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - if(any(sapply(LPJ_GUESS_CONST_INTS$var, grepl, sub_string, fixed = TRUE))){ # uses one of the constant ints - specs$n <- LPJ_GUESS_CONST_INTS$val[sapply(LPJ_GUESS_CONST_INTS$var, grepl, sub_string, fixed = TRUE)] - }else{ - specs$n <- as.numeric(sub(".*\\[(.*)\\].*", "\\1", sub_string, perl=TRUE)) - } - - specs$single <- TRUE - } - - return(specs) -} # find_stream_size - - -# helper function to decide the type of the stream -# this function relies on the architecture of LPJ-GUESS and has bunch of harcoded checks, see model documentation -find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in){ - - if(current_stream_var == "seed"){ # a bit of a special case - return(list(type = "long", name = "seed", substring = "long seed;")) - } - - if(current_stream_var == "nstands"){ # a bit of a special case, it is read by guess.cpp - return(list(type = "int", name = "nstands", substring = "int nstands;")) #there is not substring like that in guess.h - } - - if(current_stream_var == "landcover"){ # a bit of a special case - return(list(type = "landcovertype", name = "landcover", substring = "landcovertype landcover;")) - } - - # it might be difficult to extract the "type" before the varname - # there are not that many to check - possible_types <- c("class ", "double ", "bool ", "int ") - - possible_types <- c(possible_types, LPJ_GUESS_TYPES) - - beg_end <- NULL # not going to need it always - - # class or not? - if(tools::toTitleCase(current_stream_var) %in% LPJ_GUESS_CLASSES){ - stream_type <- "class" - stream_name <- tools::toTitleCase(current_stream_var) - sub_string <- NULL - }else {# find type from guess.h - - if(is.null(class)){ - sub_string <- guessh_in[grepl(paste0(" ", current_stream_var), guessh_in, fixed = TRUE)] - }else{ - beg_end <- serialize_starts_ends(file_in = guessh_in, - pattern = paste0("class ", - tools::toTitleCase(class), - " : public ")) - # subset - sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var, ";"), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] - } - - if(length(sub_string) == 0){ - sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] - } - # e.g. "sompool[i]" in guess.cpp, Sompool sompool[NSOMPOOL]; in guess.h - if(length(sub_string) == 0){ - current_stream_var <- gsub("\\[|.\\]", "", current_stream_var) - sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] - if(tools::toTitleCase(current_stream_var) %in% LPJ_GUESS_CLASSES){ - stream_type <- "class" - stream_name <- current_stream_var - sub_string <- NULL - return(list(type = gsub(" ", "", stream_type), name = stream_name, substring = sub_string)) - } - } - if(length(sub_string) == 0){ - sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(",", current_stream_var), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] - } - if(length(sub_string) > 1){ - - # some varnames are very common characters unfortunately like u, v... check if [] comes after - if(any(grepl(paste0(" ", current_stream_var, "["), sub_string, fixed = TRUE))){ - sub_string <- sub_string[grepl(paste0(" ", current_stream_var, "["), sub_string, fixed = TRUE)] - }else if(any(grepl(paste0("double ", current_stream_var), sub_string, fixed = TRUE))){ # just fishing, double is the most common type - sub_string <- sub_string[grepl(paste0("double ", current_stream_var), sub_string, fixed = TRUE)] - }else if(any(grepl("///", sub_string, fixed = TRUE))){ # three slashes are very common in commented out code - sub_string <- sub_string[!grepl("///", sub_string, fixed = TRUE)] - } - - if(length(unique(sub_string)) == 1){ - sub_string <- unique(sub_string) - }else{ - PEcAn.logger::logger.severe("Check this out.") - } - } - - # clean from tabs - sub_string <- gsub("\t", "", sub_string) - # clean from commented out lines? - - if(grepl("Historic", sub_string, fixed = TRUE)){ - # Historic types has the form Historic& data) - stream_type <- "Historic" - stream_name <- current_stream_var - }else if(grepl("std::vector", sub_string, fixed = TRUE)){ - stream_type <- "struct" - stream_name <- current_stream_var - }else{ - stream_type <- possible_types[sapply(possible_types, grepl, sub_string, fixed = TRUE)] - stream_name <- current_stream_var - } - - } - - return(list(type = gsub(" ", "", stream_type), name = stream_name, substring = sub_string)) -} # find_stream_type - - -###################################### READ STATE - -library(stringr) - -# this fcn is for potential natural vegetation only -# when there is landcover, there will be more stand types - -# also for cohort mode only - -# Gridcell: Top-level object containing all dynamic and static data for a particular gridcell -# Gridcellpft: Object containing data common to all individuals of a particular PFT in a particular gridcell -# Gridcellst : Object containing data common to all stands of a particular stand type (ST) in a particular gridcell -# Climate : Contains all static and dynamic data relating to the overall environmental properties, other than soil properties, of a gridcell -# Soiltype : Stores soil static parameters. One object of class Soiltype is defined for each gridcell. -# Stand : Object containing all dynamic and static data for a particular stand -# Patch : Stores data specific to a patch. In cohort and individual modes, replicate patches are required in each stand to accommodate stochastic variation across the site. -# Patchpft : Object containing data common to all individuals of a particular PFT in a particular patch, including litter pools. -# Vegetation : A dynamic list of Individual objects, representing the vegetation of a particular patch -# Soil : Stores state variables for soils and the snow pack. One object of class Soil is defined for each patch. -# Fluxes : The Fluxes class stores accumulated monthly and annual fluxes. One object of type Fluxes is defined for each patch. -# Individual : Stores state variables for an average individual plant. In cohort mode, it is the average individual of a cohort of plants approximately the same age and from the same patch. - -# maybe put guess.h and guess.cpp for each model version into the model package -guesscpp_loc <- "/fs/data5/pecan.models/LPJ-GUESS/framework/guess.cpp" -guessh_loc <- "/fs/data5/pecan.models/LPJ-GUESS/framework/guess.h" -paramh_loc <- "/fs/data5/pecan.models/LPJ-GUESS/framework/parameters.h" - -# guess.cpp has the info of what is being written -guesscpp_in <- readLines(guesscpp_loc) -# guess.h has the types so that we know what streamsize to read -guessh_in <- readLines(guessh_loc) -# parameters.h has some more types -paramh_in <- readLines(paramh_loc) - -############ open - -# test path -out.path = "/fs/data2/output/PEcAn_1000002393/out/1000458390" -setwd(out.path) - -###################################### -## read meta.bin -# not sure if the content will change under guessserializer.cpp -meta_data <- list() -meta_bin_con <- file("meta.bin", "rb") -meta_data$num_processes <- readBin(meta_bin_con, integer(), 1, size = 4) -meta_data$vegmode <- readBin(meta_bin_con, integer(), 1, size = 4) -meta_data$npft <- readBin(meta_bin_con, integer(), 1, size = 4) -meta_data$pft <- list() -for(i in seq_len(meta_data$npft)){ - char_len <- readBin(meta_bin_con, integer(), 1, size = 8) - meta_data$pft[[i]] <- readChar(meta_bin_con, char_len) -} -close(meta_bin_con) - -# open connection to the binary state file -zz <- file("0.state", "rb") - -### these are the values read from params.ins, passed to this fcn -n_pft <- meta_data$npft -npatches <- 5 - -################################ check class compatibility ################################ -# between model versions we don't expect major classes or hierarchy to change -# but give check and fail if necessary -LPJ_GUESS_CLASSES <- c("Gridcell", "Climate", "Gridcellpft", "Stand", "Standpft", "Patch", "Patchpft", - "Individual", "Soil", "Sompool", "Fluxes", "Vegetation") - -lpjguess_classes <- list() -ctr <- 1 -# NOTE THAT THESE PATTERNS ASSUME SOME CODING STYLE, thanks to LPJ-GUESS developers this might not be an issue in the future -for(i in seq_along(guessh_in)){ - # search for "class XXX : public Serializable {" - res <- str_match(guessh_in[i], "class (.*?) : public Serializable") - if(is.na(res[,2])){ - # try "class XXX : public ..., public Serializable {" pattern - res <- str_match(guessh_in[i], "class (.*?) : public .* Serializable") - } - if(!is.na(res[,2])){ - lpjguess_classes[[ctr]] <- res[,2] - ctr <- ctr + 1 - } -} - -# all match? -if(!setequal(unlist(lpjguess_classes), LPJ_GUESS_CLASSES)){ - PEcAn.logger::logger.severe("This function can only read the following class objects: ", paste(LPJ_GUESS_CLASSES, collapse="--")) -} - -# there are couple of LPJ-GUESS specific types that we'll need below -lpjguess_types <- list() -ctr <- 1 -for(i in seq_along(guessh_in)){ - if(grepl("typedef enum {", guessh_in[i], fixed = TRUE)){ - this_line <- find_closing("}", i, guessh_in) - l_type <- gsub(".*}(.*?);.*", "\\1", guessh_in[this_line]) - l_type <- gsub(" ", "", l_type) - lpjguess_types[[ctr]] <- l_type - ctr <- ctr + 1 - } -} -for(i in seq_along(paramh_in)){ #do same for parameters.h - if(grepl("typedef enum {", paramh_in[i], fixed = TRUE)){ - this_line <- find_closing("}", i, paramh_in) - l_type <- gsub(".*}(.*?);.*", "\\1", paramh_in[this_line]) - l_type <- gsub(" ", "", l_type) - lpjguess_types[[ctr]] <- l_type - ctr <- ctr + 1 - } -} -LPJ_GUESS_TYPES <- unlist(lpjguess_types) - - -lpjguess_consts <- list() -ctr <- 1 -for(i in seq_along(guessh_in)){ - if(grepl("const int ", guessh_in[i], fixed = TRUE)){ # probably won't need "const double"s - cnst_val <- gsub(".*=(.*?);.*", "\\1", guessh_in[i]) - cnst_val <- gsub(" ", "", cnst_val) # get rid of the space if there is one - cnst_nam <- gsub(".*int(.*?)=.*", "\\1", guessh_in[i]) - cnst_nam <- gsub(" ", "", cnst_nam) - lpjguess_consts[[ctr]] <- cnst_val - names(lpjguess_consts)[ctr] <- cnst_nam - ctr <- ctr + 1 - } -} -# few cleaning -dont_need <- c("COLDEST_DAY_NHEMISPHERE", "COLDEST_DAY_SHEMISPHERE", "WARMEST_DAY_NHEMISPHERE", "WARMEST_DAY_SHEMISPHERE", "data[]") -lpjguess_consts[match(dont_need, names(lpjguess_consts))] <- NULL -# this needs to be extracted from parameters.h:48-49 or somewhere else, but hardcoding for now -lpjguess_consts$NLANDCOVERTYPES <- 6 -# this needs to be extracted from guess.h:94 , but hardcoding for now -lpjguess_consts$NSOMPOOL <- 12 -# this needs to be extracted from guess.h:644 , but hardcoding for now NOTE that new versions has 13 flux types -lpjguess_consts$PerPatchFluxType <- 12 -# this needs to be extracted from guess.h:659 , but hardcoding for now -lpjguess_consts$PerPFTFluxType <- 5 -LPJ_GUESS_CONST_INTS <- data.frame(var = names(lpjguess_consts), val = as.numeric(unlist(lpjguess_consts)), stringsAsFactors = FALSE) - - -# Gridcell is the top-level container, start parsing from there -beg_end <- serialize_starts_ends(file_in = guesscpp_in, pattern = "void Gridcell::serialize") - -# now we will parse the stuff between these lines -# first find what is being written -streamed_vars_gridcell <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - -################################## CAUTION : THE FOLLOWING IS A MONSTROUS NESTED-LOOP ################################## - -# Now I can use streamed_vars_gridcell to loop over them -# We read everything in this loop, Gridcell list is going to be the top container -# there will be nested loops, the hierarchy will follow LPJ-GUESS architecture -Gridcell <- list() -level <- "Gridcell" -for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts - current_stream <- streamed_vars_gridcell[g_i] - if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard - if(grepl(glob2rx("(*this)[*].landcover"), current_stream)){ # s counter might change, using wildcard - # not sure how to handle this better. If we see this, it means we are now looping over Stands - # this function considers "NATURAL" vegetation only, so there is only one stand - # this is an integer that tells us which landcover type this stand is - # so it should be the indice of NATURAL in typedef enum landcovertype (I believe indexing starts from 0) - - num_stnd <- as.numeric(Gridcell$nstands) - Gridcell[["Stand"]] <- vector("list", num_stnd) - - # note that this is streamed under Gridcell, not Stand in guess.cpp, - # but I think this info needs to go together with the Stand sublist - # so prepend landcovertype to the streamed_vars_stand - - next - } - - # "(*this)[*]" points to different things under different levels, here it is stand - if(grepl(glob2rx("(*this)[*]"), current_stream)){ # note that first else-part will be evaluated considering the order in guess.cpp - - # STAND - level <- "Stand" - current_stream <- "Stand" - current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void ", - tools::toTitleCase(current_stream_type$name), - "::serialize")) - streamed_vars_stand <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - streamed_vars_stand <- c("landcover", streamed_vars_stand) # prepending landcovertype to the streamed_vars_stand - - - for(stnd_i in seq_len(num_stnd)){ #looping over the stands - for(svs_i in seq_along(streamed_vars_stand)){ # looping over the streamed stand vars - - current_stream <- streamed_vars_stand[svs_i] - if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard - - if(current_stream == "nobj" & level == "Stand"){ - # nobj points to different things under different levels, here it is the number of patches - # number of patches is set through insfiles, read by write.configs and passed to this fcn - # but it's also written to the state file, need to move bytes - nofpatch <- readBin(zz, integer(), 1, size = 4) - if(npatches == nofpatch){ # also not a bad place to check if everything is going fine so far - Gridcell[["Stand"]][[stnd_i]]$npatches <- npatches - #Gridcell[["Stand"]] <- vector("list", npatches) - }else{ - PEcAn.logger::logger.severe("The number of patches set through the instruction file does not match the number read from the state files. Probably a bug in the read.state function! Terminating.") - } - next - } - - # "(*this)[*]" points to different things under different levels, here it is patch - if(grepl(glob2rx("(*this)[*]"), current_stream)){ - # PATCH - level <- "Patch" - current_stream <- "Patch" - current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void ", - tools::toTitleCase(current_stream_type$name), - "::serialize")) - streamed_vars_patch <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - - Gridcell[["Stand"]][[stnd_i]][["Patch"]] <- vector("list", npatches) - - for(ptch_i in seq_len(npatches)){ #looping over the patches - for(svp_i in seq_along(streamed_vars_patch)){ #looping over the streamed patch vars - current_stream <- streamed_vars_patch[svp_i] - if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard - - if(tools::toTitleCase(current_stream) %in% LPJ_GUESS_CLASSES){ - current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - }else{ - current_stream_type <- find_stream_type("Patch", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - } - - - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[length(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])+1]] <- list() - names(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])[length(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])] <- current_stream_type$name - - if(current_stream_type$type == "class"){ - - # CLASS - class_name <- current_stream_type$name - - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void ", - tools::toTitleCase(current_stream_type$name), - "::serialize")) - - - if(class_name == "Vegetation"){ - # VEGETATION - # Vegetation class has a bit of a different structure, it has one more depth, see model documentation - streamed_vars_veg <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - - # NOTE : Unlike other parts, this bit is a lot less generalized!!! - # I'm gonna asumme Vegetation class won't change much in the future - # indiv.pft.id and indiv needs to be looped over nobj times - if(!setequal(streamed_vars_veg, c("nobj", "indiv.pft.id", "indiv"))){ - PEcAn.logger::logger.severe("Vegetation class object changed in this model version, you need to fix read.state") - } - - # nobj points to different things under different levels, here it is the number of individuals - number_of_individuals <- readBin(zz, integer(), 1, size = 4) - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["number_of_individuals"]] <- number_of_individuals - - # few checks for sensible vals - if(number_of_individuals < 1 | number_of_individuals > 10000){ # should there be an upper limit here too? - # if number of individuals is 0 it's a bit suspicious. Not sure if ever will get negative but that'd definitely be wrong - PEcAn.logger::logger.warn("Number of individuals under vegetation is", number_of_individuals) - } - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]] <- vector("list", number_of_individuals) - - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void Individual::serialize")) - streamed_vars_indv <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - - # loop over nobj - for(indv_i in seq_len(number_of_individuals)){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]] <- list() - # which PFT is this? - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][["indiv.pft.id"]] <- readBin(zz, integer(), 1, size = 4) - # read all the individual class - for(svi_i in seq_along(streamed_vars_indv)){ # - current_stream <- streamed_vars_indv[svi_i] - - current_stream_type <- find_stream_type("individual", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - - if(current_stream_specs$single){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][[current_stream_type$name]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ - for(css.i in seq_along(current_stream_specs$what)){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, - what = current_stream_specs$what[css.i], - n = current_stream_specs$n[css.i], - size = current_stream_specs$size[css.i]) - } - } - - }# end loop over stream vars individual - } # end loop over number_of_individuals - - - - - - }else if(class_name == "Fluxes"){ - # FLUXES - # this is not generalized at all - streamed_vars_flux <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - - if(!setequal(streamed_vars_flux, c("annual_fluxes_per_pft", "monthly_fluxes_patch", "monthly_fluxes_pft"))){ - PEcAn.logger::logger.severe("Fluxes class object changed in this model version, you need to fix read.state") - } - - # annual_fluxes_per_pft loops over - # parse from guess.h - PerPFTFluxType <- c("NPP", "GPP", "RA", "ISO", "MON") - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]] <- list() - key1 <- readBin(zz, "integer", 1, 8) - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]][["n_pft"]] <- key1 - for(fpft_i in seq_len(key1)){ # key1 11 PFTs - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]][[fpft_i]] <- list() - key2 <- readBin(zz, "integer", 1, 8) - if(key2 > 10000){ #make sure you dind't read a weird number, this is supposed to be number of fluxes per pft, can't have too many - PEcAn.logger::logger.severe("Number of fluxes per pft read from the state file is too high. Check read.state function") - } - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]][[fpft_i]][["key2"]] <- key2 - for(flux_i in seq_len(key2)){ - # is this double? - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]][[fpft_i]][[PerPFTFluxType[flux_i]]] <- readBin(zz, "double", 1, 8) - } - } - - # monthly_fluxes_patch read as a vector at once - # double monthly_fluxes_patch[12][NPERPATCHFLUXTYPES]; - # maybe read this as a matrix? - n_monthly_fluxes_patch <- 12 * LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var =="PerPatchFluxType"] - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["monthly_fluxes_patch"]] <- readBin(zz, "double", n_monthly_fluxes_patch, 8) - - # monthly_fluxes_pft read as a vector at once - # double monthly_fluxes_pft[12][NPERPFTFLUXTYPES]; - # maybe read this as a matrix? - n_monthly_fluxes_pft <- 12 * LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var =="PerPFTFluxType"] - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["monthly_fluxes_pft"]] <- readBin(zz, "double", n_monthly_fluxes_pft, 8) - - }else{ - # NOT VEGETATION OR FLUX - streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) - - for(varname in streamed_vars){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[current_stream_type$name]][[varname]] <- vector("list", num_pft) - } - - # maybe try modifying this bit later to make it a function - for(pft_i in seq_len(num_pft)){ - for(sv_i in seq_along(streamed_vars)){ - current_stream <- streamed_vars[sv_i] #it's OK to overwrite - current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - - if(current_stream_type$type == "class"){ - - if(current_stream_type$name != "sompool"){ - PEcAn.logger::logger.debug("Classes other than sompool enter here.") - } - # ONLY SOMPOOL HERE SO FAR ****************************************************************** - # code below is very sompool specific - # class_name <- # don't overwrite class_name - - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void ", - tools::toTitleCase(current_stream_type$name), - "::serialize")) - streamed_vars_sompool <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - - nsompool <- LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var == "NSOMPOOL"] - - for(varname in streamed_vars_sompool){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Soil"]][["sompool[i]"]][[varname]] <- vector("list", nsompool) - } - - names( Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Soil"]])[names( Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Soil"]]) == "sompool[i]"] <- "Sompool" - - ###################### LOOP OVER NSOMPOOL - for(som_i in seq_len(nsompool)){ - for(sv_sompool_i in seq_along(streamed_vars_sompool)){ - current_stream <- streamed_vars_sompool[sv_sompool_i] - - current_stream_type <- find_stream_type("Sompool", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - - if(current_stream_specs$single){ - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Soil"]][["Sompool"]][[current_stream_type$name]][[som_i]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ - PEcAn.logger::logger.severe("Historic under sompool.") # Not expecting any - } - } - } - - }else{ - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - # and read! - if(current_stream_specs$single){ # maybe use current_stream in sublist names to find correct place - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[length( Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ # only for historic type? - for(css.i in seq_along(current_stream_specs$what)){ # maybe use current_stream in sublist names to find correct place - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[length( Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, - what = current_stream_specs$what[css.i], - n = current_stream_specs$n[css.i], - size = current_stream_specs$size[css.i]) - } - } - } - } # streamed_vars-loop ends - } # pft-loop ends - } - - - }else{ - # NOT CLASS - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - # and read! - if(current_stream_specs$single){ - - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[current_stream_type$name]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ # probably don't need this but let's keep - for(css_i in seq_along(current_stream_specs$what)){ - # CHANGE ALL THESE HISTORIC TYPES SO THAT cirrent_index and full goes together with the variable - Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[current_stream_specs$names[css_i]]] <- readBin(con = zz, - what = current_stream_specs$what[css_i], - n = current_stream_specs$n[css_i], - size = current_stream_specs$size[css_i]) - } - } - }# end if-class within Patch - } - } - - }else{ - # NOT PATCH - - if(tools::toTitleCase(current_stream) %in% LPJ_GUESS_CLASSES){ - current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - }else{ - current_stream_type <- find_stream_type("Stand", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - } - - Gridcell[["Stand"]][[stnd_i]][[length(Gridcell[["Stand"]][[stnd_i]])+1]] <- list() - names(Gridcell[["Stand"]][[stnd_i]])[length(Gridcell[["Stand"]][[stnd_i]])] <- current_stream_type$name - - if(current_stream_type$type == "class"){ - - # CLASS - class_name <- current_stream_type$name - - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void ", - tools::toTitleCase(current_stream_type$name), - "::serialize")) - streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) - - for(varname in streamed_vars){ - Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]][[varname]] <- varname - Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]][[varname]] <- vector("list", num_pft) - } - - for(pft_i in seq_len(num_pft)){ - for(sv_i in seq_along(streamed_vars)){ - current_stream <- streamed_vars[sv_i] #it's OK to overwrite - current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - - if(current_stream_type$type == "class"){ - - # CLASS, NOT EVER GOING HERE? - class_name <- current_stream_type$name - - }else{ - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - # and read! - if(current_stream_specs$single){ - Gridcell[["Stand"]][[stnd_i]][[length(Gridcell[["Stand"]][[stnd_i]])]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ - for(css.i in seq_along(current_stream_specs$what)){ - Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, - what = current_stream_specs$what[css.i], - n = current_stream_specs$n[css.i], - size = current_stream_specs$size[css.i]) - } - } - } - } # streamed_vars-loop ends - } # pft-loop ends - - }else{ - # NOT CLASS - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - # and read! - if(current_stream_specs$single){ - Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ # probably don't need this but let's keep - for(css_i in seq_along(current_stream_specs$what)){ - Gridcell[[length(Gridcell)]][[current_stream_specs$names[css_i]]] <- readBin(con = zz, - what = current_stream_specs$what[css_i], - n = current_stream_specs$n[css_i], - size = current_stream_specs$size[css_i]) - } - } - }# end if-class within Stand - } # end patch-if - - - }# end for-loop over the streamed stand vars (svs_i, L.165) - }# end for-loop over the stands (stnd_i, L.164) - - }else{ #not reading in Stand variables - - # NOT STAND - - current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - - Gridcell[[length(Gridcell)+1]] <- list() - names(Gridcell)[length(Gridcell)] <- current_stream_type$name - if(current_stream_type$type == "class"){ - - # CLASS - class_name <- current_stream_type$name - - beg_end <- serialize_starts_ends(file_in = guesscpp_in, - pattern = paste0("void ", - tools::toTitleCase(current_stream_type$name), - "::serialize")) - streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) - num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) - - for(varname in streamed_vars){ - Gridcell[[length(Gridcell)]][[varname]] <- varname - Gridcell[[length(Gridcell)]][[varname]] <- vector("list", num_pft) - } - - for(pft_i in seq_len(num_pft)){ - for(sv_i in seq_along(streamed_vars)){ - #for(sv_i in 21:37){ - current_stream <- streamed_vars[sv_i] #it's OK to overwrite - current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) - - if(current_stream_type$type == "class"){ - - # CLASS, NOT EVER GOING HERE? - class_name <- current_stream_type$name - - }else{ - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - # and read! - if(current_stream_specs$single){ - Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ - for(css.i in seq_along(current_stream_specs$what)){ - Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, - what = current_stream_specs$what[css.i], - n = current_stream_specs$n[css.i], - size = current_stream_specs$size[css.i]) - } - } - } - } # streamed_vars-loop ends - } # pft-loop ends - - }else{ - # NOT CLASS - current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) - # and read! - if(current_stream_specs$single){ - Gridcell[[length(Gridcell)]][[current_stream_type$name]] <- readBin(con = zz, - what = current_stream_specs$what, - n = current_stream_specs$n, - size = current_stream_specs$size) - }else{ # probably don't need this but let's keep - for(css_i in seq_along(current_stream_specs$what)){ - Gridcell[[length(Gridcell)]][[current_stream_specs$names[css_i]]] <- readBin(con = zz, - what = current_stream_specs$what[css_i], - n = current_stream_specs$n[css_i], - size = current_stream_specs$size[css_i]) - } - } - }# end if-class within Gridcell - - } # Stand if-else ends -} # Gridcell-loop ends - - - +#' ######################## Helper functions ######################## +#' +#' +#' # helper function that lists streamed variables, it just returns the names, types are checked by other fucntion +#' find_stream_var <- function(file_in, line_nos){ +#' +#' streaming_list <- list() +#' str.i <- 1 +#' when_here <- NULL +#' not_skipping <- TRUE +#' +#' i <- line_nos[1] +#' repeat{ +#' i <- i + 1 +#' if(!is.null(when_here)){ +#' if(i == when_here){ +#' i <- skip_to +#' when_here <- NULL +#' } +#' } +#' +#' # some functions (Vegetation, Patch, Stand, Gridcell) have two modes: saving / reading +#' # we only need the stream that is saved +#' if(grepl("arch.save()", file_in[i])){ +#' when_here <- find_closing("}", i, file_in) +#' skip_to <- find_closing("}", i, file_in, if_else_check = TRUE) +#' } +#' +#' # all streams start with arch & +#' if(grepl("arch & ", file_in[i])){ +#' # get variable name +#' streaming_list[[str.i]] <- sub(".*arch & ", "", file_in[i]) # always one var after arch? +#' str.i <- str.i + 1 +#' # check for ampersand for the subsequent variable names +#' repeat{ +#' i <- i + 1 +#' if(!is.null(when_here)){ +#' if(i == when_here){ +#' i <- skip_to +#' when_here <- NULL +#' } +#' } +#' check1 <- !grepl(".*& ", file_in[i]) # when there are no subsequent stream +#' check2 <- !grepl(".*& ", file_in[i+1]) # sometimes following line is empty or commented, check the next one too +#' if(check1 & !check2) i <- i+1 +#' if(check1 & check2) break # looks like there are no subsequent stream +#' this_line <- gsub("[[:space:]]", "", strsplit(file_in[i], "& ")[[1]]) +#' for(var in this_line){ +#' if(var != ""){ +#' if(var != "arch"){ +#' streaming_list[[str.i]] <- var +#' str.i <- str.i + 1 +#' } +#' } +#' } +#' if(!is.null(when_here)){ # now that increased i check this just in case +#' if(i == when_here){ +#' i <- skip_to +#' when_here <- NULL +#' } +#' } +#' } +#' } +#' if(i == line_nos[2]) break +#' } +#' +#' #unlist and nix the ; +#' returnin_stream <- gsub(";", "", unlist(streaming_list), fixed = TRUE) +#' return(returnin_stream) +#' } # find_stream_var +#' +#' +#' +#' # helper function that scans LPJ-GUESS that returns the beginning and the ending lines of serialized object +#' serialize_starts_ends <- function(file_in, pattern = "void Gridcell::serialize"){ +#' # find the starting line from the given pattern +#' starting_line <- which(!is.na(str_match(file_in, pattern))) +#' if(length(starting_line) != 1){ # check what's going on +#' PEcAn.logger::logger.severe("Couldn't find the starting line with this pattern ***",pattern, "***.") +#' } +#' +#' # screen for the closing curly bracket after function started +#' # keep track of opening-closing brackets +#' ending_line <- find_closing(find = "}", starting_line, file_in) +#' +#' return(c(starting_line, ending_line)) +#' } # serialize_starts_ends +#' +#' +#' # helper function that finds the closing bracket, can work over if-else +#' find_closing <- function(find = "}", line_no, file_in, if_else_check = FALSE){ +#' opened <- 1 +#' closed <- 0 +#' if(find == "}"){ +#' start_char <- "{" +#' end_char <- "}" +#' }else{ +#' #there can be else-ifs, find closing paranthesis / square breacket etc +#' } +#' +#' # check the immediate line and return if closed there already +#' if(grepl(end_char, file_in[line_no], fixed = TRUE)) return(line_no) +#' +#' repeat{ +#' line_no <- line_no + 1 +#' if(grepl(start_char, file_in[line_no], fixed = TRUE)) opened <- opened + 1 +#' if(grepl(end_char, file_in[line_no], fixed = TRUE)) closed <- closed + 1 +#' if(if_else_check){ +#' else_found <- FALSE +#' same_line_check <- grepl("else", file_in[line_no], fixed = TRUE) #same line +#' next_line_check <- grepl("else", file_in[line_no + 1], fixed = TRUE) #next line +#' if(same_line_check | next_line_check){ +#' closed <- closed - 1 +#' if(next_line_check) line_no <- line_no + 1 +#' } +#' } +#' if(opened == closed) break +#' } +#' return(line_no) +#' } # find_closing +#' +#' +#' #' @export +#' # helper function that determines the stream size to read +#' find_stream_size <- function(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS){ +#' +#' possible_types <- c("double ", "bool ", "int " , "long ") # space because these can be part of other words +#' possible_types <- c(possible_types, LPJ_GUESS_TYPES) +#' n_sizes <- c(8, 1, 4, 8, rep(4, length(LPJ_GUESS_TYPES) )) +#' rbin_tbl <- c("double", "logical", "integer", "integer", rep("integer", length(LPJ_GUESS_TYPES))) +#' +#' specs <- list() +#' +#' sub_string <- current_stream_type$substring +#' +#' #is there a ; immediately after? +#' if(grepl(paste0(current_stream_type$type, " ", current_stream_type$name, ";"), sub_string, fixed = TRUE) | +#' grepl(paste0(current_stream_type$type, " ", current_stream_type$name, ","), sub_string, fixed = TRUE)){ # e.g. "double alag, exp_alag;" +#' # this is only length 1 +#' specs$n <- 1 +#' specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] +#' specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] +#' specs$single <- TRUE +#' +#' }else if(current_stream_type$type == "Historic"){ +#' possible_types <- c("double", "bool", "int" , "long") # # I haven't seen any Historic that doesn't store double but... historic has a comma after type: double, +#' possible_types <- c(possible_types, LPJ_GUESS_TYPES) +#' +#' # Historic types are special to LPJ-GUESS +#' # They have stored values, current index, and a boolean in that order +#' specs$n <- specs$what <- specs$size <- specs$names <- rep(NA, 3) +#' # always three, this is a type defined in guessmath.h +#' specs$what[1] <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] +#' specs$size[1] <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] +#' specs$names[1] <- current_stream_type$name +#' # n is tricky, it can be hardcoded it can be one of the const ints +#' to_read <- str_match(sub_string, paste0("Historic<", specs$what[1], ", (.*?)>.*"))[,2] +#' if(to_read %in% LPJ_GUESS_CONST_INTS$var){ +#' specs$n <- LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var == to_read] +#' }else{ +#' specs$n[1] <- as.numeric(to_read) +#' } +#' specs$what[2] <- "integer" #need to check what size_t is +#' specs$size[2] <- 8 +#' specs$n[2] <- 1 +#' specs$names[2] <- "current_index" +#' +#' specs$what[3] <- "logical" +#' specs$size[3] <- 1 +#' specs$n[3] <- 1 +#' specs$names[3] <- "full" +#' +#' specs$single <- FALSE +#' +#' }else if(current_stream_type$type == "struct"){ +#' if(current_stream_type$name != "solvesom"){ +#' PEcAn.logger::logger.debug("Another struct type.") +#' } +#' #for now hardcoding this will be back +#' # specs$n <- specs$what <- specs$size <- specs$names <- rep(NA, 2) +#' # specs$what[1] <- "double" +#' # specs$size[1] <- 8 +#' # specs$names[1] <- "clitter" +#' # specs$n[1] <- 12 #NSOMPOOL +#' # +#' # specs$what[2] <- "double" +#' # specs$size[2] <- 8 +#' # specs$names[2] <- "nlitter" +#' # specs$n[2] <- 12 #NSOMPOOL +#' # +#' # LOOKS LIKE THIS ONE IS NOT SERIALIZED PROPERLY +#' # just return 8 +#' +#' +#' specs$n <- 1 +#' specs$what <- "integer" +#' specs$size <- 8 +#' specs$single <- TRUE +#' +#' }else if(grepl(glob2rx(paste0(current_stream_type$type, "*", current_stream_type$name, ";")), sub_string)){ +#' +#' # this is only length 1 +#' specs$n <- 1 +#' specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] +#' specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] +#' specs$single <- TRUE +#' +#' }else if(length(regmatches(sub_string, gregexpr("\\[.+?\\]", sub_string))[[1]]) > 1){ +#' #looks like we have a matrix +#' spec_dims <- regmatches(sub_string, gregexpr("\\[.+?\\]", sub_string))[[1]] +#' spec_dims <- gsub("\\].*", "", gsub(".*\\[", "", spec_dims)) +#' for(spec_dims_i in seq_along(spec_dims)){ +#' if(any(sapply(LPJ_GUESS_CONST_INTS$var, grepl, spec_dims[spec_dims_i], fixed = TRUE))){ # uses one of the constant ints +#' spec_dims[spec_dims_i] <- LPJ_GUESS_CONST_INTS$val[sapply(LPJ_GUESS_CONST_INTS$var, grepl, spec_dims[spec_dims_i], fixed = TRUE)] +#' }else{ +#' spec_dims[spec_dims_i] <- as.numeric(sub(".*\\[(.*)\\].*", "\\1", spec_dims[spec_dims_i], perl=TRUE)) +#' } +#' } +#' spec_dims <- as.numeric(spec_dims) +#' +#' specs$n <- prod(spec_dims) +#' specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] +#' specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] +#' specs$single <- TRUE +#' }else{ +#' # reading a vector +#' specs$what <- rbin_tbl[sapply(possible_types, grepl, sub_string, fixed = TRUE)] +#' specs$size <- n_sizes[sapply(possible_types, grepl, sub_string, fixed = TRUE)] +#' if(any(sapply(LPJ_GUESS_CONST_INTS$var, grepl, sub_string, fixed = TRUE))){ # uses one of the constant ints +#' specs$n <- LPJ_GUESS_CONST_INTS$val[sapply(LPJ_GUESS_CONST_INTS$var, grepl, sub_string, fixed = TRUE)] +#' }else{ +#' specs$n <- as.numeric(sub(".*\\[(.*)\\].*", "\\1", sub_string, perl=TRUE)) +#' } +#' +#' specs$single <- TRUE +#' } +#' +#' return(specs) +#' } # find_stream_size +#' +#' +#' # helper function to decide the type of the stream +#' # this function relies on the architecture of LPJ-GUESS and has bunch of harcoded checks, see model documentation +#' find_stream_type <- function(class = NULL, current_stream_var, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in){ +#' +#' if(current_stream_var == "seed"){ # a bit of a special case +#' return(list(type = "long", name = "seed", substring = "long seed;")) +#' } +#' +#' if(current_stream_var == "nstands"){ # a bit of a special case, it is read by guess.cpp +#' return(list(type = "int", name = "nstands", substring = "int nstands;")) #there is not substring like that in guess.h +#' } +#' +#' if(current_stream_var == "landcover"){ # a bit of a special case +#' return(list(type = "landcovertype", name = "landcover", substring = "landcovertype landcover;")) +#' } +#' +#' # it might be difficult to extract the "type" before the varname +#' # there are not that many to check +#' possible_types <- c("class ", "double ", "bool ", "int ") +#' +#' possible_types <- c(possible_types, LPJ_GUESS_TYPES) +#' +#' beg_end <- NULL # not going to need it always +#' +#' # class or not? +#' if(tools::toTitleCase(current_stream_var) %in% LPJ_GUESS_CLASSES){ +#' stream_type <- "class" +#' stream_name <- tools::toTitleCase(current_stream_var) +#' sub_string <- NULL +#' }else {# find type from guess.h +#' +#' if(is.null(class)){ +#' sub_string <- guessh_in[grepl(paste0(" ", current_stream_var), guessh_in, fixed = TRUE)] +#' }else{ +#' beg_end <- serialize_starts_ends(file_in = guessh_in, +#' pattern = paste0("class ", +#' tools::toTitleCase(class), +#' " : public ")) +#' # subset +#' sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var, ";"), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] +#' } +#' +#' if(length(sub_string) == 0){ +#' sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] +#' } +#' # e.g. "sompool[i]" in guess.cpp, Sompool sompool[NSOMPOOL]; in guess.h +#' if(length(sub_string) == 0){ +#' current_stream_var <- gsub("\\[|.\\]", "", current_stream_var) +#' sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(" ", current_stream_var), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] +#' if(tools::toTitleCase(current_stream_var) %in% LPJ_GUESS_CLASSES){ +#' stream_type <- "class" +#' stream_name <- current_stream_var +#' sub_string <- NULL +#' return(list(type = gsub(" ", "", stream_type), name = stream_name, substring = sub_string)) +#' } +#' } +#' if(length(sub_string) == 0){ +#' sub_string <- guessh_in[beg_end[1]:beg_end[2]][grepl(paste0(",", current_stream_var), guessh_in[beg_end[1]:beg_end[2]], fixed = TRUE)] +#' } +#' if(length(sub_string) > 1){ +#' +#' # some varnames are very common characters unfortunately like u, v... check if [] comes after +#' if(any(grepl(paste0(" ", current_stream_var, "["), sub_string, fixed = TRUE))){ +#' sub_string <- sub_string[grepl(paste0(" ", current_stream_var, "["), sub_string, fixed = TRUE)] +#' }else if(any(grepl(paste0("double ", current_stream_var), sub_string, fixed = TRUE))){ # just fishing, double is the most common type +#' sub_string <- sub_string[grepl(paste0("double ", current_stream_var), sub_string, fixed = TRUE)] +#' }else if(any(grepl("///", sub_string, fixed = TRUE))){ # three slashes are very common in commented out code +#' sub_string <- sub_string[!grepl("///", sub_string, fixed = TRUE)] +#' } +#' +#' if(length(unique(sub_string)) == 1){ +#' sub_string <- unique(sub_string) +#' }else{ +#' PEcAn.logger::logger.severe("Check this out.") +#' } +#' } +#' +#' # clean from tabs +#' sub_string <- gsub("\t", "", sub_string) +#' # clean from commented out lines? +#' +#' if(grepl("Historic", sub_string, fixed = TRUE)){ +#' # Historic types has the form Historic& data) +#' stream_type <- "Historic" +#' stream_name <- current_stream_var +#' }else if(grepl("std::vector", sub_string, fixed = TRUE)){ +#' stream_type <- "struct" +#' stream_name <- current_stream_var +#' }else{ +#' stream_type <- possible_types[sapply(possible_types, grepl, sub_string, fixed = TRUE)] +#' stream_name <- current_stream_var +#' } +#' +#' } +#' +#' return(list(type = gsub(" ", "", stream_type), name = stream_name, substring = sub_string)) +#' } # find_stream_type +#' +#' +#' ###################################### READ STATE +#' +#' library(stringr) +#' +#' # this fcn is for potential natural vegetation only +#' # when there is landcover, there will be more stand types +#' +#' # also for cohort mode only +#' +#' # Gridcell: Top-level object containing all dynamic and static data for a particular gridcell +#' # Gridcellpft: Object containing data common to all individuals of a particular PFT in a particular gridcell +#' # Gridcellst : Object containing data common to all stands of a particular stand type (ST) in a particular gridcell +#' # Climate : Contains all static and dynamic data relating to the overall environmental properties, other than soil properties, of a gridcell +#' # Soiltype : Stores soil static parameters. One object of class Soiltype is defined for each gridcell. +#' # Stand : Object containing all dynamic and static data for a particular stand +#' # Patch : Stores data specific to a patch. In cohort and individual modes, replicate patches are required in each stand to accommodate stochastic variation across the site. +#' # Patchpft : Object containing data common to all individuals of a particular PFT in a particular patch, including litter pools. +#' # Vegetation : A dynamic list of Individual objects, representing the vegetation of a particular patch +#' # Soil : Stores state variables for soils and the snow pack. One object of class Soil is defined for each patch. +#' # Fluxes : The Fluxes class stores accumulated monthly and annual fluxes. One object of type Fluxes is defined for each patch. +#' # Individual : Stores state variables for an average individual plant. In cohort mode, it is the average individual of a cohort of plants approximately the same age and from the same patch. +#' +#' # maybe put guess.h and guess.cpp for each model version into the model package +#' guesscpp_loc <- "/fs/data5/pecan.models/LPJ-GUESS/framework/guess.cpp" +#' guessh_loc <- "/fs/data5/pecan.models/LPJ-GUESS/framework/guess.h" +#' paramh_loc <- "/fs/data5/pecan.models/LPJ-GUESS/framework/parameters.h" +#' +#' # guess.cpp has the info of what is being written +#' guesscpp_in <- readLines(guesscpp_loc) +#' # guess.h has the types so that we know what streamsize to read +#' guessh_in <- readLines(guessh_loc) +#' # parameters.h has some more types +#' paramh_in <- readLines(paramh_loc) +#' +#' ############ open +#' +#' # test path +#' out.path = "/fs/data2/output/PEcAn_1000002393/out/1000458390" +#' setwd(out.path) +#' +#' ###################################### +#' ## read meta.bin +#' # not sure if the content will change under guessserializer.cpp +#' meta_data <- list() +#' meta_bin_con <- file("meta.bin", "rb") +#' meta_data$num_processes <- readBin(meta_bin_con, integer(), 1, size = 4) +#' meta_data$vegmode <- readBin(meta_bin_con, integer(), 1, size = 4) +#' meta_data$npft <- readBin(meta_bin_con, integer(), 1, size = 4) +#' meta_data$pft <- list() +#' for(i in seq_len(meta_data$npft)){ +#' char_len <- readBin(meta_bin_con, integer(), 1, size = 8) +#' meta_data$pft[[i]] <- readChar(meta_bin_con, char_len) +#' } +#' close(meta_bin_con) +#' +#' # open connection to the binary state file +#' zz <- file("0.state", "rb") +#' +#' ### these are the values read from params.ins, passed to this fcn +#' n_pft <- meta_data$npft +#' npatches <- 5 +#' +#' ################################ check class compatibility ################################ +#' # between model versions we don't expect major classes or hierarchy to change +#' # but give check and fail if necessary +#' LPJ_GUESS_CLASSES <- c("Gridcell", "Climate", "Gridcellpft", "Stand", "Standpft", "Patch", "Patchpft", +#' "Individual", "Soil", "Sompool", "Fluxes", "Vegetation") +#' +#' lpjguess_classes <- list() +#' ctr <- 1 +#' # NOTE THAT THESE PATTERNS ASSUME SOME CODING STYLE, thanks to LPJ-GUESS developers this might not be an issue in the future +#' for(i in seq_along(guessh_in)){ +#' # search for "class XXX : public Serializable {" +#' res <- str_match(guessh_in[i], "class (.*?) : public Serializable") +#' if(is.na(res[,2])){ +#' # try "class XXX : public ..., public Serializable {" pattern +#' res <- str_match(guessh_in[i], "class (.*?) : public .* Serializable") +#' } +#' if(!is.na(res[,2])){ +#' lpjguess_classes[[ctr]] <- res[,2] +#' ctr <- ctr + 1 +#' } +#' } +#' +#' # all match? +#' if(!setequal(unlist(lpjguess_classes), LPJ_GUESS_CLASSES)){ +#' PEcAn.logger::logger.severe("This function can only read the following class objects: ", paste(LPJ_GUESS_CLASSES, collapse="--")) +#' } +#' +#' # there are couple of LPJ-GUESS specific types that we'll need below +#' lpjguess_types <- list() +#' ctr <- 1 +#' for(i in seq_along(guessh_in)){ +#' if(grepl("typedef enum {", guessh_in[i], fixed = TRUE)){ +#' this_line <- find_closing("}", i, guessh_in) +#' l_type <- gsub(".*}(.*?);.*", "\\1", guessh_in[this_line]) +#' l_type <- gsub(" ", "", l_type) +#' lpjguess_types[[ctr]] <- l_type +#' ctr <- ctr + 1 +#' } +#' } +#' for(i in seq_along(paramh_in)){ #do same for parameters.h +#' if(grepl("typedef enum {", paramh_in[i], fixed = TRUE)){ +#' this_line <- find_closing("}", i, paramh_in) +#' l_type <- gsub(".*}(.*?);.*", "\\1", paramh_in[this_line]) +#' l_type <- gsub(" ", "", l_type) +#' lpjguess_types[[ctr]] <- l_type +#' ctr <- ctr + 1 +#' } +#' } +#' LPJ_GUESS_TYPES <- unlist(lpjguess_types) +#' +#' +#' lpjguess_consts <- list() +#' ctr <- 1 +#' for(i in seq_along(guessh_in)){ +#' if(grepl("const int ", guessh_in[i], fixed = TRUE)){ # probably won't need "const double"s +#' cnst_val <- gsub(".*=(.*?);.*", "\\1", guessh_in[i]) +#' cnst_val <- gsub(" ", "", cnst_val) # get rid of the space if there is one +#' cnst_nam <- gsub(".*int(.*?)=.*", "\\1", guessh_in[i]) +#' cnst_nam <- gsub(" ", "", cnst_nam) +#' lpjguess_consts[[ctr]] <- cnst_val +#' names(lpjguess_consts)[ctr] <- cnst_nam +#' ctr <- ctr + 1 +#' } +#' } +#' # few cleaning +#' dont_need <- c("COLDEST_DAY_NHEMISPHERE", "COLDEST_DAY_SHEMISPHERE", "WARMEST_DAY_NHEMISPHERE", "WARMEST_DAY_SHEMISPHERE", "data[]") +#' lpjguess_consts[match(dont_need, names(lpjguess_consts))] <- NULL +#' # this needs to be extracted from parameters.h:48-49 or somewhere else, but hardcoding for now +#' lpjguess_consts$NLANDCOVERTYPES <- 6 +#' # this needs to be extracted from guess.h:94 , but hardcoding for now +#' lpjguess_consts$NSOMPOOL <- 12 +#' # this needs to be extracted from guess.h:644 , but hardcoding for now NOTE that new versions has 13 flux types +#' lpjguess_consts$PerPatchFluxType <- 12 +#' # this needs to be extracted from guess.h:659 , but hardcoding for now +#' lpjguess_consts$PerPFTFluxType <- 5 +#' LPJ_GUESS_CONST_INTS <- data.frame(var = names(lpjguess_consts), val = as.numeric(unlist(lpjguess_consts)), stringsAsFactors = FALSE) +#' +#' +#' # Gridcell is the top-level container, start parsing from there +#' beg_end <- serialize_starts_ends(file_in = guesscpp_in, pattern = "void Gridcell::serialize") +#' +#' # now we will parse the stuff between these lines +#' # first find what is being written +#' streamed_vars_gridcell <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) +#' +#' ################################## CAUTION : THE FOLLOWING IS A MONSTROUS NESTED-LOOP ################################## +#' +#' # Now I can use streamed_vars_gridcell to loop over them +#' # We read everything in this loop, Gridcell list is going to be the top container +#' # there will be nested loops, the hierarchy will follow LPJ-GUESS architecture +#' Gridcell <- list() +#' level <- "Gridcell" +#' for(g_i in seq_along(streamed_vars_gridcell)){ # Gridcell-loop starts +#' current_stream <- streamed_vars_gridcell[g_i] +#' if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard +#' if(grepl(glob2rx("(*this)[*].landcover"), current_stream)){ # s counter might change, using wildcard +#' # not sure how to handle this better. If we see this, it means we are now looping over Stands +#' # this function considers "NATURAL" vegetation only, so there is only one stand +#' # this is an integer that tells us which landcover type this stand is +#' # so it should be the indice of NATURAL in typedef enum landcovertype (I believe indexing starts from 0) +#' +#' num_stnd <- as.numeric(Gridcell$nstands) +#' Gridcell[["Stand"]] <- vector("list", num_stnd) +#' +#' # note that this is streamed under Gridcell, not Stand in guess.cpp, +#' # but I think this info needs to go together with the Stand sublist +#' # so prepend landcovertype to the streamed_vars_stand +#' +#' next +#' } +#' +#' # "(*this)[*]" points to different things under different levels, here it is stand +#' if(grepl(glob2rx("(*this)[*]"), current_stream)){ # note that first else-part will be evaluated considering the order in guess.cpp +#' +#' # STAND +#' level <- "Stand" +#' current_stream <- "Stand" +#' current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) +#' +#' beg_end <- serialize_starts_ends(file_in = guesscpp_in, +#' pattern = paste0("void ", +#' tools::toTitleCase(current_stream_type$name), +#' "::serialize")) +#' streamed_vars_stand <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) +#' streamed_vars_stand <- c("landcover", streamed_vars_stand) # prepending landcovertype to the streamed_vars_stand +#' +#' +#' for(stnd_i in seq_len(num_stnd)){ #looping over the stands +#' for(svs_i in seq_along(streamed_vars_stand)){ # looping over the streamed stand vars +#' +#' current_stream <- streamed_vars_stand[svs_i] +#' if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard +#' +#' if(current_stream == "nobj" & level == "Stand"){ +#' # nobj points to different things under different levels, here it is the number of patches +#' # number of patches is set through insfiles, read by write.configs and passed to this fcn +#' # but it's also written to the state file, need to move bytes +#' nofpatch <- readBin(zz, integer(), 1, size = 4) +#' if(npatches == nofpatch){ # also not a bad place to check if everything is going fine so far +#' Gridcell[["Stand"]][[stnd_i]]$npatches <- npatches +#' #Gridcell[["Stand"]] <- vector("list", npatches) +#' }else{ +#' PEcAn.logger::logger.severe("The number of patches set through the instruction file does not match the number read from the state files. Probably a bug in the read.state function! Terminating.") +#' } +#' next +#' } +#' +#' # "(*this)[*]" points to different things under different levels, here it is patch +#' if(grepl(glob2rx("(*this)[*]"), current_stream)){ +#' # PATCH +#' level <- "Patch" +#' current_stream <- "Patch" +#' current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) +#' +#' beg_end <- serialize_starts_ends(file_in = guesscpp_in, +#' pattern = paste0("void ", +#' tools::toTitleCase(current_stream_type$name), +#' "::serialize")) +#' streamed_vars_patch <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) +#' +#' Gridcell[["Stand"]][[stnd_i]][["Patch"]] <- vector("list", npatches) +#' +#' for(ptch_i in seq_len(npatches)){ #looping over the patches +#' for(svp_i in seq_along(streamed_vars_patch)){ #looping over the streamed patch vars +#' current_stream <- streamed_vars_patch[svp_i] +#' if(grepl(glob2rx("pft[*]"), current_stream)) current_stream <- paste0(level, "pft") # i counter might change, using wildcard +#' +#' if(tools::toTitleCase(current_stream) %in% LPJ_GUESS_CLASSES){ +#' current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) +#' }else{ +#' current_stream_type <- find_stream_type("Patch", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) +#' } +#' +#' +#' Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[length(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])+1]] <- list() +#' names(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])[length(Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])] <- current_stream_type$name +#' +#' if(current_stream_type$type == "class"){ +#' +#' # CLASS +#' class_name <- current_stream_type$name +#' +#' beg_end <- serialize_starts_ends(file_in = guesscpp_in, +#' pattern = paste0("void ", +#' tools::toTitleCase(current_stream_type$name), +#' "::serialize")) +#' +#' +#' if(class_name == "Vegetation"){ +#' # VEGETATION +#' # Vegetation class has a bit of a different structure, it has one more depth, see model documentation +#' streamed_vars_veg <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) +#' +#' # NOTE : Unlike other parts, this bit is a lot less generalized!!! +#' # I'm gonna asumme Vegetation class won't change much in the future +#' # indiv.pft.id and indiv needs to be looped over nobj times +#' if(!setequal(streamed_vars_veg, c("nobj", "indiv.pft.id", "indiv"))){ +#' PEcAn.logger::logger.severe("Vegetation class object changed in this model version, you need to fix read.state") +#' } +#' +#' # nobj points to different things under different levels, here it is the number of individuals +#' number_of_individuals <- readBin(zz, integer(), 1, size = 4) +#' Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["number_of_individuals"]] <- number_of_individuals +#' +#' # few checks for sensible vals +#' if(number_of_individuals < 1 | number_of_individuals > 10000){ # should there be an upper limit here too? +#' # if number of individuals is 0 it's a bit suspicious. Not sure if ever will get negative but that'd definitely be wrong +#' PEcAn.logger::logger.warn("Number of individuals under vegetation is", number_of_individuals) +#' } +#' Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]] <- vector("list", number_of_individuals) +#' +#' beg_end <- serialize_starts_ends(file_in = guesscpp_in, +#' pattern = paste0("void Individual::serialize")) +#' streamed_vars_indv <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) +#' +#' # loop over nobj +#' for(indv_i in seq_len(number_of_individuals)){ +#' Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]] <- list() +#' # which PFT is this? +#' Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][["indiv.pft.id"]] <- readBin(zz, integer(), 1, size = 4) +#' # read all the individual class +#' for(svi_i in seq_along(streamed_vars_indv)){ # +#' current_stream <- streamed_vars_indv[svi_i] +#' +#' current_stream_type <- find_stream_type("individual", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) +#' current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) +#' +#' if(current_stream_specs$single){ +#' Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][[current_stream_type$name]] <- readBin(con = zz, +#' what = current_stream_specs$what, +#' n = current_stream_specs$n, +#' size = current_stream_specs$size) +#' }else{ +#' for(css.i in seq_along(current_stream_specs$what)){ +#' Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Vegetation"]][["Individuals"]][[indv_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, +#' what = current_stream_specs$what[css.i], +#' n = current_stream_specs$n[css.i], +#' size = current_stream_specs$size[css.i]) +#' } +#' } +#' +#' }# end loop over stream vars individual +#' } # end loop over number_of_individuals +#' +#' +#' +#' +#' +#' }else if(class_name == "Fluxes"){ +#' # FLUXES +#' # this is not generalized at all +#' streamed_vars_flux <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) +#' +#' if(!setequal(streamed_vars_flux, c("annual_fluxes_per_pft", "monthly_fluxes_patch", "monthly_fluxes_pft"))){ +#' PEcAn.logger::logger.severe("Fluxes class object changed in this model version, you need to fix read.state") +#' } +#' +#' # annual_fluxes_per_pft loops over +#' # parse from guess.h +#' PerPFTFluxType <- c("NPP", "GPP", "RA", "ISO", "MON") +#' Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]] <- list() +#' key1 <- readBin(zz, "integer", 1, 8) +#' Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]][["n_pft"]] <- key1 +#' for(fpft_i in seq_len(key1)){ # key1 11 PFTs +#' Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]][[fpft_i]] <- list() +#' key2 <- readBin(zz, "integer", 1, 8) +#' if(key2 > 10000){ #make sure you dind't read a weird number, this is supposed to be number of fluxes per pft, can't have too many +#' PEcAn.logger::logger.severe("Number of fluxes per pft read from the state file is too high. Check read.state function") +#' } +#' Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]][[fpft_i]][["key2"]] <- key2 +#' for(flux_i in seq_len(key2)){ +#' # is this double? +#' Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["annual_fluxes_per_pft"]][[fpft_i]][[PerPFTFluxType[flux_i]]] <- readBin(zz, "double", 1, 8) +#' } +#' } +#' +#' # monthly_fluxes_patch read as a vector at once +#' # double monthly_fluxes_patch[12][NPERPATCHFLUXTYPES]; +#' # maybe read this as a matrix? +#' n_monthly_fluxes_patch <- 12 * LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var =="PerPatchFluxType"] +#' Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["monthly_fluxes_patch"]] <- readBin(zz, "double", n_monthly_fluxes_patch, 8) +#' +#' # monthly_fluxes_pft read as a vector at once +#' # double monthly_fluxes_pft[12][NPERPFTFLUXTYPES]; +#' # maybe read this as a matrix? +#' n_monthly_fluxes_pft <- 12 * LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var =="PerPFTFluxType"] +#' Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Fluxes"]][["monthly_fluxes_pft"]] <- readBin(zz, "double", n_monthly_fluxes_pft, 8) +#' +#' }else{ +#' # NOT VEGETATION OR FLUX +#' streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) +#' num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) +#' +#' for(varname in streamed_vars){ +#' Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[current_stream_type$name]][[varname]] <- vector("list", num_pft) +#' } +#' +#' # maybe try modifying this bit later to make it a function +#' for(pft_i in seq_len(num_pft)){ +#' for(sv_i in seq_along(streamed_vars)){ +#' current_stream <- streamed_vars[sv_i] #it's OK to overwrite +#' current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) +#' +#' if(current_stream_type$type == "class"){ +#' +#' if(current_stream_type$name != "sompool"){ +#' PEcAn.logger::logger.debug("Classes other than sompool enter here.") +#' } +#' # ONLY SOMPOOL HERE SO FAR ****************************************************************** +#' # code below is very sompool specific +#' # class_name <- # don't overwrite class_name +#' +#' beg_end <- serialize_starts_ends(file_in = guesscpp_in, +#' pattern = paste0("void ", +#' tools::toTitleCase(current_stream_type$name), +#' "::serialize")) +#' streamed_vars_sompool <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) +#' +#' nsompool <- LPJ_GUESS_CONST_INTS$val[LPJ_GUESS_CONST_INTS$var == "NSOMPOOL"] +#' +#' for(varname in streamed_vars_sompool){ +#' Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Soil"]][["sompool[i]"]][[varname]] <- vector("list", nsompool) +#' } +#' +#' names( Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Soil"]])[names( Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Soil"]]) == "sompool[i]"] <- "Sompool" +#' +#' ###################### LOOP OVER NSOMPOOL +#' for(som_i in seq_len(nsompool)){ +#' for(sv_sompool_i in seq_along(streamed_vars_sompool)){ +#' current_stream <- streamed_vars_sompool[sv_sompool_i] +#' +#' current_stream_type <- find_stream_type("Sompool", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) +#' current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) +#' +#' if(current_stream_specs$single){ +#' Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][["Soil"]][["Sompool"]][[current_stream_type$name]][[som_i]] <- readBin(con = zz, +#' what = current_stream_specs$what, +#' n = current_stream_specs$n, +#' size = current_stream_specs$size) +#' }else{ +#' PEcAn.logger::logger.severe("Historic under sompool.") # Not expecting any +#' } +#' } +#' } +#' +#' }else{ +#' current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) +#' # and read! +#' if(current_stream_specs$single){ # maybe use current_stream in sublist names to find correct place +#' Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[length( Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, +#' what = current_stream_specs$what, +#' n = current_stream_specs$n, +#' size = current_stream_specs$size) +#' }else{ # only for historic type? +#' for(css.i in seq_along(current_stream_specs$what)){ # maybe use current_stream in sublist names to find correct place +#' Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[length( Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]])]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, +#' what = current_stream_specs$what[css.i], +#' n = current_stream_specs$n[css.i], +#' size = current_stream_specs$size[css.i]) +#' } +#' } +#' } +#' } # streamed_vars-loop ends +#' } # pft-loop ends +#' } +#' +#' +#' }else{ +#' # NOT CLASS +#' current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) +#' # and read! +#' if(current_stream_specs$single){ +#' +#' Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[current_stream_type$name]] <- readBin(con = zz, +#' what = current_stream_specs$what, +#' n = current_stream_specs$n, +#' size = current_stream_specs$size) +#' }else{ # probably don't need this but let's keep +#' for(css_i in seq_along(current_stream_specs$what)){ +#' # CHANGE ALL THESE HISTORIC TYPES SO THAT cirrent_index and full goes together with the variable +#' Gridcell[["Stand"]][[stnd_i]][["Patch"]][[ptch_i]][[current_stream_specs$names[css_i]]] <- readBin(con = zz, +#' what = current_stream_specs$what[css_i], +#' n = current_stream_specs$n[css_i], +#' size = current_stream_specs$size[css_i]) +#' } +#' } +#' }# end if-class within Patch +#' } +#' } +#' +#' }else{ +#' # NOT PATCH +#' +#' if(tools::toTitleCase(current_stream) %in% LPJ_GUESS_CLASSES){ +#' current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) +#' }else{ +#' current_stream_type <- find_stream_type("Stand", current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) +#' } +#' +#' Gridcell[["Stand"]][[stnd_i]][[length(Gridcell[["Stand"]][[stnd_i]])+1]] <- list() +#' names(Gridcell[["Stand"]][[stnd_i]])[length(Gridcell[["Stand"]][[stnd_i]])] <- current_stream_type$name +#' +#' if(current_stream_type$type == "class"){ +#' +#' # CLASS +#' class_name <- current_stream_type$name +#' +#' beg_end <- serialize_starts_ends(file_in = guesscpp_in, +#' pattern = paste0("void ", +#' tools::toTitleCase(current_stream_type$name), +#' "::serialize")) +#' streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) +#' num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) +#' +#' for(varname in streamed_vars){ +#' Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]][[varname]] <- varname +#' Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]][[varname]] <- vector("list", num_pft) +#' } +#' +#' for(pft_i in seq_len(num_pft)){ +#' for(sv_i in seq_along(streamed_vars)){ +#' current_stream <- streamed_vars[sv_i] #it's OK to overwrite +#' current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) +#' +#' if(current_stream_type$type == "class"){ +#' +#' # CLASS, NOT EVER GOING HERE? +#' class_name <- current_stream_type$name +#' +#' }else{ +#' current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) +#' # and read! +#' if(current_stream_specs$single){ +#' Gridcell[["Stand"]][[stnd_i]][[length(Gridcell[["Stand"]][[stnd_i]])]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, +#' what = current_stream_specs$what, +#' n = current_stream_specs$n, +#' size = current_stream_specs$size) +#' }else{ +#' for(css.i in seq_along(current_stream_specs$what)){ +#' Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, +#' what = current_stream_specs$what[css.i], +#' n = current_stream_specs$n[css.i], +#' size = current_stream_specs$size[css.i]) +#' } +#' } +#' } +#' } # streamed_vars-loop ends +#' } # pft-loop ends +#' +#' }else{ +#' # NOT CLASS +#' current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) +#' # and read! +#' if(current_stream_specs$single){ +#' Gridcell[["Stand"]][[stnd_i]][[current_stream_type$name]] <- readBin(con = zz, +#' what = current_stream_specs$what, +#' n = current_stream_specs$n, +#' size = current_stream_specs$size) +#' }else{ # probably don't need this but let's keep +#' for(css_i in seq_along(current_stream_specs$what)){ +#' Gridcell[[length(Gridcell)]][[current_stream_specs$names[css_i]]] <- readBin(con = zz, +#' what = current_stream_specs$what[css_i], +#' n = current_stream_specs$n[css_i], +#' size = current_stream_specs$size[css_i]) +#' } +#' } +#' }# end if-class within Stand +#' } # end patch-if +#' +#' +#' }# end for-loop over the streamed stand vars (svs_i, L.165) +#' }# end for-loop over the stands (stnd_i, L.164) +#' +#' }else{ #not reading in Stand variables +#' +#' # NOT STAND +#' +#' current_stream_type <- find_stream_type(NULL, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) +#' +#' Gridcell[[length(Gridcell)+1]] <- list() +#' names(Gridcell)[length(Gridcell)] <- current_stream_type$name +#' if(current_stream_type$type == "class"){ +#' +#' # CLASS +#' class_name <- current_stream_type$name +#' +#' beg_end <- serialize_starts_ends(file_in = guesscpp_in, +#' pattern = paste0("void ", +#' tools::toTitleCase(current_stream_type$name), +#' "::serialize")) +#' streamed_vars <- find_stream_var(file_in = guesscpp_in, line_nos = beg_end) +#' num_pft <- ifelse(grepl("pft", current_stream_type$name, fixed = TRUE), n_pft, 1) +#' +#' for(varname in streamed_vars){ +#' Gridcell[[length(Gridcell)]][[varname]] <- varname +#' Gridcell[[length(Gridcell)]][[varname]] <- vector("list", num_pft) +#' } +#' +#' for(pft_i in seq_len(num_pft)){ +#' for(sv_i in seq_along(streamed_vars)){ +#' #for(sv_i in 21:37){ +#' current_stream <- streamed_vars[sv_i] #it's OK to overwrite +#' current_stream_type <- find_stream_type(class_name, current_stream, LPJ_GUESS_CLASSES, LPJ_GUESS_TYPES, guessh_in) +#' +#' if(current_stream_type$type == "class"){ +#' +#' # CLASS, NOT EVER GOING HERE? +#' class_name <- current_stream_type$name +#' +#' }else{ +#' current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) +#' # and read! +#' if(current_stream_specs$single){ +#' Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]] <- readBin(con = zz, +#' what = current_stream_specs$what, +#' n = current_stream_specs$n, +#' size = current_stream_specs$size) +#' }else{ +#' for(css.i in seq_along(current_stream_specs$what)){ +#' Gridcell[[length(Gridcell)]][[current_stream_type$name]][[pft_i]][[current_stream_specs$names[css.i]]]<- readBin(con = zz, +#' what = current_stream_specs$what[css.i], +#' n = current_stream_specs$n[css.i], +#' size = current_stream_specs$size[css.i]) +#' } +#' } +#' } +#' } # streamed_vars-loop ends +#' } # pft-loop ends +#' +#' }else{ +#' # NOT CLASS +#' current_stream_specs <- find_stream_size(current_stream_type, guessh_in, LPJ_GUESS_TYPES, LPJ_GUESS_CONST_INTS) +#' # and read! +#' if(current_stream_specs$single){ +#' Gridcell[[length(Gridcell)]][[current_stream_type$name]] <- readBin(con = zz, +#' what = current_stream_specs$what, +#' n = current_stream_specs$n, +#' size = current_stream_specs$size) +#' }else{ # probably don't need this but let's keep +#' for(css_i in seq_along(current_stream_specs$what)){ +#' Gridcell[[length(Gridcell)]][[current_stream_specs$names[css_i]]] <- readBin(con = zz, +#' what = current_stream_specs$what[css_i], +#' n = current_stream_specs$n[css_i], +#' size = current_stream_specs$size[css_i]) +#' } +#' } +#' }# end if-class within Gridcell +#' +#' } # Stand if-else ends +#' } # Gridcell-loop ends +#' +#' +#' diff --git a/models/lpjguess/R/updateState.LPJGUESS.R b/models/lpjguess/R/update.state.LPJGUESS.R similarity index 83% rename from models/lpjguess/R/updateState.LPJGUESS.R rename to models/lpjguess/R/update.state.LPJGUESS.R index 0bbebc5f515..0dea2b46bde 100644 --- a/models/lpjguess/R/updateState.LPJGUESS.R +++ b/models/lpjguess/R/update.state.LPJGUESS.R @@ -7,37 +7,34 @@ # http://opensource.ncsa.illinois.edu/license.html #------------------------------------------------------------------------------- -#' Adjust LPJ-GUESS state -#' -#' @title updateState.LPJGUESS -#' -#' @description -#' -#' -#' @param model.state A large multiply-nested list containing the entire LPJ-GUESS state as read by -#' function \code{readStateBinary.LPJGUESS} -#' @param dens.initial A numeric vector of the initial stand-level stem densities (indiv/m^2) as named numeric vector -#' with one entry per PFT/species, with the names being the PFT/species codes. These values should be produced -#' using state data assimilation from function XXXXXX. -#' @param dens.target A numeric vector of the target stand-level stem densities (indiv/m^2) as named numeric vector -#' with one entry per PFT/species, with the names being the PFT/species codes. These values should be produced -#' using state data assimilation from function XXXXXX -#' @param cmass.target A numeric vector of the target stand-level biomasses (kgC/m^2) as named numeric vector -#' with one entry per PFT/species, with the names being the PFT/species codes. These values should be produced -#' using state data assimilation from function XXXXXX -#' @param cmass.target A numeric vector of the target stand-level biomasses (kgC/m^2) as named numeric vector -#' with one entry per PFT/species, with the names being the PFT/species codes. These values should be produced -#' using state data assimilation from function XXXXXX -#' @param HEIGHT_MAX Maximum allowed height of an individual. This is the maximum height that a tree -#' can have. This is hard-coded in LPJ-GUESS to 150 m, but for SDA that might be unrealistically big, -#' so this argument allows adjustment. -#' @return And updated model state (as a big old list o' lists) -#' @export -#' @author Matthew Forrest - - - -updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, cmass.initial, cmass.target, HEIGHT_MAX = 150) { +##' Adjust LPJ-GUESS state +##' +##' @title updateState.LPJGUESS +##' +##' @description +##' +##' +##' @param model.state A large multiply-nested list containing the entire LPJ-GUESS state as read by +##' function \code{readStateBinary.LPJGUESS} +##' @param dens.initial A numeric vector of the initial stand-level stem densities (indiv/m^2) as named numeric vector +##' with one entry per PFT/species, with the names being the PFT/species codes. These values should be produced +##' using state data assimilation from function XXXXXX. +##' @param dens.target A numeric vector of the target stand-level stem densities (indiv/m^2) as named numeric vector +##' with one entry per PFT/species, with the names being the PFT/species codes. These values should be produced +##' using state data assimilation from function XXXXXX +##' @param cmass.target A numeric vector of the target stand-level biomasses (kgC/m^2) as named numeric vector +##' with one entry per PFT/species, with the names being the PFT/species codes. These values should be produced +##' using state data assimilation from function XXXXXX +##' @param cmass.target A numeric vector of the target stand-level biomasses (kgC/m^2) as named numeric vector +##' with one entry per PFT/species, with the names being the PFT/species codes. These values should be produced +##' using state data assimilation from function XXXXXX +##' @param HEIGHT_MAX Maximum allowed height of an individual. This is the maximum height that a tree +##' can have. This is hard-coded in LPJ-GUESS to 150 m, but for SDA that might be unrealistically big, +##' so this argument allows adjustment. +##' @return And updated model state (as a big old list o' lists) +##' @export update.state.LPJGUESS +##' @author Matthew Forrest +update.state.LPJGUESS <- function(model.state, dens.initial, dens.target, cmass.initial, cmass.target, HEIGHT_MAX = 150) { # calculate relative increases to be applied later on (per PFT) @@ -104,7 +101,7 @@ updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, cmass.i # for each individual - for(individual.counter in 1:this.patch$Vegetation$number_of_individuals) { + for(individual.counter in 1:length(this.patch$Vegetation)) { # IMPORTANT: note that this is for convenience to *read* variables from the original individual @@ -186,7 +183,7 @@ updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, cmass.i # STEP 1 - nudge density of stems by adjusting the "densindiv" and also scaling the biomass pools appropriately - updated.individual <- adjustDensity.LPJGUESS(original.individual, current.target.densindiv.rel.change) + updated.individual <- adjust.density.LPJGUESS(original.individual, current.target.densindiv.rel.change) # STEP 2 - nudge biomass by performing the LPJ-GUESS allocation routine @@ -194,7 +191,7 @@ updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, cmass.i # this function call runs the LPJ-GUESS allocation routine and adjusts the pools vegetation pools accordingly # however, it doesn't adjust the litter pools or do anything with 'exceeds_cmass', these are returned # as elements of the list, because they should only be applied to the state *if* this was a valid allocation - updated.list <- adjustBiomass(individual = updated.individual, + updated.list <- adjust.biomass.LPJGUESS(individual = updated.individual, rel.change = current.target.biomass.rel.change, sla = sla[this.pft.id+1], wooddens = wooddens[this.pft.id+1], @@ -243,6 +240,16 @@ updateState.LPJGUESS <- function(model.state, dens.initial, dens.target, cmass.i # if not, there will be a new iteration with new multipliers if(result.code == "OK") { + + # check if the change in the wood compartment is close to the nudge + wood.before <- original.individual$cmass_sap + original.individual$cmass_heart + wood.after <- updated.individual$cmass_sap + updated.individual$cmass_heart + + print("--------------------------------------------") + print(paste("wood change = ", wood.after/ wood.before)) + print(paste("nudge = ", current.target.biomass.rel.change )) + + # first update the allometry updated.individual$height <- allometry.results$height updated.individual$crownarea <- allometry.results$crownarea diff --git a/models/lpjguess/man/adjustBiomass.Rd b/models/lpjguess/man/adjust.biomass.LPJGUESS.Rd similarity index 89% rename from models/lpjguess/man/adjustBiomass.Rd rename to models/lpjguess/man/adjust.biomass.LPJGUESS.Rd index 6af95e96a69..7ee2528faa7 100644 --- a/models/lpjguess/man/adjustBiomass.Rd +++ b/models/lpjguess/man/adjust.biomass.LPJGUESS.Rd @@ -1,11 +1,11 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/adjustBiomass.LPJGUESS.R -\name{adjustBiomass} -\alias{adjustBiomass} +% Please edit documentation in R/adjust.biomass.LPJGUESS.R +\name{adjust.biomass.LPJGUESS} +\alias{adjust.biomass.LPJGUESS} \title{Adjust LPJ-GUESS individual's biomass} \usage{ -adjustBiomass(individual, rel.change, sla, wooddens, lifeform, k_latosa, - k_allom2, k_allom3) +adjust.biomass.LPJGUESS(individual, rel.change, sla, wooddens, lifeform, + k_latosa, k_allom2, k_allom3) } \arguments{ \item{individual}{A nested list which encapsulates an LPJ-GUESS 'Individual' as read from a binary state file} diff --git a/models/lpjguess/man/adjustDensity.LPJGUESS.Rd b/models/lpjguess/man/adjust.density.LPJGUESS.Rd similarity index 76% rename from models/lpjguess/man/adjustDensity.LPJGUESS.Rd rename to models/lpjguess/man/adjust.density.LPJGUESS.Rd index 5df6681e612..59a4af431d1 100644 --- a/models/lpjguess/man/adjustDensity.LPJGUESS.Rd +++ b/models/lpjguess/man/adjust.density.LPJGUESS.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/adjustDensity.LPJGUESS.R -\name{adjustDensity.LPJGUESS} -\alias{adjustDensity.LPJGUESS} +% Please edit documentation in R/adjust.density.LPJGUESS.R +\name{adjust.density.LPJGUESS} +\alias{adjust.density.LPJGUESS} \title{Adjust LPJ-GUESS individual's density} \usage{ -adjustDensity.LPJGUESS(individual, rel.change) +adjust.density.LPJGUESS(individual, rel.change) } \arguments{ \item{individual}{A nested list which encapsulates an LPJ-GUESS 'Individual' as read from a binary state file} diff --git a/models/lpjguess/man/allometry.Rd b/models/lpjguess/man/allometry.Rd index 4a572e4e611..282d61f7904 100644 --- a/models/lpjguess/man/allometry.Rd +++ b/models/lpjguess/man/allometry.Rd @@ -6,7 +6,7 @@ \usage{ allometry(lifeform, cmass_leaf, cmass_sap, cmass_heart, densindiv, age, fpc, deltafpc, sla, k_latosa, k_rp, k_allom1, k_allom2, k_allom3, - wooddens, crownarea_max) + wooddens, crownarea_max, HEIGHT_MAX = 150) } \arguments{ \item{lifeform}{An integer code for the lifeform of this individual (cohort): 1 = Tree, 2 = Grass} @@ -33,7 +33,11 @@ allometry(lifeform, cmass_leaf, cmass_sap, cmass_heart, densindiv, age, \item{wooddens}{Wood density (kgC/m^2) (per PFT parameter)} -\item{crownarea_max}{Maximum allowed crown area (m^2) (per PFT parameter) +\item{crownarea_max}{Maximum allowed crown area (m^2) (per PFT parameter)} + +\item{HEIGHT_MAX}{Maximum allowed height of an individual. This is the maximum height that a tree +can have. This is hard-coded in LPJ-GUESS to 150 m, but for SDA that might be unrealistically big, +so this argument allows adjustment. This function was transcribed from LPJ-GUESS (v4.0) C++ to R for the purpose of nudging the LPJ-GUESS state offline. The idea is of course to use the output from the analysis step from an SDA routine to provide the nudged values, although that isn't diff --git a/models/lpjguess/man/updateState.LPJGUESS.Rd b/models/lpjguess/man/update.state.LPJGUESS.Rd similarity index 75% rename from models/lpjguess/man/updateState.LPJGUESS.Rd rename to models/lpjguess/man/update.state.LPJGUESS.Rd index ec6a8ed5186..e82f3f2be4a 100644 --- a/models/lpjguess/man/updateState.LPJGUESS.Rd +++ b/models/lpjguess/man/update.state.LPJGUESS.Rd @@ -1,11 +1,11 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/updateState.LPJGUESS.R -\name{updateState.LPJGUESS} -\alias{updateState.LPJGUESS} +% Please edit documentation in R/update.state.LPJGUESS.R +\name{update.state.LPJGUESS} +\alias{update.state.LPJGUESS} \title{updateState.LPJGUESS} \usage{ -updateState.LPJGUESS(model.state, dens.initial, dens.target, cmass.initial, - cmass.target) +\method{update}{state.LPJGUESS}(model.state, dens.initial, dens.target, + cmass.initial, cmass.target, HEIGHT_MAX = 150) } \arguments{ \item{model.state}{A large multiply-nested list containing the entire LPJ-GUESS state as read by @@ -23,6 +23,10 @@ using state data assimilation from function XXXXXX} with one entry per PFT/species, with the names being the PFT/species codes. These values should be produced using state data assimilation from function XXXXXX} +\item{HEIGHT_MAX}{Maximum allowed height of an individual. This is the maximum height that a tree +can have. This is hard-coded in LPJ-GUESS to 150 m, but for SDA that might be unrealistically big, +so this argument allows adjustment.} + \item{cmass.target}{A numeric vector of the target stand-level biomasses (kgC/m^2) as named numeric vector with one entry per PFT/species, with the names being the PFT/species codes. These values should be produced using state data assimilation from function XXXXXX} From 3adac8ed9f2893a3fcd18579cb96a6917e49b0ca Mon Sep 17 00:00:00 2001 From: istfer Date: Thu, 27 Jun 2019 16:58:15 -0400 Subject: [PATCH 53/56] define state year --- models/lpjguess/R/read_restart.LPJGUESS.R | 27 ++++++++++++++++--- models/lpjguess/R/write.config.LPJGUESS.R | 19 +++++++++++-- models/lpjguess/inst/lpjguess_params.Rdata | Bin 2316 -> 2316 bytes models/lpjguess/inst/pecan.ins | 30 ++++++++++----------- 4 files changed, 56 insertions(+), 20 deletions(-) diff --git a/models/lpjguess/R/read_restart.LPJGUESS.R b/models/lpjguess/R/read_restart.LPJGUESS.R index 6e19cad8306..e480dd3241b 100644 --- a/models/lpjguess/R/read_restart.LPJGUESS.R +++ b/models/lpjguess/R/read_restart.LPJGUESS.R @@ -1,7 +1,7 @@ # developing # outdir = "/fs/data2/output//PEcAn_1000010473/out" -# runid = 1002656610 +# runid = 1002656839 # stop.time = "1960-12-31 23:59:59 UTC" # load("/fs/data2/output/PEcAn_1000010473/SDAsettings_develop.Rdata") # var.names = c("AGB.pft", "TotSoilCarb") @@ -27,7 +27,28 @@ read_restart.LPJGUESS <- function(outdir, runid, stop.time, settings, var.names, forecast <- list() - # for (var_name in var.names) {} + # additional varnames for LPJ-GUESS? + + for (var_name in var.names) { + + if (var_name == "AGB.pft") { + + cmass_sap_perpft <- calculateGridcellVariablePerPFT(model.state = Gridcell_container, variable = "cmass_sap") + cmass_heart_perpft <- calculateGridcellVariablePerPFT(model.state = Gridcell_container, variable = "cmass_heart") + + cmass_wood <- cmass_sap_perpft + cmass_heart_perpft + cmass_wood <- udunits2::ud.convert(cmass_wood, "kg/m^2", "Mg/ha") + + # calculate below ground and subtract + # 0.23 magic number from Chojnacky Table 6 + cmass_blwg_wood <- cmass_wood * 0.23 + cmass_abvg_wood <- cmass_wood - cmass_blwg_wood + + forecast[[length(forecast) + 1]] <- cmass_abvg_wood + names(forecast[[length(forecast)]]) <- paste0("AGB.pft.", unlist(Gridcell_container$meta_data$pft)) + + } + } params$LPJGUESS_state <- Gridcell_container @@ -37,4 +58,4 @@ read_restart.LPJGUESS <- function(outdir, runid, stop.time, settings, var.names, return(X_tmp) -} # read_restart.LPJGUESS \ No newline at end of file +} # read_restart.LPJGUESS diff --git a/models/lpjguess/R/write.config.LPJGUESS.R b/models/lpjguess/R/write.config.LPJGUESS.R index 2f0907b4bb7..3febb642c08 100644 --- a/models/lpjguess/R/write.config.LPJGUESS.R +++ b/models/lpjguess/R/write.config.LPJGUESS.R @@ -36,7 +36,7 @@ write.config.LPJGUESS <- function(defaults, trait.values, settings, run.id, rest #----------------------------------------------------------------------- # write LPJ-GUESS specific instruction file - settings <- write.insfile.LPJGUESS(settings, trait.values, rundir, outdir, run.id) + settings <- write.insfile.LPJGUESS(settings, trait.values, rundir, outdir, run.id, restart) #----------------------------------------------------------------------- # create launch script (which will create symlink) @@ -94,7 +94,7 @@ write.config.LPJGUESS <- function(defaults, trait.values, settings, run.id, rest #' @param run.id PEcAn run ID #' @return settings Updated list #' @author Istem Fer -write.insfile.LPJGUESS <- function(settings, trait.values, rundir, outdir, run.id) { +write.insfile.LPJGUESS <- function(settings, trait.values, rundir, outdir, run.id, restart = NULL) { guessins <- readLines(con = system.file("template.ins", package = "PEcAn.LPJGUESS"), n = -1) paramsins <- readLines(con = system.file("pecan.ins", package = "PEcAn.LPJGUESS"), n = -1) @@ -102,19 +102,33 @@ write.insfile.LPJGUESS <- function(settings, trait.values, rundir, outdir, run.i pftblock <- paramsins[pftindx] # lines with pft params # fill save state flags + if(is.null(restart)){ + year_string <- substring(basename(settings$run$inputs$met[[1]]), + nchar(basename(settings$run$inputs$met[[1]]))-15, + nchar(basename(settings$run$inputs$met[[1]]))-7) + #spinup plus simulation years, extract from defult, or pass it here if you'll be varying this in the future + spinup_years <- as.numeric(gsub("[^[:digit:].]", "", paramsins[grepl("nyear_spinup", paramsins, fixed = TRUE)])) + state_year <- spinup_years + diff(as.numeric(strsplit(year_string, split = ".", fixed = TRUE)[[1]])) + 1 + }else{ + # read previous year's params.ins and add 1 or? + } + if(!is.null(settings$model$save_state)){ save_state <- as.logical(settings$model$save_state) if(save_state){ paramsins <- gsub("@SAVE_STATE_OPTION@", 1, paramsins) paramsins <- gsub("@STATE_PATH@", paste0("state_path '", outdir, "'"), paramsins) + paramsins <- gsub("@STATE_YEAR@", paste0("state_year '", state_year, "'"), paramsins) }else{ paramsins <- gsub("@RESTART_OPTION@", 0, paramsins) paramsins <- gsub("@STATE_PATH@", "!state_path", paramsins) + paramsins <- gsub("@STATE_PATH@", "!state_year", paramsins) } }else{ # wouldn't hurt to save state by default? paramsins <- gsub("@SAVE_STATE_OPTION@", 1, paramsins) paramsins <- gsub("@STATE_PATH@", paste0("state_path '", outdir, "'"), paramsins) + paramsins <- gsub("@STATE_YEAR@", paste0("state_year '", state_year, "'"), paramsins) } # cp the grid indices file @@ -157,6 +171,7 @@ write.insfile.LPJGUESS <- function(settings, trait.values, rundir, outdir, run.i pecan_sample <- paste(upper_layer_fraction, lower_layer_fraction) } + if(trait_name == "wooddens"){ # convert from relative density to sapwood and heartwood density (kgC/m3) pecan_sample <- pecan_sample*997 # density of water } diff --git a/models/lpjguess/inst/lpjguess_params.Rdata b/models/lpjguess/inst/lpjguess_params.Rdata index 112a2316802430db79dae3ecffce4158425b50e8..108a293f0e18456d4168bd3cf62aeb04523b3ff3 100644 GIT binary patch delta 18 acmeAX>Ji%To|(!1!Ng~BoB3J(vH$=^hzDE% delta 31 dcmeAX>Ji%To>|C&0S@?pEJphWn;BWSSpj0_1t$Oi diff --git a/models/lpjguess/inst/pecan.ins b/models/lpjguess/inst/pecan.ins index bb3e2aa0c30..d8d52274477 100755 --- a/models/lpjguess/inst/pecan.ins +++ b/models/lpjguess/inst/pecan.ins @@ -16,20 +16,20 @@ outputdirectory "./" ! Prefined yearly output ! These files may be outcommented if their output is not required. -!file_cmass "cmass.out" -!file_anpp "anpp.out" +file_cmass "cmass.out" +file_anpp "anpp.out" file_agpp "agpp.out" -!file_fpc "fpc.out" -!file_aaet "aaet.out" -!file_lai "lai.out" -!file_cflux "cflux.out" -!file_dens "dens.out" -!file_runoff "tot_runoff.out" -!file_cpool "cpool.out" -!file_clitter "clitter.out" -!file_firert "firert.out" -!file_aiso "aiso.out" -!file_amon "amon.out" +file_fpc "fpc.out" +file_aaet "aaet.out" +file_lai "lai.out" +file_cflux "cflux.out" +file_dens "dens.out" +file_runoff "tot_runoff.out" +file_cpool "cpool.out" +file_clitter "clitter.out" +file_firert "firert.out" +file_aiso "aiso.out" +file_amon "amon.out" !file_speciesheights "height.out" !file_nmass "nmass.out" @@ -83,7 +83,7 @@ npatch 5 ! number of replicate patches to simulate patcharea 1000 ! patch area (m2) estinterval 5 ! years between establishment events in cohort mode ifdisturb 1 ! whether generic patch-destroying disturbances enabled -distinterval 100 ! average return time for generic patch-destroying disturbances +distinterval 500 ! average return time for generic patch-destroying disturbances disturb_year -1 ifbgestab 1 ! whether background establishment enabled ifsme 1 ! whether spatial mass effect enabled @@ -108,7 +108,7 @@ nrelocfrac 0.5 ! fraction of N retranslocated prior to leaf and root shedding !/////////////////////////////////////////////////////////////////////////////// ! SERIALIZATION SETTINGS !/////////////////////////////////////////////////////////////////////////////// -!state_year 500 ! year to save/start state file (no setting = after spinup) +@STATE_YEAR@ ! year to save/start state file (no setting = after spinup) restart 0 ! wheter to start from a state file save_state @SAVE_STATE_OPTION@ ! wheter to save a state file @STATE_PATH@ ! directory to put state files in From 14d05f6d05aa3971944978793b36609a05c4bfea Mon Sep 17 00:00:00 2001 From: istfer Date: Fri, 28 Jun 2019 14:00:16 -0400 Subject: [PATCH 54/56] add doc tags --- models/lpjguess/R/split_inputs.LPJGUESS.R | 48 +++++++++++------------ 1 file changed, 22 insertions(+), 26 deletions(-) diff --git a/models/lpjguess/R/split_inputs.LPJGUESS.R b/models/lpjguess/R/split_inputs.LPJGUESS.R index 7f4c1e48bd1..7932cd786c4 100644 --- a/models/lpjguess/R/split_inputs.LPJGUESS.R +++ b/models/lpjguess/R/split_inputs.LPJGUESS.R @@ -1,12 +1,17 @@ - -# developing -# settings = settings -# start.time = "1920-01-01 UTC" -# stop.time = "1960-12-31 UTC" -# inputs = "/fs/data3/istfer/LPJGUESS_ShortRuns/LPJGUESS_bcc-csm1-1_031.03/bcc-csm1-1_031.03.1960.2010.tmp.nc" -# overwrite = F - -split_inputs.LPJGUESS <- function(settings, start.time, stop.time, inputs, overwrite = FALSE, outpath = NULL, version = "PalEON"){ +## split LPJ-GUESS ncdf files into smaller time units to use in KF +##' @author Istem Fer +##' +##' @param settings PEcAn settings object +##' @param start.time start date and time for each SDA ensemble +##' @param stop.time stop date and time for each SDA ensemble +##' @param inputs list of model inputs to use in write.configs.LPJGUESS +##' @param overwrite Default FALSE +##' @param outpath if specified, write output to a new directory. Default NULL writes back to the directory being read +##' @description Splits climate met for LPJGUESS +##' +##' @return name of the split met file +##' @export +split_inputs.LPJGUESS <- function(settings, start.time, stop.time, inputs, overwrite = FALSE, outpath = NULL){ #### Lubridate start and end times start.day <- lubridate::yday(start.time) @@ -59,17 +64,10 @@ split_inputs.LPJGUESS <- function(settings, start.time, stop.time, inputs, overw } # split - if(version != "PalEON"){ - nc.tmp <- nc.tmp[1,1,inds] - nc.pre <- nc.pre[1,1,inds] - nc.cld <- nc.cld[1,1,inds] - }else{ - nc.tmp <- nc.tmp[inds] - nc.pre <- nc.pre[inds] - nc.cld <- nc.cld[inds] - } + nc.tmp <- nc.tmp[1,1,inds] + nc.pre <- nc.pre[1,1,inds] + nc.cld <- nc.cld[1,1,inds] - var.list <- list(nc.tmp, nc.pre, nc.cld) # not that these will be different than "K", "kg m-2 s-1", "W m-2" @@ -104,13 +102,11 @@ split_inputs.LPJGUESS <- function(settings, start.time, stop.time, inputs, overw # create netCD file for LPJ-GUESS ncfile <- ncdf4::nc_create(files.out[[n]], vars = var.def, force_v4 = TRUE) - if(version != "PalEON"){ - # put variable, rep(...,each=4) is a hack to write the same data for all grids (which all are the - # same) - ncdf4::ncvar_put(ncfile, var.def, rep(var.list[[n]], each = 4)) - }else{ - ncdf4::ncvar_put(ncfile, var.def, var.list[[n]]) - } + + # put variable, rep(...,each=4) is a hack to write the same data for all grids (which all are the + # same) + ncdf4::ncvar_put(ncfile, var.def, rep(var.list[[n]], each = 4)) + # additional attributes for LPJ-GUESS ncdf4::ncatt_put(nc = ncfile, varid = var.names[n], attname = "standard_name", long.names[n]) From 47a7c05f0c96091e04b262e7621b42181789e931 Mon Sep 17 00:00:00 2001 From: istfer Date: Fri, 28 Jun 2019 14:36:43 -0400 Subject: [PATCH 55/56] LPJGUESS package build --- models/lpjguess/DESCRIPTION | 2 +- models/lpjguess/NAMESPACE | 1 + models/lpjguess/man/write.config.LPJGUESS.Rd | 3 ++- models/lpjguess/man/write.insfile.LPJGUESS.Rd | 3 ++- 4 files changed, 6 insertions(+), 3 deletions(-) diff --git a/models/lpjguess/DESCRIPTION b/models/lpjguess/DESCRIPTION index 4a7ed6a4fcc..0599e0d192e 100644 --- a/models/lpjguess/DESCRIPTION +++ b/models/lpjguess/DESCRIPTION @@ -15,7 +15,7 @@ Imports: PEcAn.remote, lubridate (>= 1.6.0), ncdf4 (>= 1.15), - Rcpp (>= 0.11.0) + Rcpp (>= 1.0.1) LinkingTo: Rcpp Suggests: testthat (>= 1.0.2) diff --git a/models/lpjguess/NAMESPACE b/models/lpjguess/NAMESPACE index 1b374965b8a..dada54e6005 100644 --- a/models/lpjguess/NAMESPACE +++ b/models/lpjguess/NAMESPACE @@ -5,6 +5,7 @@ export(met2model.LPJGUESS) export(model2netcdf.LPJGUESS) export(pecan2lpjguess) export(readStateBinary) +export(split_inputs.LPJGUESS) export(update.state.LPJGUESS) export(write.config.LPJGUESS) export(write.insfile.LPJGUESS) diff --git a/models/lpjguess/man/write.config.LPJGUESS.Rd b/models/lpjguess/man/write.config.LPJGUESS.Rd index abeda198864..6778bceec8f 100644 --- a/models/lpjguess/man/write.config.LPJGUESS.Rd +++ b/models/lpjguess/man/write.config.LPJGUESS.Rd @@ -4,7 +4,8 @@ \alias{write.config.LPJGUESS} \title{Write LPJ-GUESS configuration files} \usage{ -write.config.LPJGUESS(defaults, trait.values, settings, run.id) +write.config.LPJGUESS(defaults, trait.values, settings, run.id, + restart = NULL) } \arguments{ \item{defaults}{list of defaults to process} diff --git a/models/lpjguess/man/write.insfile.LPJGUESS.Rd b/models/lpjguess/man/write.insfile.LPJGUESS.Rd index 6ad5a57f5c0..cf581863d50 100644 --- a/models/lpjguess/man/write.insfile.LPJGUESS.Rd +++ b/models/lpjguess/man/write.insfile.LPJGUESS.Rd @@ -4,7 +4,8 @@ \alias{write.insfile.LPJGUESS} \title{Write LPJ-GUESS instruction script} \usage{ -write.insfile.LPJGUESS(settings, trait.values, rundir, outdir, run.id) +write.insfile.LPJGUESS(settings, trait.values, rundir, outdir, run.id, + restart = NULL) } \arguments{ \item{settings}{PEcAn settings list} From e6d5138b27336deca0880f5e01b151c7f8809c59 Mon Sep 17 00:00:00 2001 From: istfer Date: Fri, 28 Jun 2019 15:11:18 -0400 Subject: [PATCH 56/56] no need for single quote --- models/lpjguess/R/write.config.LPJGUESS.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/models/lpjguess/R/write.config.LPJGUESS.R b/models/lpjguess/R/write.config.LPJGUESS.R index 3febb642c08..a5f3b3040f3 100644 --- a/models/lpjguess/R/write.config.LPJGUESS.R +++ b/models/lpjguess/R/write.config.LPJGUESS.R @@ -118,7 +118,7 @@ write.insfile.LPJGUESS <- function(settings, trait.values, rundir, outdir, run.i if(save_state){ paramsins <- gsub("@SAVE_STATE_OPTION@", 1, paramsins) paramsins <- gsub("@STATE_PATH@", paste0("state_path '", outdir, "'"), paramsins) - paramsins <- gsub("@STATE_YEAR@", paste0("state_year '", state_year, "'"), paramsins) + paramsins <- gsub("@STATE_YEAR@", paste0("state_year ", state_year), paramsins) }else{ paramsins <- gsub("@RESTART_OPTION@", 0, paramsins) paramsins <- gsub("@STATE_PATH@", "!state_path", paramsins) @@ -128,7 +128,7 @@ write.insfile.LPJGUESS <- function(settings, trait.values, rundir, outdir, run.i # wouldn't hurt to save state by default? paramsins <- gsub("@SAVE_STATE_OPTION@", 1, paramsins) paramsins <- gsub("@STATE_PATH@", paste0("state_path '", outdir, "'"), paramsins) - paramsins <- gsub("@STATE_YEAR@", paste0("state_year '", state_year, "'"), paramsins) + paramsins <- gsub("@STATE_YEAR@", paste0("state_year ", state_year), paramsins) } # cp the grid indices file