Skip to content

Instantly share code, notes, and snippets.

@ougx
Last active August 29, 2015 14:16
Show Gist options
  • Save ougx/45bbfd8fce7b6a90ac19 to your computer and use it in GitHub Desktop.
Save ougx/45bbfd8fce7b6a90ac19 to your computer and use it in GitHub Desktop.
Create the SWAT files for PEST
# Produced by Michael Ou, 2/11/2015
# using PEST for SWAT calibration
# grouping the same parameter for all HRUs
# change of parameter is accommodated by multiplying a relative rate which is operated by PEST
# for uniform parameters (same value for all HRUs), we replace it directly.
# observations are donwloaded automatically from USGS
# r__CN2.mgt -0.2 0.2
# v__ALPHA_BF.gw 0.0 1.0
# v__GW_DELAY.gw 30.0 450.0
# v__GWQMN.gw 0.0 2.0
#
#
# v__GW_REVAP.gw 0.0 0.2
# v__ESCO.hru 0.8 1.0
# v__CH_N2.rte 0.0 0.3
# v__CH_K2.rte 5.0 130.0
# v__ALPHA_BNK.rte 0.0 1.0
# r__SOL_AWC(1).sol -0.2 0.4
# r__SOL_K(1).sol -0.8 0.8
# r__SOL_BD(1).sol -0.5 0.6
# v__SFTMP.bsn -5.0 5.0
#
#
#
# --------------------------------------------------
# example of parameterization:
#
# r__Precipitation(){1990001-2000265}.pcp 0 0.4
# r__AUTO_EFF{[],11,AUTO_NSTRS=0.6}.mgt 0.2 0.6
# r__BLAI{22}.crop.dat 2 8
#
#
#
# -----------------------------------------
#
# r__CN2.mgt________1 -0.2 0.2
# r__SOL_AWC(1).sol________1 -0.2 0.1
# r__SOL_K(1).sol________1 -0.8 0.8
# r__SOL_BD(1).sol________1 -0.5 0.6
# a__GWQMN.gw________1 0.0 25.0
# a__GW_REVAP.gw________1 -0.1 0.0
# v__REVAPMN.gw________1 0.0 10.0
# a__ESCO.hru________1 0.0 0.2
# r__HRU_SLP.hru________1 0.0 0.2
# r__OV_N.hru________1 -0.2 0.0
# r__SLSUBBSN.hru________1 0.0 0.2
#
#
#
# r__CN2.mgt________3-6 -0.2 0.2
# r__SOL_AWC(1).sol________3-6 -0.2 0.1
# r__SOL_K(1).sol________3-6 -0.8 0.8
# r__SOL_BD(1).sol________3-6 -0.5 0.6
# a__GWQMN.gw________3-6 0.0 25.0
# a__GW_REVAP.gw________3-6 -0.1 0.0
# v__REVAPMN.gw________3-6 0.0 10.0
# a__ESCO.hru________3-6 0.0 0.2
# r__HRU_SLP.hru________3-6 0.0 0.2
# r__OV_N.hru________3-6 -0.2 0.0
# r__SLSUBBSN.hru________3-6 0.0 0.2
#
#
# r__CN2.mgt________7-20 -0.2 0.2
# r__SOL_AWC(1).sol________7-20 -0.2 0.1
# r__SOL_K(1).sol________7-20 -0.8 0.8
# r__SOL_BD(1).sol________7-20 -0.5 0.6
# a__GWQMN.gw________7-20 0.0 25.0
# a__GW_REVAP.gw________7-20 -0.1 0.0
# v__REVAPMN.gw________7-20 0.0 10.0
# a__ESCO.hru________7-20 0.0 0.2
# r__HRU_SLP.hru________7-20 0.0 0.2
# r__OV_N.hru________7-20 -0.2 0.0
# r__SLSUBBSN.hru________7-20 0.0 0.2
#
#
# v__ALPHA_BF.gw 0.0 1.0
# v__GW_DELAY.gw 30.0 450.0
# v__CH_N2.rte 0.0 0.3
# v__CH_K2.rte 5.0 130.0
# v__ALPHA_BNK.rte 0.0 1.0
# v__SFTMP.bsn -5.0 5.0
library("stringr")
library("gdata")
setwd("D:\\@Workspace\\Okalahoma_Lake_Cr\\CN_46_HRU\\PESTCN")
NPAR = 0
NOBS = 0
NPARGP = 0
NPRIOR = 0
NOBSGP = 0
# PARAMETER GROUP
# PARGPNME INCTYP DERINC DERINCLB FORCEN DERINCMUL DERMTHD
#123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc
# 1 2 3 4 5 6 7 8 9 10
PARGPNME <- c( "SLSUBBSN", "HRU_SLP", "OV_N", "ESCO", "CN2", "BD", "AWC", "KSAT", "GW_DELAY", "ALPHA_BF",
"GWQMN", "RCHRG_DP", "GW_SPYLD", "KS", "QR", "QS", "LAMBDA", "HBUB", "WCET")
NPARGP = length(PARGPNME)
#INCTYP is a character variable which can assume the values "relative", "absolute" or "rel_to_max".
INCTYP<-rep("relative", NPARGP)
#DERINC is the increment used for forward-difference calculation of derivatives
DERINC <- c( 0.1, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.5, 0.1,
0.1, 0.1, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05)
#DERINCLB is an absolute lower bound can be placed on parameter increments
DERINCLB <-rep(0.01, NPARGP)
#The character variable FORCEN (an abbreviation of "FORward/CENtral") determines whether derivatives for group members are calculated using
# forward differences, one of the variants of the central difference method, of whether both alternatives are used in the course of an optimisation run.
# It must assume one of the values "always_2", "always_3" or "switch".
# Experience has shown that in most instances the most appropriate value for FORCEN is "switch".
FORCEN = rep("switch", NPARGP)
#DERINCMUL Whenever the central method is employed for derivatives calculation, DERINC is multiplied by DERINCMUL
# Experience shows that a value between 1.0 and 2.0 is usually satisfactory.
DERINCMUL = rep(2.0, NPARGP)
#
DERMTHD = rep("parabolic", NPARGP)
ParaGroup <- data.frame(PARGPNME,INCTYP,DERINC,DERINCLB,FORCEN,DERINCMUL,DERMTHD)
row.names(ParaGroup) <- PARGPNME
# Parameter Data
# PARNME PARTRANS PARCHGLIM PARVAL1 PARLBND PARUBND PARGP SCALE OFFSET DERCOM
#123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc
# 1 2 3 4 5 6 7 8 9 10
PARNME <- PARGPNME
NPAR = length(PARNME)
#PARTRANS is a character variable which must assume one of four values, viz. "none", "log", "fixed" or "tied".
PARTRANS<-rep("none", NPAR)
#This character variable is used to designate whether an adjustable parameter is relative-limited or factor-limited;
# PARCHGLIM must be provided with one of two possible values, viz. "relative" or "factor".
PARCHGLIM<-rep("factor", NPAR)
#PARVAL1, a real variable, is a parameter's initial value.
PARVAL1 <- rep(1, NPAR)
#PARLBND and PARUBND: These two real variables represent a parameter's lower and upper bounds respectively.
PARLBND <- c(0.01, 0.05, 0.1, 0.05, 0.8, 0.1, 0.3, 0.001, 0.1, 0.1,
0.01, 0.1, 0.05, 0.0001, 0.1, 0.1, 0.1, 0.01, 0.1)
PARUBND <-c( 10.0, 10.0, 10.0, 10.0, 1.3, 3.0, 3.0, 1.0e3, 20, 10,
1e5, 10.0, 20.0, 1e4, 10, 10, 10, 100, 3)
#PARGP is the name of the group to which a parameter belongs.
PARGP = PARGPNME
#SCALE and OFFSET
#Just before a parameter value is written to a model input file (be it for initial determination of the objective function,
# derivatives calculation or parameter upgrade), it is multiplied by the real variable SCALE, after which the real variable OFFSET is added.
SCALE = rep(1.0, NPAR)
OFFSET = rep(0.0, NPAR)
#DERCOM: Unless using PEST's external derivatives functionality (see Chapter 9), this variable should be set to 1.
DERCOM = rep(1, NPAR)
# PARNME PARTRANS PARCHGLIM PARVAL1 PARLBND PARUBND PARGP SCALE OFFSET DERCOM
ParaData <- data.frame(PARNME, PARTRANS, PARCHGLIM, PARVAL1, PARLBND, PARUBND, PARGP, SCALE, OFFSET, DERCOM)
row.names(ParaData) <- PARNME
# real values
#123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc
# 1 2 3 4 5 6 7 8 9 10
# "SLSUBBSN", "HRU_SLP", "OV_N", "ESCO", "CN2", "BD", "AWC", "KSAT", "GW_DELAY", "ALPHA_BF",
# "GWQMN", "RCHRG_DP", "GW_SPYLD", "KS", "QR", "QS", "LAMBDA", "HBUB", "WCET"
REALLBND <-c(10.0, 0.001, 0.008, 0.8, 35, 0.9, 0.05, 1e-4, 1, 0.01,
1, 0.01, 0.01, 1e-4, 1e-4, 0.1, 0.04, 0.1, 0.01)
REALUBND <-c(1000, 0.3, 0.6, 1.0, 98, 2.0, 0.5, 1e4, 1000, 0.99,
1e5, 0.99, 0.5, 5e3, 0.2, 0.6, 1.2, 5000, 0.3)
RealPara <- data.frame(PARNME, REALLBND, REALUBND)
row.names(RealPara) <- PARNME
#read number of sub
nsub = 0
pname <- ""
pgroup <- ""
pvalue <- 0.0
pline <- ""
tplname <- "" #this is the template file for par2par but not the pest
ntpl <- 0
np <- 0
filename<-paste0("fig.fig")
fig <- paste(readLines(filename), sep = "\n")
fig <- chartr("\t"," ", fig) #delete tab
ZBOT = 0
BD = 0
AWC = 0
KSAT = 0
isub = 0
ihru = 0
i = 0
hrutot = 0
for (isub in 1:length(fig)){
sline <- unlist(strsplit(fig[isub]," "))
sline <- sline[sline != ""]
if (sline[1] == "subbasin") {
nsub = nsub + 1
sline <- unlist(strsplit(fig[isub+1]," "))
sline <- sline[sline != ""]
#### sub file ###
filename<-sline[1]
filename <-gsub("^\\s+|\\s+$", "", filename)
sub <- paste(readLines(filename), sep = "\n")
#CH_N1
#np=np+1
#pvalue[np]<-as.numeric(substr(sub[29], 1, 16))
#pname[np]<- paste0("CH_N1",isub)
#pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t",pvalue[np]," \t0.008 ","\t0.6","\tCH_N1 "," \t1.0 \t0.0 \t1")
#substr(sub[29], 1, 16) <- paste0("$",substr(paste0(pname[np]," "),1,14),"$")
ntpl = ntpl + 1
tplname[ntpl] <- paste0(filename,".tpl")
writeLines(c("ptf $", sub), tplname[ntpl], sep = "\n")
nhru = as.numeric(substr(sub[53], 1, 16))
hrutot = hrutot + nhru
iisub = nsub
for (ihru in 1:nhru){
### hru file ###
filename<-substr(sub[61+ihru], 1, 13)
filename <-gsub("^\\s+|\\s+$", "", filename)
hru <- paste(readLines(filename), sep = "\n")
#SLSUBBSN
np=np+1
pgroup[np] <- "SLSUBBSN"
pvalue[np]<-as.numeric(substr(hru[3], 1, 16))
pname[np]<- paste0(pgroup[np],iisub,ihru)
pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t",pvalue[np]," \t10.0 ","\t1000.0","\t",pgroup[np]," \t1.0 \t0.0 \t1")
substr(hru[3], 1, 16) <- paste0("$",substr(paste0(pname[np]," "),1,14),"$")
#HRU_SLP
np=np+1
pgroup[np] <- "HRU_SLP"
pvalue[np]<-as.numeric(substr(hru[4], 1, 16))
pname[np]<- paste0(pgroup[np],iisub,ihru)
pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t",pvalue[np]," \t0.005 ","\t0.2","\t",pgroup[np]," \t1.0 \t0.0 \t1")
substr(hru[4], 1, 16) <- paste0("$",substr(paste0(pname[np]," "),1,14),"$")
#OV_N
np=np+1
pgroup[np] <- "OV_N"
pvalue[np]<-as.numeric(substr(hru[5], 1, 16))
pname[np]<- paste0(pgroup[np],iisub,ihru)
pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t",pvalue[np]," \t0.008 ","\t0.6","\t",pgroup[np]," \t1.0 \t0.0 \t1")
substr(hru[5], 1, 16) <- paste0("$",substr(paste0(pname[np]," "),1,14),"$")
#ESCO
np=np+1
pgroup[np] <- "ESCO"
pvalue[np]<-as.numeric(substr(hru[11], 1, 16))
pname[np]<- paste0(pgroup[np],iisub,ihru)
pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t",pvalue[np]," \t0.8 ","\t1.0 ","\tESCO "," \t1.0 \t0.0 \t1")
substr(hru[11], 1, 16) <- paste0("$",substr(paste0(pname[np]," "),1,14),"$")
# #SURLAG
# np=np+1
# pvalue[np]<-as.numeric(substr(hru[11], 1, 16))
# pname[np]<- paste0("SURLAG",iisub,ihru)
# pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t",pvalue[np]," \t0 ","\t0.6","\tSURLAG "," \t1.0 \t0.0 \t1")
# substr(hru[5], 1, 16) <- paste0("$",substr(paste0(pname[np]," "),1,14),"$")
ntpl = ntpl + 1
tplname[ntpl] <- paste0(filename,".tpl")
writeLines(c("ptf $", hru), tplname[ntpl], sep = "\n")
### mgt ###
filename<-substr(sub[61+ihru], 14, 26)
filename <-gsub("^\\s+|\\s+$", "", filename)
mgt <- paste(readLines(filename), sep = "\n")
#CN2
np=np+1
pgroup[np] <- "CN2"
pvalue[np]<-as.numeric(substr(mgt[11], 1, 16))
pname[np]<- paste0("CN2",iisub,ihru)
pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t",pvalue[np]," \t35 ","\t98","\tCN2 "," \t1.0 \t0.0 \t1")
substr(mgt[11], 1, 16) <- paste0("$",substr(paste0(pname[np]," "),1,14),"$")
ntpl = ntpl + 1
tplname[ntpl] <- paste0(filename,".tpl")
writeLines(c("ptf $", mgt), tplname[ntpl], sep = "\n")
### sol ###
filename<-substr(sub[61+ihru], 27, 39)
filename <-gsub("^\\s+|\\s+$", "", filename)
sol <- paste(readLines(filename), sep = "\n")
NLAY <- (str_length(sol[8]) - 27) / 12
INDEX <- 28 + ((1:(NLAY+1))-1) * 12
ii <- 1:NLAY
for (i in ii){
#BD
np=np+1
pgroup[np] <- "BD"
pvalue[np]<-as.numeric(substr(sol[9], INDEX[i], INDEX[i]+11))
pname[np]<- paste0("BD",iisub,ihru,i)
pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t",pvalue[np]," \t0.9 ","\t2.0","\tBD "," \t1.0 \t0.0 \t1")
substr(sol[9], INDEX[i], INDEX[i]+11) <- paste0("$",substr(paste0(pname[np]," "),1,10),"$")
#AWC
np=np+1
pgroup[np] <- "AWC"
pvalue[np]<-as.numeric(substr(sol[10], INDEX[i], INDEX[i]+11))
pname[np]<- paste0("AWC",iisub,ihru,i)
pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t",pvalue[np]," \t0.05 ","\t0.8","\tAWC "," \t1.0 \t0.0 \t1")
substr(sol[10], INDEX[i], INDEX[i]+11) <- paste0("$",substr(paste0(pname[np]," "),1,10),"$")
#KSAT
np=np+1
pgroup[np] <- "KSAT"
pvalue[np]<- as.numeric(substr(sol[11], INDEX[i], INDEX[i]+11))
pname[np]<- paste0("KSAT",iisub,ihru,i)
pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t",pvalue[np]," \t0.0001 ","\t2000","\tKSAT "," \t1.0 \t0.0 \t1")
substr(sol[11], INDEX[i], INDEX[i]+11) <- paste0("$",substr(paste0(pname[np]," "),1,10),"$")
}
ntpl = ntpl + 1
tplname[ntpl] <- paste0(filename,".tpl")
writeLines(c("ptf $", sol), tplname[ntpl], sep = "\n")
# ### usf ###
# filename<-paste0(substr(sub[61+ihru], 27, 35),".usf")
# filename <-gsub("^\\s+|\\s+$", "", filename)
# usf <- paste(readLines(filename), sep = "\n")
# #skip the comment lines
#
# for (ncmt in 1:length(usf)){
# if (substr(usf[ncmt],1,1) != "#") break()
# }
#
# #WCET
# np=np+1
# pgroup[np] <- "WCET"
# pvalue[np]<-as.numeric(substr(usf[5+ncmt], 1, 16))
# pname[np]<- paste0(pgroup[np],iisub,ihru)
# substr(usf[5+ncmt], 1, 16) <- paste0("$",substr(paste0(pname[np]," "),1,14),"$")
#
#
# ntpl = ntpl + 1
# tplname[ntpl] <- paste0(filename,".tpl")
# writeLines(c("ptf $", usf), tplname[ntpl], sep = "\n")
### chm ###
### gw ###
filename<-substr(sub[61+ihru], 53, 65)
filename <-gsub("^\\s+|\\s+$", "", filename)
gw <- paste(readLines(filename), sep = "\n")
#GW_DELAY
np=np+1
pgroup[np] <- "GW_DELAY"
pvalue[np]<-as.numeric(substr(gw[4], 1, 16))
pname[np]<- paste0("GW_DELAY",iisub,ihru)
pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t", pvalue[np]," \t20 ","\t450","\tGW_DELAY"," \t1.0 \t0.0 \t1")
substr(gw[4], 1, 16) <- paste0("$",substr(paste0(pname[np]," "),1,14),"$")
#ALPHA_BF
np=np+1
pgroup[np] <- "ALPHA_BF"
pvalue[np]<-as.numeric(substr(gw[5], 1, 16))
pname[np]<- paste0("ALPHA_BF",iisub,ihru)
pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t", pvalue[np]," \t0.001 ","\t0.999","\tALPHA_BF"," \t1.0 \t0.0 \t1")
substr(gw[5], 1, 16) <- paste0("$",substr(paste0(pname[np]," "),1,14),"$")
#GWQMN
np=np+1
pgroup[np] <- "GWQMN"
pvalue[np]<-as.numeric(substr(gw[6], 1, 16))
if (pvalue[np]<0.1) pvalue[np] <- 1.0
pname[np]<- paste0("GWQMN",iisub,ihru)
pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t", pvalue[np]," \t0.01 ","\t10000.0","\tGWQMN"," \t1.0 \t0.0 \t1")
substr(gw[6], 1, 16) <- paste0("$",substr(paste0(pname[np]," "),1,14),"$")
#RCHRG_DP
np=np+1
pgroup[np] <- "RCHRG_DP"
pvalue[np]<-as.numeric(substr(gw[9], 1, 16))
pname[np]<- paste0("RCHRG_DP",iisub,ihru)
pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t", pvalue[np]," \t0.001 ","\t0.9","\tRCHRG_DP","\t1.0 \t0.0 \t1")
substr(gw[9], 1, 16) <- paste0("$",substr(paste0(pname[np]," "),1,14),"$")
#GW_SPYLD
np=np+1
pgroup[np] <- "GW_SPYLD"
pvalue[np]<-as.numeric(substr(gw[11], 1, 16))
pname[np]<- paste0("GW_SPYLD",iisub,ihru)
pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t", pvalue[np]," \t0.01 ","\t0.6","\tGW_SPYLD","\t1.0 \t0.0 \t1")
substr(gw[11], 1, 16) <- paste0("$",substr(paste0(pname[np]," "),1,14),"$")
ntpl = ntpl + 1
tplname[ntpl] <- paste0(filename,".tpl")
writeLines(c("ptf $", gw), tplname[ntpl], sep = "\n")
}
}
}
#translate soil mat file
# filename <- "soil.mat"
# mat <- paste(readLines(filename), sep = "\n")
# mat <- chartr("\t"," ", mat)
# for (ncmt in 1:length(mat)){
# if (substr(mat[ncmt],1,1) != "#") break()
# }
#
# sline <- unlist(strsplit(mat[ncmt]," "))
# sline <- sline[sline != ""]
#
# nmat <- as.numeric(sline[1])
# for (i in 1:(nmat)){
# sline <- unlist(strsplit(mat[i+ncmt]," "))
# sline <- sline[sline != ""]
#
# #KS
# np=np+1
# pgroup[np] <- "KS"
# pvalue[np]<-as.numeric(sline[1])
# pname[np]<- paste0(pgroup[np],i)
#
#
# #QR
# np=np+1
# pgroup[np] <- "QR"
# pvalue[np]<-as.numeric(sline[2])
# pname[np]<- paste0(pgroup[np],i)
#
#
# #QS
# np=np+1
# pgroup[np] <- "QS"
# pvalue[np]<-as.numeric(sline[3])
# pname[np]<- paste0(pgroup[np],i)
#
#
# #LAMBDA
# np=np+1
# pgroup[np] <- "LAMBDA"
# pvalue[np]<-as.numeric(sline[4])
# pname[np]<- paste0(pgroup[np],i)
#
#
# #ETA calculated by par2par
# #np=np+1
# #pvalue[np]<-as.numeric(sline[5])
# #pname[np]<- paste0("LAMBDA",i)
# #pline[np]<- paste0(pname[np],"\ttied "," \tfactor ","\t",pvalue[np]," \t10.0 ","\t1000.0","\tETA","\t1.0 \t0.0 \t1")
#
# #HBUB
# np=np+1
# pgroup[np] <- "HBUB"
# pvalue[np]<- -as.numeric(sline[6])
# pname[np]<- paste0(pgroup[np],i)
#
# mat[i+ncmt] <- paste0(paste0("$",substr(paste0(pname[np-4]," "),1,14),"$\t "),
# paste0("$",substr(paste0(pname[np-3]," "),1,14),"$\t "),
# paste0("$",substr(paste0(pname[np-2]," "),1,14),"$\t "),
# paste0("$",substr(paste0(pname[np-1]," "),1,14),"$\t "),
# paste0("$",substr(paste0("ETA",i," "),1,14),"$\t "),
# paste0("$",substr(paste0(pname[np]," "),1,14),"$"))
# }
#
# ntpl = ntpl + 1
# tplname[ntpl] <- paste0(filename,".tpl")
# writeLines(c("ptf $", mat), tplname[ntpl], sep = "\n")
# paragroup
groups <- unique(pgroup)
ngroup = length(groups)
NPAR = ngroup
NPARGP = ngroup
ParaGroup <- subset(ParaGroup, PARGPNME %in% groups)
#write.table(ParaGroup, "!!paragroup.dat", quote = FALSE, sep = " \t", row.names = FALSE, col.names = FALSE)
write.fwf(ParaGroup, "!!paragroup.dat", quote = FALSE, rownames = FALSE, colnames = FALSE)
# * parameter data for PEST (parameter groups)
ParaData <- subset(ParaData, PARNME %in% groups)
write.fwf(ParaData, "!!parameter.dat", quote = FALSE, rownames = FALSE, colnames = FALSE)
#write.table(ParaData, "!!parameter.dat", quote = FALSE, row.names = FALSE, col.names = FALSE)
ppestline = ""
#for par2par tpl
p2pline <- ""
l=0
p2pline[(l=l+1)] <- "ptf $"
p2pline[(l=l+1)] <- "* parameter data"
for (gg in groups){
p2pline[(l=l+1)] <- paste(substr(paste0(gg," "),1,20), "=", paste0("$",substr(paste0(gg," "),1,14),"$"))
}
for (i in 1:np) {
p2pline[(l=l+1)] <- paste(substr(paste0(pname[i]," "),1,20), "=", "max ( min (",
substr(paste0(pgroup[i]," "),1,10),
"*", substr(paste0(pvalue[i]," "),1,10), ",",
substr(paste0(RealPara[pgroup[i],"REALUBND"]," "),1,10), "),", RealPara[pgroup[i],"REALLBND"], ")")
if (pgroup[i] == "QS"){
p2pline[l] <- paste(substr(paste0(pname[i]," "),1,20), "=", "max ( min (",
substr(paste0(pgroup[i]," "),1,10),
"*", substr(paste0(pvalue[i]," "),1,10), ",",
substr(paste0(RealPara[pgroup[i],"REALUBND"]," "),1,10), "),", pname[i-1], " + 0.1 )")
}
if (pgroup[i] == "LAMBDA"){
p2pline[(l=l+1)] <- paste(sprintf("%-20s", gsub("LAMBDA", "ETA", pname[i])), "= 2 /", pname[i],"+ 3")
}
if (pgroup[i] == "HBUB"){
p2pline[l] <- paste(substr(paste0(pname[i]," "),1,20), "=", "- max ( min (",
substr(paste0(pgroup[i]," "),1,10),
"*", substr(paste0(pvalue[i]," "),1,10), ",",
substr(paste0(RealPara[pgroup[i],"REALUBND"]," "),1,10), "),", RealPara[pgroup[i],"REALLBND"], ")")
}
# if (pgroup[i] == "WCET"){
# p2pline[l] <- paste(substr(paste0(pname[i]," "),1,20), "=", "max ( min (",
# substr(paste0(pgroup[i]," "),1,10),
# "*", substr(paste0(pvalue[i]," "),1,10), ",",
# substr(paste0(gsub("WCET", "QR", pname[i])," "),1,10), "),", gsub("WCET", "QS", pname[i]), ")")
# }
}
p2pline[(l=l+1)] <- "* template and model input files"
for (i in 1:ntpl){
p2pline[(l=l+1)] <- paste(tplname[i], substr(tplname[i], 1, str_length(tplname[i])-4))
}
p2pline[(l=l+1)] <- "* control data"
p2pline[(l=l+1)] <- "single point"
writeLines(p2pline, "!!par2par.tpl", sep = "\n")
#create observation data and instruction file
nhru = hrutot
hrus <- c(17,hrutot)
NOBSGP = length(hrus)
OBGNME <- paste0("flow", hrus)
lad <- c(hrus[1],diff(hrus))
cio <- paste(readLines("file.cio"), sep = "\n")
NBYR <- as.numeric(substr(cio[8], 1, 16))
IYR <- as.numeric(substr(cio[9], 1, 16))
IDAF <- as.numeric(substr(cio[10], 1, 16))
IDAL <- as.numeric(substr(cio[11], 1, 16))
NYSKIP <- as.numeric(substr(cio[60], 1, 16))
beginDate <- as.Date(IDAF-1, as.Date(paste0(IYR+NYSKIP,"-1-1")))
endDate <- as.Date(IDAL-1, as.Date(paste0(IYR+NBYR-1,"-1-1")))
ndays <- endDate - beginDate + 1
#processing streamflow data
library("dataRetrieval")
obsites <- c("07325840","07325850")
runoff.obs<-readNWISdv(obsites, "00060",beginDate, endDate)
runoff.obs$X_00060_00003 <- runoff.obs$X_00060_00003 * 0.3048^3
runoff.site<-readNWISsite(obsites)
NOBS = nrow(runoff.obs)
head(runoff.obs)
tail(runoff.obs)
nsites<-c(table(runoff.obs$site_no))
runoff.obs$hru <- rep(hrus, times = nsites)
runoff.obs$weight <- 1.0
runoff.obs$weight[runoff.obs$hrus < max(hrus)] <- 1/length(hrus)
runoff.obs$weight[runoff.obs$Date < as.Date("2006-10-1")] <- 0.0
runoffob <- data.frame(OBSNME = paste0("Q", sprintf("%02i", runoff.obs$hru),"D",format(runoff.obs$Date, "%y%m%d")),
OBSVAL = runoff.obs$X_00060_00003,
WEIGHT = runoff.obs$weight,
OBGNME = paste0("flow", runoff.obs$hru))
head(runoffob)
#convert to cms
write.fwf(runoffob, "!!OBData.txt", quote = FALSE, rownames = FALSE, colnames = FALSE)
obins <- ""
l = 0
obins[(l=l+1)] <- "pif $"
obins[(l=l+1)] <- "l9"
minDate <- tapply(runoff.obs$Date, runoff.obs$hru, min)
maxDate <- tapply(runoff.obs$Date, runoff.obs$hru, max)
for (dd in 0:(ndays-1)){
for (i in 1:length(hrus)){
currentD <- as.Date(dd, beginDate)
if (currentD >= minDate[i] & currentD <= maxDate[i])
obins[(l=l+1)] <- paste0("l",lad[i]," [Q", sprintf("%02i", hrus[i]),"D",format(currentD, "%y%m%d"), "]50:61")
else
obins[(l=l+1)] <- paste0("l",lad[i])
}
}
writeLines(obins, "!!OB.ins", sep = "\n")
pst <- ""
l = 0
# pcf
pst[(l=l+1)] <- paste0("pcf")
# * control data
pst[(l=l+1)] <- paste0("* control data")
# RSTFLE PESTMODE
pst[(l=l+1)] <- paste0(" restart estimation")
# NPAR NOBS NPARGP NPRIOR NOBSGP
pst[(l=l+1)] <- paste(" ", NPAR, NOBS, NPARGP, NPRIOR, NOBSGP)
# NTPLFLE NINSFLE PRECIS DPOINT NUMCOM JACFILE MESSFILE
pst[(l=l+1)] <- paste0(" 1 1 single point 1 0 0")
# RLAMBDA1 RLAMFAC PHIRATSUF PHIREDLAM NUMLAM
pst[(l=l+1)] <- paste0(" 0.1 2.0 0.3 0.03 10")
# RELPARMAX FACPARMAX FACORIG
pst[(l=l+1)] <- paste0(" 5.0 5.0 0.001")
# PHIREDSWH
pst[(l=l+1)] <- paste0(" 0.1")
# NOPTMAX PHIREDSTP NPHISTP NPHINORED RELPARSTP NRELPAR
pst[(l=l+1)] <- paste0(" 30 .005 4 4 .005 4")
# ICOV ICOR IEIG
pst[(l=l+1)] <- paste0(" 1 1 1")
# * singular value decomposition
pst[(l=l+1)] <- paste0("* singular value decomposition")
pst[(l=l+1)] <- paste0(" 1")
pst[(l=l+1)] <- paste0(" 10 5.0000000E-07")
pst[(l=l+1)] <- paste0(" 1")
# * parameter groups
pst[(l=l+1)] <- paste0("* parameter groups")
# PARGPNME INCTYP DERINC DERINCLB FORCEN DERINCMUL DERMTHD
# (one such line for each of the NPARGP parameter groups)
pst[(l=l+1)] <- paste0(readLines("!!paragroup.dat"), collapse = "\n")
# * parameter data
pst[(l=l+1)] <- paste0("* parameter data")
# PARNME PARTRANS PARCHGLIM PARVAL1 PARLBND PARUBND PARGP SCALE OFFSET DERCOM
# (one such line for each of the NPAR parameters)
pst[(l=l+1)] <- paste0(readLines("!!parameter.dat"), collapse = "\n")
# PARNME PARTIED
# (one such line for each tied parameter)
# * observation groups
pst[(l=l+1)] <- paste0("* observation groups")
# OBGNME
# (one such line for each observation group)
pst[(l=l+1)] <- paste0(OBGNME, collapse = "\n")
# * observation data
pst[(l=l+1)] <- paste0("* observation data")
# OBSNME OBSVAL WEIGHT OBGNME
# (one such line for each of the NOBS observations)
pst[(l=l+1)] <- paste0(readLines("!!OBData.txt"), collapse = "\n")
# * model command line
pst[(l=l+1)] <- paste0("* model command line")
# write the command which PEST must use to run the model
pst[(l=l+1)] <- paste0(" !!model_predict.bat")
# * model input/output
pst[(l=l+1)] <- paste0("* model input/output")
# TEMPFLE INFLE
# (one such line for each model input file containing parameters)
pst[(l=l+1)] <- paste0(" !!par2par.tpl !!par2par.dat")
# INSFLE OUTFLE
# (one such line for each model output file containing observations)
pst[(l=l+1)] <- paste0(" !!OB.ins output.rch")
# * prior information
pst[(l=l+1)] <- paste0("* prior information")
# PILBL PIFAC * PARNME + PIFAC * log(PARNME) ... = PIVAL WEIGHT OBGNME
# (one such line for each of the NPRIOR articles of prior information)
writeLines(pst, "!!calib1.pst", sep = "\n")
# Produced by Michael Ou, 2/11/2015
# using PEST for SWAT calibration
# grouping the same parameter for all HRUs
# change of parameter is accommodated by multiplying a relative rate which is operated by PEST
# for uniform parameters (same value for all HRUs), we replace it directly.
# r__CN2.mgt -0.2 0.2
# v__ALPHA_BF.gw 0.0 1.0
# v__GW_DELAY.gw 30.0 450.0
# v__GWQMN.gw 0.0 2.0
#
#
# v__GW_REVAP.gw 0.0 0.2
# v__ESCO.hru 0.8 1.0
# v__CH_N2.rte 0.0 0.3
# v__CH_K2.rte 5.0 130.0
# v__ALPHA_BNK.rte 0.0 1.0
# r__SOL_AWC(1).sol -0.2 0.4
# r__SOL_K(1).sol -0.8 0.8
# r__SOL_BD(1).sol -0.5 0.6
# v__SFTMP.bsn -5.0 5.0
#
#
#
# --------------------------------------------------
# example of parameterization:
#
# r__Precipitation(){1990001-2000265}.pcp 0 0.4
# r__AUTO_EFF{[],11,AUTO_NSTRS=0.6}.mgt 0.2 0.6
# r__BLAI{22}.crop.dat 2 8
#
#
#
# -----------------------------------------
#
# r__CN2.mgt________1 -0.2 0.2
# r__SOL_AWC(1).sol________1 -0.2 0.1
# r__SOL_K(1).sol________1 -0.8 0.8
# r__SOL_BD(1).sol________1 -0.5 0.6
# a__GWQMN.gw________1 0.0 25.0
# a__GW_REVAP.gw________1 -0.1 0.0
# v__REVAPMN.gw________1 0.0 10.0
# a__ESCO.hru________1 0.0 0.2
# r__HRU_SLP.hru________1 0.0 0.2
# r__OV_N.hru________1 -0.2 0.0
# r__SLSUBBSN.hru________1 0.0 0.2
#
#
#
# r__CN2.mgt________3-6 -0.2 0.2
# r__SOL_AWC(1).sol________3-6 -0.2 0.1
# r__SOL_K(1).sol________3-6 -0.8 0.8
# r__SOL_BD(1).sol________3-6 -0.5 0.6
# a__GWQMN.gw________3-6 0.0 25.0
# a__GW_REVAP.gw________3-6 -0.1 0.0
# v__REVAPMN.gw________3-6 0.0 10.0
# a__ESCO.hru________3-6 0.0 0.2
# r__HRU_SLP.hru________3-6 0.0 0.2
# r__OV_N.hru________3-6 -0.2 0.0
# r__SLSUBBSN.hru________3-6 0.0 0.2
#
#
# r__CN2.mgt________7-20 -0.2 0.2
# r__SOL_AWC(1).sol________7-20 -0.2 0.1
# r__SOL_K(1).sol________7-20 -0.8 0.8
# r__SOL_BD(1).sol________7-20 -0.5 0.6
# a__GWQMN.gw________7-20 0.0 25.0
# a__GW_REVAP.gw________7-20 -0.1 0.0
# v__REVAPMN.gw________7-20 0.0 10.0
# a__ESCO.hru________7-20 0.0 0.2
# r__HRU_SLP.hru________7-20 0.0 0.2
# r__OV_N.hru________7-20 -0.2 0.0
# r__SLSUBBSN.hru________7-20 0.0 0.2
#
#
# v__ALPHA_BF.gw 0.0 1.0
# v__GW_DELAY.gw 30.0 450.0
# v__CH_N2.rte 0.0 0.3
# v__CH_K2.rte 5.0 130.0
# v__ALPHA_BNK.rte 0.0 1.0
# v__SFTMP.bsn -5.0 5.0
library("stringr")
library("gdata")
setwd("D:\\@Workspace\\Okalahoma_Lake_Cr\\CN_46_HRU\\PESTUN")
NPAR = 0
NOBS = 0
NPARGP = 0
NPRIOR = 0
NOBSGP = 0
# PARAMETER GROUP
# PARGPNME INCTYP DERINC DERINCLB FORCEN DERINCMUL DERMTHD
#123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc
# 1 2 3 4 5 6 7 8 9 10
PARGPNME <- c( "SLSUBBSN", "HRU_SLP", "OV_N", "ESCO", "CN2", "BD", "AWC", "KSAT", "GW_DELAY", "ALPHA_BF",
"GWQMN", "RCHRG_DP", "GW_SPYLD", "KS", "QR", "QS", "LAMBDA", "HBUB", "WCET")
NPARGP = length(PARGPNME)
#INCTYP is a character variable which can assume the values "relative", "absolute" or "rel_to_max".
INCTYP<-rep("relative", NPARGP)
#DERINC is the increment used for forward-difference calculation of derivatives
DERINC <- c( 0.1, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.5, 0.1,
0.1, 0.1, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05)
#DERINCLB is an absolute lower bound can be placed on parameter increments
DERINCLB <-rep(0.01, NPARGP)
#The character variable FORCEN (an abbreviation of "FORward/CENtral") determines whether derivatives for group members are calculated using
# forward differences, one of the variants of the central difference method, of whether both alternatives are used in the course of an optimisation run.
# It must assume one of the values "always_2", "always_3" or "switch".
# Experience has shown that in most instances the most appropriate value for FORCEN is "switch".
FORCEN = rep("switch", NPARGP)
#DERINCMUL Whenever the central method is employed for derivatives calculation, DERINC is multiplied by DERINCMUL
# Experience shows that a value between 1.0 and 2.0 is usually satisfactory.
DERINCMUL = rep(2.0, NPARGP)
#
DERMTHD = rep("parabolic", NPARGP)
ParaGroup <- data.frame(PARGPNME,INCTYP,DERINC,DERINCLB,FORCEN,DERINCMUL,DERMTHD)
row.names(ParaGroup) <- PARGPNME
# Parameter Data
# PARNME PARTRANS PARCHGLIM PARVAL1 PARLBND PARUBND PARGP SCALE OFFSET DERCOM
#123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc
# 1 2 3 4 5 6 7 8 9 10
PARNME <- PARGPNME
NPAR = length(PARNME)
#PARTRANS is a character variable which must assume one of four values, viz. "none", "log", "fixed" or "tied".
PARTRANS<-rep("none", NPAR)
#This character variable is used to designate whether an adjustable parameter is relative-limited or factor-limited;
# PARCHGLIM must be provided with one of two possible values, viz. "relative" or "factor".
PARCHGLIM<-rep("factor", NPAR)
#PARVAL1, a real variable, is a parameter's initial value.
PARVAL1 <- rep(1, NPAR)
#PARLBND and PARUBND: These two real variables represent a parameter's lower and upper bounds respectively.
PARLBND <- c(0.01, 0.05, 0.1, 0.05, 0.8, 0.1, 0.3, 0.001, 0.1, 0.1,
0.01, 0.1, 0.05, 0.0001, 0.1, 0.1, 0.1, 0.01, 0.1)
PARUBND <-c( 10.0, 10.0, 10.0, 10.0, 1.3, 3.0, 3.0, 1.0e3, 20, 10,
1e5, 10.0, 20.0, 1e4, 10, 10, 10, 100, 3)
#PARGP is the name of the group to which a parameter belongs.
PARGP = PARGPNME
#SCALE and OFFSET
#Just before a parameter value is written to a model input file (be it for initial determination of the objective function,
# derivatives calculation or parameter upgrade), it is multiplied by the real variable SCALE, after which the real variable OFFSET is added.
SCALE = rep(1.0, NPAR)
OFFSET = rep(0.0, NPAR)
#DERCOM: Unless using PEST's external derivatives functionality (see Chapter 9), this variable should be set to 1.
DERCOM = rep(1, NPAR)
# PARNME PARTRANS PARCHGLIM PARVAL1 PARLBND PARUBND PARGP SCALE OFFSET DERCOM
ParaData <- data.frame(PARNME, PARTRANS, PARCHGLIM, PARVAL1, PARLBND, PARUBND, PARGP, SCALE, OFFSET, DERCOM)
row.names(ParaData) <- PARNME
# real values
#123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc123456789abc
# 1 2 3 4 5 6 7 8 9 10
# "SLSUBBSN", "HRU_SLP", "OV_N", "ESCO", "CN2", "BD", "AWC", "KSAT", "GW_DELAY", "ALPHA_BF",
# "GWQMN", "RCHRG_DP", "GW_SPYLD", "KS", "QR", "QS", "LAMBDA", "HBUB", "WCET"
REALLBND <-c(10.0, 0.001, 0.008, 0.8, 35, 0.9, 0.05, 1e-4, 1, 0.01,
1, 0.01, 0.01, 1e-4, 1e-4, 0.1, 0.04, 0.1, 0.01)
REALUBND <-c(1000, 0.3, 0.6, 1.0, 98, 2.0, 0.5, 1e4, 1000, 0.99,
1e5, 0.99, 0.5, 5e3, 0.2, 0.6, 1.2, 5000, 0.3)
RealPara <- data.frame(PARNME, REALLBND, REALUBND)
row.names(RealPara) <- PARNME
#read number of sub
nsub = 0
pname <- ""
pgroup <- ""
pvalue <- 0.0
pline <- ""
tplname <- "" #this is the template file for par2par but not the pest
ntpl <- 0
np <- 0
filename<-paste0("fig.fig")
fig <- paste(readLines(filename), sep = "\n")
fig <- chartr("\t"," ", fig) #delete tab
ZBOT = 0
BD = 0
AWC = 0
KSAT = 0
isub = 0
ihru = 0
i = 0
hrutot = 0
for (isub in 1:length(fig)){
sline <- unlist(strsplit(fig[isub]," "))
sline <- sline[sline != ""]
if (sline[1] == "subbasin") {
nsub = nsub + 1
sline <- unlist(strsplit(fig[isub+1]," "))
sline <- sline[sline != ""]
#### sub file ###
filename<-sline[1]
filename <-gsub("^\\s+|\\s+$", "", filename)
sub <- paste(readLines(filename), sep = "\n")
#CH_N1
#np=np+1
#pvalue[np]<-as.numeric(substr(sub[29], 1, 16))
#pname[np]<- paste0("CH_N1",isub)
#pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t",pvalue[np]," \t0.008 ","\t0.6","\tCH_N1 "," \t1.0 \t0.0 \t1")
#substr(sub[29], 1, 16) <- paste0("$",substr(paste0(pname[np]," "),1,14),"$")
ntpl = ntpl + 1
tplname[ntpl] <- paste0(filename,".tpl")
writeLines(c("ptf $", sub), tplname[ntpl], sep = "\n")
nhru = as.numeric(substr(sub[53], 1, 16))
hrutot = hrutot + nhru
iisub = nsub
for (ihru in 1:nhru){
### hru file ###
filename<-substr(sub[61+ihru], 1, 13)
filename <-gsub("^\\s+|\\s+$", "", filename)
hru <- paste(readLines(filename), sep = "\n")
#SLSUBBSN
np=np+1
pgroup[np] <- "SLSUBBSN"
pvalue[np]<-as.numeric(substr(hru[3], 1, 16))
pname[np]<- paste0(pgroup[np],iisub,ihru)
pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t",pvalue[np]," \t10.0 ","\t1000.0","\t",pgroup[np]," \t1.0 \t0.0 \t1")
substr(hru[3], 1, 16) <- paste0("$",substr(paste0(pname[np]," "),1,14),"$")
#HRU_SLP
np=np+1
pgroup[np] <- "HRU_SLP"
pvalue[np]<-as.numeric(substr(hru[4], 1, 16))
pname[np]<- paste0(pgroup[np],iisub,ihru)
pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t",pvalue[np]," \t0.005 ","\t0.2","\t",pgroup[np]," \t1.0 \t0.0 \t1")
substr(hru[4], 1, 16) <- paste0("$",substr(paste0(pname[np]," "),1,14),"$")
#OV_N
np=np+1
pgroup[np] <- "OV_N"
pvalue[np]<-as.numeric(substr(hru[5], 1, 16))
pname[np]<- paste0(pgroup[np],iisub,ihru)
pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t",pvalue[np]," \t0.008 ","\t0.6","\t",pgroup[np]," \t1.0 \t0.0 \t1")
substr(hru[5], 1, 16) <- paste0("$",substr(paste0(pname[np]," "),1,14),"$")
#ESCO
np=np+1
pgroup[np] <- "ESCO"
pvalue[np]<-as.numeric(substr(hru[11], 1, 16))
pname[np]<- paste0(pgroup[np],iisub,ihru)
pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t",pvalue[np]," \t0.8 ","\t1.0 ","\tESCO "," \t1.0 \t0.0 \t1")
substr(hru[11], 1, 16) <- paste0("$",substr(paste0(pname[np]," "),1,14),"$")
# #SURLAG
# np=np+1
# pvalue[np]<-as.numeric(substr(hru[11], 1, 16))
# pname[np]<- paste0("SURLAG",iisub,ihru)
# pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t",pvalue[np]," \t0 ","\t0.6","\tSURLAG "," \t1.0 \t0.0 \t1")
# substr(hru[5], 1, 16) <- paste0("$",substr(paste0(pname[np]," "),1,14),"$")
ntpl = ntpl + 1
tplname[ntpl] <- paste0(filename,".tpl")
writeLines(c("ptf $", hru), tplname[ntpl], sep = "\n")
### mgt ###
filename<-substr(sub[61+ihru], 14, 26)
filename <-gsub("^\\s+|\\s+$", "", filename)
mgt <- paste(readLines(filename), sep = "\n")
#CN2
np=np+1
pgroup[np] <- "CN2"
pvalue[np]<-as.numeric(substr(mgt[11], 1, 16))
pname[np]<- paste0("CN2",iisub,ihru)
pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t",pvalue[np]," \t35 ","\t98","\tCN2 "," \t1.0 \t0.0 \t1")
substr(mgt[11], 1, 16) <- paste0("$",substr(paste0(pname[np]," "),1,14),"$")
ntpl = ntpl + 1
tplname[ntpl] <- paste0(filename,".tpl")
writeLines(c("ptf $", mgt), tplname[ntpl], sep = "\n")
### sol ###
# filename<-substr(sub[61+ihru], 27, 39)
# filename <-gsub("^\\s+|\\s+$", "", filename)
# sol <- paste(readLines(filename), sep = "\n")
#
# NLAY <- (str_length(sol[8]) - 27) / 12
# INDEX <- 28 + ((1:(NLAY+1))-1) * 12
# ii <- 1:NLAY
# for (i in ii){
# #BD
# np=np+1
# pgroup[np] <- "BD"
# pvalue[np]<-as.numeric(substr(sol[9], INDEX[i], INDEX[i]+11))
# pname[np]<- paste0("BD",iisub,ihru,i)
# pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t",pvalue[np]," \t0.9 ","\t2.0","\tBD "," \t1.0 \t0.0 \t1")
# substr(sol[9], INDEX[i], INDEX[i]+11) <- paste0("$",substr(paste0(pname[np]," "),1,10),"$")
#
#
# #AWC
# np=np+1
# pgroup[np] <- "AWC"
# pvalue[np]<-as.numeric(substr(sol[10], INDEX[i], INDEX[i]+11))
# pname[np]<- paste0("AWC",iisub,ihru,i)
# pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t",pvalue[np]," \t0.05 ","\t0.8","\tAWC "," \t1.0 \t0.0 \t1")
# substr(sol[10], INDEX[i], INDEX[i]+11) <- paste0("$",substr(paste0(pname[np]," "),1,10),"$")
#
#
# #KSAT
# np=np+1
# pgroup[np] <- "KSAT"
# pvalue[np]<- as.numeric(substr(sol[11], INDEX[i], INDEX[i]+11))
# pname[np]<- paste0("KSAT",iisub,ihru,i)
# pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t",pvalue[np]," \t0.0001 ","\t2000","\tKSAT "," \t1.0 \t0.0 \t1")
# substr(sol[11], INDEX[i], INDEX[i]+11) <- paste0("$",substr(paste0(pname[np]," "),1,10),"$")
# }
#
#
# ntpl = ntpl + 1
# tplname[ntpl] <- paste0(filename,".tpl")
# writeLines(c("ptf $", sol), tplname[ntpl], sep = "\n")
### usf ###
filename<-paste0(substr(sub[61+ihru], 27, 35),".usf")
filename <-gsub("^\\s+|\\s+$", "", filename)
usf <- paste(readLines(filename), sep = "\n")
#skip the comment lines
for (ncmt in 1:length(usf)){
if (substr(usf[ncmt],1,1) != "#") break()
}
#WCET
np=np+1
pgroup[np] <- "WCET"
pvalue[np]<-as.numeric(substr(usf[5+ncmt], 1, 16))
pname[np]<- paste0(pgroup[np],iisub,ihru)
substr(usf[5+ncmt], 1, 16) <- paste0("$",substr(paste0(pname[np]," "),1,14),"$")
ntpl = ntpl + 1
tplname[ntpl] <- paste0(filename,".tpl")
writeLines(c("ptf $", usf), tplname[ntpl], sep = "\n")
### chm ###
### gw ###
filename<-substr(sub[61+ihru], 53, 65)
filename <-gsub("^\\s+|\\s+$", "", filename)
gw <- paste(readLines(filename), sep = "\n")
#GW_DELAY
np=np+1
pgroup[np] <- "GW_DELAY"
pvalue[np]<-as.numeric(substr(gw[4], 1, 16))
pname[np]<- paste0("GW_DELAY",iisub,ihru)
pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t", pvalue[np]," \t20 ","\t450","\tGW_DELAY"," \t1.0 \t0.0 \t1")
substr(gw[4], 1, 16) <- paste0("$",substr(paste0(pname[np]," "),1,14),"$")
#ALPHA_BF
np=np+1
pgroup[np] <- "ALPHA_BF"
pvalue[np]<-as.numeric(substr(gw[5], 1, 16))
pname[np]<- paste0("ALPHA_BF",iisub,ihru)
pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t", pvalue[np]," \t0.001 ","\t0.999","\tALPHA_BF"," \t1.0 \t0.0 \t1")
substr(gw[5], 1, 16) <- paste0("$",substr(paste0(pname[np]," "),1,14),"$")
#GWQMN
np=np+1
pgroup[np] <- "GWQMN"
pvalue[np]<-as.numeric(substr(gw[6], 1, 16))
if (pvalue[np]<0.1) pvalue[np] <- 1.0
pname[np]<- paste0("GWQMN",iisub,ihru)
pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t", pvalue[np]," \t0.01 ","\t10000.0","\tGWQMN"," \t1.0 \t0.0 \t1")
substr(gw[6], 1, 16) <- paste0("$",substr(paste0(pname[np]," "),1,14),"$")
#RCHRG_DP
np=np+1
pgroup[np] <- "RCHRG_DP"
pvalue[np]<-as.numeric(substr(gw[9], 1, 16))
pname[np]<- paste0("RCHRG_DP",iisub,ihru)
pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t", pvalue[np]," \t0.001 ","\t0.9","\tRCHRG_DP","\t1.0 \t0.0 \t1")
substr(gw[9], 1, 16) <- paste0("$",substr(paste0(pname[np]," "),1,14),"$")
#GW_SPYLD
np=np+1
pgroup[np] <- "GW_SPYLD"
pvalue[np]<-as.numeric(substr(gw[11], 1, 16))
pname[np]<- paste0("GW_SPYLD",iisub,ihru)
pline[np]<- paste0(pname[np],"\tlog ","\tfactor ","\t", pvalue[np]," \t0.01 ","\t0.6","\tGW_SPYLD","\t1.0 \t0.0 \t1")
substr(gw[11], 1, 16) <- paste0("$",substr(paste0(pname[np]," "),1,14),"$")
ntpl = ntpl + 1
tplname[ntpl] <- paste0(filename,".tpl")
writeLines(c("ptf $", gw), tplname[ntpl], sep = "\n")
}
}
}
#translate soil mat file
filename <- "soil.mat"
mat <- paste(readLines(filename), sep = "\n")
mat <- chartr("\t"," ", mat)
for (ncmt in 1:length(mat)){
if (substr(mat[ncmt],1,1) != "#") break()
}
sline <- unlist(strsplit(mat[ncmt]," "))
sline <- sline[sline != ""]
nmat <- as.numeric(sline[1])
for (i in 1:(nmat)){
sline <- unlist(strsplit(mat[i+ncmt]," "))
sline <- sline[sline != ""]
#KS
np=np+1
pgroup[np] <- "KS"
pvalue[np]<-as.numeric(sline[1])
pname[np]<- paste0(pgroup[np],i)
#QR
np=np+1
pgroup[np] <- "QR"
pvalue[np]<-as.numeric(sline[2])
pname[np]<- paste0(pgroup[np],i)
#QS
np=np+1
pgroup[np] <- "QS"
pvalue[np]<-as.numeric(sline[3])
pname[np]<- paste0(pgroup[np],i)
#LAMBDA
np=np+1
pgroup[np] <- "LAMBDA"
pvalue[np]<-as.numeric(sline[4])
pname[np]<- paste0(pgroup[np],i)
#ETA calculated by par2par
#np=np+1
#pvalue[np]<-as.numeric(sline[5])
#pname[np]<- paste0("LAMBDA",i)
#pline[np]<- paste0(pname[np],"\ttied "," \tfactor ","\t",pvalue[np]," \t10.0 ","\t1000.0","\tETA","\t1.0 \t0.0 \t1")
#HBUB
np=np+1
pgroup[np] <- "HBUB"
pvalue[np]<- -as.numeric(sline[6])
pname[np]<- paste0(pgroup[np],i)
mat[i+1] <- paste0(paste0("$",substr(paste0(pname[np-4]," "),1,14),"$\t "),
paste0("$",substr(paste0(pname[np-3]," "),1,14),"$\t "),
paste0("$",substr(paste0(pname[np-2]," "),1,14),"$\t "),
paste0("$",substr(paste0(pname[np-1]," "),1,14),"$\t "),
paste0("$",substr(paste0("ETA",i," "),1,14),"$\t "),
paste0("$",substr(paste0(pname[np]," "),1,14),"$"))
}
ntpl = ntpl + 1
tplname[ntpl] <- paste0(filename,".tpl")
writeLines(c("ptf $", mat), tplname[ntpl], sep = "\n")
# paragroup
groups <- unique(pgroup)
ngroup = length(groups)
NPAR = ngroup
NPARGP = ngroup
ParaGroup <- subset(ParaGroup, PARGPNME %in% groups)
#write.table(ParaGroup, "!!paragroup.dat", quote = FALSE, sep = " \t", row.names = FALSE, col.names = FALSE)
write.fwf(ParaGroup, "!!paragroup.dat", quote = FALSE, rownames = FALSE, colnames = FALSE)
# * parameter data for PEST (parameter groups)
ParaData <- subset(ParaData, PARNME %in% groups)
write.fwf(ParaData, "!!parameter.dat", quote = FALSE, rownames = FALSE, colnames = FALSE)
#write.table(ParaData, "!!parameter.dat", quote = FALSE, row.names = FALSE, col.names = FALSE)
ppestline = ""
#for par2par tpl
p2pline <- ""
l=0
p2pline[(l=l+1)] <- "ptf $"
p2pline[(l=l+1)] <- "* parameter data"
for (gg in groups){
p2pline[(l=l+1)] <- paste(substr(paste0(gg," "),1,20), "=", paste0("$",substr(paste0(gg," "),1,14),"$"))
}
for (i in 1:np) {
p2pline[(l=l+1)] <- paste(substr(paste0(pname[i]," "),1,20), "=", "max ( min (",
substr(paste0(pgroup[i]," "),1,10),
"*", substr(paste0(pvalue[i]," "),1,10), ",",
substr(paste0(RealPara[pgroup[i],"REALUBND"]," "),1,10), "),", RealPara[pgroup[i],"REALLBND"], ")")
if (pgroup[i] == "QS"){
p2pline[l] <- paste(substr(paste0(pname[i]," "),1,20), "=", "max ( min (",
substr(paste0(pgroup[i]," "),1,10),
"*", substr(paste0(pvalue[i]," "),1,10), ",",
substr(paste0(RealPara[pgroup[i],"REALUBND"]," "),1,10), "),", pname[i-1], " + 0.1 )")
}
if (pgroup[i] == "LAMBDA"){
p2pline[(l=l+1)] <- paste(sprintf("%-20s", gsub("LAMBDA", "ETA", pname[i])), "= 2 /", pname[i],"+ 3")
}
if (pgroup[i] == "HBUB"){
p2pline[l] <- paste(substr(paste0(pname[i]," "),1,20), "=", "- max ( min (",
substr(paste0(pgroup[i]," "),1,10),
"*", substr(paste0(pvalue[i]," "),1,10), ",",
substr(paste0(RealPara[pgroup[i],"REALUBND"]," "),1,10), "),", RealPara[pgroup[i],"REALLBND"], ")")
}
}
p2pline[(l=l+1)] <- "* template and model input files"
for (i in 1:ntpl){
p2pline[(l=l+1)] <- paste(tplname[i], substr(tplname[i], 1, str_length(tplname[i])-4))
}
p2pline[(l=l+1)] <- "* control data"
p2pline[(l=l+1)] <- "single point"
writeLines(p2pline, "!!par2par.tpl", sep = "\n")
#create observation data and instruction file
nhru = hrutot
hrus <- c(17,hrutot)
NOBSGP = length(hrus)
OBGNME <- paste0("flow", hrus)
lad <- c(hrus[1],diff(hrus))
cio <- paste(readLines("file.cio"), sep = "\n")
NBYR <- as.numeric(substr(cio[8], 1, 16))
IYR <- as.numeric(substr(cio[9], 1, 16))
IDAF <- as.numeric(substr(cio[10], 1, 16))
IDAL <- as.numeric(substr(cio[11], 1, 16))
NYSKIP <- as.numeric(substr(cio[60], 1, 16))
beginDate <- as.Date(IDAF-1, as.Date(paste0(IYR+NYSKIP,"-1-1")))
endDate <- as.Date(IDAL-1, as.Date(paste0(IYR+NBYR-1,"-1-1")))
ndays <- endDate - beginDate + 1
#processing streamflow data
library("dataRetrieval")
obsites <- c("07325840","07325850")
runoff.obs<-readNWISdv(obsites, "00060",beginDate, endDate)
runoff.obs$X_00060_00003 <- runoff.obs$X_00060_00003 * 0.3048^3
runoff.site<-readNWISsite(obsites)
NOBS = nrow(runoff.obs)
head(runoff.obs)
tail(runoff.obs)
nsites<-c(table(runoff.obs$site_no))
runoff.obs$hru <- rep(hrus, times = nsites)
runoff.obs$weight <- 1.0
runoff.obs$weight[runoff.obs$Date < as.Date("2006-1-1")] <- 0.0
runoffob <- data.frame(OBSNME = paste0("Q", sprintf("%02i", runoff.obs$hru),"D",format(runoff.obs$Date, "%y%m%d")),
OBSVAL = runoff.obs$X_00060_00003,
WEIGHT = runoff.obs$weight,
OBGNME = paste0("flow", runoff.obs$hru))
head(runoffob)
#convert to cms
write.fwf(runoffob, "!!OBData.txt", quote = FALSE, rownames = FALSE, colnames = FALSE)
obins <- ""
l = 0
obins[(l=l+1)] <- "pif $"
obins[(l=l+1)] <- "l9"
minDate <- tapply(runoff.obs$Date, runoff.obs$hru, min)
maxDate <- tapply(runoff.obs$Date, runoff.obs$hru, max)
for (dd in 0:(ndays-1)){
for (i in 1:length(hrus)){
currentD <- as.Date(dd, beginDate)
if (currentD >= minDate[i] & currentD <= maxDate[i])
obins[(l=l+1)] <- paste0("l",lad[i]," [Q", sprintf("%02i", hrus[i]),"D",format(currentD, "%y%m%d"), "]50:61")
else
obins[(l=l+1)] <- paste0("l",lad[i])
}
}
writeLines(obins, "!!OB.ins", sep = "\n")
pst <- ""
l = 0
# pcf
pst[(l=l+1)] <- paste0("pcf")
# * control data
pst[(l=l+1)] <- paste0("* control data")
# RSTFLE PESTMODE
pst[(l=l+1)] <- paste0(" restart estimation")
# NPAR NOBS NPARGP NPRIOR NOBSGP
pst[(l=l+1)] <- paste(" ", NPAR, NOBS, NPARGP, NPRIOR, NOBSGP)
# NTPLFLE NINSFLE PRECIS DPOINT NUMCOM JACFILE MESSFILE
pst[(l=l+1)] <- paste0(" 1 1 single point 1 0 0")
# RLAMBDA1 RLAMFAC PHIRATSUF PHIREDLAM NUMLAM
pst[(l=l+1)] <- paste0(" 0.1 2.0 0.3 0.03 10")
# RELPARMAX FACPARMAX FACORIG
pst[(l=l+1)] <- paste0(" 5.0 5.0 0.001")
# PHIREDSWH
pst[(l=l+1)] <- paste0(" 0.1")
# NOPTMAX PHIREDSTP NPHISTP NPHINORED RELPARSTP NRELPAR
pst[(l=l+1)] <- paste0(" 30 .005 4 4 .005 4")
# ICOV ICOR IEIG
pst[(l=l+1)] <- paste0(" 1 1 1")
# * singular value decomposition
pst[(l=l+1)] <- paste0("* singular value decomposition")
pst[(l=l+1)] <- paste0(" 1")
pst[(l=l+1)] <- paste0(" 10 5.0000000E-07")
pst[(l=l+1)] <- paste0(" 1")
# * parameter groups
pst[(l=l+1)] <- paste0("* parameter groups")
# PARGPNME INCTYP DERINC DERINCLB FORCEN DERINCMUL DERMTHD
# (one such line for each of the NPARGP parameter groups)
pst[(l=l+1)] <- paste0(readLines("!!paragroup.dat"), collapse = "\n")
# * parameter data
pst[(l=l+1)] <- paste0("* parameter data")
# PARNME PARTRANS PARCHGLIM PARVAL1 PARLBND PARUBND PARGP SCALE OFFSET DERCOM
# (one such line for each of the NPAR parameters)
pst[(l=l+1)] <- paste0(readLines("!!parameter.dat"), collapse = "\n")
# PARNME PARTIED
# (one such line for each tied parameter)
# * observation groups
pst[(l=l+1)] <- paste0("* observation groups")
# OBGNME
# (one such line for each observation group)
pst[(l=l+1)] <- paste0(OBGNME, collapse = "\n")
# * observation data
pst[(l=l+1)] <- paste0("* observation data")
# OBSNME OBSVAL WEIGHT OBGNME
# (one such line for each of the NOBS observations)
pst[(l=l+1)] <- paste0(readLines("!!OBData.txt"), collapse = "\n")
# * model command line
pst[(l=l+1)] <- paste0("* model command line")
# write the command which PEST must use to run the model
pst[(l=l+1)] <- paste0(" !!model_predict.bat")
# * model input/output
pst[(l=l+1)] <- paste0("* model input/output")
# TEMPFLE INFLE
# (one such line for each model input file containing parameters)
pst[(l=l+1)] <- paste0(" !!par2par.tpl !!par2par.dat")
# INSFLE OUTFLE
# (one such line for each model output file containing observations)
pst[(l=l+1)] <- paste0(" !!OB.ins output.rch")
# * prior information
pst[(l=l+1)] <- paste0("* prior information")
# PILBL PIFAC * PARNME + PIFAC * log(PARNME) ... = PIVAL WEIGHT OBGNME
# (one such line for each of the NPRIOR articles of prior information)
writeLines(pst, "!!calib1.pst", sep = "\n")
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment