ET decay model
Beni Stocker
4/26/2019
Linear model
Assume a 60-days dry down event with the following setup:
- The initial water available to plants across the rooting zone, \(S_0\) is 100 mm.
- ET (termed \(T\), since it’s only transpiration here) is a linear function of the remaining water stored \(S_t\) and is independent of VPD. \[ T(t) = \alpha S(t)/S_0 \]
- The change in plant-available water storage is \(\Delta S=T\).
This leads to an exponential decay of both \(S\) and \(D\) with time. We can set \(\alpha = 0.01\) d \(^{-1}\).
s0 <- 100
alpha <- 1
ntsteps <- 500
s_t <- rep(NA, ntsteps)
t_t <- rep(NA, ntsteps)
s_t[1] <- s0
for (idx in 1:(ntsteps-1)){
t_t[idx] <- alpha * s_t[idx] / s0
s_t[idx + 1] <- s_t[idx] - t_t[idx]
}
df_lin <- tibble( time = 1:ntsteps, soilm = s_t, transp = t_t )
df_lin %>%
ggplot(aes(time, soilm)) +
geom_line()
df_lin %>%
tidyr::drop_na() %>%
ggplot(aes(time, transp)) +
geom_line()
df_lin %>%
tidyr::drop_na() %>%
ggplot(aes(100-soilm, transp)) +
labs(x=expression(integral(ET))) +
geom_line()
Effect of rooting zone water storage capacity
Let’s compare the same relationship as above but with two different \(S_0\).
s0 <- 50
s_t[1] <- s0
for (idx in 1:(ntsteps-1)){
t_t[idx] <- alpha * s_t[idx] / s0
s_t[idx + 1] <- s_t[idx] - t_t[idx]
}
df_lin_deep <- df_lin %>%
mutate(rzwsc = "deep", cwd = cumsum(transp))
df_lin_shallow <- tibble(time = 1:ntsteps, soilm= s_t, transp = t_t) %>%
mutate(rzwsc = "shallow", cwd = cumsum(transp))
df_lin2 <- bind_rows(df_lin_deep, df_lin_shallow)
df_lin2 %>%
ggplot(aes(x = time, y = soilm, color = rzwsc)) +
geom_line()
df_lin2 %>%
tidyr::drop_na() %>%
ggplot(aes(time, transp, color = rzwsc)) +
geom_line()
df_lin2 %>%
tidyr::drop_na() %>%
ggplot(aes(x = cwd, y = transp, color = rzwsc)) +
labs(x=expression(integral(ET))) +
geom_line()
The question is: How does VPD affect the ET decline?
Effect of maximum conductance
Let’s compare the same relationship as above but with two different \(S_0\).
s0 <- 100
s_t[1] <- s0
for (idx in 1:(ntsteps-1)){
t_t[idx] <- 1.5 * alpha * s_t[idx] / s0
s_t[idx + 1] <- s_t[idx] - t_t[idx]
}
df_lin_conservative <- df_lin %>%
mutate(fet = transp / transp[1]) %>%
mutate(strategy = "conservative", cwd = cumsum(transp))
df_lin_exploit <- tibble(time = 1:ntsteps, soilm = s_t, transp = t_t) %>%
mutate(fet = transp / transp[1]) %>%
mutate(strategy = "exploit", cwd = cumsum(transp))
df_lin3 <- bind_rows(df_lin_conservative, df_lin_exploit)
df_lin3 %>%
ggplot(aes(x = time, y = soilm, color = strategy)) +
geom_line()
df_lin3 %>%
tidyr::drop_na() %>%
ggplot(aes(time, transp, color = strategy)) +
geom_line()
df_lin3 %>%
tidyr::drop_na() %>%
ggplot(aes(time, fet, color = strategy)) +
geom_line()
df_lin3 %>%
tidyr::drop_na() %>%
ggplot(aes(x = cwd, y = fet, color = strategy)) +
labs(x=expression(integral(ET))) +
geom_line()
VPD-enabled model, linear
We can formulate a model for \(T\) as a function of VPD (termed \(D\)) and canopy conductance \(G_s\). \[ T = G_s D \] \(G_s\) itself is a function of the remaining soil water content \(S\). We can assume a linear model with \(G_s = 0\) for \(S = 0\): \[ G_s = \beta S \] To get comparable numbers to the example above, let’s assume that under under well-watered conditions (\(S = 100\) mm) and a VPD of 1000 Pa, we should have a transpiration of 1 mm d\(^{-1}\). Hence, we \(\beta = 10^{-5}\). \[ T = \beta S D \]
How does \(T\) evolve under constant \(D\)?
## deep
s0 <- 100
alpha <- 1
ntsteps <- 500
d_t <- rep(1, ntsteps)
s_t <- rep(NA, ntsteps)
t_t <- rep(NA, ntsteps)
s_t[1] <- s0
for (idx in 1:(ntsteps-1)){
t_t[idx] <- alpha * s_t[idx] * d_t[idx] / s0
s_t[idx + 1] <- s_t[idx] - t_t[idx]
}
df_lin_deep <- tibble( time = 1:ntsteps, soilm = s_t, transp = t_t ) %>%
mutate(rzwsc = "deep", cwd = cumsum(transp))
## shallow
s0 <- 50
s_t[1] <- s0
for (idx in 1:(ntsteps-1)){
t_t[idx] <- alpha * s_t[idx] * d_t[idx] / s0
s_t[idx + 1] <- s_t[idx] - t_t[idx]
}
df_lin_shallow <- tibble(time = 1:ntsteps, soilm= s_t, transp = t_t) %>%
mutate(rzwsc = "shallow", cwd = cumsum(transp))
df_lin <- bind_rows(df_lin_deep, df_lin_shallow)
df_lin %>%
ggplot(aes(x = time, y = soilm, color = rzwsc)) +
geom_line()
df_lin %>%
tidyr::drop_na() %>%
ggplot(aes(time, transp, color = rzwsc)) +
geom_line()
df_lin %>%
tidyr::drop_na() %>%
ggplot(aes(x = cwd, y = transp, color = rzwsc)) +
labs(x=expression(integral(ET))) +
geom_line()
Ok. That’s the same. As expected because transpiration is effectively just a function of the \(S\), equivalent to the linear model above.
But what happens when \(D\) changes over time? Let’s assume a linear increase from 1000 Pa to 4000 Pa.
## deep
s0 <- 100
alpha <- 1
ntsteps <- 500
d_t <- rep(NA, ntsteps)
d_t[1] <- 1
d_t[ntsteps] <- 4
d_t <- approx(1:ntsteps, d_t, xout=1:ntsteps)$y
s_t <- rep(NA, ntsteps)
t_t <- rep(NA, ntsteps)
s_t[1] <- s0
for (idx in 1:(ntsteps-1)){
t_t[idx] <- alpha * s_t[idx] * d_t[idx] / s0
s_t[idx + 1] <- s_t[idx] - t_t[idx]
}
df_lin_deep <- tibble( time = 1:ntsteps, soilm = s_t, transp = t_t ) %>%
mutate(rzwsc = "deep", cwd = cumsum(transp))
## shallow
s0 <- 50
s_t[1] <- s0
for (idx in 1:(ntsteps-1)){
t_t[idx] <- alpha * s_t[idx] * d_t[idx] / s0
s_t[idx + 1] <- s_t[idx] - t_t[idx]
}
df_lin_shallow <- tibble(time = 1:ntsteps, soilm= s_t, transp = t_t) %>%
mutate(rzwsc = "shallow", cwd = cumsum(transp))
df_lin <- bind_rows(df_lin_deep, df_lin_shallow)
df_lin %>%
ggplot(aes(x = time, y = soilm, color = rzwsc)) +
geom_line()
df_lin %>%
tidyr::drop_na() %>%
ggplot(aes(time, transp, color = rzwsc)) +
geom_line()
df_lin %>%
tidyr::drop_na() %>%
ggplot(aes(x = cwd, y = transp, color = rzwsc)) +
labs(x=expression(integral(ET))) +
geom_line()
Hmmm. That’s not exactly the same.
Gs a non-linear function of soil moisture
Instead of a linear response of \(G_s\) to \(S\), we can assume a sigmoidal response that looks (somewhat more realistically) like this:
sigm <- function(x){1/(1+exp(-(x/2.5-2.5)))}
df_sigm <- tibble(soilm=0:100) %>%
rowwise() %>%
mutate(gs = sigm(soilm))
df_sigm %>%
ggplot(aes(soilm, gs)) +
geom_line()
Now, let’s look at the evolution of soil moisture and transpiration during dry-down events. First, with constant VPD.
## deep
s0 <- 100
alpha <- 1
ntsteps <- 500
d_t <- rep(1, ntsteps)
s_t <- rep(NA, ntsteps)
t_t <- rep(NA, ntsteps)
s_t[1] <- s0
for (idx in 1:(ntsteps-1)){
t_t[idx] <- alpha * sigm(s_t[idx]) * d_t[idx]
s_t[idx + 1] <- s_t[idx] - t_t[idx]
}
df_lin_deep <- tibble( time = 1:ntsteps, soilm = s_t, transp = t_t ) %>%
mutate(rzwsc = "deep", cwd = cumsum(transp))
## shallow
s0 <- 50
s_t[1] <- s0
for (idx in 1:(ntsteps-1)){
t_t[idx] <- alpha * sigm(s_t[idx]) * d_t[idx]
s_t[idx + 1] <- s_t[idx] - t_t[idx]
}
df_lin_shallow <- tibble(time = 1:ntsteps, soilm= s_t, transp = t_t) %>%
mutate(rzwsc = "shallow", cwd = cumsum(transp))
df_lin <- bind_rows(df_lin_deep, df_lin_shallow)
df_lin %>%
ggplot(aes(x = time, y = soilm, color = rzwsc)) +
geom_line()
df_lin %>%
tidyr::drop_na() %>%
ggplot(aes(time, transp, color = rzwsc)) +
geom_line()
df_lin %>%
tidyr::drop_na() %>%
ggplot(aes(x = cwd, y = transp, color = rzwsc)) +
labs(x=expression(integral(ET))) +
geom_line()