#' Generation of Forcing Functions in Fortran
#'
#' Generates Fortran code to return the current values of forcing functions
#' based on interpolation in tabulated time series data.
#'
#' @param x Data frame with colums 'name', 'file', 'column', 'mode', 'default'.
#' See below for expected entries.
#'
#' @return A character string holding generated Fortran code. Must be written to
#' disk, e.g. using \code{\link[base]{write}}, prior to compilation.
#'
#' @note
#' The fields of the input data frame are interpreted as follows:
#' \itemize{
#' \item{\code{name } Name of the forcing function as declared in the table
#' of functions.}
#' \item{\code{file } Name of the text file containing the time series data
#' either as an absolute or relative path.
#' Time information is expected as numeric values in the first column (e.g.
#' as number of seconds after some reference date).
#' The period is used as the decimal character in floating point numbers,
#' numeric values can also be given in scientific format (e.g. as 0.314e+1).
#' Allowed column delimiters are blank, tab, or comma. A sequence of white
#' spaces collapses to a single delimiter but this is not the case for
#' commas. It is strictly recommended to use a consistent delimiter
#' character within a particular file.
#' Blank lines are allowed everywhere in the file, comment lines must start
#' with a '#'. The first non-blank, non-comment line is interpreted as
#' column headers and the name of the first column (holding time info)
#' is essentially ignored).
#' }
#' \item{\code{column } Name of the column in \code{file} from which data are
#' to be read.}
#' \item{\code{mode } Integer code to control how the interpolation is
#' performed. Use 0 for constant interpolation with full weight given to the
#' value at the end of a time interval. Use 1 for constant interpolation
#' with full weight given to the value at the begin of a time interval. Any
#' other values (< 0 or > 1) result in linear interpolation with weights
#' being set automatically.}
#' \item{\code{default } Logical. If \code{FALSE}, the generated function has
#' the interface 'f(time)'. If \code{TRUE}, the generated function has a
#' two-argument interface 'f(time, z)'. If the actual argument 'z' is
#' \code{NaN}, the function behaves just like the single-argument version,
#' i.e. interpolation in tabulated data is performed. If 'z' is not
#' \code{NaN}, the function returns the value of 'z'.}
#' }
#'
#' The generated code provides a single module named 'forcings' which defines
#' as many forcing functions as there are rows in \code{x}.
#' The module 'forcings' needs to be made available to the compiler
#' (either at the command line or via inclusion in another file with Fortran's
#' include mechanism). In addition, it must be referenced in the module
#' 'functions' with an appropriate 'use' statement (see example below).
#'
#' The generated function return scalar values of type double precision. If an
#' error condition is encountered, the return value of a functions equals the
#' largest possible double precision value (generated by Fortran's 'huge'
#' function). In addition, errors trigger calls of the subroutines 'rexit'
#' (at top level) or 'rwarn' (at lower levels). These two functions are
#' available automatically if the Fortran code is compiled using 'R CMD SHLIB'.
#' Otherwise, the two functions need to be defined (see examples below).
#'
#' In the two-argument version, the second argument is tested against \code{NaN}
#' using 'ISNAN'. This function is not part of the Fortran standard but it is
#' supported by most compilers, including gfortan. The Fortran 2003 standard
#' conformal function would be 'IS_IEEE_NAN' which is not yet supported by
#' compiler versions normally installed with R (March 2016).
#'
#' @author David Kneis \email{david.kneis@@tu-dresden.de}
#'
#' @export
#'
#' @examples
#' \dontrun{
#' ! Example of a Fortran file to define functions
#' include 'forcings.f95' ! include generated forcings file in compilation
#' module functions
#' use forcings ! make forcings available as functions
#' implicit none
#' contains
#' ! ... any non-forcing functions go here ...
#' end module
#' }
#'
#' \dontrun{
#' ! Definition of 'rexit' and 'rwarn' for testing of the generated code
#' ! outside of R
#' subroutine rexit (x)
#' character(len=*), intent(in):: x
#' write(*,*) "ERROR: ",trim(adjustl(x))
#' stop 1
#' end subroutine
#'
#' subroutine rwarn (x)
#' character(len=*), intent(in):: x
#' write(*,*) "WARNING: ",trim(adjustl(x))
#' end subroutine
#' }
forcingFunctions <- function(x) {
# check args
if (!is.data.frame(x))
stop("expecting a data frame as input")
cols <- c("name","column","mode","file","default")
if (!all(cols %in% names(x)))
stop("provided data must have columns '",paste(cols, collapse="', '"),"'")
if (any(duplicated(x$name)))
stop("duplicate names of forcing functions")
# process
code <- "! GENERATED CODE -- YOU PROBABLY DO NOT WANT TO EDIT THIS\n"
code <- paste0(code, "\n")
code <- paste0(code,"include '",
system.file('fortran/forcingsGenericMethods.f95',package='rodeo'),"'")
code <- paste0(code, "\n", "module forcings")
code <- paste0(code, "\n", "use forcings_generic")
code <- paste0(code, "\n", "implicit none")
code <- paste0(code, "\n", "private TSeries, readTS, interpol")
code <- paste0(code, "\n", "contains")
code <- paste0(code, "\n")
for (i in 1:nrow(x)) {
if (x$default[i]) {
code <- paste0(code,"\n","function ",x$name[i]," (time, dflt) result (res)")
code <- paste0(code,"\n"," double precision, intent(in):: time, dflt")
} else {
code <- paste0(code,"\n"," function ",x$name[i]," (time) result (res)")
code <- paste0(code,"\n"," double precision, intent(in):: time")
}
code <- paste0(code,"\n"," character(len=256), parameter:: file='",x$file[i],"'")
code <- paste0(code,"\n"," character(len=256), parameter:: col='",x$column[i],"'")
code <- paste0(code,"\n"," integer, parameter:: lweight= ",x$mode[i])
code <- paste0(code,"\n"," logical, save:: firstCall= .TRUE.")
code <- paste0(code,"\n"," integer, save:: latest= 1")
code <- paste0(code,"\n"," type(TSeries), save:: x")
code <- paste0(code,"\n"," double precision, parameter:: NA= huge(0d0)")
code <- paste0(code,"\n"," character(len=512):: errmsg")
code <- paste0(code,"\n"," double precision:: res")
if (x$default[i]) {
code <- paste0(code,"\n"," if (isnan(dflt)) then")
}
code <- paste0(code,"\n"," include '",
system.file('fortran/forcingsInclude.f95',package='rodeo'),"'")
if (x$default[i]) {
code <- paste0(code,"\n"," else")
code <- paste0(code,"\n"," res= dflt")
code <- paste0(code,"\n"," end if")
}
code <- paste0(code,"\n","end function")
}
code <- paste0(code, "\n", "end module")
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.